mim/development/mim/20c/othgen.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 TYPE!-MIMOC (L "AUX" (ARG <1 .L>) AC NAC)
  21         #DECL ((L) LIST (ARG) ANY (AC) ATOM (NAC) <OR FALSE ATOM>)
  22         <COND (<==? <3 .L> STACK>
  23                <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
  24                <LOAD-TYPE O* <OBJ-TYP .ARG>>
  25                <OCEMIT PUSH TP* O*>
  26                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>
  27                <MUNGED-AC O*>)
  28               (T
  29                <SET AC <ASSIGN-AC <3 .L> BOTH>>
  30                <AC-TYPE <GET-AC .AC> FIX>
  31                <LOAD-TYPE <NEXT-AC .AC> <OBJ-TYP .ARG>>)>>
  32
  33 <DEFINE TYPE?!-MIMOC (L
  34                       "AUX" (ARG <1 .L>) (TYP <2 .L>) (CAM CAMN) (CAI CAIN)
  35                             (JMP JUMPE) AC)
  36         #DECL ((L) LIST (ARG) ANY (TYP) <OR ATOM FIX XTYPE-C>
  37                (CAM CAI JMP) ATOM (AC) <OR FALSE ATOM>)
  38         <COND (<==? <3 .L> -> <SET CAM CAME> <SET CAI CAIE> <SET JMP JUMPN>)>
  39         <COND (<SET AC <IN-AC? .ARG TYPE>> <LOAD-TYPE O* (.AC)> <MUNGED-AC O*>)
  40               (T <SET AC <SMASH-AC O* .ARG TYPECODE>>)>
  41         <LABEL-UPDATE-ACS <4 .L> <>>
  42         <COND (,GC-MODE <OCEMIT TRZ O* 56>)>
  43         <COND (<TYPE? .TYP FIX>
  44                <COND (<==? .TYP 0> <OCEMIT .JMP O* <XJUMP <4 .L>>>)
  45                      (ELSE <OCEMIT .CAI O* .TYP>)>)
  46               (T <OCEMIT .CAM O* !<OBJ-VAL .TYP>>)>
  47         <COND (<N==? .TYP 0> <OCEMIT JRST <XJUMP <4 .L>>>)>>
  48
  49 <DEFINE CHTYPE!-MIMOC (L
  50                        "AUX" (ARG1 <1 .L>) (ARG2 <2 .L>) (VAL <4 .L>) AC PCOD
  51                              TYFRM VTYP ACT
  52                              (LV
  53                               <OR <LMEMQ .VAL ,LOCALS>
  54                                   <AND ,ICALL-FLAG
  55                                        <LMEMQ .VAL ,ICALL-TEMPS>>>))
  56    #DECL ((L) LIST (AC VAL) ATOM (ARG1 ARG2) ANY
  57           (TYFRM) <OR FALSE <FORM ATOM ATOM>>)
  58    <COND
  59     (<AND .LV
  60           <MEMQ .LV ,TYPED-LOCALS>
  61           <SET VTYP <LDECL .LV>>
  62           <OR <MEMQ <TYPEPRIM .VTYP> '[WORD FIX LIST]>
  63               <MEMQ .VTYP ,TYPE-LENGTHS>>>
  64      <SET AC <LOAD-AC .ARG1 BOTH>>
  65      <COND (<AND <N==? .VAL .ARG1> <NOT <WILL-DIE? .ARG1>>>
  66             <COND (<AC-UPDATE <GET-AC .AC>>
  67                    <UPDATE-AC <GET-AC .AC>>
  68                    <UPDATE-AC <GET-AC <NEXT-AC .AC>>>)>)>
  69      <CLEAN-ACS .VAL>
  70      <AC-CODE <AC-ITEM <AC-UPDATE <GET-AC <NEXT-AC .AC>> T> .VAL> VALUE>
  71      <AC-TYPE <AC-CODE <AC-ITEM <AC-UPDATE <GET-AC .AC> T> .VAL> TYPE> .VTYP>)
  72     (<TYPE? .ARG2 FIX>
  73      <COND (<AND <SET TYFRM <GETPROP <REST .L> EVAL>>
  74                  <OR <==? <SET PCOD <CHTYPE <ANDB .ARG2 7> FIX>> ,PRIM-FIX>
  75                      <==? .PCOD ,PRIM-LIST>
  76                      <MEMQ <2 .TYFRM> ,TYPE-LENGTHS>>>
  77             <COND (<==? .VAL STACK>
  78                    <OCEMIT PUSH TP* !<TYPE-WORD <2 .TYFRM>>>
  79                    <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
  80                    <OCEMIT PUSH TP* !<OBJ-VAL .ARG1>>
  81                    <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>)
  82                   (ELSE
  83                    <SET AC <LOAD-AC .ARG1 BOTH>>
  84                    <COND (<WILL-DIE? .ARG1>
  85                           <AC-UPDATE <GET-AC .AC> <>>
  86                           <AC-UPDATE <GET-AC <NEXT-AC .AC>> <>>
  87                           <AC-TYPE <GET-AC .AC> <>>)>
  88                    <COND (<N==? .ARG1 .VAL> <CLEAN-ACS .VAL> <ALTER-AC .AC .VAL>)>
  89                    <AC-TYPE <GET-AC .AC> <2 .TYFRM>>
  90                    <AC-UPDATE <GET-AC .AC> T>)>)
  91            (ELSE
  92             <SET AC <LOAD-AC .ARG1 BOTH>>
  93             <COND (<WILL-DIE? .ARG1>
  94                    <AC-UPDATE <GET-AC .AC> <>>
  95                    <AC-UPDATE <GET-AC <NEXT-AC .AC>> <>>
  96                    <AC-TYPE <GET-AC .AC> <>>)>
  97             <COND (<N==? .ARG1 .VAL> <CLEAN-ACS .VAL> <ALTER-AC .AC .VAL>)>
  98             <AC-TYPE <GET-AC .AC> <>>
  99             <OCEMIT HRLI .AC .ARG2>
 100             <AC-UPDATE <GET-AC .AC> T>
 101             <COND (<==? .VAL STACK>
 102                    <OCEMIT PUSH TP* .AC>
 103                    <OCEMIT PUSH TP* <NEXT-AC .AC>>
 104                    <COND (,WINNING-VICTIM
 105                           <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>)>)
 106     (ELSE
 107      <SET AC <LOAD-AC .ARG1 BOTH>>
 108      <SET ACT <AC-TYPE <GET-AC .AC>>>
 109      <COND (<N==? .ARG1 .VAL>
 110             <COND (<WILL-DIE? .ARG1>
 111                    <AC-UPDATE <GET-AC .AC> <>>
 112                    <AC-UPDATE <GET-AC <NEXT-AC .AC>> <>>)>
 113             <FLUSH-AC .AC T>
 114             <MUNGED-AC .AC T>)>
 115      <AC-TYPE <GET-AC .AC> <>>
 116      <COND (<AND <TYPE? .ARG2 FORM>
 117                  <==? <LENGTH .ARG2> 2>
 118                  <==? <1 .ARG2> TYPE>
 119                  <TYPE? <2 .ARG2> ATOM>>
 120             <COND (<AND .ACT
 121                         <MEMQ .ACT ,TYPE-LENGTHS>>
 122                    <LOAD-TYPE-IN-AC .AC .ACT>)>
 123             <OCEMIT HLL .AC !<OBJ-TYP <2 .ARG2>>>)
 124            (.ACT
 125             <COND (<MEMQ .ACT ,TYPE-LENGTHS>
 126                    <OCEMIT MOVE .AC !<OBJ-VAL <CHTYPE .ARG2 XTYPE-W>>>)
 127                   (ELSE <OCEMIT HRLZ .AC !<OBJ-VAL .ARG2>>)>)
 128            (ELSE <OCEMIT HRL .AC !<OBJ-VAL .ARG2>>)>
 129      <COND (<AND <N==? .VAL STACK> <N==? .VAL .ARG1>>
 130             <CLEAN-ACS .VAL>
 131             <ALTER-AC .AC .VAL>)>
 132      <AC-UPDATE <GET-AC .AC> T>
 133      <COND (<==? .VAL STACK>
 134             <OCEMIT PUSH TP* .AC>
 135             <OCEMIT PUSH TP* <NEXT-AC .AC>>
 136             <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>)>>
 137
 138 <DEFINE NEWTYPE!-MIMOC (L)
 139         #DECL ((L) LIST)
 140         <UPDATE-ACS>
 141         <OCEMIT MOVE O1* !<OBJ-VAL <1 .L>>>
 142         <PUSHJ NEWTYPE <3 .L>>>
 143
 144 \f
 145 ;"Randomness"
 146
 147 <DEFINE VALUE!-MIMOC (L "AUX" (IT <1 .L>) (VAL <3 .L>) AC)
 148         #DECL ((L) LIST (VAL) ATOM)
 149         <COND (<==? .VAL STACK>
 150                <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
 151                <OCEMIT PUSH TP* !<OBJ-VAL .IT>>
 152                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 153               (<AND <OR <==? .IT .VAL> <WILL-DIE? .IT>>
 154                     <OR <SET AC <IN-AC? .IT BOTH>>
 155                         <AND <SET AC <IN-AC? .IT VALUE>>
 156                              <SET AC <GETPROP .AC AC-PAIR>>>>>
 157                <COND (<N==? .IT .VAL> <CLEAN-ACS .VAL>)>
 158                <ALTER-AC .AC .VAL>
 159                <AC-TYPE <GET-AC .AC> FIX>)
 160               (T
 161                <SET AC <ASSIGN-AC .VAL BOTH>>
 162                <AC-TYPE <GET-AC .AC> FIX>
 163                <OCEMIT MOVE <NEXT-AC .AC> !<OBJ-VAL <1 .L>>>)>>
 164
 165 <DEFINE ON-STACK?!-MIMOC (L "AUX" (IT <1 .L>) (VAL <3 .L>) AC NAC)
 166         #DECL ((L) LIST (VAL) ATOM)
 167         <COND (<==? .VAL STACK>
 168                <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
 169                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
 170                <COND (<AND <WILL-DIE? .IT> <SET AC <IN-AC? .IT VALUE>>>)
 171                      (ELSE <OCEMIT MOVE <SET AC O1*> !<OBJ-VAL .IT>>)>
 172                <DO-ON-STACK .AC O*>
 173                <OCEMIT PUSH TP* O*>
 174                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>)
 175               (<AND <==? .IT .VAL> <SET AC <IN-AC? .IT VALUE>>>
 176                <CLEAN-ACS .IT>
 177                <AC-TIME <GET-AC .AC> ,AC-STAMP>
 178                <SETG FIRST-AC <>>
 179                <DO-ON-STACK .AC <NEXT-AC <SET NAC <ASSIGN-AC .VAL BOTH>>>>
 180                <AC-TYPE <GET-AC .NAC> FIX>)
 181               (T
 182                <COND (<AND <SET NAC <IN-AC? .IT VALUE>>
 183                            <WILL-DIE? .IT>>
 184                       <SETG FIRST-AC <>>
 185                       <AC-TIME <GET-AC .NAC> ,AC-STAMP>)
 186                      (ELSE
 187                       <OCEMIT MOVE <SET NAC O1*> !<OBJ-VAL .IT>>)>
 188                <DO-ON-STACK .NAC <NEXT-AC <SET AC <ASSIGN-AC .VAL BOTH>>>>
 189                <AC-TYPE <GET-AC .AC> FIX>)>>
 190
 191 <DEFINE DO-ON-STACK (ARG DEST "AUX" (LBL <GENLBL "DOS">))
 192         <OCEMIT MOVEI .DEST 0>
 193         <OCEMIT TLZ .ARG *770000*>
 194         <OCEMIT CAMLE .ARG !<OBJ-VAL *3000000*>>        ;"Border btwn stk + gc"
 195         <OCEMIT JRST <XJUMP .LBL>>
 196         <OCEMIT MOVNI .DEST 1>                          ;"Assume legal"
 197         <OCEMIT HRRZ .ARG .ARG>
 198         <OCEMIT CAILE .ARG 0 '(TP*)>                    ;"Skip if legal"
 199         <OCEMIT MOVEI .DEST 1>                          ;"Not legal"
 200         <LABEL .LBL>>
 201
 202 <DEFINE OBJECT!-MIMOC (L "AUX" (TY <1 .L>) (CNT <2 .L>) (VAL <3 .L>)
 203                                (V-DONE <>) (RES <5 .L>) (AC <>) (TAC <>) (CAC <>))
 204         #DECL ((L) <LIST [5 <OR ATOM FIX>]>)
 205         <COND (<==? .RES STACK>
 206                <COND (<AND <TYPE? .TY FIX> <TYPE? .CNT FIX>>
 207                       <OCEMIT PUSH TP*
 208                               !<OBJ-VAL <CHTYPE <ORB <LSH .TY 18> .CNT>
 209                                                 FIX>>>)
 210                      (ELSE
 211                       <SMASH-AC O* .CNT VALUE>
 212                       <COND (<TYPE? .TY FIX>
 213                              <OCEMIT HRLI O* .TY>)
 214                             (ELSE
 215                              <OCEMIT HRL O* !<OBJ-VAL .TY>>)>
 216                       <OCEMIT PUSH TP* O*>)>
 217                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
 218                <OCEMIT PUSH TP* !<OBJ-VAL .VAL>>
 219                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>)
 220               (ELSE
 221                <COND (<AND <TYPE? .TY ATOM>
 222                            <OR <==? .RES .TY> <WILL-DIE? .TY>>>
 223                       <COND (<SET TAC <IN-AC? .TY BOTH>>
 224                              <MUNGED-AC .TAC T>
 225                              <SET TAC <NEXT-AC .TAC>>)
 226                             (<SET TAC <IN-AC? .TY VALUE>>
 227                              <MUNGED-AC .TAC>)>
 228                       <DEAD!-MIMOC (.TY) T>)>
 229                <COND (<AND <TYPE? .CNT ATOM>
 230                            <OR <==? .RES .CNT> <WILL-DIE? .CNT>>>
 231                       <COND (<SET CAC <IN-AC? .CNT BOTH>>
 232                              <MUNGED-AC .CAC T>
 233                              <SET CAC <NEXT-AC .CAC>>)
 234                             (<SET CAC <IN-AC? .CNT VALUE>>
 235                              <MUNGED-AC .CAC>)>
 236                       <DEAD!-MIMOC (.CNT) T>)>
 237                <COND (<AND <TYPE? .VAL ATOM>
 238                            <OR <==? .RES .VAL> <WILL-DIE? .VAL>>>
 239                       <DEAD!-MIMOC (.VAL) T>
 240                       <COND (<SET AC <IN-AC? .VAL BOTH>>
 241                              <SET V-DONE T>
 242                              <MUNGED-AC .AC>)
 243                             (<SET AC <IN-AC? .VAL VALUE>>
 244                              <SET AC <GETPROP .AC AC-PAIR>>
 245                              <MUNGED-AC .AC>
 246                              <SET V-DONE T>)>)>
 247                <COND (<NOT .AC>
 248                       <SET AC <ASSIGN-AC .RES BOTH>>)>
 249                <COND (<AND <TYPE? .TY FIX> <TYPE? .CNT FIX>>
 250                       <COND (<0? .CNT>
 251                              <OCEMIT MOVSI .AC .TY>)
 252                             (ELSE
 253                              <OCEMIT MOVE .AC
 254                                      !<OBJ-VAL <CHTYPE <ORB <LSH .TY 18> .CNT>
 255                                                        FIX>>>)>)
 256                      (<TYPE? .TY FIX>
 257                       <COND (<0? .TY>
 258                              <COND (.CAC <OCEMIT HRRZ .AC .CAC>)
 259                                    (ELSE <OCEMIT HRRZ .AC !<OBJ-VAL .CNT>>)>)
 260                             (ELSE
 261                              <OCEMIT MOVSI .AC .TY>
 262                              <COND (.CAC <OCEMIT HRR .AC .CAC>)
 263                                    (ELSE <OCEMIT HRR .AC !<OBJ-VAL .CNT>>)>)>)
 264                      (<TYPE? .CNT FIX>
 265                       <COND (<0? .CNT>
 266                              <COND (.TAC <OCEMIT HRLZ .AC .TAC>)
 267                                    (ELSE <OCEMIT HRLZ .AC !<OBJ-VAL .TY>>)>)
 268                             (ELSE
 269                              <OCEMIT MOVEI .AC .CNT>
 270                              <COND (.TAC <OCEMIT HRL .AC .TAC>)
 271                                    (ELSE <OCEMIT HRL .AC !<OBJ-VAL .TY>>)>)>)
 272                      (ELSE
 273                       <COND (.CAC <OCEMIT MOVE .AC .CAC>)
 274                             (ELSE <OCEMIT MOVE .AC !<OBJ-VAL .CNT>>)>
 275                       <COND (.TAC <OCEMIT HRL .AC .TAC>)
 276                             (ELSE <OCEMIT HRL .AC !<OBJ-VAL .TY>>)>)>
 277                <COND (<NOT .V-DONE>
 278                       <OCEMIT MOVE <NEXT-AC .AC> !<OBJ-VAL .VAL>>)
 279                      (ELSE
 280                       <ALTER-AC .AC .RES>)>)>>
 281
 282 \f
 283 ;"I/O routines"
 284
 285 <DEFINE OPEN!-MIMOC (L)
 286         #DECL ((L) LIST)
 287         <UPDATE-ACS>
 288         <OCEMIT MOVE O1* !<OBJ-VAL <1 .L>>>
 289         <OCEMIT MOVE O2* !<OBJ-VAL <2 .L>>>
 290         <OCEMIT DMOVE B1* !<OBJ-TYP <3 .L>>>
 291         <PUSHJ OPEN <5 .L>>>
 292
 293 <DEFINE CLOSE!-MIMOC (L)
 294         #DECL ((L) LIST)
 295         <UPDATE-ACS>
 296         <OCEMIT MOVE A1* !<OBJ-VAL <1 .L>>>
 297         <PUSHJ CLOSE <COND (<G? <LENGTH .L> 2> <3 .L>)>>>
 298
 299 <DEFINE RESET!-MIMOC (L)
 300         #DECL ((L) LIST)
 301         <UPDATE-ACS>
 302         <OCEMIT MOVE A1* !<OBJ-VAL <1 .L> >>
 303         <PUSHJ RESET>>
 304
 305 <DEFINE READ!-MIMOC (L "AUX" (LL <LENGTH .L>) (TL <MEMQ = .L>)
 306                      (NARGS <- <LENGTH .L> <LENGTH .TL>>))
 307         #DECL ((L) LIST)
 308         <UPDATE-ACS>
 309         <SMASH-AC A1* <1 .L> VALUE>
 310         <SMASH-AC A2* <2 .L> VALUE>
 311         <SMASH-AC B1* <3 .L> VALUE>
 312         <SMASH-AC B2* <4 .L> VALUE>
 313         <COND (<G=? .NARGS 5>
 314                <SMASH-AC C1* <5 .L> VALUE>)
 315               (<SMASH-AC C1* 0 VALUE>)>
 316         <COND (<G=? .NARGS 6>
 317                <SMASH-AC C2* <6 .L> VALUE>)
 318               (<SMASH-AC C2* 0 VALUE>)>
 319         <PUSHJ READ <COND (.TL <2 .TL>)>>>
 320
 321 <DEFINE PRINT!-MIMOC (L)
 322         #DECL ((L) LIST)
 323         <UPDATE-ACS>
 324         <SMASH-AC A1* <1 .L> VALUE>
 325         <SMASH-AC A2* <2 .L> VALUE>
 326         <SMASH-AC B1* <3 .L> VALUE>
 327         <PUSHJ PRINT>>
 328
 329 \f
 330 ;"Stack, variable hacking"
 331
 332
 333 <DEFINE SET!-MIMOC (L
 334                     "AUX" (ARG1 <1 .L>) (ARG2 <2 .L>) (VT <VAR-TYPED? .ARG1>)
 335                           (STK? <VAR-STACKED? .ARG1>) AC NAC ITM FARG2 LV TAC
 336                           LL (MIML .MIML))
 337    #DECL ((L MIML) LIST (AC ARG1) ATOM (ARG2 ITM) ANY (NAC) <OR FALSE ATOM>
 338           (FARG2) FIX)
 339    <COND
 340     (<AND <TYPE? .ARG2 ATOM> <SET ITM <WILL-DIE? .ARG2>>>
 341      <CLEAN-ACS .ARG1>
 342      <DEAD!-MIMOC (.ARG2) T>
 343      <COND (<AND <TYPE? <2 .MIML> FORM>
 344                  <NOT <EMPTY? <2 .MIML>>>
 345                  <==? <1 <2 .MIML>> RETURN>>
 346             <GET-INTO-ACS .ARG2 BOTH <SET AC A1*>>)
 347            (<SET NAC <IN-AC? .ARG2 BOTH>> <SET AC .NAC>)
 348            (<AND .VT <SET NAC <IN-AC? .ARG2 VALUE>>>
 349             <SET AC .NAC>
 350             <AC-TYPE <GET-AC <SET AC <GETPROP .AC AC-PAIR>>> .VT>)
 351            (T <SET AC <LOAD-AC .ARG2 BOTH>>)>
 352      <AC-CODE <AC-ITEM <AC-UPDATE <GET-AC .AC> <NOT .VT>> .ARG1> TYPE>
 353      <AC-CODE <AC-ITEM <AC-UPDATE <GET-AC <NEXT-AC .AC>> T> .ARG1> VALUE>)
 354     (<AND <NOT <TYPE? .ARG2 ATOM>>
 355           <NOT <EMPTY? <SET LL <REST .MIML>>>>
 356           <TYPE? <SET LL <1 .LL>> FORM>
 357           <==? <1 .LL> RETURN>>
 358      <CLEAN-ACS .ARG1>
 359      <GET-INTO-ACS .ARG2 BOTH <SET AC A1*>>
 360      <AC-CODE <AC-ITEM <AC-UPDATE <GET-AC .AC> <NOT .VT>> .ARG1> TYPE>
 361      <AC-CODE <AC-ITEM <AC-UPDATE <GET-AC <NEXT-AC .AC>> T> .ARG1> VALUE>)
 362     (T
 363      <COND (<AND <TYPE? .ARG2 ATOM>
 364                  <SET NAC <OR <IN-AC? .ARG2 BOTH> <IN-AC? .ARG2 VALUE>>>
 365                  <AC-UPDATE <GET-AC .NAC>>>
 366             <AC-TIME <GET-AC .NAC> ,AC-STAMP>)>
 367      <SET AC <ASSIGN-AC .ARG1 BOTH>>
 368      <AC-TYPE <GET-AC .AC> <>>
 369      <COND (<AND <SET NAC <IN-AC? .ARG2 BOTH>> <NOT <AC-TYPE <GET-AC .NAC>>>>
 370             <OCEMIT DMOVE .AC .NAC>)
 371            (<AND <MEMQ <PRIMTYPE .ARG2> '[WORD FIX]>
 372                  <MEMQ <TYPE .ARG2> ,TYPE-WORDS>>
 373             <COND (<==? <CHTYPE .ARG2 FIX> 0>
 374                    <COND (<AND .STK? .VT>
 375                           <OCEMIT SETZB <NEXT-AC .AC> !<OBJ-VAL .ARG1 <>>>
 376                           <AC-UPDATE <GET-AC <NEXT-AC .AC>> <>>)
 377                          (ELSE <OCEMIT MOVEI <NEXT-AC .AC> 0>)>)
 378                   (<==? <CHTYPE .ARG2 FIX> -1>
 379                    <COND (<AND .STK? .VT>
 380                           <OCEMIT SETOB <NEXT-AC .AC> !<OBJ-VAL .ARG1 <>>>
 381                           <AC-UPDATE <GET-AC <NEXT-AC .AC>> <>>)
 382                          (ELSE <OCEMIT MOVNI <NEXT-AC .AC> 1>)>)
 383                   (<==? <CHTYPE <ANDB .ARG2 262143> FIX> 0>
 384                    <OCEMIT MOVSI <NEXT-AC .AC> <CHTYPE <LSH .ARG2 -18> FIX>>)
 385                   (<L=? <ABS <SET FARG2 <CHTYPE .ARG2 FIX>>> ,MAX-IMMEDIATE>
 386                    <COND (<G=? .FARG2 0> <OCEMIT MOVEI <NEXT-AC .AC> .FARG2>)
 387                          (ELSE <OCEMIT MOVNI <NEXT-AC .AC> <ABS .FARG2>>)>)
 388                   (ELSE <OCEMIT MOVE <NEXT-AC .AC> !<OBJ-VAL .FARG2>>)>
 389             <AC-TYPE <GET-AC .AC> <TYPE .ARG2>>
 390             <COND (<VAR-TYPED? .ARG1> <AC-UPDATE <GET-AC .AC> <>>)
 391                   (ELSE <AC-UPDATE <GET-AC .AC> T>)>)
 392            (<AND <==? <PRIMTYPE .ARG2> LIST>
 393                  <EMPTY? <CHTYPE .ARG2 LIST>>
 394                  <MEMQ <TYPE .ARG2> ,TYPE-WORDS>>
 395             <COND (<AND .STK? .VT>
 396                    <OCEMIT SETZB <NEXT-AC .AC> !<OBJ-VAL .ARG1 <>>>
 397                    <AC-UPDATE <GET-AC <NEXT-AC .AC>> <>>)
 398                   (ELSE <OCEMIT MOVEI <NEXT-AC .AC> 0>)>
 399             <AC-TYPE <GET-AC .AC> <TYPE .ARG2>>
 400             <COND (<VAR-TYPED? .ARG1> <AC-UPDATE <GET-AC .AC> <>>)>)
 401            (<AND <SET LV <VAR-TYPED? .ARG1>> <SET NAC <IN-AC? .ARG2 VALUE>>>
 402             <OCEMIT MOVE <NEXT-AC .AC> .NAC>
 403             <AC-TYPE <AC-UPDATE <GET-AC .AC> <>> .LV>)
 404            (<AND <SET NAC <IN-AC? .ARG2 VALUE>>
 405                  <SET LV
 406                       <OR <VAR-TYPED? .ARG2>
 407                           <AND <SET TAC <IN-AC? .ARG2 TYPE>>
 408                                <AC-TYPE <GET-AC .TAC>>>>>>
 409             <OCEMIT MOVE <NEXT-AC .AC> .NAC>
 410             <AC-TYPE <GET-AC .AC> .LV>)
 411            (<AND <SET NAC <IN-AC? .ARG2 VALUE>> <AC-UPDATE <GET-AC .NAC>>>
 412             <OCEMIT MOVE .AC !<OBJ-TYP .ARG2>>
 413             <OCEMIT MOVE <NEXT-AC .AC> .NAC>)
 414            (<AND <SET NAC <IN-AC? .ARG2 TYPE>> <AC-UPDATE <GET-AC .NAC>>>
 415             <OCEMIT MOVE .AC .NAC>
 416             <OCEMIT MOVE <NEXT-AC .AC> !<OBJ-VAL .ARG2>>)
 417            (T <OCEMIT DMOVE .AC !<OBJ-LOC .ARG2 0>>)>)>>
 418
 419 <DEFINE VAR-TYPED? (ARG1 "AUX" LV)
 420         #DECL ((ARG1) ATOM)
 421         <AND <SET LV <OR <LMEMQ .ARG1 ,LOCALS>
 422                          <AND ,ICALL-FLAG
 423                               <LMEMQ .ARG1 ,ICALL-TEMPS>>>>
 424              <N==? <LUPD .LV> OARG>
 425              <SET LV <LDECL .LV>>
 426              <OR <MEMQ <TYPEPRIM .LV> '[WORD FIX LIST]>
 427                  <MEMQ .LV ,TYPE-LENGTHS>>
 428              .LV>>
 429
 430 <DEFINE VAR-STACKED? (ARG1 "AUX" LV)
 431         #DECL ((ARG1) ATOM)
 432         <AND <SET LV <OR <LMEMQ .ARG1 ,LOCALS>
 433                          <AND ,ICALL-FLAG
 434                               <LMEMQ .ARG1 ,ICALL-TEMPS>>>>
 435              <LUPD .LV>>>
 436
 437 <SETG SIMPLE-DEATH <>>
 438
 439 <NEWTYPE DEAD-VAR ATOM>
 440
 441 <DEFINE WILL-DIE? (ARG "OPT" (MIML .MIML)
 442                              (VISIT <SETG VISIT-COUNT <+ ,VISIT-COUNT 1>>)
 443                        "AUX" FOO LB)
 444    #DECL ((ARG) ANY (MIML) LIST (VISIT) FIX)
 445    <PROG LEAVE (NXT ITM (SIMPLE ,SIMPLE-DEATH) LAB)
 446      #DECL ((NXT) <OR ATOM FORM LIST>)
 447      <COND
 448       (<NOT <TYPE? .ARG ATOM>> <RETURN T>)
 449       (<L=? <LENGTH .MIML> 1> <RETURN T>)
 450       (<TYPE? <SET NXT <2 .MIML>> FORM>
 451        <OR <AND <==? <SET ITM <1 .NXT>> DEAD>
 452                 <OR <MEMQ .ARG <REST .NXT>>
 453                     <AND .SIMPLE <RETURN <>>>
 454                     <AND <SET MIML <REST .MIML>> <AGAIN>>>>
 455            <AND <==? .ITM RETURN> <RETURN <N==? <2 .NXT> .ARG>>>
 456            <AND <==? .ITM DISPATCH> <RETURN <>>>
 457            <==? .ITM END>
 458            <AND <==? .ITM SET>
 459                 <COND (<==? <2 .NXT> .ARG>)
 460                       (<OR <==? <3 .NXT> .ARG> .SIMPLE> <RETURN <>>)
 461                       (ELSE <SET MIML <REST .MIML>> <AGAIN>)>>
 462            <AND <N==? .ITM ICALL>
 463                 <MAPR <>
 464                       <FUNCTION (XP "AUX" (X <1 .XP>))
 465                          <COND (<==? .X =>
 466                                 <COND (<==? <SET X <2 .XP>> .ARG>
 467                                        <RETURN T .LEAVE>)
 468                                       (ELSE <MAPLEAVE <>>)>)
 469                                (<==? .X .ARG> <RETURN <> .LEAVE>)>>
 470                       .NXT>>
 471            <AND .SIMPLE <RETURN <>>>
 472            <AND <OR <SET FOO <MEMQ + <SET NXT <REST .NXT>>>>
 473                     <SET FOO <MEMQ - .NXT>>
 474                     <AND <==? .ITM NTHR>
 475                          <TYPE? <SET ITM <NTH .NXT <LENGTH .NXT>>> LIST>
 476                          <==? <1 .ITM> BRANCH-FALSE>
 477                          <SET FOO <REST .ITM>>>
 478                     <AND <==? .ITM ICALL> <SET FOO <2 .MIML>>>>
 479                 <COND (<AND <SET LB <FIND-LABEL <SET LAB <2 .FOO>>>>
 480                             <LAB-WILL-DIE .LB .ARG .VISIT
 481                                           <COND (<AND <==? .ITM ICALL>
 482                                                       <G? <LENGTH .FOO> 1>>
 483                                                  <4 .FOO>)>>>
 484                        <SET MIML <REST .MIML>>
 485                        <COND (<==? .ITM JUMP> <RETURN T>)
 486                              (ELSE <AGAIN>)>)
 487                       (<OR <==? .LAB COMPERR>
 488                            <==? .LAB IOERR>
 489                            <==? .LAB UNWCNT>>
 490                        <COND (<==? .ITM JUMP> <RETURN T>)
 491                              (ELSE <>)>)
 492                       (ELSE <RETURN <>>)>>
 493            <AND <NOT <EMPTY? ,THE-BIG-LABELS>>
 494                 <OR <==? .ITM CALL> <==? .ITM ACALL> <==? .ITM SCALL>>
 495                 <MAPF <>
 496                       <FUNCTION (NAM)
 497                            <COND (<LAB-WILL-DIE <FIND-LABEL .NAM> .ARG .VISIT
 498                                                 <>>
 499                                   T)
 500                                  (ELSE <RETURN <>>)>>
 501                       ,THE-BIG-LABELS>
 502                 <>>
 503            <NOT <SET MIML <REST .MIML>>>
 504            <AGAIN>>)
 505       (ELSE <SET MIML <REST .MIML>> <AGAIN>)>>>
 506
 507 <DEFINE LAB-WILL-DIE (LB:LAB ARG:ATOM VISIT:FIX ICALL-VAR:<OR ATOM FALSE>)
 508         <PROG ()
 509               <COND (<==? .ICALL-VAR .ARG> <RETURN T>)>
 510               <AND <OR <AND <GASSIGNED? DO-LOOPS> ,DO-LOOPS>
 511                        <NOT <LAB-LOOP .LB>>>
 512                    <OR <MAPF <>
 513                              <FUNCTION (X)
 514                                   <COND (<==? <CHTYPE .X ATOM> .ARG>
 515                                          <COND (<TYPE? .X ATOM>
 516                                                 <RETURN <>>)
 517                                                (ELSE <MAPLEAVE>)>)>
 518                                   <>>
 519                              <LAB-DEAD-VARS .LB>>
 520                        <==? <LAB-VISIT-MARK .LB> .VISIT>
 521                        <AND <PUT .LB ,LAB-VISIT-MARK .VISIT> <>>
 522                        <COND (<WILL-DIE? .ARG <LAB-CODE-PNTR .LB> .VISIT>
 523                               <PUT .LB ,LAB-DEAD-VARS
 524                                    (<CHTYPE .ARG DEAD-VAR>
 525                                     !<LAB-DEAD-VARS .LB>)>)
 526                              (ELSE
 527                               <PUT .LB ,LAB-DEAD-VARS
 528                                    (.ARG !<LAB-DEAD-VARS .LB>)>
 529                               <>)>>>>>
 530 <NEWTYPE T$UNBOUND FIX>
 531
 532 <DEFINE PUSH!-MIMOC (L "AUX" (ARG <1 .L>) AC TY)
 533         #DECL ((L) LIST (ARG) ANY)
 534         <COND (<TYPE? .ARG T$UNBOUND>
 535                <OCEMIT PUSH TP* !<OBJ-VAL 0>>
 536                <OCEMIT PUSH TP* !<OBJ-VAL 0>>
 537                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 538               (T
 539                <COND (<AND <TYPE? .ARG ATOM>
 540                            <SET AC <IN-AC? .ARG TYPE>>
 541                            <SET TY <AC-TYPE <GET-AC .AC>>>>
 542                       <OCEMIT PUSH TP* !<TYPE-WORD .TY>>)
 543                      (ELSE
 544                       <OCEMIT PUSH TP* !<OBJ-TYP .ARG>>)>
 545                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
 546                <OCEMIT PUSH TP* !<OBJ-VAL .ARG>>
 547                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>)>>
 548
 549 <DEFINE POP!-MIMOC (L "AUX" AC)
 550         #DECL ((L) LIST (AC) ATOM)
 551         <SET AC <ASSIGN-AC <2 .L> BOTH>>
 552         <OCEMIT DMOVE .AC -1 '(TP*)>
 553         <OCEMIT ADJSP TP* -2>
 554         <COND (,WINNING-VICTIM <SETG STACK-DEPTH <- ,STACK-DEPTH 2>>)>>
 555
 556 <DEFINE ADJ!-MIMOC (L "AUX" (ARG <1 .L>))
 557         #DECL ((L) LIST (ARG) ANY)
 558         <COND (<TYPE? .ARG FIX>
 559                <OCEMIT ADJSP TP* .ARG>
 560                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH
 561                                                            .ARG>>)>)
 562               (T
 563                <SMASH-AC T* .ARG VALUE>
 564                <OCEMIT ADJSP TP* '(T*)>)>>
 565
 566 <DEFINE GETS!-MIMOC (L "AUX" (ARG1 <1 .L>) (VAL <3 .L>) (VAR <2 .ARG1>)
 567                              AC TEMP)
 568         #DECL ((L) LIST (ARG1) <FORM ATOM ATOM> (VAR VAL AC) ATOM)
 569         <COND (<==? .VAR ARGS>
 570                <COND (<==? .VAL STACK>
 571                       <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
 572                       <OCEMIT HLRZ O* -2 '(F*)>
 573                       <MUNGED-AC O*>
 574                       <OCEMIT PUSH TP* O*>
 575                       <COND (,WINNING-VICTIM
 576                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 577                      (T
 578                       <SET AC <ASSIGN-AC .VAL BOTH T>>
 579                       <AC-TYPE <GET-AC .AC> FIX>
 580                       <OCEMIT HLRZ <NEXT-AC .AC> -2 '(F*)>)>)
 581               (<==? .VAR OBLIST>
 582                <COND (<==? .VAL STACK>
 583                       <FLUSH-AC T*>
 584                       <MUNGED-AC T*>
 585                       <OCEMIT MOVE T* *144*>
 586                       <OCEMIT PUSH TP* '(T*)>
 587                       <OCEMIT PUSH TP* 1 '(T*)>
 588                       <COND (,WINNING-VICTIM
 589                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 590                      (T
 591                       <SET AC <ASSIGN-AC .VAL BOTH T>>
 592                       <OCEMIT DMOVE .AC @ *144*>)>)
 593               (<==? .VAR BIND>
 594                <COND (<==? .VAL STACK>
 595                       <OCEMIT PUSH TP* !<TYPE-WORD T$LBIND>>
 596                       <OCEMIT PUSH TP* SP*>
 597                       <COND (,WINNING-VICTIM
 598                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 599                      (T
 600                       <SET AC <ASSIGN-AC .VAL BOTH T>>
 601                       <AC-TYPE <GET-AC .AC> T$LBIND>
 602                       <OCEMIT MOVE <NEXT-AC .AC> SP*>)>)
 603               (<==? .VAR PAGPTR>
 604                <COND (<==? .VAL STACK>
 605                       <FLUSH-AC T*>
 606                       <MUNGED-AC T*>
 607                       <OCEMIT MOVE T* *145*>
 608                       <OCEMIT PUSH TP* '(T*)>
 609                       <OCEMIT PUSH TP* 1 '(T*)>
 610                       <COND (,WINNING-VICTIM
 611                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>
 612                       <OCEMIT SKIPN '(TP*)>
 613                       <OCEMIT SETZM -1 '(TP*)>)
 614                      (ELSE
 615                       <SET AC <ASSIGN-AC .VAL BOTH T>>
 616                       <OCEMIT DMOVE .AC @ *145*>
 617                       <OCEMIT SKIPN O* <NEXT-AC .AC>>
 618                       <OCEMIT MOVEI .AC 0>)>)
 619               (<==? .VAR MINF>
 620                <COND (<==? .VAL STACK>
 621                       <OCEMIT PUSH TP* !<TYPE-WORD T$MINF>>
 622                       <OCEMIT PUSH TP* @ *143*>
 623                       <COND (,WINNING-VICTIM
 624                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>
 625                       <OCEMIT SKIPN '(TP*)>
 626                       <OCEMIT SETZM -1 '(TP*)>)
 627                      (ELSE
 628                       <SET AC <ASSIGN-AC .VAL BOTH T>>
 629                       <OCEMIT MOVE .AC !<TYPE-WORD T$MINF>>
 630                       <OCEMIT SKIPN <NEXT-AC .AC> @ *143*>
 631                       <OCEMIT MOVEI .AC 0>)>)
 632               (<SET TEMP <MEMQ .VAR '[ICALL ECALL NCALL UWATM MAPPER
 633                                       PURVEC DBVEC TBIND]>>
 634                <SET TEMP <LENGTH .TEMP>>
 635                <COND (<==? .VAL STACK>
 636                       <COND (<==? .VAR TBIND>
 637                              <OCEMIT PUSH TP* !<TYPE-WORD T$LBIND>>)
 638                             (<MEMQ .VAR '[PURVEC DBVEC]>
 639                              <OCEMIT PUSH TP* !<TYPE-WORD LIST>>)
 640                             (<OCEMIT PUSH TP* !<TYPE-WORD T$ATOM>>)>
 641                       <OCEMIT PUSH TP* @ <NTH '![*136* *142* *141*
 642                                                  *140* *146* *151* *150* *147*]
 643                                               .TEMP>>
 644                       <COND (,WINNING-VICTIM
 645                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>
 646                       <OCEMIT SKIPN '(TP*)>
 647                       <OCEMIT SETZM -1 '(TP*)>)
 648                      (ELSE
 649                       <SET AC <ASSIGN-AC .VAL BOTH T>>
 650                       <COND (<==? .VAR TBIND>
 651                              <OCEMIT MOVE .AC !<TYPE-WORD T$LBIND>>)
 652                             (<MEMQ .VAR '[PURVEC DBVEC]>
 653                              <OCEMIT MOVE .AC !<TYPE-WORD LIST>>)
 654                             (<OCEMIT MOVE .AC !<TYPE-WORD T$ATOM>>)>
 655                       <OCEMIT SKIPN <NEXT-AC .AC> @
 656                               <NTH '![*136* *142* *141*
 657                                       *140* *146* *151* *150* *147*] .TEMP>>
 658                       <OCEMIT MOVEI .AC 0>)>)
 659               (<MEMQ .VAR '[ENVIR ARGV]>
 660                <COND (<==? .VAL STACK>
 661                       <OCEMIT PUSH TP* !<TYPE-WORD FALSE>>
 662                       <OCEMIT PUSH TP* !<OBJ-VAL 0>>
 663                       <COND (,WINNING-VICTIM
 664                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 665                      (T
 666                       <SET AC <ASSIGN-AC .VAL BOTH T>>
 667                       <OCEMIT MOVE .AC !<TYPE-WORD FALSE>>
 668                       <OCEMIT MOVEI <NEXT-AC .AC> 0>)>)
 669               (<OR <==? .VAR BINDID> <==? .VAR INGC>>
 670                <COND (<==? .VAL STACK>
 671                       <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
 672                       <OCEMIT PUSH TP* @ <COND (<==? .VAR BINDID> *137*)
 673                                                (ELSE *161*)>>
 674                       <COND (,WINNING-VICTIM
 675                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 676                       (ELSE
 677                        <SET AC <ASSIGN-AC .VAL BOTH T>>
 678                        <OCEMIT MOVSI .AC !<TYPE-CODE FIX T>>
 679                        <OCEMIT MOVE <NEXT-AC .AC> @ <COND (<==? .VAR BINDID> *137*)
 680                                                           (ELSE *161*)>>)>)
 681               (T <MIMOCERR UNKNOWN-SPECIAL-VARIABLE!-ERRORS .VAR>)>>
 682
 683 <DEFINE ATIC!-MIMOC (L "AUX")
 684         #DECL ((L) LIST)
 685         <UPDATE-ACS>
 686         <OCEMIT MOVE O1* !<OBJ-VAL <1 .L>>>
 687         <PUSHJ ATIC <3 .L>>>
 688
 689 <DEFINE SETS!-MIMOC (L "AUX" (ARG <1 .L>) (VAR <2 .ARG>) (VAL <2 .L>) AC)
 690         #DECL ((L) LIST (ARG) <FORM ATOM ATOM> (VAR) ATOM
 691                (VAL) <OR ATOM <FORM ATOM ATOM>>)
 692         <COND (<MEMQ = .L> <ERROR CANT-ASSIGN-RESULT-OF-SETS!-ERRORS .L>)>
 693         <COND (<==? .VAR BIND>
 694                <OCEMIT MOVE SP* !<OBJ-VAL .VAL>>)
 695               (<==? .VAR ICALL>
 696                <COND (<NOT <SET AC <IN-AC? .VAL VALUE>>>
 697                       <GET-INTO-ACS .VAL VALUE <SET AC O1*>>)>
 698                <OCEMIT MOVEM .AC @ *147*>)
 699               (<==? .VAR INGC>
 700                <COND (<NOT <SET AC <IN-AC? .VAL VALUE>>>
 701                       <GET-INTO-ACS .VAL VALUE <SET AC O1*>>)>
 702                <OCEMIT MOVEM .AC @ *161*>)
 703               (<==? .VAR ECALL>
 704                <COND (<NOT <SET AC <IN-AC? .VAL VALUE>>>
 705                       <GET-INTO-ACS .VAL VALUE <SET AC O1*>>)>
 706                <OCEMIT MOVEM .AC @ *150*>)
 707               (<==? .VAR NCALL>
 708                <COND (<NOT <SET AC <IN-AC? .VAL VALUE>>>
 709                       <GET-INTO-ACS .VAL VALUE <SET AC O1*>>)>
 710                <OCEMIT MOVEM .AC @ *151*>)
 711               (<==? .VAR RUNINT>
 712                <UPDATE-ACS>
 713                <OCEMIT MOVE O1* !<OBJ-VAL .VAL>>
 714                <PUSHJ IENABLE>)
 715               (<==? .VAR UWATM>
 716                <OCEMIT MOVE O1* !<OBJ-VAL .VAL>>
 717                <PUSHJ SUNWAT>)
 718               (<==? .VAR PAGPTR>
 719                <COND (<NOT <SET AC <IN-AC? .VAL BOTH>>>
 720                       <GET-INTO-ACS .VAL BOTH <SET AC O1*>>)>
 721                <OCEMIT DMOVEM .AC @ *145*>)
 722               (<==? .VAR MINF>
 723                <COND (<NOT <SET AC <IN-AC? .VAL VALUE>>>
 724                       <GET-INTO-ACS .VAL VALUE <SET AC O1*>>)>
 725                <OCEMIT MOVEM .AC @ *143*>)
 726               (<==? .VAR MAPPER>
 727                <COND (<NOT <SET AC <IN-AC? .VAL VALUE>>>
 728                       <GET-INTO-ACS .VAL VALUE <SET AC O1*>>)>
 729                <OCEMIT MOVEM .AC @ *140*>)
 730               (<==? .VAR PURVEC>
 731                <COND (<NOT <SET AC <IN-AC? .VAL VALUE>>>
 732                       <GET-INTO-ACS .VAL VALUE <SET AC O1*>>)>
 733                <OCEMIT MOVEM .AC @ *141*>)
 734               (<==? .VAR DBVEC>
 735                <COND (<NOT <SET AC <IN-AC? .VAL VALUE>>>
 736                       <GET-INTO-ACS .VAL VALUE <SET AC O1*>>)>
 737                <OCEMIT MOVEM .AC @ *142*>)
 738               (<==? .VAR OBLIST>
 739                <COND (<NOT <SET AC <IN-AC? .VAL BOTH>>>
 740                       <GET-INTO-ACS .VAL BOTH <SET AC O1*>>)>
 741                <OCEMIT DMOVEM .AC @ *144*>)
 742               (<==? .VAR TBIND>
 743                <COND (<NOT <SET AC <IN-AC? .VAL VALUE>>>
 744                       <GET-INTO-ACS .VAL VALUE <SET AC O1*>>)>
 745                <OCEMIT MOVEM .AC @ *136*>)
 746               (<==? .VAR BINDID>
 747                <COND (<NOT <SET AC <IN-AC? .VAL VALUE>>>
 748                       <GET-INTO-ACS .VAL VALUE <SET AC O1*>>)>
 749                <OCEMIT MOVEM .AC @ *137*>)
 750               (T <MIMOCERR UNKNOWN-SPECIAL-VARIABLE!-ERRORS .VAR>)>>
 751
 752 ;"Control"
 753
 754 <DEFINE JUMP!-MIMOC (L)
 755         #DECL ((L) LIST)
 756         <LABEL-UPDATE-ACS <2 .L> T>
 757         <SETG LAST-UNCON T>
 758         <OCEMIT JRST <XJUMP <2 .L>>>>
 759
 760 <NEWTYPE GFRM ATOM>
 761
 762 <NEWTYPE GCAL ATOM>
 763
 764 <NEWTYPE SGFRM ATOM>
 765
 766 <SETG GLUE-FRAME 100>
 767
 768 <DEFINE SFRAME!-MIMOC (L) <FRAME!-MIMOC .L T>>
 769
 770 <DEFINE FRAME!-MIMOC (L "OPT" (SEG <>) "AUX" PN NM CN)
 771         #DECL ((L) LIST)
 772         <COND (<AND ,GLUE-MODE <NOT <EMPTY? .L>> <NOT <TYPE? <1 .L> FORM>>>
 773                <COND (<AND ,SURVIVOR-MODE
 774                            <SET PN <FIND-CALL <SET NM <2 .L>> ,PRE-NAMES>>
 775                            <NOT <GETPROP .PN NDFRM>>
 776                            <NOT <FIND-OPT .NM ,PRE-OPTS>>
 777                            <NOT <SURVIVOR? .NM>>>
 778                       <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
 779                       <COND (.SEG <OCEMIT <CHTYPE <1 .L> SGFRM> T>)
 780                             (ELSE <OCEMIT <CHTYPE <1 .L> GFRM> T>)>
 781                       <COND (<NOT ,PASS1> <CONST-ADD-FRM>)>
 782                       <COND (,WINNING-VICTIM
 783                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 784                      (ELSE
 785                       <FLUSH-AC T*>
 786                       <MUNGED-AC T*>
 787                       <OCEMIT SKIPL T* -1 '(F*)>
 788                       <OCEMIT HRROI T* '(F*)>
 789                       <OCEMIT PUSH TP* T*>
 790                       <COND (.SEG <OCEMIT <CHTYPE <1 .L> SGFRM> T>)
 791                             (ELSE <OCEMIT <CHTYPE <1 .L> GFRM> T>)>
 792                       <COND (<NOT ,PASS1> <CONST-ADD-FRM>)>
 793                       <OCEMIT PUSH TP* F*>
 794                       <COND (,WINNING-VICTIM
 795                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 3>>)>)>)
 796               (<AND <NOT <EMPTY? .L>>
 797                     <NOT <TYPE? <SET NM <1 .L>> FORM>>
 798                     <SUBRIFY? <2 .L>>>
 799                <FLUSH-AC T*>
 800                <MUNGED-AC T*>
 801                <OCEMIT <CHTYPE .NM SBFRM> T>
 802                <COND (<NOT ,PASS1> <CONST-ADD-FRM>)>
 803                <OCEMIT JSP T* @ <- <OPCODE SBRFRAM>>>
 804                <COND (,WINNING-VICTIM
 805                       <SETG STACK-DEPTH <+ ,STACK-DEPTH 7>>)>)
 806               (T
 807                <UPDATE-ACS>
 808                <PUSHJ <COND (.SEG SFRAME) (ELSE FRAME)>>
 809                <COND (,WINNING-VICTIM
 810                       <SETG STACK-DEPTH <+ ,STACK-DEPTH 7>>)>)>>
 811
 812 <DEFINE VFRAME!-MIMOC (L)
 813         #DECL ((L) LIST)
 814         <UPDATE-ACS>
 815         <PUSHJ FRAME <2 .L>>>
 816
 817 <DEFINE CFRAME!-MIMOC (L "AUX" (VAL <2 .L>) AC)
 818         #DECL ((L) LIST (VAL AC) ATOM)
 819         <COND (<==? .VAL STACK>
 820                <OCEMIT PUSH TP* !<TYPE-WORD FRAME>>
 821                <OCEMIT XMOVEI O* -4 '(F*)>
 822                <OCEMIT PUSH TP* O*>
 823                <COND (,WINNING-VICTIM
 824                       <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 825               (T
 826                <SET AC <ASSIGN-AC .VAL BOTH>>
 827                <AC-TYPE <GET-AC .AC> FRAME>
 828                <OCEMIT XMOVEI <NEXT-AC .AC> -4 '(F*)>)>>
 829
 830 <DEFINE PFRAME!-MIMOC (L "AUX" (VAL <3 .L>) AC NAC RNAC TAG)
 831         #DECL ((L) LIST (VAL AC NAC RNAC TAG) ATOM)
 832         <SET AC <LOAD-AC <1 .L> VALUE>>
 833         <SET NAC <ASSIGN-AC .VAL BOTH T>>
 834         <AC-TYPE <GET-AC .NAC> FRAME>
 835         <OCEMIT MOVE <SET RNAC <NEXT-AC .NAC>> 3 (.AC)>
 836         <OCEMIT SKIPL (.RNAC)>
 837         <OCEMIT JRST <XJUMP <SET TAG <GENLBL "END">>>>
 838         <OCEMIT HRR .RNAC -1 (.RNAC)>
 839         <OCEMIT SUBI .RNAC 4>
 840         <LABEL .TAG>
 841         <OCEMIT HLL .RNAC F*>
 842         <COND (<==? .VAL STACK>
 843                <OCEMIT PUSH TP* .NAC>
 844                <OCEMIT PUSH TP* .RNAC>
 845                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>>
 846
 847 <DEFINE RFRAME!-MIMOC (L)
 848         #DECL ((L) LIST)
 849         <RETURN!-MIMOC .L <2 .L>>>
 850
 851 <DEFINE RTUPLE!-MIMOC (L)
 852         #DECL ((L) LIST)
 853         <UPDATE-ACS>
 854         <OCEMIT MOVE O1* !<OBJ-VAL <1 .L>>>
 855         <OCEMIT MOVE O2* !<OBJ-VAL <2 .L>>>
 856         <OCEMIT JRST @ <OPCODE RTUPLE>>>
 857
 858 <DEFINE MRETURN!-MIMOC (L)
 859         #DECL ((L) LIST)
 860         <UPDATE-ACS>
 861         <OCEMIT MOVE O1* !<OBJ-VAL <1 .L>>>
 862         <COND (<==? <2 .L> 0>
 863                <OCEMIT MOVEI O2* 0>)
 864               (ELSE
 865                <OCEMIT MOVE O2* !<OBJ-VAL <2 .L>>>)>
 866         <OCEMIT JRST @ <OPCODE MRETURN>>>
 867
 868 <DEFINE ICALL!-MIMOC (L "AUX" (END <GENLBL "ICALL">))
 869         #DECL ((L) LIST)
 870         <COND (,ICALL-FLAG <SETG ICALL-FLAG <+ ,ICALL-FLAG 1>>)
 871               (ELSE <SETG ICALL-FLAG 1>)>
 872         <UPDATE-ACS>
 873         <FLUSH-ACS>
 874         <OCEMIT JSP T* @ <- <OPCODE ICALL>>>
 875         <OCEMIT JRST <XJUMP .END>>
 876         <SETG ICALL-TAGS (<1 .L> .END <COND (<G=? <LENGTH .L> 3>
 877                                              <3 .L>)
 878                                             (ELSE <>)>  !,ICALL-TAGS)>>
 879
 880 <DEFINE SCALL!-MIMOC (L) <CALL!-MIMOC .L T>>
 881
 882 <DEFINE CALL!-MIMOC (L
 883                      "OPT" (SEG <>)
 884                      "AUX" (ARG1 <1 .L>) (ARG2 <2 .L>) C AC PN OP-INF TAG COUNT
 885                            (XTAG <GENLBL "SC">) (SBYFINF <>))
 886         #DECL ((L) LIST (ARG1) <OR ATOM <FORM ATOM ATOM>> (C) ATOM
 887                (ARG2) <OR FIX ATOM>
 888                (OP-INF) <OR !<FALSE> <LIST <OR <FORM ANY FIX> !<FALSE>>>>)
 889         <COND (<AND .SEG <G? <LENGTH .L> 5>>
 890                <SET TAG <6 .L>>
 891                <SET COUNT <7 .L>>)>
 892         <COND (<AND <TYPE? .ARG1 FORM>
 893                     <OR <AND ,GLUE-MODE
 894                              <SET PN <FIND-CALL <2 .ARG1> ,PRE-NAMES>>>
 895                         <SET SBYFINF <SUBRIFY? <2 .ARG1>>>>>
 896                <COND (.SBYFINF
 897                       <COND (<NOT <TYPE? .ARG2 FIX>>
 898                              <OCEMIT MOVE O2* !<OBJ-VAL .ARG2>>)
 899                             (<NOT <KNOWN-ARGS .SBYFINF>>
 900                              <OCEMIT MOVEI O2* .ARG2>)>)
 901                      (<SET OP-INF <FIND-OPT <2 .ARG1> ,PRE-OPTS>>
 902                       <COND (<NOT <TYPE? .ARG2 FIX>>
 903                              <OCEMIT MOVE O2* !<OBJ-VAL .ARG2>>)
 904                             (<NOT <1 .OP-INF>> <OCEMIT MOVEI O2* .ARG2>)>)
 905                      (<AND <TYPE? .ARG2 ATOM> <NOT <IN-AC? .ARG2 VALUE>>>
 906                       <OCEMIT MOVE O2* !<OBJ-VAL .ARG2>>)>
 907                <COND (<AND <TYPE? .ARG2 FIX>
 908                            ,SURVIVOR-MODE
 909                            <NOT <GETPROP .PN NDFRM>>
 910                            <NOT .OP-INF>
 911                            <NOT <SURVIVOR? <2 .ARG1>>>>
 912                       <UPDATE-ACS>
 913                       <COND (,WINNING-VICTIM
 914                              <SETG STACK-DEPTH
 915                                    <- ,STACK-DEPTH <+ <* .ARG2 2> 2>>>)>)
 916                      (<TYPE? .ARG2 FIX>
 917                       <UPDATE-ACS>
 918                       <OCEMIT XMOVEI F* <- <+ <* .ARG2 2> 1>> (TP*)>
 919                       <COND (,WINNING-VICTIM
 920                              <SETG STACK-DEPTH
 921                                    <- ,STACK-DEPTH <+ <* .ARG2 2> 3>>>)>)
 922                      (T
 923                       <COND (<AND <TYPE? .ARG2 ATOM>
 924                                   <OR <WILL-DIE? .ARG2>
 925                                       <==? .ARG2
 926                                            <COND (<G? <LENGTH .L> 3> <4 .L>)>>>>
 927                              <DEAD!-MIMOC (.ARG2) T>)>
 928                       <UPDATE-ACS>
 929                       <OCEMIT XMOVEI F* -1 '(TP*)>
 930                       <COND (<SET AC <IN-AC? .ARG2 VALUE>>
 931                              <OCEMIT LSH .AC 1>
 932                              <OCEMIT SUB F* .AC>)
 933                             (ELSE
 934                              <OCEMIT SUB F* O2*>
 935                              <OCEMIT SUB F* O2*>)>)>
 936                <COND (.SBYFINF
 937                       <OCEMIT DMOVE A1* !<OBJ-TYP .SBYFINF>>
 938                       <OCEMIT DMOVEM A1* -3 '(F*)>
 939                       <OCEMIT MOVE M* 1 '(A2*)>
 940                       <OCEMIT XCT 3 '(A2*)>
 941                       <OCEMIT JRST @ 5 '(A2*)>)
 942                      (ELSE
 943                       <OCEMIT <CHTYPE <2 .ARG1> GCAL>
 944                               T
 945                               <COND (<AND .OP-INF <1 .OP-INF> <TYPE? .ARG2 FIX>>
 946                                      <NTH <1 .OP-INF>
 947                                           <- .ARG2
 948                                              <CHTYPE <2 <1 .OP-INF>> FIX>
 949                                              -4>>)>>)>
 950                <LABEL <NTH .L <LENGTH .L>> 0>
 951                <FLUSH-ACS>
 952                <COND (<AND .SEG <ASSIGNED? TAG>>
 953                       <COND (<N==? .TAG <2 .MIML>>
 954                              <OCEMIT JRST <XJUMP .XTAG>>)
 955                             (ELSE
 956                              <OCEMIT JFCL O* O*>)>
 957                       <COND (<NOT <WILL-DIE? .COUNT>>
 958                              <CLEAN-ACS .COUNT>
 959                              <OCEMIT ADDB A2* !<OBJ-VAL .COUNT>>
 960                              <SET AC <GET-AC A1*>>
 961                              <AC-ITEM .AC .COUNT>
 962                              <AC-CODE .AC TYPE>
 963                              <AC-UPDATE .AC <>>
 964                              <AC-TIME .AC <SETG AC-STAMP <+ ,AC-STAMP 1>>>
 965                              <SET AC <GET-AC A2*>>
 966                              <AC-ITEM .AC .COUNT>
 967                              <AC-CODE .AC VALUE>
 968                              <AC-UPDATE .AC <>>
 969                              <AC-TIME .AC ,AC-STAMP>)>
 970                       <COND (<N==? .TAG <2 .MIML>>
 971                              <LABEL-UPDATE-ACS .TAG <>>
 972                              <OCEMIT JRST <XJUMP .TAG>>
 973                              <LABEL .XTAG>
 974                              <SET AC <GET-AC A1*>>
 975                              <CLEAN-ACS <4 .L>>
 976                              <AC-ITEM .AC <4 .L>>
 977                              <AC-CODE .AC TYPE>
 978                              <AC-UPDATE .AC T>
 979                              <AC-TIME .AC <SETG AC-STAMP <+ ,AC-STAMP 1>>>
 980                              <SET AC <GET-AC A2*>>
 981                              <AC-ITEM .AC <4 .L>>
 982                              <AC-CODE .AC VALUE>
 983                              <AC-UPDATE .AC T>
 984                              <AC-TIME .AC ,AC-STAMP>)>)
 985                      (ELSE
 986                       <COND (<G? <LENGTH .L> 3> <PUSHJ-VAL <4 .L>>)>)>)
 987               (T
 988                <OCEMIT MOVE O1* !<OBJ-VAL .ARG1>>
 989                <COND (<TYPE? .ARG2 FIX>
 990                       <OCEMIT MOVEI O2* .ARG2>)
 991                      (T <OCEMIT MOVE O2* !<OBJ-VAL .ARG2>>)>
 992                <COND (<AND <TYPE? .ARG1 ATOM>
 993                            <OR <WILL-DIE? .ARG1>
 994                                <==? .ARG1 <COND (<G? <LENGTH .L> 3> <4 .L>)>>>>
 995                       <DEAD!-MIMOC (.ARG1)>)>
 996                <COND (<AND <TYPE? .ARG2 ATOM>
 997                            <OR <WILL-DIE? .ARG2>
 998                                <==? .ARG2 <COND (<G? <LENGTH .L> 3> <4 .L>)>>>>
 999                       <DEAD!-MIMOC (.ARG2)>)>
1000                <UPDATE-ACS>
1001                <COND (<AND ,WINNING-VICTIM <TYPE? .ARG2 FIX>>
1002                       <SETG STACK-DEPTH
1003                             <- ,STACK-DEPTH <* .ARG2 2> 7>>)>
1004                <COND (<AND .SEG <ASSIGNED? TAG>>
1005                       <PUSHJ CALL>
1006                       <COND (<N==? .TAG <2 .MIML>>
1007                              <OCEMIT JRST <XJUMP .XTAG>>)
1008                             (ELSE
1009                              <OCEMIT JFCL O* O*>)>
1010                       <COND (<NOT <WILL-DIE? .COUNT>>
1011                              <SET AC <GET-AC A1*>>
1012                              <CLEAN-ACS .COUNT>
1013                              <OCEMIT ADDB A2* !<OBJ-VAL .COUNT>>
1014                              <AC-ITEM .AC .COUNT>
1015                              <AC-CODE .AC TYPE>
1016                              <AC-UPDATE .AC <>>
1017                              <AC-TIME .AC <SETG AC-STAMP <+ ,AC-STAMP 1>>>
1018                              <SET AC <GET-AC A2*>>
1019                              <AC-ITEM .AC .COUNT>
1020                              <AC-CODE .AC VALUE>
1021                              <AC-UPDATE .AC <>>
1022                              <AC-TIME .AC ,AC-STAMP>)>
1023                       <COND (<N==? .TAG <2 .MIML>>
1024                              <LABEL-UPDATE-ACS .TAG <>>
1025                              <OCEMIT JRST <XJUMP .TAG>>
1026                              <LABEL .XTAG>
1027                              <SET AC <GET-AC A1*>>
1028                              <CLEAN-ACS <4 .L>>
1029                              <AC-ITEM .AC <4 .L>>
1030                              <AC-CODE .AC TYPE>
1031                              <AC-UPDATE .AC T>
1032                              <AC-TIME .AC <SETG AC-STAMP <+ ,AC-STAMP 1>>>
1033                              <SET AC <GET-AC A2*>>
1034                              <AC-ITEM .AC <4 .L>>
1035                              <AC-CODE .AC VALUE>
1036                              <AC-UPDATE .AC T>
1037                              <AC-TIME .AC ,AC-STAMP>)>)
1038                      (ELSE
1039                       <COND (<L=? <LENGTH .L> 3> <PUSHJ CALL>)
1040                             (T <PUSHJ CALL <4 .L>>)>
1041                       <COND (.SEG <OCEMIT JFCL O* O*>)>)>)>>
1042
1043 <DEFINE ACALL!-MIMOC (L "AUX" (ARG1 <1 .L>) (ARG2 <2 .L>) C (VAL <>))
1044         #DECL ((L) LIST (ARG1) <OR ATOM <FORM ATOM ATOM>> (C) ATOM
1045                (ARG2) <OR FIX ATOM>)
1046         <COND (<G? <LENGTH .L> 3> <SET VAL <4 .L>>)>
1047         <COND (<OR <==? .ARG1 .VAL> <WILL-DIE? .ARG1>>
1048                <DEAD!-MIMOC (.ARG1) T>)>
1049         <COND (<OR <==? .ARG2 .VAL> <WILL-DIE? .ARG2>>
1050                <DEAD!-MIMOC (.ARG2) T>)>
1051         <UPDATE-ACS>
1052         <GET-INTO-ACS .ARG1 BOTH A1* .ARG2 VALUE O2*>
1053         <COND (<AND <TYPE? .ARG2 FIX>
1054                     ,WINNING-VICTIM>
1055                <SETG STACK-DEPTH <- ,STACK-DEPTH
1056                                     <* .ARG2 2> 7>>)>
1057         <COND (<NOT .VAL> <PUSHJ ACALL>) (T <PUSHJ ACALL .VAL>)>>
1058
1059 <DEFINE SETLR!-MIMOC (L "AUX" AC LCL)
1060         #DECL ((L) LIST (AC) ATOM (P) <OR FALSE FIX>)
1061         <SET AC <ASSIGN-AC <1 .L> BOTH>>
1062         <OCEMIT MOVE T* !<OBJ-VAL <2 .L>>>
1063         <SET LCL <OR <LMEMQ <3 .L> ,LOCALS>
1064                      <LMEMQ <3 .L> ,ICALL-TEMPS>>>
1065         <OCEMIT DMOVE .AC <LNAME .LCL> '(T*)>>
1066
1067 <DEFINE SETRL!-MIMOC (L "AUX" AC LCL)
1068         #DECL ((L) LIST (AC) ATOM (P) <OR FALSE FIX>)
1069         <SET AC <LOAD-AC <3 .L> BOTH>>
1070         <OCEMIT MOVE T* !<OBJ-VAL <1 .L>>>
1071         <COND (<OR <SET LCL <LMEMQ <2 .L> ,LOCALS>>
1072                    <SET LCL <LMEMQ <2 .L> ,ICALL-TEMPS>>>
1073                <COND (<NOT <LUPD .LCL>> <LUPD .LCL TEMP>)>)>
1074         <OCEMIT DMOVEM .AC <LNAME .LCL> '(T*)>>
1075
1076 <DEFINE RETURN!-MIMOC (L "OPTIONAL" (FRM <>) "AUX" TYP)
1077         #DECL ((L) LIST (TYP FRM) <OR FALSE ATOM>)
1078         <COND (.FRM <GET-INTO-ACS <1 .L> BOTH A1* .FRM VALUE T*>)
1079               (ELSE <GET-INTO-ACS <1 .L> BOTH A1*>)>
1080         <COND (<SET TYP <AC-TYPE <GET-AC A1*>>>
1081                <XEMIT MOVSI A1* !<TYPE-CODE .TYP T>>)>
1082         <COND (.FRM
1083                <OCEMIT XMOVEI F* 4 '(T*)>
1084                <OCEMIT SKIPGE '(F*)>
1085                 <OCEMIT HRR F* -1 '(F*)>
1086                <OCEMIT JRST @ <OPCODE RETURN>>)
1087               (,WINNING-VICTIM
1088                <OCEMIT MOVE O* '(TP*) '<- 2 ,WINNING-VICTIM>>
1089                <OCEMIT SUBI TP* ',WINNING-VICTIM>
1090                <OCEMIT JRST @ O*>)
1091               (T <OCEMIT JRST @ <OPCODE RETURN>>)>
1092         <SETG LAST-UNCON T>
1093         <FLUSH-ACS>>
1094
1095 <DEFINE BIND!-MIMOC (L)
1096         #DECL ((L) LIST)
1097         <UPDATE-ACS>
1098         <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 9>>)>
1099         <PUSHJ BIND <2 .L>>>
1100
1101 <DEFINE ACTIVATION!-MIMOC (L)
1102         #DECL ((L) LIST)
1103         <UPDATE-ACS>
1104         <PUSHJ ACTIVATION>>
1105
1106 <DEFINE AGAIN!-MIMOC (L)
1107         #DECL ((L) LIST)
1108         <UPDATE-ACS>
1109         <OCEMIT MOVE O1* !<OBJ-VAL <1 .L>>>
1110         <OCEMIT JRST @ <OPCODE AGAIN>>
1111         <FLUSH-ACS>>
1112
1113 <DEFINE RETRY!-MIMOC (L)
1114         #DECL ((L) LIST)
1115         <UPDATE-ACS>
1116         <OCEMIT MOVE O1* !<OBJ-VAL <1 .L>>>
1117         <OCEMIT JRST @ <OPCODE RETRY>>
1118         <FLUSH-ACS>>
1119
1120 <DEFINE FIXBIND!-MIMOC (L)
1121         #DECL ((L) LIST)
1122         <UPDATE-ACS>
1123         <PUSHJ FIXBIND>>
1124
1125 <DEFINE UNBIND!-MIMOC (L)
1126         #DECL ((L) LIST)
1127         <UPDATE-ACS>
1128         <OCEMIT MOVE O1* !<OBJ-VAL <1 .L>>>
1129         <PUSHJ UNBIND>>
1130
1131 <DEFINE ARGS!-MIMOC (L)
1132         #DECL ((L) LIST)
1133         <UPDATE-ACS>
1134         <OCEMIT MOVE O1* !<OBJ-VAL <1 .L>>>
1135         <PUSHJ ARGS <3 .L>>>
1136
1137 <DEFINE TUPLE!-MIMOC (L)
1138         #DECL ((L) LIST)
1139         <UPDATE-ACS>
1140         <OCEMIT MOVE O1* !<OBJ-VAL <1 .L>>>
1141         <PUSHJ TUPLE <3 .L>>>
1142
1143 <DEFINE ARGNUM!-MIMOC (L)
1144         #DECL ((L) LIST)
1145         <UPDATE-ACS>
1146         <OCEMIT MOVEI O1* <1 .L>>
1147         <PUSHJ ARGNUM>>
1148
1149 \f
1150 ;"General Predicates"
1151
1152 <DEFINE EQUAL?!-MIMOC (L "OPT" (ADDR1 <>) (ADDR2 <>) (OFF <>)
1153                          "AUX" (ARG1 <1 .L>) (ARG2 <2 .L>) (AC1 <>) (AC2 <>)
1154                                (AC-T1 <>) (AC-T2 <>) NEW (TY1 <>) (TY2 <>))
1155         #DECL ((NEW L) LIST (ARG1 ARG2) ANY (AC1 AC2) <OR ATOM FALSE>)
1156         <COND (<AND <NOT .ADDR1>
1157                     <SET AC1 <IN-AC? .ARG1 BOTH>>
1158                     <NOT <SET TY1 <AC-TYPE <GET-AC .AC1>>>>>
1159                <AND <SET AC2 <IN-AC? .ARG2 BOTH>>
1160                     <SET TY2 <AC-TYPE <GET-AC .AC2>>>>)
1161               (<AND <NOT .ADDR2>
1162                     <SET AC2 <IN-AC? .ARG2 BOTH>>
1163                     <NOT <SET TY2 <AC-TYPE <GET-AC .AC2>>>>>
1164                <SET TY2 .TY1>
1165                <SET AC1 .AC2>
1166                <SET ARG2 .ARG1>
1167                <SET ADDR2 .ADDR1>
1168                <SET ARG1 <2 .L>>
1169                <SET ADDR1 <SET TY1 <>>>
1170                <SET AC2 <IN-AC? .ADDR2 BOTH>>)
1171               (.AC1
1172                <AND <SET AC2 <IN-AC? .ARG2 BOTH>>
1173                     <SET TY2 <AC-TYPE <GET-AC .AC2>>>>)
1174               (.AC2
1175                <SET TY2 .TY1>
1176                <SET AC1 .AC2>
1177                <SET ARG2 .ARG1>
1178                <SET ADDR2 .ADDR1>
1179                <SET ARG1 <2 .L>>
1180                <SET ADDR1 <SET TY1 <>>>
1181                <SET AC2 <>>)
1182               (ELSE
1183                <SET AC1 <LOAD-AC .ARG1 BOTH>>)>
1184         <SET NEW <LABEL-UPDATE-ACS <4 .L> <> <> .AC1 .AC2>>
1185         <COND (<N==? .AC1 <1 .NEW>>
1186                <SET AC-T1 <AC-TIME <GET-AC <SET AC1 <1 .NEW>>>>>)>
1187         <COND (<AND .AC2 <N==? .AC2 <2 .NEW>>>
1188                <SET AC-T2 <AC-TIME <GET-AC <SET AC2 <2 .NEW>>>>>)>
1189         <OCEMIT CAMN .AC1 !<COND (.ADDR2 (.OFF (.ADDR2)))
1190                                  (.TY2 <TYPE-WORD .TY2>)
1191                                  (.AC2 (.AC2))
1192                                  (ELSE <OBJ-TYP .ARG2>)>>
1193         <OCEMIT CAME <NEXT-AC .AC1>
1194                      !<COND (.AC2 (<NEXT-AC .AC2>))
1195                             (.ADDR2 (<+ .OFF 1> (.ADDR2)))
1196                             (ELSE <OBJ-VAL .ARG2>)>>
1197         <COND (<==? <3 .L> +> <OCEMIT CAIA O* O*>)>
1198         <OCEMIT JRST <XJUMP <4 .L>>>
1199         <COND (.AC-T1
1200                <AC-TIME <GET-AC .AC1> .AC-T1>
1201                <AC-TIME <GET-AC <NEXT-AC .AC1>> .AC-T1>)>
1202         <COND (.AC-T2
1203                <AC-TIME <GET-AC .AC2> .AC-T2>
1204                <AC-TIME <GET-AC <NEXT-AC .AC2>> .AC-T2>)>>
1205
1206 <DEFINE VEQUAL?!-MIMOC (L
1207                         "OPTIONAL" (ADDR1 <>) (ADDR2 <>) (OFF <>) (TY <>)
1208                                    (CAI CAIN)
1209                                    (CAM CAMN) (JUMP JUMPE) (CAIX CAIE) (CAMX CAME)
1210                                    (JUMPX JUMPN) (SOJ SOJE) (SOJX SOJN)
1211                                    (SKIP SKIPN) (SKIPX SKIPE)
1212                         "AUX" (ARG1 <1 .L>) (ARG2 <2 .L>) (TAG <4 .L>) AC1 NEW
1213                               (AC-T1 <>) (AC-T2 <>) AC2 TEM (DIR <3 .L>)
1214                               BP (KL <>) TMP (SWAPPED? <>))
1215         #DECL ((L) LIST (ARG1 ARG2) ANY (KL) <OR FALSE ATOM>
1216                (AC1 CAI CAM JUMP CAIX CAMX JUMPX TAG SKIP SKIPX) ATOM)
1217         <COND (<TYPE? .ARG2 FLOAT WORD LOSE CHARACTER>
1218                <SET ARG2 <CHTYPE .ARG2 FIX>>)
1219               (<AND <==? <PRIMTYPE .ARG2> LIST> <EMPTY? .ARG2>> <SET ARG2 0>)>
1220         <SET AC1
1221              <COND (.ADDR1)
1222                    (<IN-AC? .ARG1 VALUE>)
1223                    (<==? .ARG2 0> X*)
1224                    (<AND <TYPE? .ARG2 ATOM>
1225                          <OR <IN-AC? .ARG2 VALUE> <NOT <TYPE? .ARG1 ATOM>>>>
1226                     <COND (<==? .CAI CAIGE>                            ;"LESS?"
1227                            <SET KL T>
1228                            <COND (<==? .DIR +> <SET CAI CAILE> <SET CAM CAMLE>)
1229                                  (T <SET CAI CAIG> <SET CAM CAMG>)>)
1230                           (<==? .CAI CAILE>                            ;"GRTR?"
1231                            <SET KL T>
1232                            <COND (<==? .DIR +> <SET CAI CAIGE> <SET CAM CAMGE>)
1233                                  (T <SET CAI CAIL> <SET CAM CAML>)>)>
1234                     <SET SWAPPED? T>
1235                     <SET TEM .ARG1>
1236                     <SET ARG1 .ARG2>
1237                     <SET ARG2 .TEM>
1238                     <COND (<IN-AC? .ARG1 VALUE>)
1239                           (ELSE <NEXT-AC <LOAD-AC .ARG1 BOTH>>)>)
1240                    (T <NEXT-AC <LOAD-AC .ARG1 BOTH>>)>>
1241         <SET AC2
1242              <COND (.ADDR2)
1243                    (<AND <TYPE? .ARG2 ATOM> <IN-AC? .ARG2 VALUE>>)
1244                    (<AND .ADDR1 <TYPE? .ARG2 ATOM>> <LOAD-AC .ARG2 VALUE>)
1245                    (ELSE X*)>>
1246         <COND (<AND <==? .ARG2 1> <NOT <AC-UPDATE <GET-AC .AC1>>>>
1247                <COND (<SET TMP <IN-AC? .ARG1 BOTH>>
1248                       <MUNGED-AC .TMP T>)
1249                      (ELSE <MUNGED-AC .AC1>)>)
1250               (ELSE
1251                <SET SOJ <>>)>
1252         <SET NEW
1253              <LABEL-UPDATE-ACS .TAG
1254                                <>
1255                                T
1256                                <COND (<AND <N==? .AC1 X*> <N==? .AC1 O*>> .AC1)>
1257                                <COND (<AND <N==? .AC2 X*> <N==? .AC2 O*>> .AC2)>>>
1258         <COND (<AND <N==? .AC1 X*> <N==? .AC1 O*> <N==? .AC1 <1 .NEW>>>
1259                <SET AC-T1 <AC-TIME <GET-AC <SET AC1 <1 .NEW>>>>>)>
1260         <COND (<AND <N==? .AC2 X*> <N==? .AC2 O*> <N==? .AC2 <2 .NEW>>>
1261                <SET AC-T2 <AC-TIME <GET-AC <SET AC2 <2 .NEW>>>>>)>
1262         <COND (<AND <NOT .KL> <==? .DIR ->>
1263                <SET CAI .CAIX>
1264                <SET CAM .CAMX>
1265                <SET JUMP .JUMPX>
1266                <COND (.SOJ <SET SOJ .SOJX>)>
1267                <SET SKIP .SKIPX>)>
1268         <COND (<AND .OFF .TY>
1269                <SET BP <+ <CHTYPE <ORB 19595788288
1270                                        <LSH <2 <CHTYPE <MEMQ .AC1 ,ACS> VECTOR>>
1271                                             18>>
1272                                   FIX>
1273                           <- .OFF 1>>>
1274                <CONST-LOC .BP VALUE>
1275                <OCEMIT LDB O* !<OBJ-VAL .BP>>
1276                <OCEMIT CAIN O* .TY>
1277                <SET CAI .CAIX>
1278                <SET CAM .CAMX>
1279                <SET SKIP .SKIPX>)>
1280         <COND (<==? .ARG2 0>
1281                <COND (.OFF
1282                       <COND (<TYPE? .OFF FIX>
1283                              <OCEMIT .SKIP O* .OFF (.AC1)>)
1284                             (ELSE
1285                              <OCEMIT .SKIP O* !.OFF>)>
1286                       <COND (.TY <OCEMIT CAIA O* O*>)>
1287                       <OCEMIT JRST <XJUMP .TAG>>)
1288                      (<==? .AC1 X*>
1289                       <OCEMIT .SKIP !<OBJ-VAL .ARG1>>
1290                       <OCEMIT JRST <XJUMP .TAG>>)
1291                      (T <OCEMIT .JUMP .AC1 <XJUMP .TAG>>)>)
1292               (<AND <==? .ARG2 1> <NOT <AC-UPDATE <GET-AC .AC1>>> .SOJ>
1293                <OCEMIT .SOJ .AC1 <XJUMP .TAG>>)
1294               (<AND <TYPE? .ARG2 FIX> <G=? .ARG2 0> <L=? .ARG2 ,MAX-IMMEDIATE>>
1295                <OCEMIT .CAI .AC1 .ARG2>
1296                <OCEMIT JRST <XJUMP .TAG>>)
1297               (.OFF
1298                <COND (.SWAPPED?
1299                       <COND (<TYPE? .OFF FIX>
1300                              <OCEMIT .CAM .AC1 .OFF (.AC2)>)
1301                             (T
1302                              <OCEMIT .CAM .AC1 !.OFF>)>)
1303                      (<TYPE? .OFF FIX>
1304                       <OCEMIT .CAM .AC2 .OFF (.AC1)>)
1305                      (ELSE
1306                       <OCEMIT .CAM .AC2 !.OFF>)>
1307                <COND (.TY <OCEMIT CAIA O* O*>)>
1308                <OCEMIT JRST <XJUMP .TAG>>)
1309               (T
1310                <COND (<==? .AC2 X*> <OCEMIT .CAM .AC1 !<OBJ-VAL .ARG2>>)
1311                      (ELSE <OCEMIT .CAM .AC1 .AC2>)>
1312                <OCEMIT JRST <XJUMP .TAG>>)>
1313         <COND (.AC-T1 <AC-TIME <GET-AC .AC1> .AC-T1>)>
1314         <COND (.AC-T2 <AC-TIME <GET-AC .AC2> .AC-T2>)>>
1315
1316 <DEFINE LESS?!-MIMOC (L)
1317         #DECL ((L) LIST)
1318         <VEQUAL?!-MIMOC .L <> <> <> <> CAIGE CAMGE JUMPL CAIL CAML JUMPGE SOJL
1319                         SOJGE SKIPGE SKIPL>>
1320
1321 <DEFINE GRTR?!-MIMOC (L)
1322         #DECL ((L) LIST)
1323         <VEQUAL?!-MIMOC .L <> <> <> <> CAILE CAMLE JUMPG CAIG CAMG JUMPLE SOJG
1324                         SOJLE SKIPLE SKIPG>>
1325
1326 <SETG COMPARERS [VEQUAL!-MIMOC LESS?!-MIMOC GRTR?!-MIMOC]>
1327
1328 ;"Arithmetics"
1329
1330 <DEFINE MUL!-MIMOC (L) #DECL ((L) LIST) <ARITH!-MIMOC .L IMUL IMULI <> IMULB>>
1331 <DEFINE MULF!-MIMOC (L) #DECL ((L) LIST) <ARITH!-MIMOC .L FMPR FMPRI <> FMPRB
1332                                                        FLOAT>>
1333
1334 <DEFINE SUB!-MIMOC (L) #DECL ((L) LIST) <ARITH!-MIMOC .L SUB SUBI SOS SUBB>>
1335 <DEFINE SUBF!-MIMOC (L) #DECL ((L) LIST) <ARITH!-MIMOC .L FSBR FSBRI <> FSBRB
1336                                                        FLOAT>>
1337
1338 <DEFINE DIV!-MIMOC (L) #DECL ((L) LIST) <ARITH!-MIMOC .L IDIV IDIVI <> IDIVB>>
1339 <DEFINE DIVF!-MIMOC (L) #DECL ((L) LIST) <ARITH!-MIMOC .L FDVR FDVRI <> FDVRB
1340                                                        FLOAT>>
1341
1342 <DEFINE ADD!-MIMOC (L) #DECL ((L) LIST) <ARITH!-MIMOC .L>>
1343 <DEFINE ADDF!-MIMOC (L) #DECL ((L) LIST) <ARITH!-MIMOC .L FADR FADRI <> FADRB
1344                                                        FLOAT>>
1345
1346 <DEFINE MOD!-MIMOC (L) #DECL ((L) LIST) <ARITH!-MIMOC .L IDIV IDIVI MOD <>>>
1347 <DEFINE XOR!-MIMOC (L) #DECL ((L) LIST) <ARITH!-MIMOC .L XOR XORI TLC XORB>>
1348
1349 <DEFINE EQV!-MIMOC (L) #DECL ((L) LIST) <ARITH!-MIMOC .L EQV EQVI '(TLC TRC) EQVB>>
1350 <DEFINE OR!-MIMOC (L) #DECL ((L) LIST) <ARITH!-MIMOC .L IOR IORI TLO IORB>>
1351
1352 <DEFINE ARITH!-MIMOC (L
1353                       "OPTIONAL" (NORM ADD) (IMMED ADDI) (HACK AOS) (BO ADDB)
1354                                  (RESTYP FIX)
1355                       "AUX" AC OAC (ARG1 <1 .L>) (ARG2 <2 .L>) (VAL <4 .L>)
1356                             HACK2 (TEM .ARG1) (IMM-OK <>) (NEG-FIRST <>))
1357    #DECL ((L) LIST (NORM IMMED VAL) ATOM (HACK) <OR ATOM LIST FALSE>
1358           (ARG1 ARG2) <OR ATOM FIX FLOAT> (AC) <OR FALSE ATOM>)
1359    <COND (<AND <==? .ARG1 1> <==? .NORM ADD>> <SET ARG1 .ARG2> <SET ARG2 1>)>
1360    <COND (<AND <OR <AND <==? .ARG2 .VAL>
1361                         <NOT <AND <IN-AC? .ARG1 VALUE> <WILL-DIE? .ARG1>>>>
1362                    <COND (<SET AC <IN-AC? .ARG2 VALUE>>
1363                           <OR <NOT <SET OAC <IN-AC? .ARG1 VALUE>>>
1364                               <AND <N==? .ARG1 .VAL>
1365                                    <OR <NOT <AC-UPDATE <GET-AC .OAC>>>
1366                                        <WILL-DIE? .ARG2>>
1367                                    <AC-UPDATE <GET-AC .AC>>
1368                                    <NOT <WILL-DIE? .ARG1>>>>)>>
1369                <N==? .ARG1 0>
1370                <N==? .ARG1 0.0>
1371                <OR <MEMQ .NORM '[ADD MUL IOR XOR AND EQV]>
1372                    <AND <==? .NORM SUB>
1373                         <SET NEG-FIRST T>
1374                         <SET IMMED ADDI>
1375                         <SET NORM ADD>
1376                         <SET BO ADDB>>
1377                    <AND <==? .NORM FSBR>
1378                         <SET NEG-FIRST T>
1379                         <SET IMMED FADRI>
1380                         <SET NORM FADR>
1381                         <SET BO FADRB>>>>
1382           <SET ARG1 .ARG2>
1383           <SET ARG2 .TEM>)
1384          (<AND <OR <==? <PRIMTYPE .ARG2> WORD> <==? <PRIMTYPE .ARG2> FIX>>
1385                <OR <==? .NORM ADD> <==? .NORM SUB>>
1386                <L? <CHTYPE .ARG2 FIX> 0>
1387                <L? <ABS <CHTYPE .ARG2 FIX>> ,MAX-IMMEDIATE>>
1388           <SET ARG2 <- .ARG2>>
1389           <COND (<==? .NORM ADD> <SET NORM SUB> <SET IMMED SUBI>)
1390                 (ELSE <SET NORM ADD> <SET IMMED ADDI>)>)>
1391    <COND
1392     (<AND <OR <==? <PRIMTYPE .ARG2> WORD> <==? <PRIMTYPE .ARG2> FIX>>
1393           <OR <AND <L=? <SET ARG2 <CHTYPE .ARG2 FIX>> ,MAX-IMMEDIATE>
1394                    <G=? .ARG2 0>>
1395               <AND <==? <CHTYPE <ANDB .ARG2 262143> FIX> 0>
1396                    <OR <AND <OR <==? .NORM IOR> <==? .NORM XOR>>
1397                             <SET ARG2 <CHTYPE <LSH .ARG2 -18> FIX>>
1398                             <SET IMMED .HACK>
1399                             <COND (<AND <==? .HACK TLO> <==? .ARG2 262143>>
1400                                    <SET IMMED HRLI>
1401                                    <SET HACK HRROS>
1402                                    <SET HACK2 HRRO>)
1403                                   (ELSE T)>>
1404                        <AND <MEMQ .NORM '[FADR FSBR FDVR FMPR]>
1405                             <SET ARG2 <CHTYPE <LSH .ARG2 -18> FIX>>>>>
1406               <AND <OR <==? .NORM AND> <==? .NORM EQV>>
1407                    <OR <AND <==? <CHTYPE <ANDB .ARG2 262143> FIX> 262143>
1408                             <SET ARG2 <CHTYPE <LSH <XORB .ARG2 -1> -18> FIX>>
1409                             <SET IMMED <1 <CHTYPE .HACK LIST>>>>
1410                        <AND <==? <CHTYPE <ANDB <LSH .ARG2 -18> 262143> FIX>
1411                                  262143>
1412                             <SET ARG2
1413                                  <CHTYPE <ANDB <XORB .ARG2 -1> 262143> FIX>>
1414                             <SET IMMED <2 <CHTYPE .HACK LIST>>>
1415                             <COND (<AND <==? .ARG2 262143> <==? .IMMED TRZ>>
1416                                    <SET HACK HLLZS>
1417                                    <SET HACK2 HLLZ>)
1418                                   (ELSE T)>>>>>
1419           <SET IMM-OK T>
1420           <OR <==? .ARG1 .VAL>
1421               <AND <WILL-DIE? .ARG1>
1422                    <N==? .VAL STACK>
1423                    <PROG () <DEAD!-MIMOC (.ARG1) T> 1>>
1424               <AND <NOT <IN-AC? .ARG1 VALUE>>
1425                    <OR <==? .HACK HRROS>
1426                        <==? .HACK HLLZS>
1427                        <AND <==? .IMMED ANDI> <==? .ARG2 262143>>>>>>
1428      <COND (<SET AC <IN-AC? .ARG1 VALUE>>
1429             <COND (<AND <N==? .VAL STACK> <N==? .ARG1 .VAL>>
1430                    <CLEAN-ACS .VAL>
1431                    <AC-CODE <AC-ITEM <GET-AC .AC> .VAL> VALUE>
1432                    <PROG ((X <GET-AC <GETPROP .AC AC-PAIR>>) Y)
1433                          #DECL ((X) AC)
1434                          <COND (<OR <==? <AC-ITEM .X> .ARG1>
1435                                     <AND <SET Y <VAR-TYPED? .ARG1>>
1436                                          <AC-TYPE .X .RESTYP>>>
1437                                 <AC-UPDATE <AC-CODE <AC-ITEM .X .VAL> TYPE>
1438                                            T>
1439                                 <COND (<OR <AND <AC-TYPE .X>
1440                                                 <N==? <AC-TYPE .X> .RESTYP>>
1441                                            <AND <NOT <AC-TYPE .X>>
1442                                                 <NOT <AND <SET Y
1443                                                                <VAR-TYPED? .ARG1>>
1444                                                           <==? .Y .RESTYP>>>>>
1445                                        <AC-TYPE .X .RESTYP>)>)>>)>
1446             <COND (.NEG-FIRST <OCEMIT MOVNS O* .AC>)>
1447             <COND (<AND <OR <==? .NORM IDIV> <==? .NORM FDVR>>
1448                         <NOT <AC-TYPE <GET-AC <NEXT-AC .AC>>>>>
1449                    <FLUSH-AC <NEXT-AC .AC>>
1450                    <MUNGED-AC <NEXT-AC .AC>>)>
1451             <OCEMIT .IMMED .AC .ARG2>
1452             <AC-UPDATE <GET-AC .AC> T>
1453             <COND (<==? .HACK MOD>
1454                    <PROG ((X <GET-AC <NEXT-AC .AC>>) (Y <AC-TYPE .X>))
1455                          #DECL ((X) AC)
1456                          <AC-TYPE .X <>>
1457                          <OCEMIT SKIPGE .AC <NEXT-AC .AC>>
1458                          <OCEMIT ADDI .AC .ARG2>
1459                          <AC-TYPE .X .Y>>)>)
1460            (T
1461             <COND (<AND <1? .ARG2> <MEMQ .NORM '[ADD SUB]>>
1462                    <SET AC <ASSIGN-AC .VAL BOTH>>
1463                    <AC-UPDATE <GET-AC <NEXT-AC .AC>> <N==? .ARG1 .VAL>>
1464                    <AC-UPDATE <GET-AC .AC> <N==? .ARG1 .VAL>>
1465                    <OCEMIT .HACK <NEXT-AC .AC> !<OBJ-VAL .ARG1>>
1466                    <AC-ITEM <GET-AC <NEXT-AC .AC>> .VAL>
1467                    <AC-CODE <GET-AC <NEXT-AC .AC>> VALUE>
1468                    <AC-TYPE <GET-AC .AC> FIX>)
1469                   (<OR <==? .HACK HRROS>
1470                        <==? .HACK HLLZS>
1471                        <AND <==? .IMMED ANDI>
1472                             <==? .ARG2 262143>
1473                             <SET HACK HRRZS>
1474                             <SET HACK2 HRRZ>>>
1475                    <COND (<N==? .VAL STACK>
1476                           <SET AC <ASSIGN-AC .VAL BOTH>>
1477                           <AC-UPDATE <GET-AC <NEXT-AC .AC>> <N==? .VAL .ARG1>>
1478                           <AC-UPDATE <GET-AC .AC> <N==? .VAL .ARG1>>
1479                           <OCEMIT <COND (<==? .VAL .ARG1> .HACK)
1480                                         (ELSE .HACK2)>
1481                                   <NEXT-AC .AC> !<OBJ-VAL .ARG1>>
1482                           <AC-ITEM <GET-AC <NEXT-AC .AC>> .VAL>
1483                           <AC-CODE <GET-AC <NEXT-AC .AC>> VALUE>
1484                           <AC-TYPE <GET-AC .AC> FIX>)
1485                          (ELSE
1486                           <OCEMIT .HACK2 O* !<OBJ-VAL .ARG1>>
1487                           <OCEMIT PUSH TP* !<TYPE-WORD .RESTYP>>
1488                           <OCEMIT PUSH TP* O*>
1489                           <COND (,WINNING-VICTIM
1490                                  <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>)
1491                   (<==? .HACK MOD>
1492                    <SET AC <ASSIGN-AC .VAL BOTH T>>
1493                    <OCEMIT MOVE .AC !<OBJ-VAL .ARG1>>
1494                    <OCEMIT IDIVI .AC .ARG2>
1495                    <OCEMIT SKIPGE O* <NEXT-AC .AC>>
1496                    <OCEMIT ADDI <NEXT-AC .AC> .ARG2>
1497                    <AC-TYPE <GET-AC .AC> FIX>
1498                    <AC-ITEM <GET-AC <NEXT-AC .AC>> .VAL>
1499                    <AC-CODE <GET-AC <NEXT-AC .AC>> VALUE>
1500                    <AC-UPDATE <GET-AC <NEXT-AC .AC>> T>)
1501                   (T
1502                    <COND (.NEG-FIRST
1503                           <SET AC <ASSIGN-AC .ARG1 BOTH>>
1504                           <OCEMIT MOVN <NEXT-AC .AC> !<OBJ-VAL .ARG1>>
1505                           <AC-TYPE <GET-AC .AC> .RESTYP>)
1506                          (ELSE
1507                           <SET AC <LOAD-AC .ARG1 BOTH T>>)>
1508                    <COND (<N==? .ARG1 .VAL>
1509                           <DEAD!-MIMOC (.ARG1) T>
1510                           <PROG ((X <GET-AC .AC>) Y)
1511                                 <COND (<OR <AND <AC-TYPE .X>
1512                                                 <N==? <AC-TYPE .X> .RESTYP>>
1513                                            <AND <NOT <AC-TYPE .X>>
1514                                                 <NOT <AND <SET Y
1515                                                                <VAR-TYPED? .ARG1>>
1516                                                           <==? .Y .RESTYP>>>>>
1517                                        <AC-TYPE .X .RESTYP>)>>
1518                           <CLEAN-ACS .VAL>
1519                           <ALTER-AC .AC .VAL>)>
1520                    <SET AC <NEXT-AC .AC>>
1521                    <COND (<OR <==? .NORM IDIV> <==? .NORM FDVR>>
1522                           <FLUSH-AC <NEXT-AC .AC>>
1523                           <MUNGED-AC <NEXT-AC .AC>>)>
1524                    <OCEMIT .IMMED .AC .ARG2>)>)>)
1525     (<AND <OR <==? .ARG1 0> <==? .ARG1 0.0000000>>
1526           <OR <==? .NORM SUB> <==? .NORM FSBR>>>
1527      <COND (<SET AC <IN-AC? .ARG2 VALUE>>
1528             <COND (<==? .ARG2 .VAL>
1529                    <AC-UPDATE <GET-AC .AC> T>
1530                    <OCEMIT MOVNS O* .AC>)
1531                   (<==? .VAL STACK>
1532                    <OCEMIT MOVN O* .AC>
1533                    <OCEMIT PUSH TP* !<TYPE-WORD .RESTYP>>
1534                    <OCEMIT PUSH TP* O*>
1535                    <COND (,WINNING-VICTIM
1536                           <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
1537                   (ELSE
1538                    <SET OAC .AC>
1539                    <SET AC <ASSIGN-AC .VAL BOTH T>>
1540                    <AC-TYPE <GET-AC .AC> .RESTYP>
1541                    <AC-ITEM <GET-AC <NEXT-AC .AC>> .VAL>
1542                    <OCEMIT MOVN <NEXT-AC .AC> .OAC>)>)
1543            (<==? .ARG2 .VAL> <OCEMIT MOVNS O* !<OBJ-VAL .ARG2>>)
1544            (<==? .VAL STACK>
1545             <OCEMIT MOVN O* !<OBJ-VAL .ARG2>>
1546             <OCEMIT PUSH TP* !<TYPE-WORD .RESTYP>>
1547             <OCEMIT PUSH TP* O*>
1548             <COND (,WINNING-VICTIM
1549                    <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
1550            (ELSE
1551             <SET AC <ASSIGN-AC .VAL BOTH T>>
1552             <AC-TYPE <GET-AC .AC> .RESTYP>
1553             <OCEMIT MOVN <NEXT-AC .AC> !<OBJ-VAL .ARG2>>)>)
1554     (<AND <==? .HACK MOD> <==? .ARG1 .VAL>>
1555      <SET AC <ASSIGN-AC .ARG1 BOTH T>>
1556      <OCEMIT MOVE .AC !<OBJ-VAL .ARG1>>
1557      <OCEMIT IDIV .AC !<OBJ-VAL .ARG2>>
1558      <OCEMIT SKIPGE O* <NEXT-AC .AC>>
1559      <OCEMIT ADD <NEXT-AC .AC> !<OBJ-VAL .ARG2>>
1560      <AC-TYPE <GET-AC .AC> FIX>
1561      <AC-ITEM <GET-AC <NEXT-AC .AC>> .ARG1>
1562      <AC-CODE <GET-AC <NEXT-AC .AC>> VALUE>
1563      <AC-UPDATE <GET-AC <NEXT-AC .AC>> T>)
1564     (<==? .ARG1 .VAL>
1565      <SET AC <NEXT-AC <LOAD-AC .ARG1 BOTH>>>
1566      <COND (.NEG-FIRST <OCEMIT MOVNS O* .AC>)>
1567      <COND (<OR <==? .NORM IDIV> <==? .NORM FDVR>>
1568             <FLUSH-AC <NEXT-AC .AC>>
1569             <MUNGED-AC <NEXT-AC .AC>>)>
1570      <OCEMIT .NORM .AC !<OBJ-VAL .ARG2>>
1571      <AC-UPDATE <GET-AC .AC> T>)
1572     (<==? .HACK MOD>
1573      <COND (<==? .ARG2 .VAL> <SMASH-AC T* .ARG2 VALUE>)>
1574      <CLEAN-ACS .VAL>
1575      <SET AC <ASSIGN-AC .VAL BOTH T>>
1576      <OCEMIT MOVE .AC !<OBJ-VAL .ARG1>>
1577      <COND (<TYPE? .ARG2 FIX>
1578             <OCEMIT IDIVI .AC .ARG2>
1579             <OCEMIT SKIPGE O* <NEXT-AC .AC>>
1580             <OCEMIT ADDI <NEXT-AC .AC> .ARG2>)
1581            (ELSE
1582             <OCEMIT IDIV .AC !<OBJ-VAL .ARG2>>
1583             <OCEMIT SKIPGE O* <NEXT-AC .AC>>
1584             <OCEMIT ADD <NEXT-AC .AC> !<OBJ-VAL .ARG2>>)>
1585      <COND (<==? .VAL STACK>
1586             <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
1587             <OCEMIT PUSH TP* <NEXT-AC .AC>>
1588             <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>
1589             <MUNGED-AC .AC T>)
1590            (T
1591             <AC-TYPE <GET-AC .AC> FIX>
1592             <AC-ITEM <GET-AC <NEXT-AC .AC>> .ARG1>
1593             <AC-CODE <GET-AC <NEXT-AC .AC>> VALUE>
1594             <AC-UPDATE <GET-AC <NEXT-AC .AC>> T>)>)
1595     (T
1596      <SET TEM <>>
1597      <COND (<AND <==? .ARG2 .VAL>
1598                  <OR <AND <SET TEM <IN-AC? .ARG2 BOTH>>
1599                           <PROG ()
1600                                 <MUNGED-AC .TEM T>
1601                                 <SET TEM <NEXT-AC .TEM>>
1602                                 T>>
1603                      <AND <SET TEM <IN-AC? .ARG2 VALUE>> <MUNGED-AC .TEM>>>>)>
1604      <COND (<SET AC <IN-AC? .ARG1 BOTH>>
1605             <COND (<WILL-DIE? .ARG1> <DEAD!-MIMOC (.ARG1) T>)
1606                   (<AND <AC-UPDATE <GET-AC <NEXT-AC .AC>>>
1607                         <SET OAC <REALLY-FREE-AC-PAIR>>
1608                         <N==? <NEXT-AC .OAC> .TEM>>
1609                    <COND (.NEG-FIRST
1610                           <OCEMIT MOVN <NEXT-AC .OAC> <NEXT-AC .AC>>
1611                           <SET NEG-FIRST <>>)
1612                          (ELSE
1613                           <OCEMIT MOVE <NEXT-AC .OAC> <NEXT-AC .AC>>)>
1614                    <SET AC .OAC>
1615                    <AC-TYPE <GET-AC .AC> .RESTYP>)>
1616             <PROG ((TY <AC-TYPE <GET-AC .AC>>))
1617                   <FLUSH-AC .AC T>
1618                   <MUNGED-AC .AC T>
1619                   <AC-TYPE <GET-AC .AC> .TY>>
1620             <COND (.NEG-FIRST <OCEMIT MOVNS O* <NEXT-AC .AC>>)>)
1621            (ELSE
1622             <SET AC <ASSIGN-AC .VAL BOTH T>>
1623             <COND (<==? .TEM <NEXT-AC .AC>>
1624                    <OCEMIT MOVE T* .TEM>
1625                    <SET TEM T*>)>
1626             <AC-TYPE <GET-AC .AC> .RESTYP>
1627             <COND (<TYPE? .ARG1 ATOM>
1628                    <OCEMIT <COND (.NEG-FIRST MOVN)
1629                                  (ELSE MOVE)> <NEXT-AC .AC> !<OBJ-VAL .ARG1>>)
1630                   (ELSE <LOAD-AC .ARG1 VALUE <> <> <GET-AC <NEXT-AC .AC>>>)>)>
1631      <COND (<AND <OR <==? .NORM IDIV> <==? .NORM FDVR>>
1632                  <N==? <NEXT-AC <NEXT-AC .AC>> T*>>
1633             <FLUSH-AC <NEXT-AC <NEXT-AC .AC>>>
1634             <MUNGED-AC <NEXT-AC <NEXT-AC .AC>>>)>
1635      <COND (.IMM-OK <OCEMIT .IMMED <NEXT-AC .AC> .ARG2>)
1636            (.TEM <OCEMIT .NORM <NEXT-AC .AC> .TEM>)
1637            (<AND .BO <==? .ARG2 .VAL>>
1638             <OCEMIT .BO <NEXT-AC .AC> !<OBJ-VAL .ARG2>>)
1639            (T <OCEMIT .NORM <NEXT-AC .AC> !<OBJ-VAL .ARG2>>)>
1640      <CLEAN-ACS .VAL>
1641      <AC-CODE <AC-ITEM <GET-AC .AC> .VAL> TYPE>
1642      <AC-UPDATE <GET-AC .AC> T>
1643      <AC-CODE <AC-ITEM <GET-AC <SET AC <NEXT-AC .AC>>> .VAL> VALUE>
1644      <AC-UPDATE <GET-AC .AC> <NOT <AND .BO <==? .ARG2 .VAL> <NOT .TEM>>>>
1645      <COND (<==? .VAL STACK>
1646             <OCEMIT PUSH TP* !<TYPE-WORD .RESTYP>>
1647             <OCEMIT PUSH TP* .AC>
1648             <COND (,WINNING-VICTIM
1649                    <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>)>>
1650
1651 <DEFINE AND!-MIMOC (L "AUX" (ARG1 <1 .L>)
1652                            (ARG2 <2 .L>)
1653                            (VAL <4 .L>)
1654                            NEXTLINE AFTERNEXTLINE
1655                            DIR
1656                            DESTINATION
1657                            TRN (CONST <>)
1658                            TAC TEMP AC (MIML .MIML))
1659   #DECL ((TRN MIML L) LIST (ARG1 ARG2 TEMP) ANY
1660          (VAL DIR DESTINATION) ATOM
1661          (NEXTLINE AFTERNEXTLINE) <OR ATOM LIST FORM>)
1662   <COND (<AND <G=? <LENGTH .MIML> 3>
1663               <OR <AND <==? <PRIMTYPE .ARG1> FIX>
1664                        <TYPE? .ARG2 ATOM>
1665                        <SET TEMP .ARG1>
1666                        <SET ARG1 .ARG2>
1667                        <SET ARG2 <CHTYPE .TEMP FIX>>>
1668                   <AND <TYPE? .ARG1 ATOM>
1669                        <==? <PRIMTYPE .ARG2> FIX>
1670                        <SET ARG2 <CHTYPE .ARG2 FIX>>>
1671                   <AND <TYPE? .ARG1 ATOM>
1672                        <TYPE? .ARG2 ATOM>
1673                        <NOT <WILL-DIE? .ARG1>>
1674                        <NOT <WILL-DIE? .ARG2>>
1675                        <N==? .ARG1 .VAL>
1676                        <N==? .ARG2 .VAL>
1677                        <PROG ()
1678                              <COND (<AND <IN-AC? .ARG2 VALUE>
1679                                          <NOT <IN-AC? .ARG1 VALUE>>>
1680                                     <SET TEMP .ARG1>
1681                                     <SET ARG1 .ARG2>
1682                                     <SET ARG2 .TEMP>)>
1683                              T>>>
1684               <TYPE? <SET NEXTLINE <2 .MIML>> FORM>
1685               <=? <SPNAME <1 .NEXTLINE>> "VEQUAL?">
1686               <OR <AND <==? <2 .NEXTLINE> .VAL>
1687                        <==? <3 .NEXTLINE> 0>>
1688                   <AND <==? <2 .NEXTLINE> 0>
1689                        <==? <3 .NEXTLINE> .VAL>>>
1690               <WILL-DIE? .VAL <REST .MIML>>
1691               <WILL-DIE? .VAL <LAB-CODE-PNTR <FIND-LABEL <5 .NEXTLINE>>>>>
1692          <SET DIR <4 .NEXTLINE>>
1693          <SET DESTINATION <5 .NEXTLINE>>
1694          <COND (<SET TAC <IN-AC? .ARG1 BOTH>>
1695                 <SET AC <NEXT-AC .TAC>>)
1696                (<SET AC <IN-AC? .ARG1 VALUE>>)
1697                (ELSE <SET AC <NEXT-AC <SET TAC <LOAD-AC .ARG1 BOTH>>>>)>
1698          <LABEL-UPDATE-ACS .DESTINATION <>>
1699          <COND (<TYPE? .ARG2 ATOM> <SET CONST T>)
1700                (<L=? .ARG2 *777777*> <SET TRN '(TRNN TRNE)>)
1701                (<==? <CHTYPE <ANDB .ARG2 *777777*> FIX> 0>
1702                 <SET ARG2 <CHTYPE <LSH .ARG2 -18> FIX>>
1703                 <SET TRN '(TLNN TLNE)>)
1704                (ELSE <SET CONST T>)>
1705          <COND (<==? .DIR ->
1706                 <COND (.CONST <OCEMIT TDNE .AC !<OBJ-VAL .ARG2>>)
1707                       (ELSE <OCEMIT <2 .TRN> .AC .ARG2>)>)
1708                (<AND <TYPE? .ARG2 FIX>
1709                      <==? .ARG2 <CHTYPE <ANDB .ARG2 <- .ARG2>> FIX>>>
1710                 ;"Only one bit, can be TRNN..."
1711                 <COND (.CONST <OCEMIT TDNN .AC !<OBJ-VAL .ARG2>>)
1712                       (ELSE <OCEMIT <1 .TRN> .AC .ARG2>)>)
1713                (.CONST
1714                 <OCEMIT TDNE .AC !<OBJ-VAL .ARG2>>
1715                 <OCEMIT CAIA O* O*>)
1716                (ELSE
1717                 <OCEMIT <2 .TRN> .AC .ARG2>
1718                 <OCEMIT CAIA O* O*>)>
1719          <OCEMIT JRST <XJUMP .DESTINATION>>
1720          <SETG NEXT-FLUSH 1>)
1721         (ELSE <ARITH!-MIMOC .L AND ANDI '(TLZ TRZ) ANDB>)>>
1722
1723 <DEFINE FLOAT!-MIMOC (L "AUX" (VAL <3 .L>) NAC)
1724         #DECL ((L) LIST (VAL NAC) ATOM)
1725         <COND (<==? .VAL STACK>
1726                <OCEMIT PUSH TP* !<TYPE-WORD FLOAT>>
1727                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
1728                <OCEMIT FLTR O* !<OBJ-VAL <1 .L>>>
1729                <OCEMIT PUSH TP* O*>
1730                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>)
1731               (T
1732                <SET NAC <ASSIGN-AC <3 .L> BOTH>>
1733                <AC-TYPE <GET-AC .NAC> FLOAT>
1734                <OCEMIT FLTR <NEXT-AC .NAC> !<OBJ-VAL <1 .L>>>)>>
1735
1736 <DEFINE FIX!-MIMOC (L "AUX" (VAL <3 .L>) NAC)
1737         #DECL ((L) LIST (VAL NAC) ATOM)
1738         <COND (<==? .VAL STACK>
1739                <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
1740                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
1741                <OCEMIT FIX O* !<OBJ-VAL <1 .L>>>
1742                <OCEMIT PUSH TP* O*>
1743                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>)
1744               (T
1745                <SET NAC <ASSIGN-AC <3 .L> BOTH>>
1746                <AC-TYPE <GET-AC .NAC> FIX>
1747                <OCEMIT FIX <NEXT-AC .NAC> !<OBJ-VAL <1 .L>>>)>>
1748
1749 <DEFINE LSH!-MIMOC (L
1750                     "OPTIONAL" (INS LSH)
1751                     "AUX" TAC (AC <>) (ARG <1 .L>) (AMT <2 .L>) (VAL <4 .L>)
1752                           FAC NAC AMT-AC)
1753    #DECL ((L) LIST (VAL INS NAC) ATOM (AMT) <OR FIX ATOM> (AC) <OR ATOM FALSE>)
1754    <COND
1755     (<AND <==? .INS LSH> <OR <==? .AMT 18> <==? .AMT -18>>>
1756      <DO-HWRD-INS .ARG .VAL .AMT>)
1757     (ELSE
1758      <COND (<TYPE? .ARG ATOM> <SET AC <NEXT-AC <SET TAC <LOAD-AC .ARG BOTH>>>>)>
1759      <COND (<SET AMT-AC <IN-AC? .AMT BOTH>>
1760             <SETG FIRST-AC <>>
1761             <COND (<OR <==? .AMT .VAL> <WILL-DIE? .AMT>>
1762                    <COND (<OR .AC
1763                               <SET FAC <REALLY-FREE-AC-PAIR>>>
1764                           <MUNGED-AC .AMT-AC T>)
1765                          (ELSE
1766                           <OCEMIT MOVE <SET FAC T*> <NEXT-AC .AMT-AC>>
1767                           <SET AMT-AC T*>)>)>
1768             <COND (<N==? .AMT-AC T*>
1769                    <AC-TIME <GET-AC .AMT-AC> ,AC-STAMP>
1770                    <AC-TIME <GET-AC <NEXT-AC .AMT-AC>> ,AC-STAMP>
1771                    <SET AMT-AC <NEXT-AC .AMT-AC>>)>)>
1772      <COND (<AND <N==? .ARG .VAL>
1773                  <TYPE? .ARG ATOM>
1774                  <NOT <WILL-DIE? .ARG>>
1775                  <NOT <AND <NOT <AC-UPDATE <GET-AC .AC>>>
1776                            <PROG ()
1777                                  <FLUSH-AC .TAC T>
1778                                  <MUNGED-AC .TAC T>
1779                                  1>>>>
1780             <SET NAC <ASSIGN-AC .VAL BOTH T>>
1781             <AC-TYPE <GET-AC .NAC> FIX>
1782             <OCEMIT MOVE <SET NAC <NEXT-AC .NAC>> .AC>)
1783            (.AC
1784             <AC-TIME <GET-AC .TAC> ,AC-STAMP>
1785             <AC-TIME <GET-AC <SET NAC .AC>> ,AC-STAMP>)
1786            (ELSE
1787             <AC-TYPE <GET-AC <SET NAC <ASSIGN-AC .VAL BOTH T>>> FIX>
1788             <SET NAC <NEXT-AC .NAC>>)>
1789      <COND (<TYPE? .AMT FIX>
1790             <COND (<NOT <TYPE? .ARG ATOM>>
1791                    <LOAD-NUM-INTO-AC .ARG .NAC>)>
1792             <OCEMIT .INS .NAC .AMT>)
1793            (.AMT-AC
1794             <COND (<==? .AMT-AC .NAC>
1795                    <OCEMIT MOVE T* .AMT-AC>
1796                    <SET AMT-AC T*>)>
1797             <COND (<NOT <TYPE? .ARG ATOM>>
1798                    <LOAD-NUM-INTO-AC .ARG .NAC>)>
1799             <OCEMIT .INS .NAC (.AMT-AC)>)
1800            (<WILL-DIE? .AMT>
1801             <GET-INTO-ACS .AMT VALUE T*>
1802             <COND (<NOT <TYPE? .ARG ATOM>>
1803                    <LOAD-NUM-INTO-AC .ARG .NAC>)>
1804             <OCEMIT .INS .NAC '(T*)>)
1805            (ELSE
1806             <AC-TIME <GET-AC .NAC> ,AC-STAMP>
1807             <AC-TIME <GET-AC <GETPROP .NAC AC-PAIR>> ,AC-STAMP>
1808             <COND (<NOT <TYPE? .ARG ATOM>>
1809                    <LOAD-NUM-INTO-AC .ARG .NAC>)>
1810             <SET AMT-AC <LOAD-AC .AMT BOTH>>
1811             <OCEMIT .INS .NAC (<NEXT-AC .AMT-AC>)>)>
1812      <COND
1813       (<==? .NAC .AC>
1814        <CLEAN-ACS .VAL>
1815        <AC-CODE <AC-ITEM <AC-TYPE <AC-UPDATE <GET-AC .TAC> T> FIX> .VAL> TYPE>
1816        <AC-CODE
1817         <AC-ITEM <AC-TYPE <AC-UPDATE <GET-AC .AC> T> <>> .VAL>
1818         VALUE>)>
1819      <COND (<==? .VAL STACK>
1820             <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
1821             <OCEMIT PUSH TP* .NAC>
1822             <COND (,WINNING-VICTIM
1823                    <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>)>>
1824
1825 <DEFINE LOAD-NUM-INTO-AC (V AC) #DECL ((V) FIX (AC) ATOM)
1826         <COND (<AND <G=? .V 0> <L=? .V ,MAX-IMMEDIATE>>
1827                <OCEMIT MOVEI .AC .V>)
1828               (<AND <L? .V 0> <L=? <ABS .V> ,MAX-IMMEDIATE>>
1829                <OCEMIT MOVNI .AC <- .V>>)
1830               (<0? <CHTYPE <ANDB .V 262143> FIX>>
1831                <OCEMIT MOVSI .AC <CHTYPE <LSH .V -18> FIX>>)
1832               (ELSE <OCEMIT MOVE .AC !<OBJ-LOC .V 1>>)>>
1833
1834 <DEFINE DO-HWRD-INS (SRC VAL AMT "AUX" AC)
1835         #DECL ((AMT) FIX)
1836         <COND (<==? .VAL STACK>
1837                <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
1838                <COND (,WINNING-VICTIM
1839                       <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
1840                <OCEMIT <COND (<==? .AMT 18> HRLZ)
1841                              (ELSE HLRZ)>
1842                        O* !<OBJ-VAL .SRC>>
1843                <OCEMIT PUSH TP* O*>
1844                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>)
1845               (<==? .SRC .VAL>
1846                <COND (<SET AC <IN-AC? .SRC VALUE>>
1847                       <COND (<==? .AMT 18> <OCEMIT HRLZS O* .AC>)
1848                             (ELSE <OCEMIT HLRZS O* .AC>)>
1849                       <AC-UPDATE <GET-AC .AC> T>)
1850                      (<==? .AMT 18>
1851                       <OCEMIT HRLZS !<OBJ-VAL .SRC>>)
1852                      (ELSE
1853                       <OCEMIT HLRZS !<OBJ-VAL .SRC>>)>)
1854               (ELSE
1855                <SET AC <ASSIGN-AC .VAL BOTH>>
1856                <AC-TYPE <GET-AC .AC> FIX>
1857                <COND (<==? .AMT 18>
1858                       <OCEMIT HRLZ <NEXT-AC .AC> !<OBJ-VAL .SRC>>)
1859                      (ELSE <OCEMIT HLRZ <NEXT-AC .AC> !<OBJ-VAL .SRC>>)>)>>
1860
1861 <DEFINE ROT!-MIMOC (L) #DECL ((L) LIST) <LSH!-MIMOC .L ROT>>
1862
1863 <DEFINE RANDOM!-MIMOC (L)
1864         #DECL ((L) LIST)
1865         <UPDATE-ACS>
1866         <OCEMIT MOVE O1* !<OBJ-VAL <1 .L>>>
1867         <PUSHJ RANDOM <3 .L>>>
1868
1869 ;"Random user RECORD stuff"
1870
1871 <DEFINE TEMPLATE-TABLE!-MIMOC (L)
1872         #DECL ((L) LIST)
1873         <UPDATE-ACS>
1874         <OCEMIT MOVE O1* !<OBJ-VAL <1 .L>>>
1875         <SMASH-AC A1* <2 .L> BOTH>
1876         <PUSHJ TEMPLATE-TABLE>>
1877
1878 <DEFINE IRECORD!-MIMOC (L)
1879         #DECL ((L) LIST)
1880         <UPDATE-ACS>
1881         <OCEMIT MOVE O1* !<OBJ-VAL <1 .L>>>
1882         <OCEMIT MOVE O2* !<OBJ-VAL <2 .L>>>
1883         <OCEMIT MOVE C1* !<OBJ-VAL <3 .L>>>
1884         <PUSHJ IRECORD <5 .L>>>
1885
1886 ;"Random GC stuff"
1887
1888 <DEFINE MARKL!-MIMOC (L "AUX" AC)
1889         #DECL ((L) LIST (AC) ATOM)
1890         <SET AC <LOAD-AC <1 .L> BOTH>>
1891         <MUNGED-AC O*>
1892         <OCEMIT MOVSI O* *200000*>
1893         <OCEMIT <COND (<==? <2 .L> 0> ANDCAM) (T IORM)> O* 1 (<NEXT-AC .AC>)>>
1894
1895 <DEFINE MARK-JOIN (NUM "AUX" NAC)
1896         <MUNGED-AC O*>
1897         <OCEMIT MOVSI O* *200000*>
1898         <COND (<TYPE? .NUM FIX>
1899                <OCEMIT <COND (<0? .NUM> ANDCAM) (T IORM)> O* '(T*)>)
1900               (ELSE
1901                <OCEMIT IORM O* '(T*)>
1902                <COND (<SET NAC <IN-AC? .NUM VALUE>>)
1903                      (ELSE
1904                       <SMASH-AC O* .NUM VALUE>
1905                       <SET NAC O*>)>
1906                <OCEMIT MOVEM .NAC 1 '(T*)>)>>
1907
1908 <DEFINE MARKR!-MIMOC (L "AUX" AC (END <GENLBL "END">))
1909         #DECL ((L) LIST (AC END) ATOM)
1910         <FLUSH-AC T*>
1911         <MUNGED-AC T*>
1912         <SET AC <LOAD-AC <1 .L> BOTH>>
1913         <OCEMIT XMOVEI O* '(TP*)>
1914         <OCEMIT CAMG <NEXT-AC .AC> O*>
1915          <OCEMIT JRST <XJUMP .END>>
1916         <OCEMIT HRRZ T* .AC>
1917         <OCEMIT LSH T* -1>
1918         <OCEMIT ADD T* <NEXT-AC .AC>>
1919         <MARK-JOIN <2 .L>>
1920         <LABEL .END>>
1921
1922 <DEFINE MARKU!-MIMOC (L)
1923         #DECL ((L) LIST)
1924         <MARK!-MIMOC MARKU <1 .L> <2 .L>>>
1925
1926 <DEFINE MARKUS!-MIMOC (L "AUX" AC)
1927         #DECL ((L) LIST (AC) ATOM)
1928         <FLUSH-AC T*>
1929         <MUNGED-AC T*>
1930         <SET AC <LOAD-AC <1 .L> BOTH>>
1931         <OCEMIT MOVEI T* 5 (.AC)>
1932         <OCEMIT ADJBP T* <NEXT-AC .AC>>
1933         <OCEMIT TLZ T* *770000*>
1934         <MARK-JOIN <2 .L>>>
1935
1936 <DEFINE MARKUB!-MIMOC (L "AUX" AC)
1937         #DECL ((L) LIST (AC) ATOM)
1938         <FLUSH-AC T*>
1939         <MUNGED-AC T*>
1940         <SET AC <LOAD-AC <1 .L> BOTH>>
1941         <OCEMIT MOVEI T* 4 (.AC)>
1942         <OCEMIT ADJBP T* <NEXT-AC .AC>>
1943         <OCEMIT TLZ T* *770000*>
1944         <MARK-JOIN <2 .L>>>
1945
1946 <DEFINE MARKUV!-MIMOC (L "AUX" AC)
1947         #DECL ((L) LIST (AC) ATOM)
1948         <FLUSH-AC T*>
1949         <MUNGED-AC T*>
1950         <SET AC <LOAD-AC <1 .L> BOTH>>
1951         <OCEMIT HRRZ T* .AC>
1952         <OCEMIT LSH T* 1>
1953         <OCEMIT ADD T* <NEXT-AC .AC>>
1954         <MARK-JOIN <2 .L>>>
1955
1956 <DEFINE MARKUU!-MIMOC (L "AUX" AC)
1957         #DECL ((L) LIST (AC) ATOM)
1958         <FLUSH-AC T*>
1959         <MUNGED-AC T*>
1960         <SET AC <LOAD-AC <1 .L> BOTH>>
1961         <OCEMIT HRRZ T* .AC>
1962         <OCEMIT ADD T* <NEXT-AC .AC>>
1963         <MARK-JOIN <2 .L>>>
1964
1965 <DEFINE MARK!-MIMOC (NAM OBJ VAL)
1966         #DECL ((NAM) ATOM (OBJ) ANY (VAL) FIX)
1967         <UPDATE-ACS>
1968         <SMASH-AC A1* .OBJ BOTH>
1969         <COND (<0? .VAL> <OCEMIT MOVEI B1* 0>)
1970               (T <OCEMIT MOVSI B1* *200000*>)>
1971         <PUSHJ .NAM>>
1972
1973 <DEFINE MARKL?!-MIMOC (L "AUX" AC NAC)
1974         #DECL ((L) LIST (AC NAC) ATOM)
1975         <SET AC <LOAD-AC <1 .L> VALUE>>
1976         <SET NAC <ASSIGN-AC <3 .L> BOTH T>>
1977         <AC-TYPE <GET-AC .NAC> FIX>
1978         <OCEMIT LDB
1979                 <NEXT-AC .NAC>
1980                 !<OBJ-VAL
1981                    <CHTYPE <ORB <LSH <+ *420100* <2 <CHTYPE <MEMQ .AC ,ACS>
1982                                                             VECTOR>>> 18> 1>
1983                            FIX>>>
1984         <COND-PUSH <3 .L> .NAC>>
1985
1986 <DEFINE MARKR?!-MIMOC (L "AUX" AC NAC (END <GENLBL "END">) RES (REL <>))
1987         #DECL ((L) LIST (AC NAC END) ATOM)
1988         <COND (<==? <LENGTH .L> 4>
1989                <SET RES <4 .L>>
1990                <SET REL T>)
1991               (ELSE
1992                <SET RES <3 .L>>)>
1993         <FLUSH-AC T*>
1994         <MUNGED-AC T*>
1995         <SET AC <LOAD-AC <1 .L> BOTH>>
1996         <SET NAC <ASSIGN-AC .RES BOTH T>>
1997         <OCEMIT MOVEI <NEXT-AC .NAC> 1>
1998         <COND (.REL <OCEMIT MOVE .NAC !<TYPE-WORD FIX>>)>
1999         <OCEMIT XMOVEI O* '(TP*)>
2000         <OCEMIT CAMG <NEXT-AC .AC> O*>
2001          <OCEMIT JRST <XJUMP .END>>
2002         <OCEMIT HRRZ T* .AC>
2003         <OCEMIT LSH T* -1>
2004         <MARK?-JOIN .AC .NAC .REL <> .REL>
2005         <LABEL .END>
2006         <COND-PUSH .RES .NAC>>
2007
2008 <DEFINE MARKU?!-MIMOC (L)
2009         #DECL ((L) LIST)
2010         <UPDATE-ACS>
2011         <SMASH-AC A1* <1 .L> BOTH>
2012         <PUSHJ MARKU? <3 .L>>>
2013
2014 <DEFINE MARKUS?!-MIMOC (L "AUX" AC NAC RES (REL <>))
2015         #DECL ((L) LIST (AC NAC) ATOM)
2016         <COND (<==? <LENGTH .L> 4>
2017                <SET RES <4 .L>>
2018                <SET REL T>)
2019               (ELSE
2020                <SET RES <3 .L>>)>
2021         <FLUSH-AC T*>
2022         <MUNGED-AC T*>
2023         <SET AC <LOAD-AC <1 .L> BOTH>>
2024         <SET NAC <ASSIGN-AC .RES BOTH T>>
2025         <OCEMIT MOVEI T* 5 (.AC)>
2026         <MARK?-JOIN .AC .NAC .REL T>
2027         <COND-PUSH .RES .NAC>>
2028
2029 <DEFINE MARKUB?!-MIMOC (L "AUX" AC NAC RES (REL <>))
2030         #DECL ((L) LIST (AC NAC) ATOM)
2031         <COND (<==? <LENGTH .L> 4>
2032                <SET RES <4 .L>>
2033                <SET REL T>)
2034               (ELSE
2035                <SET RES <3 .L>>)>
2036         <FLUSH-AC T*>
2037         <MUNGED-AC T*>
2038         <SET AC <LOAD-AC <1 .L> BOTH>>
2039         <SET NAC <ASSIGN-AC .RES BOTH T>>
2040         <OCEMIT MOVEI T* 4 (.AC)>
2041         <MARK?-JOIN .AC .NAC .REL T>
2042         <COND-PUSH .RES .NAC>>
2043
2044 <DEFINE MARKUU?!-MIMOC (L "AUX" AC NAC RES (REL <>))
2045         #DECL ((L) LIST (AC NAC) ATOM)
2046         <COND (<==? <LENGTH .L> 4>
2047                <SET RES <4 .L>>
2048                <SET REL T>)
2049               (ELSE
2050                <SET RES <3 .L>>)>
2051         <FLUSH-AC T*>
2052         <MUNGED-AC T*>
2053         <SET AC <LOAD-AC <1 .L> BOTH>>
2054         <SET NAC <ASSIGN-AC .RES BOTH T>>
2055         <OCEMIT HRRZ T* .AC>
2056         <MARK?-JOIN .AC .NAC .REL>
2057         <COND-PUSH .RES .NAC>>
2058
2059 <DEFINE MARKUV?!-MIMOC (L "AUX" AC NAC RES (REL <>))
2060         #DECL ((L) LIST (AC NAC) ATOM)
2061         <COND (<==? <LENGTH .L> 4>
2062                <SET RES <4 .L>>
2063                <SET REL T>)
2064               (ELSE
2065                <SET RES <3 .L>>)>
2066         <FLUSH-AC T*>
2067         <MUNGED-AC T*>
2068         <SET AC <LOAD-AC <1 .L> BOTH>>
2069         <SET NAC <ASSIGN-AC .RES BOTH T>>
2070         <OCEMIT HRRZ T* .AC>
2071         <OCEMIT LSH T* 1>
2072         <MARK?-JOIN .AC .NAC .REL>
2073         <COND-PUSH .RES .NAC>>
2074
2075 <DEFINE COND-PUSH (ITM AC)
2076         #DECL ((ITM AC) ATOM)
2077         <COND (<==? .ITM STACK>
2078                <OCEMIT PUSH TP* .AC>
2079                <OCEMIT PUSH TP* <NEXT-AC .AC>>
2080                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>>
2081
2082 <DEFINE MARK?-JOIN (AC NAC REL "OPT" (DIV <>) (NO-LOAD-TYPE <>)
2083                     "AUX" (L1 <GENLBL "L1">) (L2 <GENLBL "L2">))
2084         #DECL ((AC NAC L1 L2) ATOM)
2085         <COND (.DIV
2086                <OCEMIT ADJBP T* <NEXT-AC .AC>>
2087                <OCEMIT TLZ T* *770000*>)
2088               (ELSE
2089                <OCEMIT ADD T* <NEXT-AC .AC>>)>
2090         <COND (<NOT .REL>
2091                <AC-TYPE <GET-AC .NAC> FIX>)>
2092         <OCEMIT LDB <NEXT-AC .NAC> !<OBJ-VAL ,LDB-PAREN-T>>
2093         <COND (.REL
2094                <OCEMIT JUMPE <NEXT-AC .NAC> <XJUMP .L1>>
2095                <OCEMIT MOVE .NAC .AC>
2096                <OCEMIT MOVE <NEXT-AC .NAC> 1 '(T*)>
2097                <OCEMIT JRST <XJUMP .L2>>
2098                <LABEL .L1>
2099                <COND (<NOT .NO-LOAD-TYPE>
2100                       <OCEMIT MOVE .NAC !<TYPE-WORD FIX>>)>
2101                <OCEMIT MOVEI <NEXT-AC .NAC> 0>
2102                <LABEL .L2>)>>
2103
2104
2105
2106 <SETG LDB-PAREN-T -32193642496>
2107
2108 <MANIFEST LDB-PAREN-T>
2109
2110 <DEFINE SWNEXT!-MIMOC (L)
2111         #DECL ((L) LIST)
2112         <UPDATE-ACS>
2113         <OCEMIT DMOVE O1* !<OBJ-TYP <1 .L>>>
2114         <OCEMIT MOVE A1* !<OBJ-VAL <2 .L>>>
2115         <PUSHJ SWNEXT <4 .L>>>
2116
2117 <DEFINE NEXTS!-MIMOC (L)
2118         #DECL ((L) LIST)
2119         <UPDATE-ACS>
2120         <OCEMIT MOVE O1* !<OBJ-VAL <1 .L>>>
2121         <PUSHJ NEXTS <3 .L>>>
2122
2123 <DEFINE CONTENTS!-MIMOC (L "AUX" AC)
2124         #DECL ((L) LIST (AC) ATOM)
2125         <SMASH-AC T* <1 .L> VALUE>
2126         <SET AC <ASSIGN-AC <3 .L> BOTH T>>
2127         <OCEMIT DMOVE .AC '(T*)>
2128         <OCEMIT TLZE .AC *40*>
2129         <OCEMIT XMOVEI <NEXT-AC .AC> 1 '(T*)>
2130         <COND (<==? <3 .L> STACK>
2131                <OCEMIT PUSH TP* .AC>
2132                <OCEMIT PUSH TP* <NEXT-AC .AC>>
2133                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>>
2134
2135 <DEFINE PUTS!-MIMOC (L "AUX" AC)
2136         #DECL ((L) LIST (AC) ATOM)
2137         <SET AC <LOAD-AC <2 .L> BOTH>>
2138         <SMASH-AC T* <1 .L> VALUE>
2139         <FLUSH-AC O*>
2140         <MUNGED-AC O*>
2141         <OCEMIT MOVE O* '(T*)>
2142         <OCEMIT TLNN O* *40*>
2143         <OCEMIT DMOVEM .AC '(T*)>>
2144
2145 <DEFINE ALLOCL!-MIMOC (L "AUX" (AC <ASSIGN-AC <3 .L> BOTH T>))
2146         #DECL ((L) LIST (AC) ATOM)
2147         <OCEMIT MOVE .AC !<TYPE-WORD LIST>>
2148         <OCEMIT MOVE <NEXT-AC .AC> !<OBJ-VAL <1 .L>>>
2149         <COND (<==? <3 .L> STACK>
2150                <OCEMIT PUSH TP* .AC>
2151                <OCEMIT PUSH TP* <NEXT-AC .AC>>
2152                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>>
2153
2154 <DEFINE ALLOCUV!-MIMOC (L)
2155         #DECL ((L) LIST)
2156         <ALLOC-JOIN <1 .L> <2 .L> <4 .L> VECTOR>>
2157
2158 <DEFINE ALLOCUU!-MIMOC (L)
2159         #DECL ((L) LIST)
2160         <ALLOC-JOIN <1 .L> <2 .L> <4 .L> UVECTOR>>
2161
2162 <DEFINE ALLOCUS!-MIMOC (L "OPTIONAL" (BYTES? <>) "AUX" AC)
2163         #DECL ((L) LIST)
2164         <SET AC <ASSIGN-AC <4 .L> BOTH T>>
2165         <OCEMIT MOVE <NEXT-AC .AC> !<OBJ-VAL <1 .L>>>
2166         <OCEMIT ADD <NEXT-AC .AC> !<OBJ-VAL <COND (.BYTES? *577777777777*)
2167                                                   (T *657777777777*)>>>
2168         <OCEMIT MOVE .AC !<OBJ-TYP <2 .L>>>
2169         <COND (<==? <4 .L> STACK>
2170                <OCEMIT PUSH TP* .AC>
2171                <OCEMIT PUSH TP* <NEXT-AC .AC>>
2172                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>>
2173
2174 <DEFINE ALLOCUB!-MIMOC (L)
2175   <ALLOCUS!-MIMOC .L T>>
2176
2177 <DEFINE ALLOCR!-MIMOC (L) #DECL ((L) LIST)
2178         <ALLOC-JOIN <1 .L> <2 .L> <4 .L> RECORD>>
2179
2180 <DEFINE ALLOC-JOIN (WHERE OLD NEW TYP "AUX" AC)
2181         <COND (<==? .NEW STACK>
2182                <OCEMIT PUSH TP* !<OBJ-TYP .OLD>>
2183                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
2184                <OCEMIT PUSH TP* !<OBJ-VAL .WHERE>>
2185                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>)
2186               (ELSE
2187                <SET AC <ASSIGN-AC .NEW BOTH T>>
2188                <OCEMIT MOVE .AC !<OBJ-TYP .OLD>>
2189                <OCEMIT MOVE <NEXT-AC .AC> !<OBJ-VAL .WHERE>>)>>
2190
2191 <DEFINE BLT!-MIMOC (L)
2192         #DECL ((L) LIST)
2193         <FLUSH-AC T*>
2194         <MUNGED-AC T*>
2195         <OCEMIT MOVE O1* !<OBJ-VAL <1 .L>>>
2196         <OCEMIT MOVE O2* !<OBJ-VAL <2 .L>>>
2197         <OCEMIT MOVE T* !<OBJ-VAL <3 .L>>>
2198         <OCEMIT XBLT T* !<OBJ-VAL *020000000000*>>>
2199
2200 <DEFINE RELL!-MIMOC (L)
2201         #DECL ((L) LIST)
2202         <UPDATE-ACS>
2203         <SMASH-AC A1* <1 .L> BOTH>
2204         <PUSHJ RELL>>
2205
2206 <DEFINE RELU!-MIMOC (L)
2207         #DECL ((L) LIST)
2208         <UPDATE-ACS>
2209         <SMASH-AC A1* <1 .L> BOTH>
2210         <PUSHJ RELU>>
2211
2212 <DEFINE RELR!-MIMOC (L)
2213         #DECL ((L) LIST)
2214         <UPDATE-ACS>
2215         <SMASH-AC A1* <1 .L> BOTH>
2216         <PUSHJ RELR>>
2217
2218 <DEFINE LOOP!-MIMOC (L "AUX" VARS (LBNM <2 .MIML>) LB LFS)
2219     #DECL ((L VARS MIML) LIST (LB) LAB (LFS) <OR FALSE LABSTATE>)
2220      <COND
2221       (<TYPE? .LBNM ATOM>
2222        <SET LB ,.LBNM>
2223        <SET LFS <LAB-FINAL-STATE .LB>>
2224        <SETG NEXT-LOOP T>
2225        <SETG LOOPTAGS (<2 .MIML> !,LOOPTAGS)>
2226        <COND
2227         (<AND <GASSIGNED? DO-LOOPS> ,DO-LOOPS>
2228          <SET VARS <MAPF ,LIST 1 .L>>
2229          <MAPF <>
2230                <FUNCTION (LL "AUX" (ITM <1 .LL>) NEED)
2231                  #DECL ((LL) LIST)
2232                  <COND
2233                   (<MEMQ VALUE <SET LL <REST .LL>>>
2234                    <COND (<NOT <EMPTY? <REST .LL>>> <SET NEED BOTH>)
2235                          (ELSE <SET NEED VALUE>)>)
2236                   (ELSE <SET NEED TYPE>)>
2237                  <COND
2238                   (<NOT <IN-AC? .ITM .NEED>>
2239                    <COND
2240                     (<NOT .LFS>
2241                      <REPEAT ((ACS <REST ,AC-TABLE>) A1 A2 IT)
2242                              #DECL ((ACS) VECTOR (A1 A2) AC)
2243                              <COND (<==? <AC-NAME <SET A1 <1 .ACS>>> X*>
2244                                     <RETURN>)>
2245                              <COND
2246                               (<AND <OR <==? .NEED VALUE>
2247                                         <NOT <SET IT <AC-ITEM .A1>>>
2248                                         <TYPE? .IT LOSE>
2249                                         <AND <NOT <AC-UPDATE .A1>>
2250                                              <NOT <MEMQ .IT .VARS>>>>
2251                                     <OR <==? .NEED TYPE>
2252                                         <NOT <SET IT <AC-ITEM <SET A2
2253                                                                    <2 .ACS>>>>>
2254                                         <TYPE? .IT LOSE>
2255                                         <AND <NOT <AC-UPDATE .A2>>
2256                                              <NOT <MEMQ .IT .VARS>>>>>
2257                                <COND (<==? .NEED VALUE>
2258                                       <LOAD-AC .ITM VALUE <> <> .A2>)
2259                                      (<==? .NEED TYPE>
2260                                       <LOAD-AC .ITM TYPE <> <> .A1>)
2261                                      (ELSE
2262                                       <LOAD-AC .ITM BOTH <> <> .A1 .A2>)>
2263                                <RETURN>)>
2264                              <SET ACS <REST .ACS 2>>>)
2265                     (ELSE
2266                      <REPEAT ((V <CHTYPE .LFS VECTOR>) ACS1 ACS2 ONE)
2267                        #DECL ((V) VECTOR (ACS1 ACS2) ACSTATE)
2268                        <COND (<EMPTY? .V> <RETURN>)>
2269                        <COND
2270                         (<OR <SET ONE
2271                                   <==? <LATM <ACS-LOCAL <SET ACS1 <1 .V>>>>
2272                                        .ITM>>
2273                              <==? <LATM <ACS-LOCAL <SET ACS2 <2 .V>>>> .ITM>>
2274                          <COND (.ONE
2275                                 <LOAD-AC .ITM
2276                                          BOTH
2277                                          <COND (<==? <LATM <ACS-LOCAL
2278                                                             <SET ACS2 <2 .V>>>>
2279                                                      .ITM>
2280                                                 <OR <NOT <ACS-STORED .ACS2>>
2281                                                     <NOT <ACS-STORED .ACS1>>>)
2282                                                (ELSE
2283                                                 <NOT <ACS-STORED .ACS1>>)>
2284                                          <> <ACS-AC .ACS1> <ACS-AC .ACS2>>)
2285                                (ELSE
2286                                 <LOAD-AC .ITM
2287                                          VALUE
2288                                          <NOT <ACS-STORED .ACS2>>
2289                                          <> <ACS-AC .ACS2>>)>
2290                          <RETURN>)>
2291                              <SET V <REST .V 2>>>)>)>>
2292                .L>)>)>>
2293
2294 <DEFINE INTGO!-MIMOC (L) T>
2295
2296 <DEFINE SAVE!-MIMOC (L)
2297         #DECL ((L) LIST)
2298         <UPDATE-ACS>
2299         <SMASH-AC A1* <1 .L> VALUE>
2300         <SMASH-AC A2* <2 .L> VALUE>
2301         <SMASH-AC B1* <3 .L> VALUE>
2302         <PUSHJ SAVE <5 .L>>>
2303
2304 <DEFINE RESTORE!-MIMOC (L)
2305         #DECL ((L) LIST)
2306         <SMASH-AC A1* <1 .L> VALUE>
2307         <PUSHJ RESTORE <3 .L>>>
2308
2309 <DEFINE QUIT!-MIMOC (L)
2310         <UPDATE-ACS>
2311         <COND (<NOT <EMPTY? .L>>
2312                ; "Stuff the return value into B, with authentication in A"
2313                <SMASH-AC A2* <1 .L> VALUE>
2314                <SMASH-AC A1* *777777000003* VALUE>)>
2315         <PUSHJ QUIT>>
2316
2317 <DEFINE SETSIZ!-MIMOC (L)
2318         #DECL ((L) LIST)
2319         <UPDATE-ACS>
2320         <SMASH-AC A1* <1 .L> BOTH>
2321         <PUSHJ SETSIZ <3 .L>>>
2322
2323 <DEFINE RNTIME!-MIMOC (L)
2324         #DECL ((L) LIST)
2325         <UPDATE-ACS>
2326         <COND (<EMPTY? .L>
2327                <PUSHJ RNTIME>)
2328               (T
2329                <PUSHJ RNTIME <2 .L>>)>>
2330
2331 "Instructions for seedup of NTH,REST,EMPTY? and MONAD? of unknown type"
2332
2333 <DEFINE NTH1!-MIMOC (L)
2334         <NEW-FUNNY-CALL *154* .L>
2335         <ALTER-AC A1* <3 .L>>
2336         <PUSHJ-VAL <3 .L>>>
2337
2338 <DEFINE REST1!-MIMOC (L)
2339         <NEW-FUNNY-CALL *155* .L>
2340         <ALTER-AC A1* <3 .L>>
2341         <PUSHJ-VAL <3 .L>>>
2342
2343 <DEFINE EMPTY?!-MIMOC (L)
2344         <FUNNY-PRED *153* .L>>
2345
2346 <DEFINE MONAD?!-MIMOC (L)
2347         <FUNNY-PRED *156* .L>>
2348
2349 <DEFINE FUNNY-PRED (LOC L "AUX" (FLAG <2 .L>) (TAG <3 .L>))
2350         #DECL ((L) LIST)
2351         <NEW-FUNNY-CALL .LOC .L .TAG>
2352         <COND (<==? .FLAG +> <OCEMIT CAIA O* O*>)>
2353         <OCEMIT JRST <XJUMP .TAG>>>
2354
2355 <DEFINE NEW-FUNNY-CALL (LOC L "OPT" (TAG <>) "AUX" AC)
2356         #DECL ((L) LIST)
2357         <COND (<N==? <SET AC <IN-AC? <1 .L> BOTH>> A1*>
2358                <FLUSH-AC A1* T>
2359                <MUNGED-AC A1* T>
2360                <COND (.AC
2361                       <OCEMIT DMOVE A1* .AC>
2362                       <MUNGED-AC .AC T>
2363                       <ALTER-AC A1* <1 .L>>)
2364                      (ELSE
2365                       <SMASH-AC A1* <1 .L> BOTH>)>)>
2366         <COND (.TAG <LABEL-UPDATE-ACS .TAG <>>)
2367               (ELSE
2368                <COND (<N==? <1 .L> <3 .L>>
2369                       <CLEAN-ACS <3 .L>>
2370                       <COND (<NOT <WILL-DIE? <1 .L>>>
2371                              <FLUSH-AC A1* T>)>)>
2372                <MUNGED-AC A1* T>)>
2373         <OCEMIT JSP T* @ .LOC>>
2374
2375 <DEFINE LEGAL?!-MIMOC (L)
2376         #DECL ((L) LIST)
2377         <FLUSH-AC A1* T>
2378         <SMASH-AC A1* <1 .L> BOTH>
2379         <PUSHJ LEGAL? <3 .L>>>
2380
2381
2382 <DEFINE SETZONE!-MIMOC (L)
2383         #DECL ((L) LIST)
2384         <SMASH-AC A1* <1 .L> BOTH>
2385         <COND (<==? <LENGTH .L> 3>
2386                <PUSHJ SETZONE <3 .L>>)
2387               (ELSE
2388                <PUSHJ SETZONE>)>>
2389
2390 <DEFINE TYPEW!-MIMOC (L) #DECL ((L) LIST)
2391         <OCEMIT MOVE O1* !<OBJ-VAL <1 .L>>>
2392         <OCEMIT MOVE O2* !<OBJ-VAL <2 .L>>>
2393         <PUSHJ TYPEW <4 .L>>>
2394
2395 <DEFINE TYPEWC!-MIMOC (L "AUX" AC) #DECL ((L) LIST)
2396         <SET AC <ASSIGN-AC <3 .L> BOTH>>
2397         <OCEMIT HLRZ <NEXT-AC .AC> !<OBJ-VAL <1 .L>>>
2398         <AC-TYPE <GET-AC .AC> TYPE-C>>
2399
2400
2401 <DEFINE FATAL!-MIMOC (L) #DECL ((L) LIST)
2402         <SMASH-AC A1* <1 .L> BOTH>
2403         <COND (<EMPTY? <REST .L>> <PUSHJ FATAL>)
2404               (ELSE <PUSHJ FATAL <3 .L>>)>>
2405
2406
2407
2408 <DEFINE GETBITS!-MIMOC (L
2409                         "AUX" (WD <1 .L>) (WL <2 .L>) (SHL <3 .L>) (DST <5 .L>)
2410                               (TAC? <IN-AC? .WD BOTH>) AN BP
2411                               (AC? <IN-AC? .WD VALUE>) (OL <>) AC (W 0) (SH 0)
2412                               (IX <>) MSK)
2413    #DECL ((L) LIST (OL) <OR FALSE LIST>)
2414    <COND (<TYPE? .WL FIX> <SET W .WL>)>
2415    <COND (<TYPE? .SHL FIX> <SET SH .SHL>)>
2416    <COND (<TYPE? .WD ATOM> <SET OL <OBJ-LOC .WD 1>>)>
2417    <SET BP <CHTYPE <ORB <LSH .SH 30> <LSH .W 24>> FIX>>
2418    <COND (.AC? <SET AN <2 <CHTYPE <MEMQ .AC? ,ACS> VECTOR>>>)>
2419    <COND (.AC? <SET BP <CHTYPE <ORB .BP .AN> CONSTANT>>)
2420          (.OL
2421           <SET BP
2422                <CHTYPE (<2 .OL>
2423                         <+ <CHTYPE <LSH <2 <MEMQ <1 <CHTYPE <3 .OL> LIST>>
2424                                                  ,ACS>> 18> FIX>
2425                            <CHTYPE <1 .OL> FIX>
2426                            .BP>)
2427                        CONST-W-LOCAL>>)>
2428    <COND
2429     (<AND <TYPE? .WL FIX> <TYPE? .SHL FIX>>
2430      <SET AC <ASSIGN-AC .DST BOTH T>>
2431      <CONST-LOC .BP VALUE>
2432      <OCEMIT LDB <NEXT-AC .AC> !<OBJ-VAL .BP>>
2433      <AC-TYPE <GET-AC .AC> FIX>)
2434     (<TYPE? .WL FIX>
2435      <COND (<NOT <AND .AC? <OR <==? .DST .WD>
2436                                <AND <WILL-DIE? .WD>
2437                                     <PROG () <DEAD!-MIMOC (.WD) T> 1>>>>>
2438             <SET AC
2439                  <ASSIGN-AC <COND (<AND <==? .SHL .DST> <IN-AC? .SHL VALUE>>
2440                                    .WD)
2441                                   (ELSE .DST)>
2442                             BOTH
2443                             T>>
2444             <AC-TYPE <GET-AC .AC> FIX>
2445             <SET AC <NEXT-AC .AC>>
2446             <OCEMIT MOVE .AC !<OBJ-VAL .WD>>)
2447            (.TAC?
2448             <AC-TYPE <GET-AC .TAC?> FIX>
2449             <SET AC .AC?>
2450             <ALTER-AC .TAC? .DST>)
2451            (ELSE
2452             <SET AC <ASSIGN-AC .DST BOTH T>>
2453             <AC-TYPE <GET-AC .AC> FIX>
2454             <OCEMIT MOVE <SET AC <NEXT-AC .AC>> .AC?>)>
2455      <FLUSH-AC T*>
2456      <MUNGED-AC T*>
2457      <OCEMIT MOVN T* !<OBJ-VAL .SHL>>
2458      <OCEMIT LSH
2459              .AC
2460              '(T*)>
2461      <COND (<L=? <SET W <CHTYPE <XORB <LSH -1 .W> -1> FIX>> 262143>
2462             <OCEMIT ANDI .AC .W>)
2463            (ELSE <OCEMIT TLZ .AC <CHTYPE <LSH <XORB .W -1> -18> FIX>>)>
2464      <COND (<==? .DST .SHL>
2465             <CLEAN-ACS .DST>
2466             <ALTER-AC <GETPROP .AC AC-PAIR> .DST>
2467             <SETG ACA-AC <SETG ACA-BOTH <SETG ACA-ITEM <>>>>
2468             <AC-TYPE <GET-AC <GETPROP .AC AC-PAIR>> FIX>)>)
2469     (<TYPE? .SHL FIX>
2470      <COND (<AND .TAC? <OR <==? .WD .DST> <WILL-DIE? .WD>>> <SET AC O*>)
2471            (ELSE
2472             <COND (<==? .WL .DST>
2473                    <COND (<SET AC <IN-AC? .WL BOTH>>
2474                           <SET IX <NEXT-AC .AC>>
2475                           <MUNGED-AC .AC T>
2476                           <AC-TIME <GET-AC .AC> ,AC-STAMP>
2477                           <AC-TIME <GET-AC <NEXT-AC .AC>> ,AC-STAMP>)
2478                          (<SET AC <IN-AC? .WL VALUE>>
2479                           <SET IX .AC>
2480                           <AC-TIME <GET-AC .AC> ,AC-STAMP>
2481                           <MUNGED-AC .AC>)>)>
2482             <AC-TYPE <GET-AC <SET AC <ASSIGN-AC .DST BOTH T>>> FIX>
2483             <SET AC <NEXT-AC .AC>>)>
2484      <SET MSK <CHTYPE <LSH -1 .SH> FIX>>
2485      <COND (<==? <CHTYPE <ANDB .MSK 262143> FIX> 0>
2486             <OCEMIT MOVSI .AC <CHTYPE <LSH .MSK -18> FIX>>)
2487            (ELSE <OCEMIT HRROI .AC <CHTYPE <ANDB .MSK 262143> FIX>>)>
2488      <OCEMIT LSH
2489              .AC
2490              !<COND (.IX ((.IX)))
2491                     (<AND <N==? .WL .DST> <SET IX <IN-AC? .WL VALUE>>>
2492                      ((.IX)))
2493                     (ELSE (@ !<OBJ-VAL .WL>))>>
2494      <COND
2495       (<==? .AC O*>
2496        <OCEMIT ANDCA .AC? O*>
2497        <OCEMIT LSH .AC? <- .SH>>
2498        <CLEAN-ACS .DST>
2499        <AC-UPDATE <AC-ITEM <AC-CODE <AC-TYPE <GET-AC .TAC?> FIX> TYPE> .DST> T>
2500        <AC-CODE <AC-TYPE <AC-ITEM <AC-UPDATE <GET-AC <SET AC .AC?>> T> .DST>
2501                          <>>
2502                 VALUE>)
2503       (ELSE
2504        <OCEMIT ANDCA .AC !<COND (.AC? (.AC?)) (ELSE <OBJ-VAL .WD>)>>
2505        <OCEMIT LSH .AC <- .SH>>)>)
2506     (ELSE
2507      <COND (.AC? <OCEMIT MOVEI O* .AC?>)
2508            (ELSE <CONST-LOC .BP VALUE> <OCEMIT MOVE O* !<OBJ-VAL .BP>>)>
2509      <OCEMIT DPB
2510              <COND (<IN-AC? .SHL VALUE>) (ELSE <NEXT-AC <LOAD-AC .SHL BOTH>>)>
2511              !<OBJ-VAL <SET BP <CHTYPE 32312918016 CONSTANT>>>>
2512      <CONST-LOC .BP VALUE>
2513      <OCEMIT DPB
2514              <COND (<IN-AC? .WL VALUE>) (ELSE <NEXT-AC <LOAD-AC .WL BOTH>>)>
2515              !<OBJ-VAL <SET BP <CHTYPE 25870467072 CONSTANT>>>>
2516      <CONST-LOC .BP VALUE>
2517      <SET AC <ASSIGN-AC .DST BOTH T>>
2518      <OCEMIT LDB <NEXT-AC .AC> O*>
2519      <AC-TYPE <GET-AC .AC> FIX>)>
2520    <COND (<==? .DST STACK>
2521           <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
2522           <OCEMIT PUSH TP* <NEXT-AC .AC>>
2523           <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>>
2524
2525 <DEFINE PUTBITS!-MIMOC (L "AUX" (WL <2 .L>) (SHL <3 .L>) (NEW <4 .L>) (OLD <1 .L>)
2526                                 AC? TAC? NAC (DST <6 .L>) (FLIP <>))
2527         #DECL ((L) LIST)
2528         <COND (<AND <==? .WL 18> <OR <==? .SHL 0> <==? .SHL 18>>>
2529                <COND (<OR <==? .OLD 0>
2530                           <==? .OLD -1>
2531                           <AND <==? .SHL 0>
2532                                <OR <AND <NOT <IN-AC? .OLD VALUE>>
2533                                         <IN-AC? .NEW VALUE>>
2534                                    <==? .NEW .DST>>>>
2535                       <SET FLIP T>
2536                       <SET NEW .OLD>
2537                       <SET OLD <4 .L>>)>
2538                <COND (<OR <AND <SET TAC? <IN-AC? .OLD BOTH>>
2539                                <SET AC? <NEXT-AC .TAC?>>>
2540                           <AND <SET AC? <IN-AC? .OLD VALUE>>
2541                                <SET TAC? <GETPROP .AC? AC-PAIR>>>
2542                           <AND <N==? .OLD .DST>
2543                                <N==? .NEW 0>
2544                                <N==? .NEW -1>
2545                                <SET AC? <NEXT-AC <SET TAC? <LOAD-AC .OLD BOTH>>>>>>
2546                       <COND (<N==? .OLD .DST>
2547                              <COND (<WILL-DIE? .OLD> <DEAD!-MIMOC (.OLD) T>)>
2548                              <COND (.TAC?
2549                                     <FLUSH-AC .TAC? T>
2550                                     <MUNGED-AC .TAC? T>)
2551                                    (ELSE
2552                                     <FLUSH-AC .AC?>
2553                                     <MUNGED-AC .AC?>)>)>
2554                       <SETG FIRST-AC <>>
2555                       <AC-TIME <GET-AC .TAC?> <SETG AC-STAMP <+ ,AC-STAMP 1>>>
2556                       <AC-UPDATE <AC-TIME <GET-AC .AC?>
2557                                           <SETG AC-STAMP <+ ,AC-STAMP 1>>> T>)>
2558                <COND (<AND <NOT .AC?>
2559                            <NOT <SET NAC <IN-AC? .NEW VALUE>>>
2560                            <N==? .NEW 0>
2561                            <N==? .NEW -1>>
2562                       <COND (<AND <TYPE? .NEW ATOM> <NOT <WILL-DIE? .NEW>>>
2563                              <SET NAC <NEXT-AC <LOAD-AC .NEW BOTH>>>)
2564                             (ELSE
2565                              <GET-INTO-ACS .NEW VALUE <SET NAC T*>>)>)>
2566                <COND (<AND .FLIP <N==? .SHL 0>>
2567                       <COND (<==? .DST STACK>
2568                              <COND (.AC?
2569                                     <OCEMIT <COND (<==? .NEW 0> HRLZ)
2570                                                   (ELSE HRLO)>
2571                                             O*
2572                                             .AC?>)
2573                                    (ELSE
2574                                     <OCEMIT <COND (<==? .NEW 0> HRLZ)
2575                                                   (ELSE HRLO)>
2576                                             O*
2577                                             !<OBJ-VAL .OLD>>)>
2578                              <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
2579                              <OCEMIT PUSH TP* O*>
2580                              <COND (,WINNING-VICTIM
2581                                     <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
2582                             (.AC?
2583                              <COND (<==? .NEW 0> <OCEMIT HRLZS O* .AC?>)
2584                                    (ELSE <OCEMIT HRLOS O* .AC?>)>
2585                              <COND (<N==? .DST .OLD>
2586                                     <CLEAN-ACS .DST>
2587                                     <ALTER-AC .TAC? .DST>
2588                                     <AC-TYPE <GET-AC .TAC?> FIX>)>)
2589                             (<N==? .DST .OLD>
2590                              <SET AC? <ASSIGN-AC .DST BOTH>>
2591                              <COND (<==? .NEW 0>
2592                                     <OCEMIT HRLZ <NEXT-AC .AC?> !<OBJ-VAL .OLD>>)
2593                                    (ELSE
2594                                     <OCEMIT HRLO <NEXT-AC .AC?> !<OBJ-VAL .OLD>>)>
2595                              <AC-TYPE <GET-AC .AC?> FIX>)
2596                             (<==? .NEW 0> <OCEMIT HRLZS O* !<OBJ-VAL .OLD>>)
2597                             (ELSE <OCEMIT HRLOS O* !<OBJ-VAL .OLD>>)>)
2598                      (.AC?
2599                       <OCEMIT <COND (<TYPE? .NEW ATOM>
2600                                      <COND (<==? .SHL 0>
2601                                             <COND (.FLIP HLL) (ELSE HRR)>)
2602                                            (ELSE HRL)>)
2603                                     (<==? .SHL 0>
2604                                      <COND (.FLIP HRLI) (ELS HRRI)>)
2605                                     (ELSE HRLI)>
2606                               .AC?
2607                               !<COND (<TYPE? .NEW ATOM> <OBJ-VAL .NEW>)
2608                                      (.FLIP (<LSH .NEW -18>))
2609                                      (ELSE (<CHTYPE <ANDB .NEW *777777*> FIX>))>>
2610                       <COND (<==? .DST STACK>
2611                              <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
2612                              <OCEMIT PUSH TP* .AC?>
2613                              <COND (,WINNING-VICTIM
2614                                     <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
2615                             (<N==? .DST .OLD>
2616                              <CLEAN-ACS .DST>
2617                              <ALTER-AC .TAC? .DST>
2618                              <AC-TYPE <GET-AC .TAC?> FIX>)>)
2619                      (<NOT .NAC>
2620                       <COND (<==? .DST .OLD>
2621                              <OCEMIT <COND (<==? .NEW -1>
2622                                             <COND (<==? .SHL 0>
2623                                                    <COND (.FLIP HRROS)
2624                                                          (ELSE HLLOS)>)
2625                                                   (.FLIP HRLOS)
2626                                                   (ELSE HRROS)>)
2627                                            (<==? .SHL 0>
2628                                             <COND (.FLIP HRRZS) (ELSE HLLZS)>)
2629                                            (.FLIP HRLZS)
2630                                            (ELSE HRRZS)> O* !<OBJ-VAL .OLD>>)
2631                             (ELSE
2632                              <COND (<N==? .DST STACK>
2633                                     <SET NAC <ASSIGN-AC .DST BOTH>>)>
2634                              <OCEMIT <COND (<==? .NEW -1>
2635                                             <COND (<==? .SHL 0>
2636                                                    <COND (.FLIP HRRO)
2637                                                          (ELSE HLLO)>)
2638                                                   (.FLIP HRLO)
2639                                                   (ELSE HRRO)>)
2640                                            (<==? .SHL 0>
2641                                             <COND (.FLIP HRRZ) (ELSE HLLZ)>)
2642                                            (.FLIP HRLZ)
2643                                            (ELSE HRRZ)>
2644                                      <COND (<==? .DST STACK> O*)
2645                                            (ELSE <NEXT-AC .NAC>)>
2646                                      !<OBJ-VAL .OLD>>
2647                              <COND(<==? .DST STACK>
2648                                    <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
2649                                    <OCEMIT PUSH TP* O*>
2650                                    <COND (,WINNING-VICTIM
2651                                           <SETG STACK-DEPTH
2652                                                 <+ ,STACK-DEPTH 2>>)>)
2653                                    (ELSE
2654                                     <AC-TYPE <GET-AC .NAC> FIX>)>)>)
2655                      (<==? .DST STACK>
2656                       <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
2657                       <OCEMIT PUSH TP* !<OBJ-VAL .OLD>>
2658                       <OCEMIT <COND (<==? .SHL 0>
2659                                      <COND (.FLIP HLLM) (ELSE HRRM)>)
2660                                     (ELSE HRLM)>
2661                               .NAC
2662                               '(TP*)>
2663                       <COND (,WINNING-VICTIM
2664                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
2665                      (ELSE
2666                       <OCEMIT <COND (<==? .SHL 0>
2667                                      <COND (.FLIP HLLM) (ELSE HRRM)>)
2668                                     (ELSE HRLM)>
2669                               .NAC
2670                               !<OBJ-VAL .OLD>>)>
2671                <COND (<AND .TAC?
2672                            <N==? .OLD .DST>
2673                            <N==? .DST STACK>>
2674                       <CLEAN-ACS .DST>
2675                       <ALTER-AC .TAC? .DST>)>)
2676               (ELSE <RPUTBITS .L>)>>
2677
2678 <DEFINE RPUTBITS (L "AUX" (WD <1 .L>) (WL <2 .L>) (SHL <3 .L>) (NEW <4 .L>)
2679                           (DST <6 .L>) (TAC? <>) (AC? <>) AN BP (OL <>) (AC <>)
2680                           (W 0) (SH 0) IX (VT <>) (WAS-TYPED <>)
2681                           (DST-IN-O1 <>))
2682         #DECL ((L) LIST (OL) <OR FALSE LIST>)
2683         <COND (<TYPE? .WL FIX> <SET W .WL>)>
2684         <COND (<TYPE? .SHL FIX> <SET SH .SHL>)>
2685         <COND (<TYPE? .WD ATOM>
2686                <SET OL <OBJ-LOC .WD 1>>
2687                <SET TAC? <IN-AC? .WD BOTH>>
2688                <SET AC? <IN-AC? .WD VALUE>>
2689                <SET VT <VAR-TYPED? .WD>>)
2690               (<N==? <PRIMTYPE .WD> FIX>
2691                <MIMOCERR BAD-ARG-TO-PUTBITS .WD>)
2692               (<==? .DST STACK>
2693                <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
2694                <OCEMIT PUSH TP* !<OBJ-VAL <CHTYPE .WD CONSTANT>>>
2695                <CONST-LOC <CHTYPE .WD CONSTANT> VALUE>
2696                <COND (,WINNING-VICTIM
2697                       <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
2698               (ELSE
2699                <COND (<OR <==? .DST .NEW> <==? .DST SHL> <==? .DST .WL>>
2700                       <SET DST-IN-O1 T>
2701                       <OCEMIT MOVE O1* !<OBJ-VAL .DST>>)>
2702                <SET AC? <NEXT-AC <SET TAC? <ASSIGN-AC .DST BOTH>>>>
2703                <LOAD-AC .WD VALUE <> <> <GET-AC .AC?>>
2704                <CLEAN-ACS .DST>
2705                <ALTER-AC .TAC? .DST>
2706                <SET WD .DST>)>
2707         <SET BP <CHTYPE <ORB <LSH .SH 30> <LSH .W 24>> FIX>>
2708         <COND (<AND <TYPE? .WD ATOM>
2709                     <OR <N==? .WD .DST> <AND <NOT .VT> <NOT .AC?>>>>
2710                <SET TAC? <LOAD-AC .WD BOTH>>
2711                <SET AC? <NEXT-AC .TAC?>>
2712                <COND (<AND <N==? .WD .DST>
2713                            <NOT <WILL-DIE? .WD>>>
2714                       <FLUSH-AC .TAC? T>)>)>
2715         <COND (<N==? .WD .DST>
2716                <COND (.TAC?
2717                       <SET WAS-TYPED <AC-TYPE <GET-AC .TAC?>>>
2718                       <MUNGED-AC .TAC? T>)
2719                      (.AC? <MUNGED-AC .AC?>)>)>
2720         <COND (.AC? <SET AN <2 <CHTYPE <MEMQ .AC? ,ACS> VECTOR>>>)>
2721         <COND (<AND <TYPE? .WD FIX> <==? .DST STACK>>
2722                <SET BP <CHTYPE <ORB .BP <LSH ,TP* 18>> CONSTANT>>)
2723               (.AC? <SET BP <CHTYPE <ORB .BP .AN> CONSTANT>>)
2724               (.OL
2725                <SET BP
2726                     <CHTYPE (<2 .OL>
2727                              <+ <CHTYPE <LSH <2 <MEMQ <1 <CHTYPE <3 .OL> LIST>>
2728                                                       ,ACS>>
2729                                              18>
2730                                         FIX>
2731                                 <CHTYPE <1 .OL> FIX>
2732                                 .BP>) CONST-W-LOCAL>>)>
2733         <COND (<AND <TYPE? .WL FIX> <TYPE? .SHL FIX>>
2734                <COND (<OR <NOT <TYPE? .NEW ATOM>>
2735                           <AND <WILL-DIE? .NEW>
2736                                <NOT <SET AC <IN-AC? .NEW VALUE>>>>>
2737                       <GET-INTO-ACS .NEW VALUE <SET AC T*>>)
2738                      (<AND .DST-IN-O1 <==? .NEW .DST>> <SET AC O1*>)
2739                      (<NOT .AC>
2740                       <SET AC <NEXT-AC <LOAD-AC .NEW BOTH>>>)>
2741                <CONST-LOC .BP VALUE>
2742                <OCEMIT DPB .AC !<OBJ-VAL .BP>>)
2743               (ELSE
2744                <COND (.AC? <OCEMIT MOVEI O* .AC?>)
2745                      (ELSE
2746                       <CONST-LOC .BP VALUE>
2747                       <OCEMIT MOVE O* !<OBJ-VAL .BP>>)>
2748                <COND (<NOT <TYPE? .SHL FIX>>
2749                       <OCEMIT DPB <COND (<IN-AC? .SHL VALUE>)
2750                                         (<AND <==? .SHL .DST> .DST-IN-O1>
2751                                          O1*)
2752                                         (ELSE <NEXT-AC <LOAD-AC .SHL BOTH>>)>
2753                               !<OBJ-VAL <SET BP <CHTYPE *360600000000*
2754                                                         CONSTANT>>>>
2755                       <CONST-LOC .BP VALUE>)>
2756                <COND (<NOT <TYPE? .WL FIX>>
2757                       <OCEMIT DPB <COND (<IN-AC? .WL VALUE>)
2758                                         (<AND <==? .WL .DST> .DST-IN-O1>
2759                                          O1*)
2760                                         (ELSE <NEXT-AC <LOAD-AC .WL BOTH>>)>
2761                               !<OBJ-VAL <SET BP <CHTYPE *300600000000*
2762                                                         CONSTANT>>>>
2763                       <CONST-LOC .BP VALUE>)>
2764                <COND (.AC?
2765                       <AC-TIME <GET-AC .AC?>
2766                                <SETG AC-STAMP <+ ,AC-STAMP 1>>>
2767                       <COND (.TAC? <AC-TIME <GET-AC .TAC?> ,AC-STAMP>)>)>
2768                <COND (<AND <==? .NEW .DST> .DST-IN-O1>
2769                       <OCEMIT DPB O1* O*>)
2770                      (ELSE
2771                       <SET AC <LOAD-AC .NEW BOTH>>
2772                       <OCEMIT DPB <NEXT-AC .AC> O*>)>)>
2773         <COND (<==? .DST STACK>
2774                <COND (<TYPE? .WD ATOM>
2775                       <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
2776                       <OCEMIT PUSH TP* .AC?>
2777                       <COND (,WINNING-VICTIM
2778                              <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>)
2779               (<N==? .WD .DST>
2780                <CLEAN-ACS .DST>
2781                <AC-UPDATE <AC-ITEM <AC-CODE <GET-AC .TAC?> TYPE>
2782                                    .DST> T>
2783                <COND (.WAS-TYPED <AC-TYPE <GET-AC .TAC?> FIX>)>
2784                <AC-CODE
2785                 <AC-TYPE
2786                  <AC-ITEM
2787                   <AC-UPDATE <GET-AC <SET AC .AC?>> T> .DST> <>> VALUE>)
2788               (.AC?
2789                <COND (<NOT .TAC?>
2790                       <SET TAC? <GETPROP .AC? AC-PAIR>>
2791                       <AC-UPDATE <AC-ITEM <AC-CODE <GET-AC .TAC?> TYPE>
2792                                           .DST> T>)>
2793                <AC-UPDATE <GET-AC .AC?> T>
2794                <COND (<NOT .VT> <AC-TYPE <GET-AC .TAC?> FIX>)>)>>
2795
2796 <DEFINE DISPATCH!-MIMOC (L
2797                          "AUX" (VAR <1 .L>) (BASE <2 .L>) DELBL AC (DF <>)
2798                                (DLBL <GENLBL "DISP">) RLBLS (LL .MIML) NEW AC-T
2799                                TAC (NV <- <LENGTH .L> 2>) (DISP-L ()))
2800         #DECL ((LL MIML L) LIST (BASE NV) FIX (DISP-L) <SPECIAL LIST>)
2801         <SET RLBLS
2802              <MAPF ,LIST
2803                    <FUNCTION (LBL "AUX" LB LBX)
2804                            <COND (<AND <SET LB <FIND-LABEL .LBL>>
2805                                        <LAB-LOOP .LB>>
2806                                   <COND (<NOT <FIND-LABEL
2807                                                <SET LBX <GENLBL "LOOPD">>>>
2808                                          <MAKE-LABEL .LBX <> ()>)>
2809                                   (.LBL .LBX))
2810                                  (ELSE (.LBL .LBL))>>
2811                    <REST .L 2>>>
2812         <SET DISP-L <MAPF ,LIST <FUNCTION (L:LIST) <2 .L>> .RLBLS>>
2813         <REPEAT (ITM)
2814                 <COND (<OR <EMPTY? <SET LL <REST .LL>>>
2815                            <AND <TYPE? <SET ITM <1 .LL>> FORM>
2816                                 <OR <EMPTY? .ITM> <N==? <1 .ITM> DEAD>>>>
2817                        <RETURN>)
2818                       (<TYPE? .ITM ATOM>
2819                        <SET DELBL .ITM>
2820                        <SET DF T>
2821                        <RETURN>)>>
2822         <COND (<SET AC <IN-AC? .VAR BOTH>> <SET AC <NEXT-AC <SET TAC .AC>>>)
2823               (<SET AC <IN-AC? .VAR VALUE>>)
2824               (ELSE <SET AC <NEXT-AC <SET TAC <LOAD-AC .VAR BOTH>>>>)>
2825         <COND (<NOT .DF>
2826                <SET DELBL <GENLBL "DEFAULT">>
2827                <COND (<NOT <FIND-LABEL .DELBL>>
2828                       <MAKE-LABEL .DELBL <> ()>)>)>
2829         <LABEL-UPDATE-ACS .DELBL <>>
2830         <COND (<AND <G=? .BASE 0> <L=? .BASE 1>>
2831                <OCEMIT <COND (<==? .BASE 0> JUMPL) (ELSE JUMPLE)>
2832                        .AC
2833                        <XJUMP .DELBL>>
2834                <OCEMIT CAILE .AC <+ .NV .BASE -1>>
2835                <OCEMIT JRST O* <XJUMP .DELBL>>)
2836               (ELSE
2837                <COND (<G? .BASE 0> <OCEMIT CAIL .AC .BASE>)
2838                      (ELSE <OCEMIT CAML .AC !<OBJ-VAL .BASE>>)>
2839                <COND (<G? <SET NV <+ .NV .BASE -1>> 0> <OCEMIT CAILE .AC .NV>)
2840                      (ELSE <OCEMIT CAMLE .AC !<OBJ-CAL .NV>>)>
2841                <OCEMIT JRST O* <XJUMP .DELBL>>)>
2842         <OCEMIT XMOVEI O1* <XJUMP .DLBL>>
2843         <OCEMIT ADD O1* .AC>
2844         <MAPF <> <FUNCTION (LBL) <LABEL-UPDATE-ACS <2 .LBL> <>>> .RLBLS>
2845         <SETG LAST-UNCON T>
2846         <OCEMIT JRST @ <- .BASE> '(O1*)>
2847         <LABEL .DLBL>
2848         <MAPF <> <FUNCTION (LBL) <OCEMIT SETZ O* <XJUMP <2 .LBL>>>> .RLBLS>
2849         <MAPF <>
2850               <FUNCTION (LBL)
2851                       <COND (<N==? <1 .LBL> <2 .LBL>>
2852                              <LABEL <2 .LBL>>
2853                              <JUMP!-MIMOC <1 .LBL>>)>>
2854               .RLBLS>
2855         <COND (<NOT .DF>
2856                <COND (,PASS1 <SET LB <LABEL .DELBL>> <SAVE-LABEL-STATE .LB>)
2857                      (,NO-AC-FUNNYNESS <SAVE-ACS> <SET LB <LABEL .DELBL>>)
2858                      (ELSE
2859                       <SET LB <FIND-LABEL .DELBL>>
2860                       <ESTABLISH-LABEL-STATE .LB>
2861                       <LABEL .DELBL>)>)>>
2862
2863
2864 <DEFINE CHANNEL-OP!-MIMOC (L "AUX" (CTYP <1 .L>) (OPER <2 .L>) (EQSN <>) RES
2865                                    (GC <>) (NUM 2) RTN  OC)
2866    #DECL ((L) LIST (CTYP OPER) <FORM ATOM ATOM>)
2867    <PROG ()
2868         <COND (<AND <SET OC <GETPROP <2 .CTYP> OC-INDICATOR>>
2869                     <SET OC <APPLY .OC <2 .OPER> <REST .L 2>>>>
2870                <RETURN .OC>)>
2871         <SET RTN <CT-QUERY <2 .CTYP> <2 .OPER>>>
2872         <COND (.RTN
2873                <COND (<AND ,GLUE-MODE <MEMQ .RTN ,PRE-NAMES>>
2874                       <FRAME!-MIMOC (<SET GC <GENLBL "?FRM">> .RTN)>
2875                       <SET RTN <FORM QUOTE .RTN>>)
2876                      (<SUBRIFY? .RTN>
2877                       <FRAME!-MIMOC (<SET GC <GENLBL "?FRM">> .RTN)>
2878                       <SET RTN <FORM QUOTE .RTN>>)
2879                      (ELSE
2880                       <SET RTN <FORM QUOTE .RTN>>
2881                       <FRAME!-MIMOC (.RTN)>)>)
2882               (ELSE <FRAME!-MIMOC ()>)>
2883         <PUSH!-MIMOC (<3 .L>)>
2884         <PUSH!-MIMOC (.OPER)>
2885         <MAPF <>
2886               <FUNCTION (ARG)
2887                    <COND (.EQSN <SET RES .ARG> <MAPLEAVE>)
2888                          (<==? .ARG => <SET EQSN T>)
2889                          (ELSE
2890                           <PUSH!-MIMOC (.ARG)>
2891                           <SET NUM <+ .NUM 1>>)>>
2892               <REST .L 3>>
2893         <COND (.RTN
2894                <CALL!-MIMOC (.RTN .NUM !<COND (.EQSN (= .RES)) (ELSE ())>
2895                              !<COND (.GC (.GC)) (ELSE ())>)>)
2896               (ELSE
2897                <OCEMIT MOVE O1* !<OBJ-VAL <CHTYPE (.CTYP .OPER) CHANNEL-ROUTINE>>>
2898                <OCEMIT MOVE O1* 2 (O1*)>
2899                <OCEMIT MOVEI O2* .NUM>
2900                <COND (,WINNING-VICTIM
2901                       <SETG STACK-DEPTH <- ,STACK-DEPTH <* .NUM 2> 7>>)>
2902                <UPDATE-ACS>
2903                <COND (<ASSIGNED? RES> <PUSHJ CALL .RES>)
2904                      (ELSE <PUSHJ CALL>)>)>>>
2905
2906 <DEFINE CHANNEL-ROUTINE-PRINT (L) #DECL ((L) CHANNEL-ROUTINE)
2907         <PRINC "%<CHANNEL-OPERATION ">
2908         <PRIN1 <1 .L>>
2909         <PRINC " ">
2910         <PRIN1 <2 .L>>
2911         <PRINC ">">>
2912
2913 <PRINTTYPE CHANNEL-ROUTINE ,CHANNEL-ROUTINE-PRINT>
2914
2915 <SETG BIND-DW *1442000000*>
2916
2917 <DEFINE BBIND!-MIMOC (L "AUX" (ATM <1 .L>) (DCL <2 .L>) (FXB <3 .L>) VAL AC)
2918         #DECL ((L) LIST (ATM) <OR ATOM <FORM ATOM ATOM>>)
2919         <OCEMIT PUSH TP* !<OBJ-VAL ,BIND-DW>>
2920         <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
2921         <COND (<==? <LENGTH .L> 4>
2922                <OCEMIT PUSH TP* !<OBJ-TYP <SET VAL <4 .L>>>>
2923                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
2924                <OCEMIT PUSH TP* !<OBJ-VAL .VAL>>
2925                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>)
2926               (ELSE
2927                <OCEMIT PUSH TP* !<OBJ-VAL 0>>
2928                <OCEMIT PUSH TP* !<OBJ-VAL 0>>
2929                <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)>
2930         <COND (<SET AC <IN-AC? .ATM VALUE>>)
2931               (<TYPE? .ATM ATOM>
2932                <SET AC <NEXT-AC <LOAD-AC .ATM BOTH>>>)
2933               (ELSE
2934                <OCEMIT MOVE <SET AC O1*> !<OBJ-VAL .ATM>>)>
2935         <OCEMIT PUSH TP* .AC>
2936         <OCEMIT PUSH TP* !<OBJ-TYP .DCL>>
2937         <OCEMIT PUSH TP* !<OBJ-VAL .DCL>>
2938         <OCEMIT PUSH TP* SP*>
2939         <OCEMIT PUSH TP* 1 (.AC)>
2940         <OCEMIT PUSH TP* @ *137*>
2941         <OCEMIT XMOVEI SP* -7 '(TP*)>
2942         <COND (.FXB <OCEMIT MOVEM SP* 1 (.AC)>)>
2943         <COND (,WINNING-VICTIM <SETG STACK-DEPTH <+ ,STACK-DEPTH 6>>)>>
2944
2945 <DEFINE GEN-LVAL!-MIMOC (L "AUX" (ATM <1 .L>) (VAL <3 .L>))
2946         #DECL ((L) LIST)
2947         <OCEMIT MOVE O1* !<OBJ-VAL .ATM>>
2948         <SAVE-ACS>
2949         <PUSHJ ILVAL .VAL>>
2950
2951 <DEFINE GEN-ASSIGNED?!-MIMOC (L "AUX" (ATM  <1 .L>) (DIR <2 .L>) (TG <3 .L>))
2952         #DECL ((L) LIST)
2953         <OCEMIT MOVE O1* !<OBJ-VAL .ATM>>
2954         <LABEL-UPDATE-ACS .TG <>>
2955         <OCEMIT JSP T* @ <- <OPCODE IASS>>>
2956         <COND (<==? .DIR +> <OCEMIT CAIA O* O*>)>
2957         <OCEMIT JRST <XJUMP .TG>>>
2958
2959 <DEFINE GEN-SET!-MIMOC (L "AUX" (ATM <1 .L>) (NVAL <2 .L>))
2960         #DECL ((L) LIST)
2961         <COND (<WILL-DIE? .NVAL> <DEAD!-MIMOC (.NVAL) T>)>
2962         <COND (<AND <TYPE? .ATM ATOM> <WILL-DIE? .ATM>> <DEAD!-MIMOC (.ATM) T>)>
2963         <UPDATE-ACS>
2964         <GET-INTO-ACS .NVAL BOTH A1* .ATM VALUE O1*>
2965         <PUSHJ ISET>>