mim/development/mim/20c/strman.mud

   1
   2 <COND (<NOT <GASSIGNED? WIDTH-MUNG>> <FLOAD "MIMOC20DEFS.MUD">)>
   3
   4 <NEWTYPE XTYPE-W ATOM>
   5
   6 <NEWTYPE LOCAL-NAME FIX>
   7
   8 <NEWTYPE LOCAL VECTOR>
   9
  10 <NEWTYPE XGLOC ATOM>
  11
  12 <SETG PRIM-FIX 0>
  13
  14 <SETG PRIM-LIST 1>
  15
  16 <MANIFEST PRIM-LIST PRIM-FIX>
  17
  18 ;"LIST manipulation"
  19
  20 <DEFINE NTHL!-MIMOC (L
  21                      "OPT" (AOS <>) (NOT-DEAD? T) LEN-VAR
  22                      "AUX" (LST <1 .L>) (AMT <2 .L>) (VAL <4 .L>)
  23                            (LOOP <GENLBL "LOOP">) (END <GENLBL "END">) (TAC <>)
  24                            CNT-AC (AHEAD <>) AC NAC (RES-TYP <EXTRAMEM TYPE .L>))
  25         #DECL ((LST) <OR LIST ATOM> (AMT) <OR FIX ATOM> (NAC LOOP END) ATOM
  26                (AC) <OR AC ATOM FALSE> (MIML L) LIST (AHEAD) <OR AC FALSE>)
  27         <COND (<AND <NOT .AOS> <NTH-PUT-LOOK-AHEAD .L "PUTL" .LST .AMT .VAL>>)
  28               (ELSE
  29                <COND (<AND <ASSIGNED? LEN-VAR> .NOT-DEAD?> <SET VAL .LEN-VAR>)>
  30                <COND (<AND <NOT <AND <SET TAC <IN-AC? .LST BOTH>>
  31                                      <SET AC <NEXT-AC .TAC>>>>
  32                            <NOT <SET AC <IN-AC? .LST VALUE>>>>
  33                       <COND (<AND <OR <NOT .AOS> .NOT-DEAD?>
  34                                   <N==? .LST .VAL>
  35                                   <SET AHEAD
  36                                        <LOOK-AHEAD <REST .MIML> .VAL BOTH>>>
  37                              <AC-TIME .AHEAD <SETG AC-STAMP <+ ,AC-STAMP 1>>>
  38                              <AC-TIME <GET-AC <NEXT-AC .AHEAD>> ,AC-STAMP>)>
  39                       <SET AC <NEXT-AC <SET TAC <LOAD-AC .LST BOTH>>>>)>
  40                <COND (<AND <NOT <WILL-DIE? .LST>>
  41                            <N==? .LST .VAL>
  42                            <N==? .AMT 1>>
  43                       <COND (.TAC <FLUSH-AC .TAC T>) (ELSE <FLUSH-AC .AC>)>)>
  44                <COND (<AND <==? .AMT .VAL>
  45                            <SET NAC
  46                                 <OR <IN-AC? .VAL BOTH> <IN-AC? .VAL VALUE>>>>
  47                       <FLUSH-AC .NAC T>)>
  48                <COND (<AND <OR <NOT .AOS> .NOT-DEAD?> <N==? .VAL STACK>>
  49                       <SET NAC <LOAD-AC .VAL BOTH T T .AHEAD>>
  50                                                          ;"Really an ASSIGN-AC"
  51                       <COND (<AND <==? .NAC .TAC> <==? .LST .VAL>>
  52                              <AC-TYPE <GET-AC .NAC> <>>)>)>
  53                <COND (<==? .AMT 1>)
  54                      (ELSE
  55                       <COND
  56                        (<AND <TYPE? .AMT ATOM>
  57                              <OR <AND <SET CNT-AC <IN-AC? .AMT BOTH>>
  58                                       <OR <AND <WILL-DIE? .AMT>
  59                                                <DEAD!-MIMOC (.AMT) T>>
  60                                           <NOT <AC-UPDATE
  61                                                 <GET-AC <NEXT-AC .CNT-AC>>>>>
  62                                       <PROG ()
  63                                             <MUNGED-AC .CNT-AC T>
  64                                             <SET CNT-AC <NEXT-AC .CNT-AC>>>>
  65                                  <AND <SET CNT-AC <IN-AC? .AMT VALUE>>
  66                                       <OR <AND <WILL-DIE? .AMT>
  67                                                <DEAD!-MIMOC (.AMT) T>>
  68                                           <NOT <AC-UPDATE <GET-AC .CNT-AC>>>>
  69                                       <PROG ()
  70                                             <MUNGED-AC .CNT-AC T>>>>>)
  71                        (ELSE
  72                         <OCEMIT MOVE <SET CNT-AC O*> !<OBJ-VAL .AMT>>)>
  73                       <SETG LOOPTAGS (.LOOP !,LOOPTAGS)>
  74                      <LABEL .LOOP>
  75                       <OCEMIT SOJE .CNT-AC <XJUMP .END>>
  76                       <OCEMIT MOVE .AC (.AC)>
  77                       <OCEMIT JRST <XJUMP .LOOP>>
  78                       <LABEL .END>
  79                       <COND (<N==? .LST .VAL>
  80                              <COND (.TAC <MUNGED-AC .TAC T>)
  81                                    (ELSE <MUNGED-AC .AC>)>)>)>
  82                <COND (.AOS
  83                       <COND (<==? .VAL STACK>
  84                              <OCEMIT .AOS
  85                                      O1*
  86                                      <COND (<==? .AOS HRRZ> 1) (ELSE 2)>
  87                                      (.AC)>
  88                              <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
  89                              <OCEMIT PUSH TP* O1*>
  90                              <COND (,WINNING-VICTIM
  91                                     <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
  92                             (.NOT-DEAD?
  93                              <OCEMIT .AOS
  94                                      <NEXT-AC .NAC>
  95                                      <COND (<==? .AOS HRRZ> 1) (ELSE 2)>
  96                                      (.AC)>
  97                              <AC-TYPE <GET-AC .NAC> FIX>)
  98                             (<TYPE? .AOS FORM>
  99                              <COND (<=? <SPNAME <1 .AOS>> "VEQUAL?">
 100                                     <VEQUAL?!-MIMOC <REST .AOS> .AC <> 2>)
 101                                    (<=? <SPNAME <1 .AOS>> "TYPE?">
 102                                     <VEQUAL?!-MIMOC <REST .AOS 3> .AC <> 2
 103                                                     <2 .AOS>>)
 104                                    (ELSE
 105                                     <EQUAL?!-MIMOC <REST .AOS> .AC <> 1>)>)
 106                             (ELSE
 107                              <OCEMIT .AOS
 108                                      <COND (<==? .AOS HRRZ> 1) (ELSE 2)>
 109                                      (.AC)>)>)
 110                      (<==? .VAL STACK>
 111                       <OCEMIT PUSH TP* 1 (.AC)>
 112                       <OCEMIT PUSH TP* 2 (.AC)>
 113                       <COND (,WINNING-VICTIM
 114                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 115                      (T <OCEMIT DMOVE .NAC 1 (.AC)>)>)>>
 116
 117 <DEFINE RESTL!-MIMOC (L
 118                       "AUX" (LST <1 .L>) (AMT <2 .L>) (VAL <4 .L>) AC NAC
 119                             (TAC <>) (END <GENLBL "END">)
 120                             (LOOP <GENLBL "LOOP">)
 121                             (LV
 122                              <OR <LMEMQ .VAL ,LOCALS>
 123                                  <AND ,ICALL-FLAG <LMEMQ .VAL ,ICALL-TEMPS>>>)
 124                             (VD <COND (.LV <LDECL .LV>)>))
 125         #DECL ((LST) <OR LIST ATOM> (AMT) <OR FIX ATOM> (NAC END LOOP) ATOM
 126                (AC) <OR ATOM FALSE> (L) LIST)
 127         <COND (<OR <==? .AMT 1> <==? .AMT 2>>
 128                <OR <AND <SET TAC <IN-AC? .LST BOTH>> <SET AC <NEXT-AC .TAC>>>
 129                    <SET AC <IN-AC? .LST VALUE>>>)
 130               (<AND <NOT <AND <SET AC <IN-AC? .LST BOTH>>
 131                               <SET TAC .AC>
 132                               <SET AC <NEXT-AC .AC>>>>
 133                     <NOT <SET AC <IN-AC? .LST VALUE>>>>
 134                <SET AC <NEXT-AC <SET TAC <LOAD-AC .LST BOTH>>>>)>
 135         <COND (<AND <==? .AMT .VAL> <SET NAC <IN-AC? .AMT BOTH>>>
 136                <FLUSH-AC .NAC T>)>
 137         <COND (<N==? .VAL .LST> <CLEAN-ACS .VAL>)>
 138         <COND (<AND .TAC <OR <==? .LST .VAL> <WILL-DIE? .LST>>> <SET NAC .TAC>)
 139               (<AND .AC
 140                     <OR <==? .LST .VAL> <WILL-DIE? .LST>>
 141                     <SET TAC <GET-AC <GETPROP .AC AC-PAIR>>>
 142                     <==? <NEXT-AC <AC-NAME .TAC>> .AC>>
 143                <SET NAC <AC-NAME .TAC>>
 144                <AC-CODE .TAC TYPE>
 145                <AC-ITEM .TAC .LST>
 146                <SET TAC <>>
 147                <FLUSH-AC .NAC>)
 148               (ELSE <SET NAC <ASSIGN-AC .VAL BOTH T>>)>
 149         <COND (<==? .AMT 1>
 150                <COND (.AC <OCEMIT MOVE <NEXT-AC .NAC> (.AC)>)
 151                      (ELSE <OCEMIT MOVE <NEXT-AC .NAC> @ !<OBJ-VAL .LST>>)>)
 152               (<==? .AMT 2>
 153                <COND (.AC <OCEMIT MOVE <NEXT-AC .NAC> @ (.AC)>)
 154                      (ELSE
 155                       <OCEMIT MOVE <NEXT-AC .NAC> @ !<OBJ-VAL .LST>>
 156                       <OCEMIT MOVE <NEXT-AC .NAC> (<NEXT-AC .NAC>)>)>)
 157               (<==? .AMT 3>
 158                <COND (.AC
 159                       <OCEMIT MOVE <NEXT-AC .NAC> @ (.AC)>
 160                       <OCEMIT MOVE <NEXT-AC .NAC> (<NEXT-AC .NAC>)>)
 161                      (ELSE
 162                       <OCEMIT MOVE <NEXT-AC .NAC> @ !<OBJ-VAL .LST>>
 163                       <OCEMIT MOVE <NEXT-AC .NAC> @ (<NEXT-AC .NAC>)>)>)
 164               (<==? .AMT 4>
 165                <COND (.AC
 166                       <OCEMIT MOVE <NEXT-AC .NAC> @ (.AC)>
 167                       <OCEMIT MOVE <NEXT-AC .NAC> @ (<NEXT-AC .NAC>)>)
 168                      (ELSE
 169                       <OCEMIT MOVE <NEXT-AC .NAC> @ !<OBJ-VAL .LST>>
 170                       <OCEMIT MOVE <NEXT-AC .NAC> @ (<NEXT-AC .NAC>)>
 171                       <OCEMIT MOVE <NEXT-AC .NAC> (<NEXT-AC .NAC>)>)>)
 172               (T
 173                <COND (<N==? .AC <NEXT-AC .NAC>>
 174                       <OCEMIT MOVE <NEXT-AC .NAC> .AC>)>
 175                <SMASH-AC O* .AMT VALUE <N==? .AMT .VAL>>
 176                <COND (<==? .AMT 0>)
 177                      (T
 178                       <COND (<TYPE? .AMT ATOM> <OCEMIT JUMPE O* <XJUMP .END>>)>
 179                       <SETG LOOPTAGS (.LOOP !,LOOPTAGS)>
 180                       <LABEL .LOOP>
 181                       <OCEMIT MOVE <NEXT-AC .NAC> (<NEXT-AC .NAC>)>
 182                       <OCEMIT SOJN O* <XJUMP .LOOP>>
 183                       <LABEL .END>
 184                       <AC-ITEM <GET-AC O*> 0>)>)>
 185         <COND (<AND <==? .AC <NEXT-AC .NAC>>
 186                     <N==? .VAL .LST> <N==? .VAL STACK>>
 187                <AC-CODE <AC-ITEM <GET-AC .NAC> .VAL> TYPE>
 188                <AC-CODE <AC-ITEM <GET-AC <NEXT-AC .NAC>> .VAL> VALUE>)>
 189         <COND (.VD <AC-UPDATE <GET-AC .NAC> <>>)
 190               (ELSE <AC-UPDATE <GET-AC .NAC> T>)>
 191         <AC-UPDATE <GET-AC <NEXT-AC .NAC>> T>
 192         <COND (<==? .VAL STACK>
 193                <OCEMIT PUSH TP* !<TYPE-WORD LIST>>
 194                <OCEMIT PUSH TP* <NEXT-AC .NAC>>
 195                <COND (,WINNING-VICTIM
 196                       <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 197               (ELSE
 198                <COND (<N==? .NAC .TAC> <AC-TYPE <GET-AC .NAC> LIST>)>
 199                <COND (.VD <AC-UPDATE <GET-AC .NAC> <>>)
 200                      (ELSE <AC-UPDATE <GET-AC .NAC> T>)>)>>
 201
 202 <DEFINE EMPL?!-MIMOC (L
 203                       "AUX" (LST <1 .L>) (FLAG <2 .L>) (TAG <3 .L>)
 204                             (JUMP JUMPE) (SKIP SKIPN) AC NEW (AC-T <>)
 205                             (LV
 206                              <OR <LMEMQ .LST ,LOCALS>
 207                                  <AND ,ICALL-FLAG <LMEMQ .LST ,ICALL-TEMPS>>>)
 208                             TAC (AC-T-2 <>)
 209                             (VD
 210                              <COND (.LV <LDECL .LV>)
 211                                    (ELSE <EXTRAMEM TYPE .L>)>))
 212         #DECL ((LST) <OR LIST ATOM> (FLAG TAG SKIP JUMP) ATOM
 213                (AC) <OR FALSE ATOM> (L) LIST)
 214         <COND (<==? .FLAG -> <SET JUMP JUMPN> <SET SKIP SKIPE>)>
 215         <COND (<OR <AND <SET TAC <IN-AC? .LST BOTH>>
 216                         <SET AC <NEXT-AC .TAC>>
 217                         <SET NEW
 218                              <LABEL-UPDATE-ACS .TAG <> T .TAC .AC>>>
 219                    <AND <SET AC <IN-AC? .LST VALUE>>
 220                         <SET NEW
 221                              <LABEL-UPDATE-ACS .TAG <> T .AC>>>>
 222                <COND (.TAC
 223                       <SET AC-T-2 <AC-TIME <GET-AC <SET TAC <1 .NEW>>>>>
 224                       <COND (<N==? .AC <2 .NEW>>
 225                              <SET AC-T
 226                                   <AC-TIME <GET-AC <SET AC <2 .NEW>>>>>)>)
 227                      (<N==? .AC <1 .NEW>>
 228                       <SET AC-T <AC-TIME <GET-AC <SET AC <1 .NEW>>>>>)>
 229                <OCEMIT .JUMP .AC <XJUMP .TAG>>
 230                <COND (.AC-T <AC-TIME <GET-AC .AC> .AC-T>)>
 231                <COND (.AC-T-2 <AC-TIME <GET-AC .TAC> .AC-T-2>)>)
 232               (T
 233                <COND (<OR <AND <SET TAC <LABEL-PREF .TAG .LST BOTH>>
 234                                <SET AC <NEXT-AC <SET TAC <AC-NAME .TAC>>>>>
 235                           <AND <SET TAC <LABEL-PREF .TAG .LST VALUE>>
 236                                <SET AC <AC-NAME .TAC>>
 237                                <SET TAC <GETPROP .TAC AC-PAIR>>>>
 238                       <LOAD-AC .LST BOTH T T <GET-AC .TAC> <GET-AC .AC>>)
 239                      (ELSE
 240                       <SET AC <NEXT-AC <SET TAC <ASSIGN-AC .LST BOTH>>>>)>
 241                <AC-UPDATE <GET-AC .AC> <>>
 242                <AC-ITEM <GET-AC .AC> .LST>
 243                <AC-CODE <GET-AC .AC> VALUE>
 244                <MUNGED-AC .TAC>
 245                <SETG ACA-AC <>>
 246                <LABEL-UPDATE-ACS .TAG <>>
 247                <OCEMIT .SKIP .AC !<OBJ-LOC .LST 1>>
 248                <OCEMIT JRST <XJUMP .TAG>>)>>
 249
 250 <DEFINE PUTREST!-MIMOC (L "AUX" (L1 <1 .L>) (L2 <2 .L>) AC NAC)
 251         #DECL ((L) LIST (L1 L2) <OR LIST ATOM> (AC NAC) <OR FALSE ATOM>)
 252         <COND (<SET AC <IN-AC? .L1 VALUE>>
 253                <SETG FIRST-AC <>>
 254                <AC-TIME <GET-AC .AC> <SETG AC-STAMP <+ ,AC-STAMP 1>>>)>
 255         <COND (<==? .L2 ()>
 256                <COND (.AC <OCEMIT SETZM 0 (.AC)>)
 257                      (ELSE <OCEMIT SETZM @ !<OBJ-VAL .L1>>)>)
 258               (ELSE
 259                <COND (<SET NAC <IN-AC? .L2 VALUE>>)
 260                      (<AND <TYPE? .L2 ATOM> <NOT <WILL-DIE? .L2>>>
 261                       <SET NAC <NEXT-AC <LOAD-AC .L2 BOTH>>>)
 262                      (T <SMASH-AC O* .L2 VALUE> <SET NAC O*>)>
 263                <COND (.AC <OCEMIT MOVEM .NAC (.AC)>)
 264                      (ELSE <OCEMIT MOVEM .NAC @ !<OBJ-VAL .L1>>)>)>>
 265
 266 <DEFINE CONS!-MIMOC (L "AUX" (L1 <1 .L>) (L2 <2 .L>) (VAL <4 .L>))
 267         #DECL ((L) LIST (L1) ANY (L1) <OR LIST ATOM> (VAL) ATOM)
 268         <COND (<OR <==? .L1 .VAL> <AND <TYPE? .L1 ATOM> <WILL-DIE? .L1>>>
 269                <DEAD!-MIMOC (.L1) T>)>
 270         <COND (<OR <==? .L2 .VAL> <AND <TYPE? .L2 ATOM> <WILL-DIE? .L2>>>
 271                <DEAD!-MIMOC (.L2) T>)>
 272         <UPDATE-ACS>
 273         <GET-INTO-ACS .L1 BOTH B1* .L2 VALUE C1*>
 274         <PUSHJ CONS .VAL>>
 275
 276 <DEFINE GET-INTO-ACS ("TUPLE" PTRNS "AUX" (FIRSTS ()) (LASTS ()) (OTHERS ()))
 277    #DECL ((PTRNS) TUPLE (FIRSTS LASTS OTHERS) LIST)
 278    <REPEAT ((P .PTRNS) (WIN T) (CHANGE <>) AC ITM DAC KIND RAC)
 279      <COND (<AND <EMPTY? .P> .WIN> <RETURN>)>
 280      <COND
 281       (<EMPTY? .P>
 282        <COND
 283         (<NOT .CHANGE>
 284          <PROG ((BOTH T))
 285            <MAPF <>
 286             <FUNCTION (ONE)
 287                     #DECL ((ONE) !<LIST [3 ATOM] TUPLE>)
 288                     <COND (<AND <OR <AND <NOT .BOTH> <N==? <2 .ONE> BOTH>>
 289                                     <AND .BOTH <==? <2 .ONE> BOTH>>>
 290                                 <N==? <1 .ONE> <3 .ONE>>>
 291                            <OCEMIT EXCH <1 .ONE> <3 .ONE>>
 292                            <FIXUP-ACS .FIRSTS <1 .ONE> <3 .ONE> .ONE <2 .ONE>>
 293                            <COND (<==? <2 .ONE> BOTH>
 294                                   <OCEMIT EXCH
 295                                           <NEXT-AC-FUNNY <1 .ONE>>
 296                                           <NEXT-AC-FUNNY <3 .ONE>>>)>
 297                            <PUT <4 .ONE> 2 <>>)
 298                           (<==? <1 .ONE> <3 .ONE>> <PUT <4 .ONE> 2 <>>)>>
 299             .FIRSTS>
 300            <COND (.BOTH <SET BOTH <>> <AGAIN>)>>
 301          <SET FIRSTS ()>)>
 302        <SET WIN T>
 303        <SET P .PTRNS>
 304        <AGAIN>)>
 305      <COND (<NOT <2 .P>>)
 306            (<NOT <TYPE? <SET ITM <1 .P>> ATOM>>
 307             <SET LASTS ((.ITM <2 .P> <3 .P>) !.LASTS)>
 308             <PUT .P 2 <>>)
 309            (<SET AC <IN-AC? .ITM <SET KIND <2 .P>>>>
 310             <COND (<==? .AC <SET DAC <3 .P>>>
 311                    <COND (<AND <N==? .KIND VALUE>
 312                                <SET RAC <GETPROP .DAC AC>>
 313                                <AC-TYPE .RAC>>
 314                           <LOAD-TYPE-IN-AC .DAC <AC-TYPE .RAC>>
 315                           <AC-TYPE .RAC <>>)>)
 316                   (<OR <AND <==? .KIND BOTH>
 317                             <OR <AC-MEMQ .DAC .PTRNS>
 318                                 <AC-MEMQ <NEXT-AC-FUNNY .DAC> .PTRNS>>>
 319                        <AND <N==? .KIND BOTH> <AC-MEMQ .DAC .PTRNS>>>
 320                    <SET WIN <>>
 321                    <SET FIRSTS ((.AC .KIND .DAC .P) !.FIRSTS)>)
 322                   (ELSE
 323                    <SET WIN <>>
 324                    <SET CHANGE T>
 325                    <COND (<GETPROP .DAC AC>
 326                           <AC-TYPE <GET-AC .DAC> <>>
 327                           <COND (<==? .KIND BOTH>
 328                                  <AC-TYPE <GET-AC <NEXT-AC .DAC>> <>>)>)>
 329                    <COND (<==? .KIND BOTH>
 330                           <OCEMIT DMOVE .DAC .AC>)
 331                          (ELSE <OCEMIT MOVE .DAC .AC>)>
 332                    <PUT .P 2 <>>)>)
 333            (ELSE
 334             <SET CHANGE T>
 335             <PUT .P 2 <>>
 336             <SET OTHERS ((.ITM .KIND <3 .P>) !.OTHERS)>)>
 337      <SET P <REST .P 3>>>
 338    <MAPF <>
 339          <FUNCTION (ONE)
 340                  #DECL ((ONE) !<LIST ATOM ATOM ATOM>)
 341                  <COND (<GETPROP <3 .ONE> AC>
 342                         <AC-TYPE <GET-AC <3 .ONE>> <>>
 343                         <COND (<==? <2 .ONE> BOTH>
 344                                <AC-TYPE <GET-AC <NEXT-AC <3 .ONE>>> <>>)>)>
 345                  <COND (<==? <2 .ONE> BOTH>
 346                         <OCEMIT DMOVE <3 .ONE> !<OBJ-LOC <1 .ONE> 0>>)
 347                        (<==? <2 .ONE> VALUE>
 348                         <OCEMIT MOVE <3 .ONE> !<OBJ-LOC <1 .ONE> 1>>)
 349                        (ELSE <OCEMIT MOVE <3 .ONE> !<OBJ-LOC <1 .ONE> 0>>)>>
 350          .OTHERS>
 351    <MAPF <>
 352          <FUNCTION (ONE "AUX" (AC <3 .ONE>) (TYP <2 .ONE>) (V <1 .ONE>))
 353                  #DECL ((ONE) !<LIST ANY ATOM ATOM>)
 354                  <COND (<GETPROP .AC AC> <MUNGED-AC .AC <==? .TYP BOTH>>)>
 355                  <COND (<AND <N==? .TYP TYPE>
 356                              <OR <MEMQ <PRIMTYPE .V> '[WORD FIX]>
 357                                  <AND <==? <PRIMTYPE .V> LIST>
 358                                       <EMPTY? <CHTYPE .V LIST>>>>>
 359                         <COND (<==? .TYP BOTH>
 360                                <OCEMIT MOVSI .AC !<TYPE-CODE <TYPE .V> T>>
 361                                <SET AC <NEXT-AC-FUNNY .AC>>)>
 362                         <COND (<==? <PRIMTYPE .V> LIST> <SET V 0>)
 363                               (ELSE <SET V <CHTYPE .V FIX>>)>
 364                         <COND (<AND <G=? .V 0> <L=? .V ,MAX-IMMEDIATE>>
 365                                <OCEMIT MOVEI .AC .V>)
 366                               (<0? <ANDB .V 262143>>
 367                                <OCEMIT MOVSI .AC <LSH .V -18>>)
 368                               (<AND <L? .V 0> <L=? <ABS .V> ,MAX-IMMEDIATE>>
 369                                <OCEMIT MOVNI .AC <- .V>>)
 370                               (ELSE <OCEMIT MOVE .AC !<OBJ-LOC .V 1>>)>)
 371                        (<==? .TYP BOTH> <OCEMIT DMOVE .AC !<OBJ-LOC .V 0>>)
 372                        (<==? .TYP VALUE> <OCEMIT MOVE .AC !<OBJ-LOC .V 1>>)
 373                        (ELSE <OCEMIT MOVE .AC !<OBJ-LOC .V 0>>)>>
 374          .LASTS>>
 375
 376 <DEFINE AC-MEMQ (AC P)
 377         #DECL ((AC) ATOM (P) <PRIMTYPE VECTOR>)
 378         <REPEAT ()
 379                 <COND (<EMPTY? .P> <RETURN <>>)>
 380                 <COND (<AND <2 .P>
 381                             <OR <==? <IN-AC? <1 .P> <2 .P>> .AC>
 382                                 <AND <==? <2 .P> BOTH>
 383                                      <OR <==? <IN-AC? <1 .P> TYPE> .AC>
 384                                          <==? <IN-AC? <1 .P> VALUE> .AC>>>>>
 385                        <RETURN T>)>
 386                 <SET P <REST .P 3>>>>
 387
 388 <DEFINE NEXT-AC-FUNNY (AC:ATOM)
 389         <OR <NEXT-AC .AC>
 390             <AND <==? .AC O1*> O2*>
 391             <AND <==? .AC O*> A1*>
 392             <ERROR NEXT-AC-LOSSAGE!-ERRORS>>>
 393
 394 <DEFINE FIXUP-ACS (L ACA ACB NOT-ME KIND "AUX" AC2A AC2B)
 395         #DECL ((L) LIST)
 396         <SET AC2B <COND (<==? .KIND BOTH> <NEXT-AC-FUNNY .ACB>)>>
 397         <SET AC2A <COND (<==? .KIND BOTH> <NEXT-AC-FUNNY .ACA>)>>
 398         <MAPF <>
 399               <FUNCTION (LL "AUX" TAC)
 400                       #DECL ((LL) !<LIST ATOM ATOM ATOM TUPLE>)
 401                       <COND (<AND <N==? .LL .NOT-ME>
 402                                   <OR <AND <==? .ACB <SET TAC <1 .LL>>>
 403                                            <SET TAC .ACA>>
 404                                       <AND <==? .ACA .TAC> <SET TAC .ACB>>
 405                                       <AND <==? .AC2A .TAC> <SET TAC .AC2B>>
 406                                       <AND <==? .AC2B .TAC> <SET TAC .AC2A>>>>
 407                              <PUT .LL 1 .TAC>)>>
 408               .L>>
 409
 410 <DEFINE PUTL!-MIMOC (L "AUX" (LST <1 .L>) (AMT <2 .L>) (VAL <3 .L>)
 411                              (LOOP <GENLBL "LOOP">) (END <GENLBL "END">)
 412                              (TAC <>) AC NAC (PUT-TYP <EXTRAMEM TYPE .L>)
 413                              CNT-AC)
 414         #DECL ((LST) <OR LIST ATOM>
 415                (AMT) <OR FIX ATOM>
 416                (LOOP) ATOM (NAC AC TAC) <OR ATOM FALSE>
 417                (L) LIST)
 418         <COND (<AND <NOT <AND <SET AC <IN-AC? .LST BOTH>>
 419                               <SET TAC .AC>
 420                               <SET AC <NEXT-AC .AC>>>>
 421                     <NOT <SET AC <IN-AC? .LST VALUE>>>>
 422                <SET AC <NEXT-AC <SET TAC <LOAD-AC .LST BOTH>>>>)
 423               (ELSE
 424                <SETG FIRST-AC <>>
 425                <AC-TIME <GET-AC .AC> <SETG AC-STAMP <+ ,AC-STAMP 1>>>)>
 426         <COND (<==? .AMT 1>)
 427               (<TYPE? .AMT FIX>
 428                <COND (.TAC <FLUSH-AC .TAC T>)
 429                      (ELSE <FLUSH-AC .AC>)>
 430                <COND (<L? <SET AMT <- .AMT 1>> 3>
 431                       <REPEAT ()
 432                               <OCEMIT MOVE .AC (.AC)>
 433                               <COND (<0? <SET AMT <- .AMT 1>>> <RETURN>)>>)
 434                      (ELSE
 435                       <SMASH-AC O* .AMT VALUE>
 436                       <SETG LOOPTAGS (.LOOP !,LOOPTAGS)>
 437                       <LABEL .LOOP>
 438                       <OCEMIT MOVE .AC (.AC)>
 439                       <OCEMIT SOJN O* <XJUMP .LOOP>>)>)
 440               (T
 441                <COND (.TAC <FLUSH-AC .TAC T>)
 442                      (ELSE <FLUSH-AC .AC>)>
 443                <COND (<OR <AND <SET CNT-AC <IN-AC? .AMT BOTH>>
 444                                <OR <AND <WILL-DIE? .AMT> <DEAD!-MIMOC (.AMT) T>>
 445                                    <NOT <AC-UPDATE <GET-AC <NEXT-AC .CNT-AC>>>>>
 446                                <PROG ()
 447                                      <MUNGED-AC .CNT-AC T>
 448                                      <SET CNT-AC <NEXT-AC .CNT-AC>>>>
 449                           <AND <SET CNT-AC <IN-AC? .AMT VALUE>>
 450                                <OR <AND <WILL-DIE? .AMT> <DEAD!-MIMOC (.AMT) T>>
 451                                    <NOT <AC-UPDATE <GET-AC .CNT-AC>>>>
 452                                <PROG ()
 453                                      <MUNGED-AC .CNT-AC T>>>>)
 454                      (ELSE
 455                       <OCEMIT MOVE <SET CNT-AC O*> !<OBJ-VAL .AMT>>)>
 456                <OCEMIT SOJE .CNT-AC <XJUMP .END>>
 457                <SETG LOOPTAGS (.LOOP !,LOOPTAGS)>
 458                <LABEL .LOOP>
 459                <OCEMIT MOVE .AC (.AC)>
 460                <OCEMIT SOJN .CNT-AC <XJUMP .LOOP>>
 461                <LABEL .END>)>
 462         <DO-PUT .PUT-TYP .AC .VAL 1>
 463         <COND (<N==? .AMT 1>
 464                <COND (.TAC <MUNGED-AC .TAC T>)
 465                      (ELSE <MUNGED-AC .AC>)>)>>
 466
 467 <DEFINE DO-PUT (PUT-TYP AC VAL OFFS "AUX" NAC)
 468         #DECL ((OFFS) FIX)
 469         <COND (.PUT-TYP <SET PUT-TYP <DECL-HACK <COND (<TYPE? .PUT-TYP LIST>
 470                                                        <2 .PUT-TYP>)
 471                                                       (ELSE .PUT-TYP)>>>)>
 472         <COND (<AND .PUT-TYP
 473                     <OR <NOT <TYPE? .VAL ATOM>> <SET NAC <IN-AC? .VAL VALUE>>>>
 474                <COND (<TYPE? .VAL ATOM> <OCEMIT MOVEM .NAC <+ .OFFS 1> (.AC)>)
 475                      (<OR <AND <==? <PRIMTYPE .VAL> LIST> <EMPTY? .VAL>>
 476                           <AND <==? <PRIMTYPE .VAL> FIX>
 477                                <==? <CHTYPE .VAL FIX> 0>>>
 478                       <OCEMIT SETZM <+ .OFFS 1> (.AC)>)
 479                      (<AND <==? <PRIMTYPE .VAL> FIX>
 480                            <==? <CHTYPE .VAL FIX> -1>>
 481                       <OCEMIT SETOM <+ .OFFS 1> (.AC)>)
 482                      (ELSE
 483                       <FLUSH-AC O*>
 484                       <MUNGED-AC O*>
 485                       <GET-INTO-ACS .VAL VALUE O*>
 486                       <OCEMIT MOVEM O* <+ .OFFS 1> (.AC)>)>)
 487               (.PUT-TYP
 488                <COND (<SET NAC <IN-AC? .VAL VALUE>>)
 489                      (<OR <NOT <TYPE? .VAL ATOM>> <WILL-DIE? .VAL>>
 490                       <GET-INTO-ACS .VAL VALUE <SET NAC O*>>)
 491                      (ELSE
 492                       <SET NAC <NEXT-AC <LOAD-AC .VAL BOTH>>>)>
 493                <OCEMIT MOVEM .NAC <+ .OFFS 1> (.AC)>)
 494               (ELSE
 495                <COND (<SET NAC <IN-AC? .VAL BOTH>>)
 496                      (<OR <NOT <TYPE? .VAL ATOM>> <WILL-DIE? .VAL>>
 497                       <GET-INTO-ACS .VAL BOTH <SET NAC O1*>>)
 498                      (ELSE
 499                       <SET NAC <LOAD-AC .VAL BOTH>>)>
 500                <OCEMIT DMOVEM .NAC .OFFS (.AC)>)>>
 501
 502 <DEFINE LENL!-MIMOC (L
 503                      "AUX" (LST <1 .L>) (VAL <3 .L>) NAC AC TAC
 504                            (END <GENLBL "END">) (LOOP <GENLBL "LOOP">))
 505         #DECL ((L) LIST (VAL AC NAC END LOOP) ATOM)
 506         <FLUSH-AC T*>
 507         <MUNGED-AC T*>
 508         <COND (<SET TAC <IN-AC? .LST VALUE>>
 509                <SETG FIRST-AC <>>
 510                <AC-TIME <GET-AC .TAC> <SETG AC-STAMP <+ ,AC-STAMP 1>>>
 511                <OCEMIT MOVEI T* .TAC>)
 512               (ELSE <OCEMIT XMOVEI T* !<OBJ-VAL .LST>>)>
 513         <SET NAC <NEXT-AC <SET AC <ASSIGN-AC .VAL BOTH>>>>
 514         <COND (<==? .VAL STACK> <SET NAC O*>)
 515               (<==? .LST .VAL> <SET NAC O*> <AC-TYPE <GET-AC .AC> FIX>)
 516               (T <AC-TYPE <GET-AC .AC> FIX>)>
 517         <OCEMIT MOVSI .NAC 131072>
 518         <SETG LOOPTAGS (.LOOP !,LOOPTAGS)>
 519         <LABEL .LOOP>
 520         <OCEMIT SKIPE T* '(T*)>
 521         <OCEMIT AOBJN .NAC <XJUMP .LOOP>>
 522         <LABEL .END>
 523         <COND (<==? .VAL STACK>
 524                <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
 525                <OCEMIT ANDI O* *777777*>
 526                <OCEMIT PUSH TP* O*>
 527                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 528               (<==? .VAL .LST> <OCEMIT HRRZ <NEXT-AC .AC> O*>)
 529               (ELSE <OCEMIT MOVEI .NAC (.NAC)>)>>
 530
 531 \\r
 532
 533 ;"UBLOCK manipulation"
 534
 535 <DEFINE NTHU!-MIMOC (L "AUX" (L1 <1 .L>))
 536         #DECL ((L) LIST (L1) ANY)
 537         <UPDATE-ACS>
 538         <SMASH-AC A1* .L1 TYPE>
 539         <OCEMIT MOVE O1* !<OBJ-VAL .L1>>
 540         <OCEMIT MOVE O2* !<OBJ-VAL <2 .L>>>
 541         <PUSHJ NTHU <4 .L>>>
 542
 543 <DEFINE RESTU!-MIMOC (L)
 544         #DECL ((L) LIST)
 545         <UPDATE-ACS>
 546         <SMASH-AC A1* <1 .L> BOTH>
 547         <OCEMIT MOVE O2* !<OBJ-VAL <2 .L>>>
 548         <PUSHJ RESTU <4 .L>>>
 549
 550 <DEFINE BACKU!-MIMOC (L)
 551         #DECL ((L) LIST)
 552         <UPDATE-ACS>
 553         <SMASH-AC A1* <1 .L> BOTH>
 554         <OCEMIT MOVE O2* !<OBJ-VAL <2 .L>>>
 555         <PUSHJ BACKU <4 .L>>>
 556
 557 <DEFINE TOPU!-MIMOC (L)
 558         #DECL ((L) LIST)
 559         <UPDATE-ACS>
 560         <SMASH-AC A1* <1 .L> BOTH>
 561         <PUSHJ TOPU <3 .L>>>
 562
 563 <SETG TOPUV!-MIMOC ,TOPU!-MIMOC>
 564
 565 <SETG TOPUS!-MIMOC ,TOPU!-MIMOC>
 566
 567 <SETG TOPUB!-MIMOC ,TOPU!-MIMOC>
 568
 569 <DEFINE PUTU!-MIMOC (L)
 570         #DECL ((L) LIST)
 571         <UPDATE-ACS>
 572         <SMASH-AC A1* <1 .L> BOTH>
 573         <SMASH-AC B1* <3 .L> BOTH>
 574         <OCEMIT MOVE O2* !<OBJ-VAL <2 .L>>>
 575         <PUSHJ PUTU>>
 576
 577 ;"VECTOR manipulation"
 578
 579 <DEFINE NTHUU!-MIMOC (L) #DECL ((L) LIST)
 580         <NTHUV!-MIMOC .L T>>
 581
 582
 583 <DEFINE NTHUV!-MIMOC (L
 584                       "OPT" (UV? <>) (AOS <>) (NOT-DEAD? T) LEN-VAR
 585                       "AUX" (V <1 .L>) (AMT <2 .L>) AM-AC (TAC <>) (VAL <4 .L>)
 586                             AC NAC NUM (AHEAD <>))
 587    #DECL ((L) LIST (V) <OR VECTOR ATOM> (AMT) <OR FIX ATOM> (VAL NAC) ATOM
 588           (NUM) FIX (AC TAC) <OR ATOM FALSE>)
 589    <COND
 590     (<AND <NOT .AOS>
 591           <NTH-PUT-LOOK-AHEAD .L
 592                               <COND (.UV? "PUTUU") ("PUTUV")>
 593                               .V
 594                               .AMT
 595                               .VAL>>)
 596     (ELSE
 597      <COND (<AND <ASSIGNED? LEN-VAR> .NOT-DEAD?> <SET VAL .LEN-VAR>)>
 598      <COND (<AND <NOT <AND <SET TAC <IN-AC? .V BOTH>> <SET AC <NEXT-AC .TAC>>>>
 599                  <NOT <SET AC <IN-AC? .V VALUE>>>
 600                  <OR <N==? .AMT 1>
 601                      <AND <OR .AOS <==? .VAL STACK>> <NOT .UV?> <N==? .AOS HRRZ>>>
 602                  <TYPE? .AMT FIX>>
 603             <COND (<AND <NOT .AOS>
 604                         <N==? .V .VAL>
 605                         <SET AHEAD <LOOK-AHEAD <REST .MIML> .VAL BOTH>>>
 606                    <AC-TIME .AHEAD <SETG AC-STAMP <+ ,AC-STAMP 1>>>
 607                    <AC-TIME <GET-AC <NEXT-AC .AHEAD>> ,AC-STAMP>)>
 608             <SET AC <NEXT-AC <SET TAC <LOAD-AC .V BOTH>>>>)
 609            (.AC
 610             <SETG FIRST-AC <>>
 611             <AC-TIME <GET-AC .AC> <SETG AC-STAMP <+ ,AC-STAMP 1>>>)>
 612      <COND
 613       (<TYPE? .AMT FIX>
 614        <COND (<AND .NOT-DEAD? <N==? .VAL STACK>>
 615               <SET NAC <LOAD-AC .VAL BOTH T T .AHEAD>> ;"Really an ASSIGN-AC")>
 616        <COND (.UV? <SET NUM <- .AMT 1>>) (ELSE <SET NUM <* <- .AMT 1> 2>>)>
 617        <COND (<==? .AOS HRRZ>
 618               <OCEMIT HRRZ
 619                       <COND (<OR <NOT .NOT-DEAD?> <==? .VAL STACK>> O*)
 620                             (ELSE <AC-TYPE <GET-AC .NAC> FIX> <NEXT-AC .NAC>)>
 621                       !<COND (.AC (.NUM (.AC))) (ELSE (@ !<OBJ-VAL .V>))>>
 622               <COND (<==? .VAL STACK>
 623                      <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
 624                      <OCEMIT PUSH TP* O*>
 625                      <COND (,WINNING-VICTIM
 626                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>)
 627              (<TYPE? .AOS FORM>
 628               <COND (<=? <SPNAME <1 .AOS>> "VEQUAL?">
 629                      <VEQUAL?!-MIMOC <REST .AOS>
 630                                      .AC <> <COND (<NOT .UV?> <+ .NUM 1>)
 631                                                   (.AC .NUM)
 632                                                   (ELSE (@ !<OBJ-VAL .V>))>>)
 633                     (<=? <SPNAME <1 .AOS>> "TYPE?">
 634                      <VEQUAL?!-MIMOC <REST .AOS 3>
 635                                      .AC <> <COND (<NOT .UV?> <+ .NUM 1>)
 636                                                   (.AC .NUM)
 637                                                   (ELSE (@ !<OBJ-VAL .V>))>
 638                                      <2 .AOS>>)
 639                     (ELSE
 640                      <EQUAL?!-MIMOC <REST .AOS> .AC <> .NUM>)>)
 641              (.AOS
 642               <OCEMIT .AOS
 643                       <COND (.NOT-DEAD? <NEXT-AC .NAC>) (ELSE O*)>
 644                       !<COND (<NOT .UV?> (<+ .NUM 1> (.AC)))
 645                              (.AC (.NUM (.AC)))
 646                              (ELSE (@ !<OBJ-VAL .V>))>>
 647               <COND (.NOT-DEAD? <AC-TYPE <GET-AC .NAC> FIX>)>)
 648              (<AND <==? .VAL STACK> <NOT .UV?>>
 649               <OCEMIT PUSH TP* .NUM (.AC)>
 650               <OCEMIT PUSH TP* <+ .NUM 1> (.AC)>
 651               <COND (,WINNING-VICTIM
 652                      <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 653              (<==? .VAL STACK>
 654               <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
 655               <COND (,WINNING-VICTIM
 656                      <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
 657               <COND (.AC <OCEMIT PUSH TP* .NUM (.AC)>)
 658                     (ELSE <OCEMIT PUSH TP* @ !<OBJ-VAL .V>>)>
 659               <COND (,WINNING-VICTIM
 660                      <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>)
 661              (<NOT .AC>
 662               <COND (.UV?
 663                      <OCEMIT MOVE <NEXT-AC .NAC> @ !<OBJ-VAL .V>>
 664                      <AC-TYPE <GET-AC .NAC> FIX>)
 665                     (ELSE <OCEMIT DMOVE .NAC @ !<OBJ-VAL .V>>)>)
 666              (.UV?
 667               <OCEMIT MOVE <NEXT-AC .NAC> .NUM (.AC)>
 668               <AC-TYPE <GET-AC .NAC> FIX>)
 669              (T <OCEMIT DMOVE .NAC .NUM (.AC)>)>)
 670       (T
 671        <COND
 672         (<OR <AND <SET AM-AC <IN-AC? .AMT VALUE>>
 673                   <OR <NOT <AC-UPDATE <GET-AC .AM-AC>>> <WILL-DIE? .AMT>>>
 674              <AND <==? .AMT .VAL>
 675                   <OR .AM-AC
 676                       <AND .NOT-DEAD?
 677                            <SET NAC <LOAD-AC .VAL BOTH T T .AHEAD>>>>>>
 678          <COND
 679           (<NOT .AM-AC>
 680            <OCEMIT MOVE <SET AM-AC <NEXT-AC .NAC>> !<OBJ-VAL .AMT>>)
 681           (<AND <MEMQ .AM-AC '[A2* B2* C2*]> <N==? .VAL STACK>>
 682            <SET NAC <GETPROP .AM-AC AC-PAIR>>
 683            <CLEAN-ACS .VAL>
 684            <AC-CODE <AC-ITEM <AC-UPDATE <AC-TYPE <GET-AC .NAC> <>> T> .VAL>
 685                     TYPE>
 686            <AC-CODE <AC-ITEM <AC-UPDATE <AC-TYPE <GET-AC .AM-AC> <>> T> .VAL>
 687                     VALUE>)
 688           (ELSE
 689            <COND (<N==? .AMT .VAL> <MUNGED-AC .AM-AC>)>
 690            <FLUSH-AC .AM-AC>
 691            <COND (.NOT-DEAD? <SET NAC <LOAD-AC .VAL BOTH T T .AHEAD>>)>)>)
 692         (ELSE
 693          <COND (.AM-AC <OCEMIT MOVE T* .AM-AC> <SET AM-AC T*>)
 694                (ELSE <SMASH-AC <SET AM-AC T*> .AMT VALUE>)>
 695          <COND (.NOT-DEAD? <SET NAC <LOAD-AC .VAL BOTH T T .AHEAD>>)>)>
 696        <COND (<AND <N==? .VAL STACK> <ASSIGNED? NAC>>
 697               <AC-TYPE <GET-AC .NAC> <>>)>
 698        <COND (<NOT .UV?> <OCEMIT LSH .AM-AC 1>)>
 699        <COND (.AC <OCEMIT ADD .AM-AC .AC>)
 700              (ELSE <OCEMIT ADD .AM-AC !<OBJ-LOC .V 1>>)>
 701        <COND (<==? .AOS HRRZ>
 702               <OCEMIT HRRZ
 703                       <COND (<OR <NOT .NOT-DEAD?> <==? .VAL STACK>> O*)
 704                             (ELSE <AC-TYPE <GET-AC .NAC> FIX> <NEXT-AC .NAC>)>
 705                       -2
 706                       (.AM-AC)>
 707               <COND (<==? .VAL STACK>
 708                      <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
 709                      <OCEMIT PUSH TP* O*>)>)
 710              (<TYPE? .AOS FORM>
 711               <COND (<=? <SPNAME <1 .AOS>> "VEQUAL?">
 712                      <VEQUAL?!-MIMOC <REST .AOS> .AM-AC <> -1>)
 713                     (<=? <SPNAME <1 .AOS>> "TYPE?">
 714                      <VEQUAL?!-MIMOC <REST .AOS 3> .AM-AC <> -2 <2 .AOS>>)
 715                     (ELSE
 716                      <EQUAL?!-MIMOC <REST .AOS> .AM-AC <> -2>)>)
 717              (.AOS
 718               <OCEMIT .AOS
 719                       <COND (.NOT-DEAD?
 720                              <AC-TYPE <GET-AC .NAC> FIX>
 721                              <NEXT-AC .NAC>)
 722                             (ELSE O*)>
 723                       -1
 724                       (.AM-AC)>)
 725              (<AND <==? .VAL STACK> <NOT .UV?>>
 726               <OCEMIT PUSH TP* -2 (.AM-AC)>
 727               <OCEMIT PUSH TP* -1 (.AM-AC)>
 728               <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 729              (<==? .VAL STACK>
 730               <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
 731               <OCEMIT PUSH TP* -1 (.AM-AC)>
 732               <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 733              (.UV?
 734               <OCEMIT MOVE <NEXT-AC .NAC> -1 (.AM-AC)>
 735               <AC-TYPE <GET-AC .NAC> FIX>)
 736              (T <OCEMIT DMOVE .NAC -2 (.AM-AC)>)>
 737        <AC-CODE <GET-AC T*> DUMMY>)>)>>
 738
 739 <DEFINE PUTUU!-MIMOC (L) #DECL ((L) LIST)
 740         <PUTUV!-MIMOC .L T>>
 741
 742 <DEFINE PUTUV!-MIMOC (L
 743                       "OPT" (UV? <>)
 744                       "AUX" (V <1 .L>) (AMT <2 .L>) (TAC <>) (VAL <3 .L>) AC
 745                             AMT-AC NAC (PUT-TYP <EXTRAMEM TYPE .L>))
 746         #DECL ((L) LIST (V) <OR VECTOR ATOM> (AMT) <OR FIX ATOM> (NAC) ATOM
 747                (VAL) ANY (AC TAC) <OR ATOM FALSE>)
 748         <COND (<AND <NOT <AND <SET TAC <IN-AC? .V BOTH>>
 749                               <SET AC <NEXT-AC .TAC>>>>
 750                     <NOT <SET AC <IN-AC? .V VALUE>>>
 751                     <N==? .AMT 1>
 752                     <TYPE? .AMT FIX>>
 753                <SET AC <NEXT-AC <SET TAC <LOAD-AC .V BOTH>>>>)
 754               (.AC
 755                <SETG FIRST-AC <>>
 756                <AC-TIME <GET-AC .AC> <SETG AC-STAMP <+ ,AC-STAMP 1>>>)>
 757         <COND (<AND <TYPE? .AMT FIX> .UV?>
 758                <COND (.AC <DO-PUT FIX .AC .VAL <- .AMT 2>>)
 759                      (<OR <AND <==? <PRIMTYPE .VAL> LIST> <EMPTY? .VAL>>
 760                           <AND <==? <PRIMTYPE .VAL> WORD>
 761                                <==? <CHTYPE .VAL FIX> 0>>>
 762                       <OCEMIT SETZM @ !<OBJ-VAL .V>>)
 763                      (<AND <==? <PRIMTYPE .VAL> WORD>
 764                            <==? <CHTYPE .VAL FIX> -1>>
 765                       <OCEMIT SETOM @ !<OBJ-VAL .V>>)
 766                      (<TYPE? .VAL ATOM>
 767                       <SET NAC <NEXT-AC <LOAD-AC .VAL BOTH>>>
 768                       <OCEMIT MOVEM .NAC @ !<OBJ-VAL .V>>)
 769                      (ELSE
 770                       <GET-INTO-ACS .VAL VALUE O*>
 771                       <OCEMIT MOVEM O* @ !<OBJ-VAL .V>>)>)
 772               (<TYPE? .AMT FIX>
 773                <COND (.AC <DO-PUT .PUT-TYP .AC .VAL <* <- .AMT 1> 2>>)
 774                      (ELSE
 775                       <SET NAC <LOAD-AC .VAL BOTH>>
 776                       <OCEMIT DMOVEM .NAC @ !<OBJ-VAL .V>>)>)
 777               (T
 778                <COND (<AND <SET AMT-AC <IN-AC? .AMT VALUE>>
 779                            <WILL-DIE? .AMT>>
 780                       <SETG FIRST-AC <>>
 781                       <DEAD!-MIMOC (.AMT) T>
 782                       <AC-TIME <GET-AC .AMT-AC> ,AC-STAMP>
 783                       <AC-TIME <GET-AC <GETPROP .AMT-AC AC-PAIR>> ,AC-STAMP>)
 784                      (ELSE
 785                       <GET-INTO-ACS .AMT VALUE <SET AMT-AC T*>>)>
 786                <COND (<NOT .UV?> <OCEMIT LSH .AMT-AC 1>)>
 787                <COND (.AC <OCEMIT ADD .AMT-AC .AC>)
 788                      (ELSE <OCEMIT ADD .AMT-AC !<OBJ-VAL .V>>)>
 789                <COND (.UV? <DO-PUT FIX .AMT-AC .VAL -2>)
 790                      (ELSE <DO-PUT .PUT-TYP .AMT-AC .VAL -2>)>
 791                <AC-CODE <GET-AC .AMT-AC> DUMMY>)>>
 792
 793 <DEFINE RESTUU!-MIMOC (L) #DECL ((L) LIST)
 794         <RESTUV!-MIMOC .L T>>
 795
 796 <DEFINE RESTUV!-MIMOC (L
 797                        "OPT" (UV? <>)
 798                        "AUX" (V <1 .L>) (AMT <2 .L>) (VAL <4 .L>) AC NAC
 799                              (RES-TYP <EXTRAMEM TYPE .L>))
 800         #DECL ((L) LIST (V) <OR VECTOR ATOM> (AMT) <OR ATOM FIX> (VAL) ATOM
 801                (AC NAC) <OR ATOM FALSE>)
 802         <COND (<TYPE? .AMT FIX>
 803                <COND (<AND <==? .AMT 1> <==? .V .VAL>>
 804                       <SET AC <IN-AC? .V BOTH>>)
 805                      (ELSE <SET AC <LOAD-AC .V BOTH>>)>
 806                <COND (.AC
 807                       <COND (<AND <N==? .V .VAL>
 808                                   <NOT <WILL-DIE? .V>>
 809                                   <AC-UPDATE <GET-AC .AC>>>
 810                              <CLEAN-ACS .VAL>
 811                              <SET NAC <ASSIGN-AC .VAL BOTH T>>
 812                              <OCEMIT DMOVE .NAC .AC>)
 813                             (ELSE
 814                              <CLEAN-ACS .VAL>
 815                              <COND (<N==? .VAL STACK> <ALTER-AC .AC .VAL>)
 816                                    (ELSE <MUNGED-AC .AC T>)>
 817                              <SET NAC .AC>)>
 818                       <OCEMIT ADDI
 819                               <NEXT-AC .NAC>
 820                               <COND (.UV? .AMT) (T <* .AMT 2>)>>
 821                       <OCEMIT SUBI .NAC .AMT>)
 822                      (ELSE
 823                       <SET NAC <ASSIGN-AC .VAL BOTH T>>
 824                       <OCEMIT SOS .NAC !<OBJ-LOC .V 0>>
 825                       <COND (.UV? <OCEMIT AOS <NEXT-AC .NAC> !<OBJ-LOC .V 1>>)
 826                             (ELSE
 827                              <OCEMIT MOVEI <NEXT-AC .NAC> 2>
 828                              <OCEMIT ADDB <NEXT-AC .NAC> !<OBJ-LOC .V 1>>)>
 829                       <AC-UPDATE <GET-AC .NAC> <>>
 830                       <AC-UPDATE <GET-AC <NEXT-AC .NAC>> <>>
 831                       <AC-ITEM <GET-AC .NAC> .V>
 832                       <AC-ITEM <GET-AC <NEXT-AC .NAC>> .V>
 833                       <AC-CODE <GET-AC .NAC> TYPE>
 834                       <AC-CODE <GET-AC <NEXT-AC .NAC>> VALUE>)>)
 835               (<==? .V .VAL>
 836                <SET NAC <LOAD-AC .V BOTH>>
 837                <COND (<AND <SET AC <IN-AC? .AMT VALUE>>
 838                            <OR <AND <WILL-DIE? .AMT> <DEAD!-MIMOC (.AMT) T>>
 839                                <NOT <AC-UPDATE <GET-AC .AC>>>>>)
 840                      (ELSE <SET AC <>>)>
 841                <OCEMIT SUB .NAC !<COND (.AC (.AC)) (ELSE <OBJ-VAL .AMT>)>>
 842                <COND (<AND <NOT .UV?> .AC> <OCEMIT LSH .AC 1>)
 843                      (<NOT .UV?>
 844                       <OCEMIT ADD
 845                               <NEXT-AC .NAC>
 846                               !<COND (.AC (.AC)) (ELSE <OBJ-VAL .AMT>)>>)>
 847                <OCEMIT ADD
 848                        <NEXT-AC .NAC>
 849                        !<COND (.AC (.AC)) (ELSE <OBJ-VAL .AMT>)>>
 850                <AC-UPDATE <GET-AC .NAC> T>
 851                <AC-UPDATE <GET-AC <NEXT-AC .NAC>> T>)
 852               (<==? .VAL .AMT>
 853                <SET AC <IN-AC? .AMT VALUE>>
 854                <SETG FIRST-AC <>>
 855                <SET NAC <LOAD-AC .V BOTH>>
 856                <FLUSH-AC .NAC T>
 857                <MUNGED-AC .NAC T>
 858                <CLEAN-ACS .AMT>
 859                <OCEMIT SUB .NAC !<COND (.AC (.AC)) (ELSE <OBJ-VAL .AMT>)>>
 860                <COND (<AND <NOT .UV?> .AC> <OCEMIT LSH .AC 1>)
 861                      (<NOT .UV?>
 862                       <OCEMIT ADD
 863                               <NEXT-AC .NAC>
 864                               !<COND (.AC (.AC)) (ELSE <OBJ-VAL .AMT>)>>)>
 865                <OCEMIT ADD
 866                        <NEXT-AC .NAC>
 867                        !<COND (.AC (.AC)) (ELSE <OBJ-VAL .AMT>)>>
 868                <ALTER-AC .NAC .VAL>)
 869               (T
 870                <SET NAC <LOAD-AC .V BOTH>>
 871                <FLUSH-AC .NAC T>
 872                <MUNGED-AC .NAC T>
 873                <COND (<AND <SET AC <IN-AC? .AMT VALUE>>
 874                            <OR <AND <WILL-DIE? .AMT> <DEAD!-MIMOC (.AMT) T>>
 875                                <NOT <AC-UPDATE <GET-AC .AC>>>
 876                                .UV?>>)
 877                      (ELSE <SET AC <>>)>
 878                <OCEMIT SUB .NAC !<COND (.AC (.AC)) (ELSE <OBJ-VAL .AMT>)>>
 879                <COND (<AND <NOT .UV?> .AC> <OCEMIT LSH .AC 1>)
 880                      (<NOT .UV?>
 881                       <OCEMIT ADD
 882                               <NEXT-AC .NAC>
 883                               !<COND (.AC (.AC)) (ELSE <OBJ-VAL .AMT>)>>)>
 884                <OCEMIT ADD
 885                        <NEXT-AC .NAC>
 886                        !<COND (.AC (.AC)) (ELSE <OBJ-VAL .AMT>)>>
 887                <COND (<N==? .VAL STACK> <ALTER-AC .NAC .VAL>)>)>
 888         <COND (<==? .VAL STACK>
 889                <OCEMIT PUSH TP* .NAC>
 890                <OCEMIT PUSH TP* <NEXT-AC .NAC>>
 891                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>>
 892
 893 <DEFINE EMPUV?!-MIMOC (L "AUX" (V <1 .L>) (TAG <3 .L>) (JUMP JUMPE)
 894                                (TRN TRNN) AC)
 895         #DECL ((L) LIST (V) <OR VECTOR ATOM> (JUMP TRN TAG) ATOM
 896                (AC) <OR FALSE ATOM>)
 897         <COND (<==? <2 .L> -> <SET JUMP JUMPN> <SET TRN TRNE>)>
 898         <LABEL-UPDATE-ACS .TAG <>>
 899         <COND (<SET AC <IN-AC? .V TYPE>>
 900                <OCEMIT .TRN .AC *777777*>
 901                <OCEMIT JRST <XJUMP .TAG>>)
 902               (T
 903                <OCEMIT HRRZ O* !<OBJ-TYP .V>>
 904                <OCEMIT .JUMP O* <XJUMP .TAG>>)>>
 905
 906 <DEFINE LENUV!-MIMOC (L "AUX" (V <1 .L>) (VAL <3 .L>) AC)
 907         #DECL ((L) LIST (V) <OR VECTOR ATOM> (VAL AC) ATOM)
 908         <COND (<==? .VAL STACK>
 909                <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
 910                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
 911                <OCEMIT HRRZ O* !<OBJ-TYP .V>>
 912                <OCEMIT PUSH TP* O*>
 913                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>)
 914               (T
 915                <SET AC <ASSIGN-AC .VAL BOTH>>
 916                <OCEMIT HRRZ <NEXT-AC .AC> !<OBJ-TYP .V>>
 917                <AC-TYPE <GET-AC .AC> FIX>)>>
 918
 919 \f
 920 ;"STRING and BYTES manipulation"
 921
 922 <DEFINE NTHUB!-MIMOC (L)
 923   <NTHUS!-MIMOC .L T>>
 924
 925 <DEFINE NTHUS!-MIMOC (L
 926                       "OPTIONAL" (BYTES? <>)
 927                       "AUX" (V <1 .L>) (AMT <2 .L>) (VAL <4 .L>) AC NUM
 928                             (NAC <PUTPROP .L DONE>))
 929         #DECL ((L) LIST (V) <OR BYTES STRING ATOM> (AMT) <OR FIX ATOM>
 930                (VAL) ATOM (NUM) FIX (AC BYTES?) <OR ATOM FALSE>)
 931         <SETG DIE-LATER <SETG REMEMBER-STRING <>>>
 932         <COND (<AND <NOT .NAC> <N==? .VAL .V> <TYPE? .AMT FIX>>
 933                <SET NAC <STRING-PUT-NTH-LOOK-AHEAD .V NTH .VAL .BYTES? .AMT>>)>
 934         <COND (<NOT .NAC>
 935                <COND (<SET AC <IN-AC? .V FUNNY-VALUE>>
 936                       <AC-CODE <GET-AC .AC> VALUE>
 937                       <SET AMT 1>
 938                       <SETG FIRST-AC <>>
 939                       <AC-TIME <GET-AC .AC> <SETG AC-STAMP <+ ,AC-STAMP 1>>>)
 940                      (<AND <N==? .AMT 1> <N==? .AMT 2>>
 941                       <SET AC <LOAD-AC .AMT VALUE>>
 942                       <FLUSH-AC .AC>
 943                       <MUNGED-AC .AC>
 944                       <OCEMIT <COND (,ADJBP-HACK MADJBP)
 945                                     (T ADJBP)>
 946                               .AC !<OBJ-VAL .V>>)
 947                      (<AND <SET AC <IN-AC? .V VALUE>>
 948                            <OR <WILL-DIE? .V>
 949                                <NOT <AC-UPDATE <GET-AC .AC>>>
 950                                <==? .V .VAL>
 951                                ,DIE-LATER>>
 952                       <MUNGED-AC .AC>
 953                       <SETG FIRST-AC <>>
 954                       <AC-TIME <GET-AC .AC> <SETG AC-STAMP <+ ,AC-STAMP 1>>>)
 955                      (,REMEMBER-STRING
 956                       <COND (.AC
 957                              <FLUSH-AC .AC>
 958                              <SETG FIRST-AC <>>
 959                              <AC-TIME <GET-AC .AC>
 960                                       <SETG AC-STAMP <+ ,AC-STAMP 1>>>)
 961                             (ELSE
 962                              <SETG FIRST-AC <>>
 963                              <SET AC <NEXT-AC <LOAD-AC .V BOTH>>>)>
 964                       <MUNGED-AC .AC>)
 965                      (ELSE <SET AC <>>)>
 966                <COND (<==? .VAL STACK>
 967                       <COND (.BYTES? <OCEMIT PUSH TP* !<TYPE-WORD FIX>>)
 968                             (T <OCEMIT PUSH TP* !<TYPE-WORD CHARACTER>>)>
 969                       <COND (,WINNING-VICTIM
 970                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
 971                       <COND (<NOT .AC>
 972                              <OCEMIT MOVE O* !<OBJ-VAL .V>>
 973                              <SET AC O*>)>
 974                       <DNTH O* .AC .AMT>
 975                       <OCEMIT PUSH TP* O*>
 976                       <COND (,WINNING-VICTIM
 977                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
 978                       <AC-CODE <GET-AC .AC> DUMMY>)
 979                      (T
 980                       <SET NAC <ASSIGN-AC .VAL BOTH>>
 981                       <COND (<NOT .AC>
 982                              <OCEMIT MOVE
 983                                      <SET AC <NEXT-AC .NAC>>
 984                                      !<OBJ-VAL .V>>)>
 985                       <DNTH <NEXT-AC .NAC> .AC .AMT>
 986                       <COND (.BYTES? <AC-TYPE <GET-AC .NAC> FIX>)
 987                             (T <AC-TYPE <GET-AC .NAC> CHARACTER>)>)>
 988                <COND (<AND .AC
 989                            <OR <NOT .NAC>
 990                                <AND <N==? .AC .NAC>
 991                                     <N==? .AC <NEXT-AC .NAC>>>>>
 992                       <COND (,REMEMBER-STRING
 993                              <AC-UPDATE <AC-CODE <AC-ITEM <GET-AC .AC> .V>
 994                                                  FUNNY-VALUE> <>>)
 995                             (ELSE
 996                              <AC-CODE <GET-AC .AC> DUMMY>)>)>)>>
 997
 998 <DEFINE DNTH (AC1 AC2 AMT)
 999         #DECL ((AC1 AC2) ATOM (AMT) <OR ATOM FIX>)
1000         <COND (<OR <==? .AMT 1><==? .AMT 2>>
1001                <COND (<==? .AMT 2>
1002                       <OCEMIT IBP O* .AC2>)>
1003                <OCEMIT ILDB .AC1 .AC2>)
1004               (ELSE
1005                <OCEMIT LDB .AC1 .AC2>)>>
1006
1007 <DEFINE PUTUS!-MIMOC (L
1008                       "OPT" (BYTES? <>)
1009                       "AUX" (V <1 .L>) (AMT <2 .L>) (VAL <3 .L>) (AC <>) NAC
1010                             (DONE <PUTPROP .L DONE>) TAC)
1011         #DECL ((L) LIST (V) <OR BYTES STRING ATOM> (AMT) <OR FIX ATOM>
1012                (NAC) <OR ATOM FALSE> (VAL) ANY (TAC AC) <OR ATOM FALSE>)
1013         <SETG DIE-LATER <SETG REMEMBER-STRING <>>>
1014         <COND (<AND <NOT .DONE> <TYPE? .AMT FIX>>
1015                <SET DONE <STRING-PUT-NTH-LOOK-AHEAD
1016                           .V PUT .VAL .BYTES? .AMT>>)>
1017         <COND (<NOT .DONE>
1018                <COND (<OR <SET AC <IN-AC? .V FUNNY-VALUE>>
1019                           <==? .AMT 1>
1020                           <==? .AMT 2>>
1021                       <COND (.AC
1022                              <AC-CODE <GET-AC .AC> VALUE>
1023                              <SET AMT 1>
1024                              <SETG FIRST-AC <>>
1025                              <AC-TIME <GET-AC .AC>
1026                                       <SETG AC-STAMP <+ ,AC-STAMP 1>>>)
1027                             (<AND <SET AC <IN-AC? .V VALUE>>
1028                                   <OR <WILL-DIE? .V> ,DIE-LATER>>
1029                              <SETG FIRST-AC <>>
1030                              <AC-TIME <GET-AC .AC>
1031                                       <SETG AC-STAMP <+ ,AC-STAMP 1>>>
1032                              <FLUSH-AC .AC>
1033                              <MUNGED-AC .AC>)
1034                             (,REMEMBER-STRING
1035                              <SETG FIRST-AC <>>
1036                              <SET AC <NEXT-AC <SET TAC <LOAD-AC .V BOTH>>>>
1037                              <COND (<NOT <OR ,DIE-LATER <WILL-DIE? .V>>>
1038                                     <FLUSH-AC .TAC T>)>
1039                              <MUNGED-AC .TAC T>)
1040                             (ELSE
1041                              <OCEMIT MOVE <SET AC O*> !<OBJ-VAL .V>>)>
1042                       <COND (<==? .AMT 2>
1043                              <OCEMIT IBP O* .AC>)>
1044                       <COND (<SET NAC <IN-AC? .VAL VALUE>>)
1045                             (<AND <TYPE? .VAL ATOM>
1046                                   <NOT <WILL-DIE? .VAL>>>
1047                              <SET NAC <NEXT-AC <LOAD-AC .VAL BOTH>>>)
1048                             (ELSE
1049                              <GET-INTO-ACS .VAL VALUE <SET NAC O1*>>)>
1050                       <OCEMIT IDPB .NAC .AC>
1051                       <COND (,REMEMBER-STRING
1052                              <AC-CODE <AC-ITEM <AC-UPDATE <GET-AC .AC> <>>
1053                                                .V> FUNNY-VALUE>)
1054                             (ELSE
1055                              <AC-CODE <GET-AC .AC> DUMMY>)>)
1056                      (ELSE
1057                       <COND (<OR <AND <SET TAC <IN-AC? .AMT BOTH>>
1058                                       <SET AC <NEXT-AC .TAC>>>
1059                                  <SET AC <IN-AC? .AMT VALUE>>>
1060                              <SETG FIRST-AC <>>
1061                              <COND (<WILL-DIE? .AMT>
1062                                     <DEAD!-MIMOC (.AMT) T>)
1063                                    (<AC-UPDATE <GET-AC .AC>>
1064                                     <OCEMIT MOVE O1* .AC>
1065                                     <SET AC O1*>)>
1066                              <COND (<N==? .AC O1*>
1067                                     <COND (.TAC
1068                                            <AC-TIME <GET-AC .TAC>
1069                                                     ,AC-STAMP>
1070                                            <FLUSH-AC .TAC T>)
1071                                           (ELSE <FLUSH-AC .AC>)>
1072                                     <AC-TIME <GET-AC .AC> ,AC-STAMP>)>)
1073                             (,REMEMBER-STRING
1074                              <SET AC <LOAD-AC .AMT VALUE>>)
1075                             (ELSE
1076                              <GET-INTO-ACS .AMT VALUE <SET AC O1*>>)>
1077                       <OCEMIT <COND (,ADJBP-HACK MADJBP)
1078                                     (T ADJBP)> .AC !<OBJ-VAL .V>>
1079                       <COND (<AND <TYPE? .VAL ATOM>
1080                                   <NOT <WILL-DIE? .VAL>>>
1081                              <SET NAC <NEXT-AC <LOAD-AC .VAL BOTH>>>)
1082                             (ELSE
1083                              <GET-INTO-ACS .VAL VALUE <SET NAC O*>>)>
1084                       <OCEMIT DPB .NAC .AC>
1085                       <COND (<N==? .AC O1*>
1086                              <COND (.TAC <MUNGED-AC .TAC T>)
1087                                    (ELSE <MUNGED-AC .AC>)>
1088                              <COND (,REMEMBER-STRING
1089                                     <AC-CODE <AC-ITEM <AC-UPDATE <GET-AC .AC>
1090                                                                  <>> .V>
1091                                              FUNNY-VALUE>)>)>)>)>>
1092
1093 <DEFINE PUTUB!-MIMOC (L) <PUTUS!-MIMOC .L T>>
1094
1095 <DEFINE RESTUS!-MIMOC (L
1096                        "OPTIONAL" (BYTES? <>) (OTH-VAL <>) OP DEAD?
1097                        "AUX" (STR <1 .L>) (AMT <2 .L>) (VAL <4 .L>) AC
1098                              (OTH-AC <>) (NAC <PUTPROP .L DONE>))
1099    #DECL ((L) LIST (STR) ATOM (AMT) <OR FIX ATOM> (VAL) ATOM
1100           (AC NAC) <OR ATOM FALSE> (BYTES?) <OR ATOM FALSE>)
1101    <COND
1102     (<AND <NOT .NAC> <==? .AMT 1> <N==? .STR .VAL> <NOT .OTH-VAL>>
1103      <SET NAC <STRING-REST-LOOK-AHEAD .L .STR .VAL .BYTES?>>)
1104     (.OTH-VAL
1105      <COND (<==? .OP PUT>
1106             <COND (<SET OTH-AC <IN-AC? .OTH-VAL BOTH>>
1107                    <AC-TIME <GET-AC .OTH-AC> <SETG AC-STAMP <+ ,AC-STAMP 1>>>
1108                    <AC-TIME <GET-AC <SET OTH-AC <NEXT-AC .OTH-AC>>> ,AC-STAMP>)
1109                   (<SET OTH-AC <IN-AC? .OTH-VAL VALUE>>
1110                    <AC-TIME <GET-AC .OTH-AC> <SETG AC-STAMP <+ ,AC-STAMP 1>>>)
1111                   (<TYPE? .OTH-VAL ATOM>
1112                    <OCEMIT MOVE <SET OTH-AC O*> !<OBJ-VAL .OTH-VAL>>)
1113                   (ELSE
1114                    <OCEMIT MOVEI <SET OTH-AC O*> <CHTYPE .OTH-VAL FIX>>)>)>)>
1115    <COND
1116     (.NAC <SET VAL T>)
1117     (<AND <==? .AMT 1> <NOT <IN-AC? .STR BOTH>> <==? .STR .VAL>>
1118      <COND (<AND <SET NAC <IN-AC? .STR TYPE>> <NOT <AC-UPDATE <GET-AC .NAC>>>>
1119             <MUNGED-AC .NAC>)>
1120      <COND (<AND <SET NAC <IN-AC? .STR VALUE>> <NOT <AC-UPDATE <GET-AC .NAC>>>>
1121             <MUNGED-AC .NAC>)>
1122      <OCEMIT SOS O* !<OBJ-TYP .STR>>
1123      <COND (.OTH-VAL
1124             <COND (<==? .OP PUT> <OCEMIT IDPB .OTH-AC !<OBJ-VAL .STR>>)
1125                   (<==? .OTH-VAL STACK>
1126                    <OCEMIT ILDB O* !<OBJ-VAL .STR>>
1127                    <OCEMIT PUSH
1128                            TP*
1129                            !<TYPE-WORD <COND (.BYTES? FIX) (ELSE CHARACTER)>>>
1130                    <OCEMIT PUSH TP* O*>
1131                    <COND (,WINNING-VICTIM
1132                           <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
1133                   (ELSE
1134                    <SET OTH-AC <ASSIGN-AC .OTH-VAL BOTH>>
1135                    <AC-TYPE <GET-AC .OTH-AC>
1136                             <COND (.BYTES? FIX) (ELSE CHARACTER)>>
1137                    <OCEMIT ILDB <NEXT-AC .OTH-AC> !<OBJ-VAL .STR>>)>)
1138            (ELSE <OCEMIT IBP O* !<OBJ-VAL .STR>>)>)
1139     (<TYPE? .AMT FIX>
1140      <COND (<==? .AMT 1>
1141             <SET NAC <LOAD-AC .STR BOTH>>
1142             <COND (<OR <NOT .OTH-VAL> <==? .OP PUT> <==? .OTH-VAL STACK>>
1143                    <COND (<NOT <OR <AND <ASSIGNED? DEAD?> .DEAD?>
1144                                    <AND <NOT <ASSIGNED? DEAD?>>
1145                                         <WILL-DIE? .STR>>
1146                                    <==? .STR .VAL>>>
1147                           <FLUSH-AC .NAC T>)>
1148                    <MUNGED-AC .NAC T>)>)
1149            (ELSE
1150             <SET NAC <LOAD-AC .STR TYPE>>
1151             <COND (<NOT <WILL-DIE? .STR>> <FLUSH-AC .NAC>)>
1152             <MUNGED-AC .NAC>)>
1153      <OCEMIT SUBI .NAC .AMT>
1154      <COND
1155       (<==? .AMT 1>
1156        <COND (.OTH-VAL
1157               <COND (<==? .OP PUT> <OCEMIT IDPB .OTH-AC <NEXT-AC .NAC>>)
1158                     (<==? .OTH-VAL STACK>
1159                      <OCEMIT ILDB O* <NEXT-AC .NAC>>
1160                      <OCEMIT PUSH
1161                              TP*
1162                              !<TYPE-WORD <COND (.BYTES? FIX)
1163                                                (ELSE CHARACTER)>>>
1164                      <OCEMIT PUSH TP* O*>
1165                      <COND (,WINNING-VICTIM
1166                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
1167                     (ELSE
1168                      <COND (<NOT <OR <AND <ASSIGNED? DEAD?> .DEAD?>
1169                                      <AND <NOT <ASSIGNED? DEAD?>>
1170                                           <WILL-DIE? .STR>>
1171                                      <==? .STR .VAL>>>
1172                             <FLUSH-AC .NAC T>)>
1173                      <MUNGED-AC .NAC T>
1174                      <SET OTH-AC <ASSIGN-AC .OTH-VAL BOTH>>
1175                      <AC-TYPE <GET-AC .OTH-AC>
1176                               <COND (.BYTES? FIX) (ELSE CHARACTER)>>
1177                      <OCEMIT ILDB <NEXT-AC .OTH-AC> <NEXT-AC .NAC>>)>)
1178              (ELSE <OCEMIT IBP O* <NEXT-AC .NAC>>)>)
1179       (<AND <==? <IN-AC? .STR VALUE> <NEXT-AC .NAC>>
1180             <AC-UPDATE <GET-AC <NEXT-AC .NAC>>>>
1181        <SMASH-AC O* .STR VALUE>
1182        <MUNGED-AC O*>
1183        <OCEMIT MOVEI <NEXT-AC .NAC> .AMT>
1184        <OCEMIT <COND (,ADJBP-HACK MADJBP)
1185                      (T ADJBP)> <NEXT-AC .NAC> O*>)
1186       (ELSE
1187        <FLUSH-AC <NEXT-AC .NAC>>
1188        <MUNGED-AC <NEXT-AC .NAC>>
1189        <OCEMIT MOVEI <NEXT-AC .NAC> .AMT>
1190        <OCEMIT <COND (,ADJBP-HACK MADJBP)
1191                      (T ADJBP)> <NEXT-AC .NAC> !<OBJ-VAL .STR>>)>
1192      <CLEAN-ACS .VAL>
1193      <AC-CODE <AC-ITEM <AC-UPDATE <GET-AC .NAC> T> .VAL> TYPE>
1194      <AC-CODE <AC-ITEM <AC-UPDATE <GET-AC <NEXT-AC .NAC>> T> .VAL> VALUE>)
1195     (<==? .AMT .VAL>
1196      <COND (<SET AC <IN-AC? .AMT VALUE>>) (ELSE <SET AC <LOAD-AC .AMT VALUE>>)>
1197      <SET NAC <GETPROP .AC AC-PAIR>>
1198      <OCEMIT MOVE .NAC !<OBJ-TYP .STR>>
1199      <OCEMIT SUB .NAC !<OBJ-VAL .AMT>>
1200      <OCEMIT <COND (,ADJBP-HACK MADJBP)
1201                    (T ADJBP)> .AC !<OBJ-VAL .STR>>
1202      <AC-CODE <AC-ITEM <AC-UPDATE <GET-AC .NAC> T> .VAL> TYPE>
1203      <AC-ITEM <AC-UPDATE <GET-AC .AC> T> .VAL>)
1204     (<==? .VAL .STR>
1205      <SET NAC <LOAD-AC .STR TYPE>>
1206      <OCEMIT SUB .NAC !<OBJ-VAL .AMT>>
1207      <FLUSH-AC <NEXT-AC .NAC>>
1208      <MUNGED-AC <NEXT-AC .NAC>>
1209      <OCEMIT MOVE <NEXT-AC .NAC> !<OBJ-VAL .AMT>>
1210      <OCEMIT <COND (,ADJBP-HACK MADJBP)
1211                    (T ADJBP)> <NEXT-AC .NAC> !<OBJ-VAL .STR>>
1212      <AC-ITEM <AC-UPDATE <GET-AC .NAC> T> .VAL>
1213      <AC-TIME <AC-CODE <AC-ITEM <AC-UPDATE <GET-AC <NEXT-AC .NAC>> T> .VAL>
1214                        VALUE>
1215               ,AC-STAMP>)
1216     (T
1217      <SET NAC <ASSIGN-AC .VAL BOTH T>>
1218      <COND (<N==? <IN-AC? .STR TYPE> .NAC>
1219             <OCEMIT MOVE .NAC !<OBJ-TYP .STR>>)>
1220      <OCEMIT SUB .NAC !<OBJ-VAL .AMT>>
1221      <OCEMIT MOVE <NEXT-AC .NAC> !<OBJ-VAL .AMT>>
1222      <OCEMIT <COND (,ADJBP-HACK MADJBP)
1223                    (T ADJBP)> <NEXT-AC .NAC> !<OBJ-VAL .STR>>)>
1224    <COND (<==? .VAL STACK>
1225           <OCEMIT PUSH TP* .NAC>
1226           <OCEMIT PUSH TP* <NEXT-AC .NAC>>
1227           <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>>
1228
1229 <DEFINE RESTUB!-MIMOC (L)
1230   <RESTUS!-MIMOC .L T>>
1231
1232 <SETG LENU!-MIMOC ,LENUV!-MIMOC>
1233
1234 <SETG LENUS!-MIMOC ,LENUV!-MIMOC>
1235
1236 <SETG LENUB!-MIMOC ,LENUV!-MIMOC>
1237
1238 <SETG LENUU!-MIMOC ,LENUV!-MIMOC>
1239
1240 <SETG EMPU?!-MIMOC ,EMPUV?!-MIMOC>
1241
1242 <SETG EMPUU?!-MIMOC ,EMPUV?!-MIMOC>
1243
1244 <SETG EMPUS?!-MIMOC ,EMPUV?!-MIMOC>
1245
1246 <SETG EMPUB?!-MIMOC ,EMPUV?!-MIMOC>
1247
1248 <SETG LENR!-MIMOC ,LENUV!-MIMOC>
1249
1250 <DEFINE EMPR?!-MIMOC (L) T ;"NO CODE">
1251
1252 \f
1253 ;"RECORD manipulation"
1254
1255 <DEFINE GVAL!-MIMOC (L "AUX" (ATM <1 .L>) (VAL <3 .L>) AC NAC (XGL <>)
1256                              (RATM .ATM))
1257         #DECL ((L) LIST (ATM) <OR ATOM <FORM ATOM ATOM>> (VAL AC) ATOM)
1258         <COND (<TYPE? .ATM FORM>
1259                <SET XGL <CHTYPE <2 .ATM> XGLOC>>
1260                <SET RATM <1 .ATM>>)>
1261         <COND (<AND ,GVAL-CAREFUL <N=? <SPNAME .RATM> "M$$BINDID">>
1262                <COND (.XGL
1263                       <SAVE-ACS>
1264                       <OCEMIT SKIPN @ !<OBJ-VAL .XGL>>
1265                       <OCEMIT GVERR !<OBJ-VAL .XGL>>
1266                       <OCEMIT DMOVE A1* @ !<OBJ-VAL .XGL>>)
1267                      (<SET NAC <IN-AC? .ATM VALUE>>
1268                       <COND (<OR <==? .VAL .ATM> <WILL-DIE? .ATM>>
1269                              <DEAD!-MIMOC (.ATM) T>)>
1270                       <SAVE-ACS>
1271                       <OCEMIT SKIPE (.NAC)>
1272                       <OCEMIT SKIPN @ (.NAC)>
1273                       <OCEMIT GVERR .NAC>
1274                       <OCEMIT DMOVE A1* @ (.NAC)>)
1275                      (ELSE
1276                       <SAVE-ACS>
1277                       <OCEMIT SKIPE T* @ !<OBJ-VAL .ATM>>
1278                       <OCEMIT SKIPN '(T*)>
1279                       <OCEMIT GVERR !<OBJ-VAL .ATM>>
1280                       <OCEMIT DMOVE A1* '(T*)>)>
1281                <PUSHJ-VAL .VAL>)
1282               (<==? .VAL STACK>
1283                <COND (<AND .XGL <NOT ,BOOT-MODE>>
1284                       <SMASH-AC <SET NAC T*> .XGL VALUE>)
1285                      (<SET NAC <IN-AC? .ATM VALUE>>)
1286                      (ELSE
1287                       <SET NAC <NEXT-AC <LOAD-AC .ATM BOTH>>>)>
1288                <COND (<OR ,BOOT-MODE <NOT .XGL>>
1289                       <OCEMIT MOVE T* (.NAC)>
1290                       <MUNGED-AC T*>)>
1291                <OCEMIT PUSH TP* '(T*)>
1292                <OCEMIT PUSH TP* 1 '(T*)>
1293                <COND (,WINNING-VICTIM
1294                       <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
1295               (T
1296                <COND (,BOOT-MODE
1297                       <SMASH-AC T* .ATM VALUE>
1298                       <SET AC <ASSIGN-AC .VAL BOTH>>
1299                       <OCEMIT DMOVE .AC @ '(T*)>
1300                       <AC-CODE <GET-AC T*> DUMMY>)
1301                      (.XGL
1302                       <SET AC <ASSIGN-AC .VAL BOTH>>
1303                       <OCEMIT DMOVE .AC @ !<OBJ-VAL .XGL>>)
1304                      (ELSE
1305                       <SET NAC <OR <IN-AC? .ATM VALUE>
1306                                    <NEXT-AC <LOAD-AC .ATM BOTH>>>>
1307                       <SET AC <ASSIGN-AC .VAL BOTH>>
1308                       <OCEMIT DMOVE .AC @ (.NAC)>)>)>>
1309
1310 <DEFINE SETG!-MIMOC (L "AUX" (ATM <1 .L>) (VAL <2 .L>) AC)
1311         #DECL ((L) LIST (ATM) <FORM ATOM ATOM> (AC) ATOM (VAL) ANY)
1312         <SET AC <LOAD-AC .VAL BOTH>>
1313         <COND (,BOOT-MODE
1314                <SMASH-AC T* .ATM VALUE>
1315                <OCEMIT DMOVEM .AC @ '(T*)>
1316                <AC-CODE <GET-AC T*> DUMMY>)
1317               (T
1318                <OCEMIT DMOVEM .AC @ !<OBJ-VAL <CHTYPE <2 .ATM> XGLOC>>>)>>
1319
1320 <GDECL (NTHR-TABLE PUTR-TABLE) <VECTOR [REST ATOM]>>
1321
1322 <SETG NTHR-TABLE
1323       '[LBIND
1324         LBIND-NTH
1325         T$LBIND
1326         LBIND-NTH
1327         GBIND
1328         LBIND-NTH
1329         T$GBIND
1330         LBIND-NTH
1331         ATOM
1332         ATOM-NTH
1333         T$ATOM
1334         ATOM-NTH
1335         LVAL
1336         ATOM-NTH
1337         GVAL
1338         ATOM-NTH
1339         OBLIST
1340         ATOM-NTH
1341         T$OBLIST
1342         ATOM-NTH
1343         T$FRAME
1344         FRAME-NTH
1345         FRAME
1346         FRAME-NTH]>
1347
1348 <SETG PUTR-TABLE
1349       '[LBIND
1350         LBIND-PUT
1351         T$LBIND
1352         LBIND-PUT
1353         GBIND
1354         LBIND-PUT
1355         T$GBIND
1356         LBIND-PUT
1357         ATOM
1358         ATOM-PUT
1359         T$ATOM
1360         ATOM-PUT
1361         LVAL
1362         ATOM-PUT
1363         GVAL
1364         ATOM-PUT
1365         OBLIST
1366         ATOM-PUT
1367         T$OBLIST
1368         ATOM-PUT
1369         T$FRAME
1370         FRAME-PUT
1371         FRAME
1372         FRAME-PUT]>
1373
1374 <DEFINE FRAME-PUT (L "AUX" (ARG1 <1 .L>) (ARG2 <2 .L>) (VAL <3 .L>) AC NAC)
1375         #DECL ((L) LIST)
1376         <COND (<N==? .ARG2 1>
1377                <PUTR!-MIMOC .L T>)
1378               (ELSE
1379                <SET NAC <COND (<IN-AC? .ARG1 VALUE>)
1380                               (<NOT <WILL-DIE? .ARG1>>
1381                                <NEXT-AC <LOAD-AC .ARG1 BOTH>>)
1382                               (T <SMASH-AC T* .ARG1 VALUE>)>>
1383                <SET AC <COND (<IN-AC? .VAL VALUE>)
1384                              (<OR <WILL-DIE? .VAL>
1385                                   <NOT <TYPE? .VAL ATOM>>>
1386                               <SMASH-AC O* .VAL VALUE>)
1387                              (ELSE
1388                               <SETG FIRST-AC <>>
1389                               <AC-TIME <GET-AC .NAC>
1390                                        <SETG AC-STAMP <+ ,AC-STAMP 1>>>
1391                               <NEXT-AC <LOAD-AC .VAL BOTH>>)>>
1392                <OCEMIT MOVEM .AC 0 (.NAC)>
1393                <COND (<==? .NAC T*> <AC-CODE <GET-AC T*> DUMMY>)>)>>
1394
1395 <DEFINE FRAME-NTH (L "AUX" (ARG1 <1 .L>) (ARG2 <2 .L>) (VAL <4 .L>) AC NAC XAC)
1396         #DECL ((L) LIST (ARG1) ANY (ARG2) FIX (AC NAC VAL) ATOM
1397                (XAC) <OR FALSE ATOM> (EX) <OR FALSE <LIST ATOM ATOM ATOM>>)
1398         <COND (<AND <N==? .ARG2 1> <N==? .ARG2 5> <N==? .ARG2 7>>
1399                <NTHR!-MIMOC .L T>)
1400               (T
1401                <SET NAC <COND (<AND <SET XAC <IN-AC? .ARG1 VALUE>>
1402                                     <N==? .XAC O*>>
1403                                <AC-TIME <GET-AC .XAC>
1404                                         <SETG AC-STAMP <+ ,AC-STAMP 1>>>
1405                                <SETG FIRST-AC <>>
1406                                .XAC)
1407                               (<NOT <WILL-DIE? .ARG1>>
1408                                <NEXT-AC <LOAD-AC .ARG1 BOTH>>)
1409                               (T <SMASH-AC T* .ARG1 VALUE>)>>
1410                <SET AC <ASSIGN-AC .VAL BOTH T>>
1411                <COND (<==? .ARG2 1>             ;"The frames MSUBR"
1412                       <AC-TYPE <GET-AC .AC> MSUBR>
1413                       <OCEMIT MOVE <NEXT-AC .AC> 0 (.NAC)>)
1414                      (<==? .ARG2 5>             ;"The previous 'frame'"
1415                       <AC-TYPE <GET-AC .AC> FRAME>
1416                       <OCEMIT MOVE <NEXT-AC .AC> 3 (.NAC)>
1417                       <OCEMIT SKIPL (<NEXT-AC .AC>)>
1418                        <OCEMIT ADDI <NEXT-AC .AC> 4>)
1419                      (ELSE
1420                       <AC-TYPE <GET-AC .AC> LBIND>
1421                       <OCEMIT HRRZ <NEXT-AC .AC> 4 (.NAC)>
1422                       <OCEMIT HLLI <NEXT-AC .AC> (.NAC)>)>
1423                <COND (<==? .NAC T*> <AC-CODE <GET-AC T*> DUMMY>)>
1424                <COND (<==? .VAL STACK>
1425                       <OCEMIT PUSH TP* !<TYPE-WORD <AC-TYPE <GET-AC .AC>>>>
1426                       <OCEMIT PUSH TP* <NEXT-AC .AC>>
1427                       <COND (,WINNING-VICTIM
1428                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>)>>
1429
1430 <DEFINE LBIND-NTH (L
1431                    "AUX" (ARG1 <1 .L>) (ARG2 <2 .L>) (VAL <4 .L>) AC NAC XAC
1432                          EX)
1433         #DECL ((L) LIST (ARG1) ANY (ARG2) FIX (AC VAL) ATOM
1434                (XAC) <OR FALSE ATOM> (EX) <OR FALSE <LIST ATOM ATOM ATOM>>)
1435         <COND (<OR <G? .ARG2 6> <L? .ARG2 1>>
1436                <MIMOCERR OUT-OF-BOUNDS!-ERRORS NTHR LBIND .ARG2>)
1437               (T
1438                <SET NAC
1439                     <COND (<AND <SET XAC <IN-AC? .ARG1 VALUE>>
1440                                 <N==? .XAC O*>>
1441                            <AC-TIME <GET-AC .XAC>
1442                                     <SETG AC-STAMP <+ ,AC-STAMP 1>>>
1443                            <SETG FIRST-AC <>>
1444                            .XAC)
1445                           (<AND <==? .ARG2 1> <N==? .VAL STACK>> <>)
1446                           (<NOT <WILL-DIE? .ARG1>>
1447                            <NEXT-AC <LOAD-AC .ARG1 BOTH>>)
1448                           (T
1449                            <SMASH-AC T* .ARG1 VALUE>
1450                            <FLUSH-AC T*>
1451                            <MUNGED-AC T*>
1452                            T*)>>
1453                <COND (<N==? .VAL STACK>
1454                       <SET AC <ASSIGN-AC .VAL BOTH T>>
1455                       <COND (<AND <==? <NEXT-AC .AC> .NAC>
1456                                   <==? .VAL .ARG1>>
1457                              <AC-TYPE <GET-AC .AC> <>>)>)>
1458                <COND (<==? .ARG2 1>
1459                       <COND (<==? .VAL STACK>
1460                              <OCEMIT PUSH TP* (.NAC)>
1461                              <OCEMIT PUSH TP* 1 (.NAC)>
1462                              <COND (,WINNING-VICTIM
1463                                     <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
1464                             (.NAC <OCEMIT DMOVE .AC (.NAC)>)
1465                             (ELSE <OCEMIT DMOVE .AC @ !<OBJ-VAL .ARG1>>)>)
1466                      (<==? .ARG2 3>
1467                       <COND (<==? .VAL STACK>
1468                              <OCEMIT PUSH TP* 3 (.NAC)>
1469                              <OCEMIT PUSH TP* 4 (.NAC)>
1470                              <COND (,WINNING-VICTIM
1471                                     <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
1472                             (ELSE <OCEMIT DMOVE .AC 3 (.NAC)>)>)
1473                      (<MEMQ .ARG2 '[2 6]>
1474                       <COND (<==? .VAL STACK>
1475                              <OCEMIT PUSH
1476                                      TP*
1477                                      !<TYPE-WORD <NTH '[#FALSE ()
1478                                                         ATOM
1479                                                         #FALSE ()
1480                                                         #FALSE ()
1481                                                         #FALSE ()
1482                                                         FIX]
1483                                                       .ARG2>>>
1484                              <OCEMIT PUSH
1485                                      TP*
1486                                      <NTH '[#FALSE ()
1487                                             2
1488                                             #FALSE ()
1489                                             #FALSE ()
1490                                             #FALSE ()
1491                                             7]
1492                                           .ARG2>
1493                                      (.NAC)>
1494                              <COND (,WINNING-VICTIM
1495                                     <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
1496                             (ELSE
1497                              <AC-TYPE <GET-AC .AC>
1498                                       <NTH '[#FALSE ()
1499                                              ATOM
1500                                              #FALSE ()
1501                                              #FALSE ()
1502                                              #FALSE ()
1503                                              FIX]
1504                                            .ARG2>>
1505                              <OCEMIT MOVE
1506                                      <NEXT-AC .AC>
1507                                      <NTH '[#FALSE ()
1508                                             2
1509                                             #FALSE ()
1510                                             #FALSE ()
1511                                             #FALSE ()
1512                                             7]
1513                                           .ARG2>
1514                                      (.NAC)>)>)
1515                      (T
1516                       <COND (<==? .VAL STACK>
1517                              <SET AC <ASSIGN-AC .VAL BOTH T>>)>
1518                       <COND (<SET EX <EXTRAMEM BRANCH-FALSE .L>>
1519                              <LABEL-UPDATE-ACS <3 .EX> <>>)>
1520                       <OCEMIT MOVE .AC !<TYPE-WORD T$LBIND>>
1521                       <COND (.EX
1522                              <OCEMIT <COND (<==? <2 .EX> +> SKIPN) (T SKIPE)>
1523                                      <NEXT-AC .AC>
1524                                      <NTH '[#FALSE ()
1525                                             #FALSE ()
1526                                             #FALSE ()
1527                                             5
1528                                             6
1529                                             #FALSE ()]
1530                                           .ARG2>
1531                                      (.NAC)>
1532                              <OCEMIT JRST <XJUMP <3 .EX>>>
1533                              <SETG NEXT-FLUSH 1>)
1534                             (T
1535                              <OCEMIT SKIPN
1536                                      <NEXT-AC .AC>
1537                                      <NTH '[#FALSE ()
1538                                             #FALSE ()
1539                                             #FALSE ()
1540                                             5
1541                                             6
1542                                             #FALSE ()]
1543                                           .ARG2>
1544                                      (.NAC)>
1545                              <OCEMIT MOVE .AC !<TYPE-WORD FALSE>>)>
1546                       <COND (<==? .VAL STACK>
1547                              <OCEMIT PUSH TP* .AC>
1548                              <OCEMIT PUSH TP* <NEXT-AC .AC>>
1549                              <COND (,WINNING-VICTIM
1550                                     <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>)>)>>
1551
1552 <DEFINE LBIND-PUT (L "AUX" (ARG1 <1 .L>) (ARG2 <2 .L>) (VAL <3 .L>) AC NAC XAC)
1553         #DECL ((L) LIST (ARG1 VAL) ANY (ARG2) FIX (AC) ATOM)
1554         <COND (<OR <G? .ARG2 6> <L? .ARG2 1>>
1555                <MIMOCERR OUT-OF-BOUNDS!-ERRORS NTHR LBIND .ARG2>)
1556               (T
1557                <SET AC <COND (<MEMQ .ARG2 '[1 3]>
1558                               <LOAD-AC .VAL BOTH>)
1559                              (<SET XAC <IN-AC? .VAL VALUE>>
1560                               <AC-TIME <GET-AC .XAC>
1561                                        <SETG AC-STAMP <+ ,AC-STAMP 1>>>
1562                               <SETG FIRST-AC <>>
1563                               .XAC)
1564                              (<OR <NOT <TYPE? .VAL ATOM>>
1565                                   <WILL-DIE? .VAL>>
1566                               <SMASH-AC O* .VAL VALUE>)
1567                              (ELSE <NEXT-AC <LOAD-AC .VAL BOTH>>)>>
1568                <SET NAC <COND (<IN-AC? .ARG1 VALUE>)
1569                               (<==? .ARG1 1> <>)
1570                               (T
1571                                <SMASH-AC T* .ARG1 VALUE>
1572                                <AC-CODE <GET-AC T*> DUMMY>
1573                                T*)>>
1574                <COND (<==? .ARG2 1>
1575                       <COND (.NAC <OCEMIT DMOVEM .AC (.NAC)>)
1576                             (ELSE <DMOVEM .AC @ !<OBJ-VAL .ARG1>>)>)
1577                      (<==? .ARG2 3>
1578                       <OCEMIT DMOVEM .AC 3 (.NAC)>)
1579                      (T
1580                       <OCEMIT MOVEM
1581                               .AC
1582                               <NTH '[%<> 2 %<> 5 6 7] .ARG2>
1583                               (.NAC)>)>)>>
1584
1585 <DEFINE ATOM-NTH (L
1586                   "AUX" (ARG1 <1 .L>) (ARG2 <2 .L>) (VAL <4 .L>) AC NAC XAC EX
1587                         (LAB <>) TY LBL (TEX <>) (WD <>) TG (AC-T1 <>)
1588                         NEW (WD1 <>) (AC-T2 <>))
1589    #DECL ((L) LIST (ARG1) ANY (ARG2) FIX (NAC VAL SKIP) ATOM
1590           (AC-T1 AC-T2) <OR FALSE FIX>
1591           (AC XAC) <OR FALSE ATOM> (EX) <OR FALSE <LIST ATOM ATOM ATOM>>)
1592    <COND
1593     (<OR <G? .ARG2 5> <L? .ARG2 1>>
1594      <MIMOCERR OUT-OF-BOUNDS!-ERRORS NTHR ATOM .ARG2>)
1595     (T
1596      <SET NAC
1597           <COND (<AND <SET XAC <IN-AC? .ARG1 VALUE>>
1598                       <N==? .XAC O*>>
1599                  <AC-TIME <GET-AC .XAC> <SETG AC-STAMP <+ ,AC-STAMP 1>>>
1600                  <SETG FIRST-AC <>>
1601                  .XAC)
1602                 (<NOT <WILL-DIE? .ARG1>>
1603                  <NEXT-AC <LOAD-AC .ARG1 BOTH>>)
1604                 (T
1605                  <SMASH-AC T* .ARG1 VALUE>
1606                  <FLUSH-AC T*>
1607                  <MUNGED-AC T*>
1608                  T*)>>
1609      <COND
1610       (<==? .ARG2 3>
1611        <COND (<==? .VAL STACK>
1612               <OCEMIT PUSH TP* 2 (.NAC)>
1613               <SMASH-AC O* <TYPE-CODE STRING> VALUE>
1614               <OCEMIT HRLM O* '(TP*)>
1615               <OCEMIT PUSH TP* 3 (.NAC)>
1616               <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
1617              (ELSE
1618               <SET AC <ASSIGN-AC .VAL BOTH T>>
1619               <OCEMIT DMOVE .AC 2 (.NAC)>
1620               <OCEMIT HRLI .AC <TYPE-CODE STRING>>)>)
1621       (T
1622        <COND (<SET EX <EXTRAMEM BRANCH-FALSE .L>>
1623               <SET LAB <3 .EX>>
1624               <SET WD <AND <SET WD1 <WILL-DIE? .VAL <REST .MIML>>>
1625                            <WILL-DIE? .VAL <LAB-CODE-PNTR ,.LAB>>>>)>
1626        <SET TEX <EXTRAMEM TYPE .L>>
1627        <COND (<NOT .WD>
1628               <SET AC <ASSIGN-AC .VAL BOTH T>>)
1629              (ELSE <SET AC <>>)>
1630        <COND (<AND <NOT .WD> <==? .ARG2 5>>
1631               <COND (<NOT .EX>
1632                      <OCEMIT MOVSI .AC <TYPE-CODE TYPE-C>>)>)
1633              (<AND <NOT .WD> <NOT .EX> <NOT .TEX>>
1634               <OCEMIT MOVE
1635                       .AC
1636                       !<TYPE-WORD <NTH '[GBIND LBIND #FALSE () OBLIST]
1637                                        .ARG2>>>)>
1638        <COND (<AND .EX <OR .WD <N==? .ARG2 5> <==? <2 .EX> +>>>
1639               <SET NEW <LABEL-UPDATE-ACS .LAB <> <> .NAC>>
1640               <AC-UPDATE <GET-AC .AC> T>
1641               <AC-UPDATE <GET-AC <NEXT-AC .AC>> T>
1642               <COND (<N==? .NAC <1 .NEW>>
1643                      <SET AC-T1 <AC-TIME <GET-AC <SET NAC <1 .NEW>>>>>)>
1644               <OCEMIT <COND (<==? <2 .EX> +>
1645                              <COND (<==? .ARG2 5> SKIPGE) (ELSE SKIPN)>)
1646                             (<==? .ARG2 5> SKIPL)
1647                             (T SKIPE)>
1648                       <COND (.WD O*) (ELSE <NEXT-AC .AC>)>
1649                       <NTH '[0 1 #FALSE () 4 2] .ARG2>
1650                       (.NAC)>
1651               <COND (<==? .ARG2 5>
1652                      <OCEMIT JRST <XJUMP .LAB>>
1653                      <COND (<NOT .WD1>
1654                             <COND (<==? <2 .EX> +>
1655                                    <OCEMIT HLRZS O* <NEXT-AC .AC>>)>)>)
1656                     (ELSE <OCEMIT JRST <XJUMP .LAB>>)>
1657               <COND (.AC-T1
1658                      <AC-TIME <GET-AC .NAC> .AC-T1>)>
1659               <COND (<NOT .WD1>
1660                      <COND (<==? <2 .EX> +>
1661                             <AC-TYPE <GET-AC .AC>
1662                                      <NTH '[GBIND LBIND T OBLIST TYPE-C]
1663                                           .ARG2>>)
1664                            (ELSE
1665                             <AC-TYPE <GET-AC .AC> FALSE>)>)>
1666               <SETG NEXT-FLUSH 1>)
1667              (<==? .ARG2 5>
1668               <OCEMIT HLRE <NEXT-AC .AC> 2 (.NAC)>
1669               <COND (.EX
1670                      <AC-ITEM <GET-AC .AC> .VAL>
1671                      <AC-ITEM <GET-AC <NEXT-AC .AC>> .VAL>
1672                      <COND (.WD1 <AC-TYPE <GET-AC .AC> TYPE-C>)
1673                            (ELSE <OCEMIT MOVSI .AC <TYPE-CODE TYPE-C>>)>
1674                      <SET NEW <LABEL-UPDATE-ACS .LAB <> <> .NAC .AC>>
1675                      <COND (<N==? .NAC <1 .NEW>>
1676                             <SET AC-T1 <AC-TIME <GET-AC <SET NAC <1 .NEW>>>>>)>
1677                      <COND (<N==? .AC <2 .NEW>>
1678                             <SET AC-T2 <AC-TIME <GET-AC <SET AC <2 .NEW>>>>>)>
1679                      <SETG NEXT-FLUSH 1>)>
1680               <COND (<NOT .TEX>
1681                      <OCEMIT JUMPGE
1682                              <NEXT-AC .AC>
1683                              <XJUMP <COND (.EX .LAB)
1684                                           (ELSE <SET LBL <GENLBL "FOO">>)>>>
1685                      <COND (<NOT .WD1>
1686                             <OCEMIT MOVEI <NEXT-AC .AC> 0>
1687                             <OCEMIT MOVSI .AC <TYPE-CODE FALSE>>)>
1688                      <COND (<NOT .EX> <LABEL .LBL>)>)>
1689               <COND (.AC-T1
1690                      <AC-TIME <GET-AC .NAC> .AC-T1>)>
1691               <COND (.AC-T2
1692                      <AC-TIME <GET-AC .AC> .AC-T2>
1693                      <AC-TIME <GET-AC <NEXT-AC .AC>> .AC-T2>)>)
1694              (.TEX
1695               <OCEMIT MOVE <NEXT-AC .AC> <NTH '[0 1 #FALSE () 4] .ARG2>
1696                       (.NAC)>
1697               <AC-TYPE <GET-AC .AC> <2 .TEX>>)
1698              (T
1699               <OCEMIT SKIPN
1700                       <NEXT-AC .AC>
1701                       <NTH '[0 1 #FALSE () 4] .ARG2>
1702                       (.NAC)>
1703               <OCEMIT MOVSI .AC <TYPE-CODE FALSE>>)>
1704        <COND (<==? .VAL STACK>
1705               <OCEMIT PUSH TP* .AC>
1706               <OCEMIT PUSH TP* <NEXT-AC .AC>>
1707               <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>)>)>>
1708
1709 <DEFINE EXTRAMEM (NAM LST)
1710         #DECL ((NAM) ATOM (LST) LIST)
1711         <MAPF <>
1712               <FUNCTION (ITM)
1713                    #DECL ((ITM) ANY)
1714                    <COND (<AND <TYPE? .ITM LIST>
1715                                <G? <LENGTH .ITM> 1>
1716                                <==? <1 .ITM> .NAM>>
1717                           <MAPLEAVE .ITM>)>>
1718               .LST>>
1719
1720 <DEFINE ATOM-PUT (L "AUX" (ARG1 <1 .L>) (ARG2 <2 .L>) (V <3 .L>) AC NAC AC1)
1721         #DECL ((L) LIST (ARG1) ANY (ARG2) FIX (AC NAC) ATOM
1722                (AC1) <OR ATOM FALSE>)
1723         <COND (<OR <G? .ARG2 5> <L? .ARG2 1>>
1724                <MIMOCERR OUT-OF-BOUNDS!-ERRORS NTHR LBIND .ARG2>)
1725               (T
1726                <SET NAC <COND (<SET AC1 <IN-AC? .ARG1 VALUE>>
1727                                <AC-TIME <GET-AC .AC1>
1728                                         <SETG AC-STAMP <+ ,AC-STAMP 1>>>
1729                                <SETG FIRST-AC <>>
1730                                .AC1)
1731                               (T
1732                                <SMASH-AC T* .ARG1 VALUE>
1733                                <FLUSH-AC T*>
1734                                <MUNGED-AC T*>
1735                                T*)>>
1736                <COND (<==? .ARG2 3>
1737                       <SET AC <LOAD-AC .V BOTH>>
1738                       <OCEMIT HRRM .AC 2 (.NAC)>
1739                       <OCEMIT MOVEM <NEXT-AC .AC> 3 (.NAC)>)
1740                      (<==? .ARG2 5>
1741                       <COND (<OR <==? <PRIMTYPE .V> WORD>
1742                                  <==? <PRIMTYPE .V> FIX>>
1743                              <SET AC <COND (<IN-AC? .V VALUE>)
1744                                            (T <SMASH-AC O* .V VALUE>)>>
1745                              <OCEMIT HRLM .AC 2 (.NAC)>)
1746                             (<TYPE? .V FALSE>
1747                              <OCEMIT HRROS O* 2 (.NAC)>)
1748                             (ELSE
1749                              <SET AC <COND (<IN-AC? .V VALUE>)
1750                                            (T <SMASH-AC O* .V VALUE>)>>
1751                              <OCEMIT HRLM .AC 2 (.NAC)>
1752                              <COND (<SET AC1 <IN-AC? .V TYPE>>
1753                                     <LOAD-TYPE O* (.AC1)>
1754                                     <MUNGED-AC O*>)
1755                                    (T <SMASH-AC O* .V TYPECODE>)>
1756                              <OCEMIT CAIN O* <TYPE-CODE FALSE>>
1757                              <OCEMIT HRROS O* 2 (.NAC)>)>)
1758                      (T
1759                       <SET AC <COND (<IN-AC? .V VALUE>)
1760                                     (<OR <NOT <TYPE? .V ATOM>>
1761                                          <WILL-DIE? .V>>
1762                                      <SMASH-AC O* .V VALUE>)
1763                                     (ELSE
1764                                      <SETG FIRST-AC <>>
1765                                      <AC-TIME <GET-AC .NAC>
1766                                               <SETG AC-STAMP <+ ,AC-STAMP 1>>>
1767                                      <NEXT-AC <LOAD-AC .V BOTH>>)>>
1768                       <OCEMIT MOVEM
1769                               .AC
1770                               <NTH '[0 1 %<> 4] .ARG2>
1771                               (.NAC)>)>)>>
1772
1773 <DEFINE NTHR!-MIMOC (L  "OPT" (NOGP <>) "AUX" (ARG1 <1 .L>) (ARG2 <2 .L>) T M)
1774         #DECL ((L) LIST (ARG1 T) ANY (M) <OR FALSE VECTOR>
1775                (ARG2) <OR ATOM FIX>)
1776         <COND (<AND <NOT .NOGP>
1777                     <TYPE? .ARG2 FIX>
1778                     <G? <LENGTH .L> 4>
1779                     <TYPE? <SET T <5 .L>> LIST>
1780                     <==? <1 .T> RECORD-TYPE>
1781                     <SET M <MEMQ <2 .T> ,NTHR-TABLE>>>
1782                <APPLY ,<2 .M> .L>)
1783               (T
1784                <UPDATE-ACS>
1785                <OCEMIT MOVE O1* !<OBJ-VAL .ARG1>>
1786                <OCEMIT MOVE O2* !<OBJ-VAL .ARG2>>
1787                <OCEMIT HLRZ A1* !<OBJ-TYP .ARG1>>
1788                <OCEMIT ANDI A1* *177777*>
1789                <OCEMIT LSH A1* -6>
1790                <PUSHJ NTHR <4 .L>>)>>
1791
1792 <DEFINE PUTR!-MIMOC (L "OPT" (NOGP <>) "AUX" (ARG1 <1 .L>) (ARG2 <2 .L>) T M)
1793         #DECL ((L) LIST (ARG1 T) ANY (M) <OR FALSE VECTOR>
1794                (ARG2) <OR ATOM FIX>)
1795         <COND (<AND <NOT .NOGP>
1796                     <TYPE? .ARG2 FIX>
1797                     <G? <LENGTH .L> 3>
1798                     <TYPE? <SET T <4 .L>> LIST>
1799                     <==? <1 .T> RECORD-TYPE>
1800                     <SET M <MEMQ <2 .T> ,PUTR-TABLE>>>
1801                <APPLY ,<2 .M> .L>)
1802               (T
1803                <UPDATE-ACS>
1804                <SMASH-AC C1* <3 .L> BOTH>
1805                <OCEMIT MOVE O1* !<OBJ-VAL .ARG1>>
1806                <OCEMIT MOVE O2* !<OBJ-VAL .ARG2>>
1807                <OCEMIT HLRZ A1* !<OBJ-TYP .ARG1>>
1808                <OCEMIT ANDI A1* *177777*>
1809                <OCEMIT LSH A1* -6>
1810                <OCEMIT MOVEI B2* C1*>
1811                <PUSHJ PUTR>)>>
1812
1813 \f
1814 ;"Structure creation"
1815
1816 <DEFINE LIST!-MIMOC (L)
1817         #DECL ((L) <LIST ANY ANY ANY>)
1818         <UPDATE-ACS>
1819         <COND (<AND <TYPE? <1 .L> FIX> <L=? <1 .L> *777777*>>
1820                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <- ,STACK-DEPTH
1821                                                            <* <1 .L> 2>>>)>
1822                <OCEMIT MOVEI O1* <1 .L>>)
1823               (ELSE
1824                <OCEMIT MOVE O1* !<OBJ-VAL <1 .L>>>)>
1825         <PUSHJ LIST <3 .L>>>
1826
1827 <DEFINE UBLOCK!-MIMOC (L) <DO-UBLOCK UBLOCK .L <> T>>
1828
1829 <DEFINE UUBLOCK!-MIMOC (L) <DO-UBLOCK UUBLOCK .L <> <>>>
1830
1831 <DEFINE SBLOCK!-MIMOC (L) <DO-UBLOCK SBLOCK .L T T>>
1832
1833 <DEFINE USBLOCK!-MIMOC (L) <DO-UBLOCK USBLOCK .L T <>>>
1834
1835 <DEFINE DO-UBLOCK (NAM L STACK? INIT? "AUX" ATM NITMS NWRDS)
1836         #DECL ((L) LIST (NITMS NWRDS) FIX)
1837         <UPDATE-ACS>
1838         <COND (<AND <TYPE? <SET ATM <1 .L>> FIX> <L=? .ATM *777777*>>
1839                <OCEMIT MOVEI O1* .ATM>)
1840               (<OR <TYPE? .ATM ATOM>
1841                    <AND <TYPE? .ATM FORM>
1842                         <NOT <EMPTY? .ATM>>
1843                         <==? <1 .ATM> QUOTE>
1844                         <TYPE? <SET ATM <2 .ATM>> ATOM>>>
1845                <OCEMIT MOVEI O1* !<TYPE-CODE .ATM T>>)
1846               (ELSE
1847                <OCEMIT MOVE O1* !<OBJ-VAL .ATM>>)>
1848         <COND (<AND <TYPE? <2 .L> FIX> <L=? <SET NITMS <2 .L>> *777777*>>
1849                <COND (<TYPE? .ATM ATOM> <SET ATM <CHTYPE <TYPE-C .ATM> FIX>>)>
1850                <SET ATM <ANDB .ATM 7>>  ;"Get SAT"
1851                <COND (<==? .ATM 4> ;"BYTES"
1852                       <SET NWRDS </ <+ .NITMS 3> 4>>)
1853                      (<==? .ATM 5> ;"STRING"
1854                       <SET NWRDS </ <+ .NITMS 4> 5>>)
1855                      (<==? .ATM 6>
1856                       <SET NWRDS .NITMS>)
1857                      (ELSE <SET NWRDS <* .NITMS 2>>)>
1858                <COND (,WINNING-VICTIM
1859                       <COND (<AND <NOT .STACK?> .INIT?>
1860                              <SETG STACK-DEPTH <- ,STACK-DEPTH
1861                                                   <* .NITMS 2>>>)
1862                             (<AND .STACK? <NOT .INIT?>>
1863                              <SETG STACK-DEPTH <+ ,STACK-DEPTH
1864                                                   .NWRDS
1865                                                   2>>)
1866                             (.STACK?
1867                              <SETG STACK-DEPTH <+ ,STACK-DEPTH
1868                                                   .NWRDS
1869                                                   2
1870                                                   <- .NITMS>>>)>)>
1871                <OCEMIT MOVEI O2* .NITMS>)
1872               (ELSE
1873                <OCEMIT MOVE O2* !<OBJ-VAL <2 .L>>>)>
1874         <PUSHJ .NAM <4 .L>>>
1875
1876 <DEFINE RECORD!-MIMOC (L "AUX" (TYP <1 .L>) TYP1)
1877         #DECL ((L) LIST (TYP) ANY)
1878         <UPDATE-ACS>
1879         <PROG ()
1880               <COND (<AND <TYPE? .TYP FORM>
1881                           <G? <LENGTH .TYP> 1>
1882                           <==? <1 .TYP> QUOTE>>
1883                      <COND (<OR <==? <SET TYP1 <2 .TYP>> ATOM>
1884                                 <==? .TYP1 LBIND>
1885                                 <==? .TYP1 GBIND>>
1886                             <EXPLICIT-MAKE-RECORD .TYP1 .L>
1887                             <RETURN>)>
1888                      <OCEMIT MOVEI O1* !<TYPE-CODE <2 .TYP> T>>)
1889               (<AND <TYPE? .TYP FIX> <L=? .TYP *777777*>>
1890                <OCEMIT MOVEI O1* .TYP>)
1891               (ELSE
1892                <OCEMIT MOVE O1* !<OBJ-VAL .TYP>>)>
1893         <REPEAT ((LL <REST .L>) (CNT 0) ITM (WV ,WINNING-VICTIM)
1894                  (SD <AND .WV ,STACK-DEPTH>))
1895                 #DECL ((LL) LIST (CNT SD) FIX (ITM) ANY (SD WV) <OR FALSE FIX>)
1896                 <COND (<==? <SET ITM <1 .LL>> =>
1897                        <OCEMIT MOVEI O2* .CNT>
1898                        <SETG STACK-DEPTH .SD>
1899                        <RETURN>)
1900                       (T
1901                        <OCEMIT PUSH TP* !<OBJ-TYP .ITM>>
1902                        <COND (.WV <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
1903                        <OCEMIT PUSH TP* !<OBJ-VAL .ITM>>
1904                        <COND (.WV <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
1905                        <SET CNT <+ .CNT 1>>
1906                        <SET LL <REST .LL>>)>>
1907         <PUSHJ RECORD <NTH .L <LENGTH .L>>>>>
1908
1909 <DEFINE EXPLICIT-MAKE-RECORD (TYP L)
1910         <COND (<==? .TYP ATOM>
1911                <OCEMIT MOVEI O1* !<TYPE-CODE ATOM T>>
1912                <OCEMIT MOVEI O2* 5>  ;"Length of atom in words"
1913                <OCEMIT MOVEI C1* 10>  ;"LH of atom pointer"
1914                <PUSHJ IRECORD>
1915                <PUT-ELEMENTS .L 0 1 '(2 3) 4 -2>)
1916               (<==? .TYP GBIND>
1917                <OCEMIT MOVEI O1* !<TYPE-CODE GBIND T>>
1918                <OCEMIT MOVEI O2* 5>  ;"Length of GBIND in words"
1919                <OCEMIT MOVEI C1* 10>  ;"LH of GBIND pointer"
1920                <PUSHJ IRECORD>
1921                <PUT-ELEMENTS .L '(0 1) 2 '(3 4)>)
1922               (<==? .TYP LBIND>
1923                <OCEMIT MOVEI O1* !<TYPE-CODE LBIND T>>
1924                <OCEMIT MOVEI O2* 8>  ;"Length of LBIND in words"
1925                <OCEMIT MOVEI C1* 16>  ;"LH of LBIND pointer"
1926                <PUSHJ IRECORD>
1927                <PUT-ELEMENTS .L '(0 1) 2 '(3 4) 5 6 7>)>>
1928
1929 <DEFINE PUT-ELEMENTS (L "TUPLE" TUP "AUX" (VAL <NTH .L <LENGTH .L>>)
1930                                           (B-USED <>) (C-USED <>))
1931         #DECL ((L) LIST (TUP) <TUPLE [REST <OR FIX <LIST FIX FIX>>]>)
1932         <MAPF <>
1933               <FUNCTION (ITM OFFS "AUX" ACS)
1934                    <COND (<TYPE? .ITM ATOM>
1935                           <COND (<AND <NOT <OR <==? .ITM .VAL> <WILL-DIE? .ITM>>>
1936                                       <OR <AND <NOT .B-USED> <SET B-USED T>>
1937                                           <AND <NOT .C-USED> <SET C-USED T>>>>
1938                                  <COND (.C-USED
1939                                         <LOAD-AC .ITM BOTH <> <>
1940                                                  <GET-AC <SET ACS C1*>>
1941                                                  <GET-AC C2*>>)
1942                                        (ELSE
1943                                         <LOAD-AC .ITM BOTH <> <>
1944                                                  <GET-AC <SET ACS B1*>>
1945                                                  <GET-AC B2*>>)>
1946                                  <COND (<TYPE? .OFFS FIX>
1947                                         <COND (<L? .OFFS 0>
1948                                                <OCEMIT HRLM <NEXT-AC .ACS>
1949                                                        <- .OFFS>
1950                                                        '(A2*)>
1951                                                <OCEMIT CAMN .ACS
1952                                                        !<TYPE-WORD FALSE>>
1953                                                <OCEMIT HRROS <- .OFFS> '(A2*)>)
1954                                               (ELSE
1955                                                <OCEMIT MOVEM <NEXT-AC .ACS>
1956                                                        .OFFS '(A2*)>
1957                                                <OCEMIT CAMN .ACS
1958                                                        !<TYPE-WORD FALSE>>
1959                                                <OCEMIT SETZM .OFFS '(A2*)>)>)
1960                                        (ELSE
1961                                         <OCEMIT DMOVEM .ACS <1 .OFFS>
1962                                                 '(A2*)>)>)
1963                                 (<TYPE? .OFFS FIX>
1964                                  <OCEMIT DMOVE O1* !<OBJ-TYP .ITM>>
1965                                  <COND (<L? .OFFS 0>
1966                                         <OCEMIT HRLM O2* <- .OFFS> '(A2*)>
1967                                         <OCEMIT CAMN O1*
1968                                                 !<TYPE-WORD FALSE>>
1969                                         <OCEMIT HRROS <- .OFFS> '(A2*)>)
1970                                        (ELSE
1971                                         <OCEMIT MOVEM O2* .OFFS '(A2*)>
1972                                         <OCEMIT CAMN O1*
1973                                                 !<TYPE-WORD FALSE>>
1974                                         <OCEMIT SETZM .OFFS '(A2*)>)>)
1975                                 (ELSE
1976                                  <OCEMIT DMOVE O1* !<OBJ-TYP .ITM>>
1977                                  <OCEMIT DMOVEM O1* <1 .OFFS> '(A2*)>)>)
1978                          (<TYPE? .OFFS FIX>
1979                           <COND (<NOT .ITM>
1980                                  <COND (<L? .OFFS 0>
1981                                         <OCEMIT HRROS <- .OFFS> '(A2*)>)
1982                                        (ELSE
1983                                         <OCEMIT SETZM .OFFS '(A2*)>)>)
1984                                 (ELSE
1985                                  <GET-INTO-ACS .ITM VALUE O*>
1986                                  <COND (<L? .OFFS 0>
1987                                         <OCEMIT HRLM O* <- .OFFS> '(A2*)>)
1988                                        (ELSE
1989                                         <OCEMIT MOVEM O* .OFFS '(A2*)>)>)>)
1990                          (ELSE
1991                           <OCEMIT DMOVE O1* !<OBJ-TYP .ITM>>
1992                           <OCEMIT DMOVEM O1* <1 .OFFS> '(A2*)>)>>
1993               <REST .L> .TUP>
1994         <PUSHJ-VAL .VAL>>
1995
1996 <DEFINE NTH-PUT-LOOK-AHEAD (OL INS STRUC AMT VAL
1997                             "AUX" (AC <>) (L <REST .MIML>) NXT INS-A (DEAD? <>)
1998                                   THE-TY ITM FOO INSC NXT2 LBL)
1999    #DECL ((INS) STRING (L MIML OL) LIST)
2000    <COND (<AND <G=? <LENGTH .L> 4>
2001                <TYPE? <SET NXT <1 .L>> FORM>
2002                <G=? <LENGTH .NXT> 5>
2003                <OR <=? <SET INS-A <SPNAME <1 .NXT>>> "ADD"> <=? .INS-A "SUB">>
2004                <==? <2 .NXT> .VAL>
2005                <==? <3 .NXT> 1>
2006                <==? <5 .NXT> .VAL>
2007                <TYPE? <SET NXT <2 .L>> FORM>
2008                <G=? <LENGTH .NXT> 4>
2009                <=? <SPNAME <1 .NXT>> .INS>
2010                <==? <2 .NXT> .STRUC>
2011                <==? <3 .NXT> .AMT>
2012                <==? <4 .NXT> .VAL>>
2013           <SETG NEXT-FLUSH 2>
2014           <COND (<AND <TYPE? <SET NXT <3 .L>> FORM>
2015                       <G=? <LENGTH .NXT> 2>
2016                       <=? <SPNAME <1 .NXT>> "DEAD">
2017                       <MEMQ .VAL <REST .NXT>>>
2018                  <SET DEAD? T>)>
2019           <COND (<=? .INS "PUTL">
2020                  <NTHL!-MIMOC .OL
2021                               <COND (<=? .INS-A "ADD"> AOS) (ELSE SOS)>
2022                               <NOT .DEAD?>>)
2023                 (ELSE
2024                  <NTHUV!-MIMOC .OL
2025                                <=? .INS "PUTUU">
2026                                <COND (<=? .INS-A "ADD"> AOS) (ELSE SOS)>
2027                                <NOT .DEAD?>>)>
2028           T)
2029          (<AND <G=? <LENGTH .L> 4>
2030                <TYPE? <SET NXT <1 .L>> FORM>
2031                <G=? <LENGTH .NXT> 4>
2032                <OR <AND <==? <LENGTH <SET INS-A <SPNAME <1 .NXT>>>> 5>
2033                         <MEMBER "LENU" .INS-A>
2034                         <==? <2 .NXT> .VAL>
2035                         <OR <==? <4 .NXT> .VAL> <WILL-DIE? .VAL .L>>
2036                         <COND (<AND <TYPE? <SET FOO <2 .L>> FORM>
2037                                     <G=? <LENGTH .FOO> 5>
2038                                     <MEMQ <LOOKUP <SPNAME <1 .FOO>>
2039                                                   ,MIMOC-OBLIST>
2040                                           ,COMPARERS>
2041                                     <MEMQ <4 .NXT> <REST .FOO>>
2042                                     <WILL-DIE? <4 .NXT> <REST .L>>
2043                                     ;"Check for death at branch"
2044                                     <WILL-DIE?
2045                                      <4 .NXT>
2046                                      <LAB-CODE-PNTR
2047                                       ,<MAPR <> ;"Find label"
2048                                              <FUNCTION (FOOL:LIST "AUX" X)
2049                                                <COND
2050                                                 (<OR <==? <SET X <1 .FOOL>> +>
2051                                                      <==? .X ->>
2052                                                  <MAPLEAVE <2 .FOOL>>)
2053                                                 (<EMPTY? <REST .FOOL>>
2054                                                  <ERROR HUH?!-ERRORS>)>>
2055                                              .FOO>>>
2056                                     >
2057                                <COND (<=? .INS "PUTL">
2058                                       <NTHL!-MIMOC .OL HRRZ <>>
2059                                       <SETG NEXT-FLUSH 1>)
2060                                      (ELSE
2061                                       <NTHUV!-MIMOC .OL <> HRRZ <>>
2062                                       <SETG NEXT-FLUSH 1>)>
2063                                <AC-ITEM <AC-CODE <GET-AC O*> VALUE> <4 .NXT>>)
2064                               (ELSE
2065                                <COND (<=? .INS "PUTL">
2066                                       <NTHL!-MIMOC .OL HRRZ T <4 .NXT>>
2067                                       <SETG NEXT-FLUSH 1>)
2068                                      (ELSE
2069                                       <NTHUV!-MIMOC .OL <> HRRZ T <4 .NXT>>
2070                                       <SETG NEXT-FLUSH 1>)>)>>
2071                    <AND <==? <LENGTH .INS-A> 6>
2072                         <MEMBER "EMPU" .INS-A>
2073                         <==? <2 .NXT> .VAL>
2074                         <WILL-DIE? .VAL .L>
2075                         <OR <==? <4 .NXT> COMPERR>
2076                             <AND <SET FOO <MEMQ <4 .NXT> <REST .L>>>
2077                                  <WILL-DIE? .VAL .FOO>>>
2078                         <PROG ()
2079                               <COND (<=? .INS "PUTL">
2080                                      <NTHL!-MIMOC .OL HRRZ <>>
2081                                      <SETG NEXT-FLUSH 1>)
2082                                     (ELSE
2083                                      <NTHUV!-MIMOC .OL <> HRRZ <>>
2084                                      <SETG NEXT-FLUSH 1>)>
2085                               <LABEL-UPDATE-ACS <4 .NXT> <>>
2086                               <OCEMIT <COND (<==? <3 .NXT> +> JUMPE)
2087                                             (ELSE JUMPN)>
2088                                       O*
2089                                       <XJUMP <4 .NXT>>>
2090                               T>>>>
2091           T)
2092          (<AND <G=? <LENGTH .L> 4>
2093                <TYPE? <SET NXT <1 .L>> FORM>
2094                <G=? <LENGTH .NXT> 5>
2095                <OR <=? <SET INS-A <SPNAME <1 .NXT>>> "VEQUAL?">
2096                    <=? .INS-A "EQUAL?">>
2097                <OR <==? <2 .NXT> .VAL>
2098                    <AND <==? <3 .NXT> .VAL>
2099                         <SET NXT <FORM <1 .NXT> .VAL <2 .NXT> !<REST .NXT 3>>>>>
2100                <PROG () <SET ITM <3 .NXT>> <SET DIR <4 .NXT>> T>
2101                <OR <AND <COND (<=? .INS-A "VEQUAL?">
2102                                <SET AC <IN-AC? .ITM VALUE>>)
2103                               (ELSE
2104                                <SET AC <IN-AC? .ITM BOTH>>)>>
2105                    <AND <=? .INS-A "VEQUAL?">
2106                         <OR <AND <==? <PRIMTYPE .ITM> FIX>
2107                                  <==? <CHTYPE .ITM FIX> 0>>
2108                             <AND <==? <PRIMTYPE .ITM> LIST>
2109                                  <EMPTY? <CHTYPE .ITM LIST>>>>>>
2110                <WILL-DIE? .VAL .L>
2111                <WILL-DIE? .VAL <LAB-CODE-PNTR <FIND-LABEL <5 .NXT>>>>>
2112           <COND (<=? .INS "PUTL">
2113                  <NTHL!-MIMOC .OL .NXT <>>
2114                  <SETG NEXT-FLUSH 1>)
2115                 (ELSE
2116                  <NTHUV!-MIMOC .OL <=? .INS "PUTUU"> .NXT <>>
2117                  <SETG NEXT-FLUSH 1>)>
2118           T)
2119          (<AND <G=? <LENGTH .L> 4>
2120                <TYPE? <SET NXT <1 .L>> FORM>
2121                <G=? <LENGTH .NXT> 5>
2122                <=? <SPNAME <1 .NXT>> "TYPE?">
2123                <==? <2 .NXT> .VAL>
2124                <TYPE? <SET THE-TY <3 .NXT>> FIX>
2125                <==? <4 .NXT> ->
2126                <SET LBL <5 .NXT>>
2127                <TYPE? <SET NXT <2 .L>> FORM>
2128                <G=? <LENGTH .NXT> 5>
2129                <=? <SPNAME <1 .NXT>> "VEQUAL?">
2130                <OR <==? <2 .NXT> .VAL>
2131                    <AND <==? <3 .NXT> .VAL>
2132                         <SET NXT <FORM <1 .NXT> .VAL <2 .NXT> !<REST .NXT 3>>>>>
2133                <PROG () <SET ITM <3 .NXT>> <==? <4 .NXT> +>>
2134                <OR <AND <TYPE? .ITM ATOM>
2135                         <IN-AC? .ITM VALUE>
2136                         <WILL-DIE? .VAL <REST .L>>
2137                         <WILL-DIE? .VAL <LAB-CODE-PNTR <FIND-LABEL <5 .NXT>>>>>
2138                    <AND <OR <AND <==? <PRIMTYPE .ITM> FIX>
2139                                  <==? <CHTYPE .ITM FIX> 0>>
2140                             <AND <==? <PRIMTYPE .ITM> LIST>
2141                                  <EMPTY? <CHTYPE .ITM LIST>>>>>>
2142                <OR <==? <3 .L> .LBL>
2143                    <AND <TYPE? <3 .L> FORM>
2144                         <=? <SPNAME <1 <3 .L>>> "DEAD">
2145                         <==? <4 .L> .LBL>>>>
2146           <SETG NEXT-FLUSH 2>
2147           <SET NXT <CHTYPE (TYPE? .THE-TY !.NXT) FORM>>
2148           <COND (<=? .INS "PUTL">
2149                  <NTHL!-MIMOC .OL .NXT <>>)
2150                 (ELSE
2151                  <NTHUV!-MIMOC .OL <=? .INS "PUTUU"> .NXT <>>)>
2152           T)>>
2153
2154 <DEFINE STRING-PUT-NTH-LOOK-AHEAD (STR PUT-OR-NTH VAL BYTES? AMT
2155                                    "AUX" (STACK-OK? T) (L <REST .MIML>))
2156    #DECL ((STR PUT-OR-NTH) ATOM (L MIML) LIST (AMT) FIX)
2157    <MAPR <>
2158          <FUNCTION (LL "AUX" (INS <1 .LL>) NM X)
2159                  #DECL ((INS) <OR ATOM <FORM ANY>> (NM) STRING)
2160                  <COND (<TYPE? .INS ATOM> <MAPLEAVE <>>)>
2161                  <COND (<OR <=? <SET NM <SPNAME <1 .INS>>> "CALL">
2162                             <=? .NM "FRAME">
2163                             <=? .NM "SFRAME">
2164                             <=? .NM "SCALL">
2165                             <=? .NM "ACALL">
2166                             <=? .NM "PUSH">
2167                             <=? .NM "ADJ">>
2168                         <SET STACK-OK? <>>)>
2169                  <COND (<AND <OR <AND <=? <SET NM <SPNAME <1 .INS>>> "RESTUS">
2170                                       <NOT .BYTES?>>
2171                                  <AND .BYTES? <=? .NM "RESTUB">>>
2172                              <==? .AMT 1>
2173                              <==? <2 .INS> .STR>
2174                              <==? <3 .INS> 1>>
2175                         <COND (<AND <NOT .STACK-OK?>
2176                                     <MEMQ STACK .INS>>
2177                                <MAPLEAVE <>>)>
2178                         <RESTUS!-MIMOC <REST .INS> .BYTES? .VAL .PUT-OR-NTH
2179                                        <WILL-DIE? .STR .LL>>
2180                         <PUTPROP <REST .INS> DONE T>
2181                         <MAPLEAVE T>)
2182                        (<AND <=? .NM <OR <AND <==? .PUT-OR-NTH PUT>
2183                                               <OR <AND .BYTES? "PUTUB">
2184                                                   "PUTUS">>
2185                                          <AND .BYTES? "NTHUB">
2186                                          "NTHUS">>
2187                              <==? <2 .INS> .STR>
2188                              <==? <3 .INS> <+ .AMT 1>>>
2189                         <COND (<AND <NOT .STACK-OK?>
2190                                     <MEMQ STACK .INS>>
2191                                <MAPLEAVE <>>)>
2192                         <SETG REMEMBER-STRING T>
2193                         <COND (<WILL-DIE? .STR .LL>
2194                                <SETG DIE-LATER T>)>
2195                         <MAPLEAVE <>>)
2196                        (<OR <MEMQ .STR .INS>
2197                             <MEMQ + .INS>
2198                             <MEMQ - .INS>
2199                             <AND <TYPE? <SET X <NTH .INS <LENGTH .INS>>> LIST>
2200                                  <OR <MEMQ + .X> <MEMQ - .X>>>>
2201                         <MAPLEAVE <>>)
2202                        (<MEMQ STACK .INS>
2203                         <SET STACK-OK? <>>)>>
2204          .L>>
2205
2206 <DEFINE STRING-REST-LOOK-AHEAD (RINS STR VAL BYTES?
2207                                 "AUX" (L <REST .MIML>) (PUT? <>))
2208    #DECL ((STR) ATOM (L MIML) LIST)
2209    <MAPR <>
2210          <FUNCTION (LL "AUX" (INS <1 .LL>) NM X DST)
2211                  #DECL ((INS) <OR ATOM <FORM ANY>> (NM) STRING)
2212                  <COND (<TYPE? .INS ATOM> <MAPLEAVE <>>)>
2213                  <COND (<AND <OR <=? <SET NM <SPNAME <1 .INS>>> "NTHUS">
2214                                  <AND <=? .NM "PUTUS"> <SET PUT? T>>>
2215                              <==? <2 .INS> .STR>
2216                              <==? <3 .INS> 1>
2217                              <PROG ()
2218                                    <SET DST <COND (.PUT? <4 .INS>)
2219                                                   (ELSE <5 .INS>)>>
2220                                    <MAPF <>
2221                                          <FUNCTION (I) #DECL ((I) FORM)
2222                                               <COND (<==? .I .INS>
2223                                                      <MAPLEAVE>)>
2224                                               <COND (<MEMQ .DST <REST .I>>
2225                                                      <MAPLEAVE <>>)>>
2226                                          .L>>>
2227                         <RESTUS!-MIMOC .RINS
2228                                        .BYTES?
2229                                        <5 .INS>
2230                                        <COND (<=? .NM "PUTUS"> PUT) (NTH)>
2231                                        <WILL-DIE? .STR .LL>>
2232                         <PUTPROP <REST .INS> DONE T>
2233                         <MAPLEAVE T>)
2234                        (<OR <MEMQ .STR .INS>
2235                             <MEMQ + .INS>
2236                             <MEMQ - .INS>
2237                             <AND <TYPE? <SET X <NTH .INS <LENGTH .INS>>> LIST>
2238                                  <OR <MEMQ + .X> <MEMQ - .X>>>>
2239                         <MAPLEAVE <>>)>>
2240          .L>>