mim/development/mim/vaxc/lookahead.mud

   1
   2 <GDECL (LOOKAHEAD?) <OR ATOM FALSE>>
   3
   4 <SETG ARITH
   5       '[ADD!-MIMOP
   6         SUB!-MIMOP
   7         MUL!-MIMOP
   8         DIV!-MIMOP
   9         ADDF!-MIMOP
  10         SUBF!-MIMOP
  11         MULF!-MIMOP
  12         DIVF!-MIMOP
  13         AND!-MIMOP
  14         OR!-MIMOP
  15         XOR!-MIMOP
  16         EQV!-MIMOP]>
  17
  18 <SETG EMPU '[EMPUV?!-MIMOP EMPUU?!-MIMOP EMPUS?!-MIMOP EMPUB?!-MIMOP]>
  19
  20 <SETG LENU '[LENUV!-MIMOP LENUU!-MIMOP LENUS!-MIMOP LENUB!-MIMOP]>
  21
  22 <SETG NTHU '[NTHUV!-MIMOP NTHUU!-MIMOP NTHUS!-MIMOP NTHUB!-MIMOP]>
  23
  24 <SETG PUTU '[PUTUV!-MIMOP PUTUU!-MIMOP PUTUS!-MIMOP PUTUB!-MIMOP]>
  25
  26 <SETG RESTU '[RESTUV!-MIMOP RESTUU!-MIMOP RESTUS!-MIMOP RESTUB!-MIMOP]>
  27
  28 <PUTPROP RESTUV!-MIMOP PUT-PAIR PUTUV!-MIMOP>
  29
  30 <PUTPROP PUTUV!-MIMOP PUT-PAIR RESTUV!-MIMOP>
  31
  32 <PUTPROP RESTUU!-MIMOP PUT-PAIR PUTUU!-MIMOP>
  33
  34 <PUTPROP PUTUU!-MIMOP PUT-PAIR RESTUU!-MIMOP>
  35
  36 <PUTPROP RESTUS!-MIMOP PUT-PAIR PUTUS!-MIMOP>
  37
  38 <PUTPROP PUTUS!-MIMOP PUT-PAIR RESTUS!-MIMOP>
  39
  40 <PUTPROP RESTUB!-MIMOP PUT-PAIR PUTUB!-MIMOP>
  41
  42 <PUTPROP PUTUB!-MIMOP PUT-PAIR RESTUB!-MIMOP>
  43
  44 <PUTPROP RESTUV!-MIMOP PAIR NTHUV!-MIMOP>
  45
  46 <PUTPROP NTHUV!-MIMOP PAIR RESTUV!-MIMOP>
  47
  48 <PUTPROP RESTUU!-MIMOP PAIR NTHUU!-MIMOP>
  49
  50 <PUTPROP NTHUU!-MIMOP PAIR RESTUU!-MIMOP>
  51
  52 <PUTPROP RESTUS!-MIMOP PAIR NTHUS!-MIMOP>
  53
  54 <PUTPROP NTHUS!-MIMOP PAIR RESTUS!-MIMOP>
  55
  56 <PUTPROP RESTUB!-MIMOP PAIR NTHUB!-MIMOP>
  57
  58 <PUTPROP NTHUB!-MIMOP PAIR RESTUB!-MIMOP>
  59
  60 <GDECL (ARITH NTHU PUTU RESTU LENU EMPU) <VECTOR [REST ATOM]>>
  61
  62 <NEWSTRUC OP-INFO (VECTOR)
  63           OP-ARGS VECTOR
  64           OP-RES <OR ATOM VARTBL>
  65           OP-HINT <OR LIST ATOM FALSE>
  66           OP-BRANCH <OR ATOM FALSE>
  67           OP-DIR ATOM>
  68
  69 <SETG OP-INFO [<IVECTOR 5 <>> T <> <> T]>
  70
  71 <DEFINE NTH-LOOK-AHEAD NLA (CINS STRUC1 OFF1 RES
  72                             "OPTIONAL" (HINT <>) (STYPE1 <>)
  73                             "AUX" (L .CODPTR) INCINS NXT (OP-INFO ,OP-INFO)
  74                                   (ADDVAL 0) STRUC2 OFF2 (ELTYPE1 <>)
  75                                   (ELTYPE2 <>) (EMPTY? <>)
  76                                   (ARGVEC <OP-ARGS .OP-INFO>) (ARITH? <>)
  77                                   (ILDB? <>) OL (IDPB? <>) NINS RES1 RES2
  78                                   (RES1? <>) (RES2? <>) PINS (STYPE2 <>) AMT
  79                                   CMPINS TMIML (NOPUT? <>))
  80    #DECL ((CINS) ATOM (RES) <OR VARTBL ATOM> (NXT) <OR ATOM FORM>
  81           (L) <SPECIAL <LIST [REST <OR ATOM FORM>]>> (OP-INFO) OP-INFO)
  82    <COND (<NOT ,LOOKAHEAD?> <RETURN <> .NLA>)>
  83    <COND (.STYPE1 <SET STYPE1 <PARSE-HINT .STYPE1 STRUCTURE-TYPE>>)
  84          (T
  85           <COND (<==? .CINS NTHUV!-MIMOP> <SET STYPE1 VECTOR>)
  86                 (<==? .CINS NTHUU!-MIMOP> <SET STYPE1 UVECTOR>)
  87                 (<==? .CINS NTHUS!-MIMOP> <SET STYPE1 STRING>)
  88                 (<==? .CINS NTHUB!-MIMOP> <SET STYPE1 BYTES>)
  89                 (<==? .CINS NTHL!-MIMOP> <SET STYPE1 LIST>)>)>
  90    <COND (<==? .CINS ILDB!-MIMOP> <SET ILDB? .OFF1> <SET OFF1 1>)>
  91    <COND
  92     (<AND <OR <MEMQ .CINS ,NTHU>
  93               <==? .CINS ILDB!-MIMOP>
  94               <==? .CINS NTHL!-MIMOP>>
  95           <G=? <LENGTH .L> 3>
  96           <TYPE? .RES VARTBL>
  97           <TYPE? .STRUC1 VARTBL>
  98           <N==? .RES .STRUC1>
  99           <TYPE? <SET NXT <GET-NEXT-INST .L>> FORM>
 100           <COND (<OR <SET ARITH? <MEMQ <SET INCINS <1 .NXT>> ,ARITH>>
 101                      <MEMQ .INCINS ,RESTU>>
 102                  <AND <PARSE-OP .NXT .OP-INFO>
 103                       <==? <1 <OP-ARGS .OP-INFO>> .RES>
 104                       <==? <OP-RES .OP-INFO> .RES>
 105                       <SET ADDVAL <2 <OP-ARGS .OP-INFO>>>
 106                       <TYPE? <SET NXT <GET-NEXT-INST .L>> FORM>>)
 107                 (T <SET INCINS <>> T)>
 108           <OR <NOT .ARITH?>
 109               <NOT <MEMQ .INCINS ,LOGIC>>
 110               <NOT <MEMQ .STYPE1 '[STRING BYTES]>>>
 111           <OR <MEMQ <SET PINS <1 .NXT>> ,PUTU>
 112               <==? .PINS PUTL!-MIMOP>
 113               <SET IDPB? <==? .PINS IDPB!-MIMOP>>
 114               <COND (.ARITH? <SET PINS <>> <SET NOPUT? T> <SET STRUC2 .RES>)>>
 115          ;"In case of CHTYPE here (for rest), will fall into
 116             normal code"
 117           <COND (<NOT .NOPUT?>
 118                  <PARSE-OP .NXT .OP-INFO>
 119                  <SET ARGVEC <OP-ARGS .OP-INFO>>
 120                  <COND (.IDPB? <==? <2 .ARGVEC> .RES>)
 121                        (<==? <3 .ARGVEC> .RES>)>)
 122                 (T)>
 123           <COND (<NOT .NOPUT?>
 124                  <COND (<WILL-DIE? .RES .L>)
 125                        (.ARITH?
 126                         ; "Work for NTH ? ADD when NTH ? ADD ? PUT can't
 127                            because of life/death"
 128                         <SET NOPUT? T>
 129                         <SET PINS <>>
 130                         <SET STRUC2 .RES>)>)
 131                 (T)>>
 132      <COND (<NOT .NOPUT?> <SET STRUC2 <1 .ARGVEC>>) (T)>
 133      <COND (.NOPUT? <PROTECT-VAL .STRUC2>)
 134            (.IDPB? <SET STYPE2 <PARSE-HINT <OP-HINT .OP-INFO> STRUCTURE-TYPE>>)
 135            (<==? .PINS PUTUV!-MIMOP> <SET STYPE2 VECTOR>)
 136            (<==? .PINS PUTL!-MIMOP> <SET STYPE2 LIST>)
 137            (<==? .PINS PUTUU!-MIMOP> <SET STYPE2 UVECTOR> <SET ELTYPE2 FIX>)
 138            (<==? .PINS PUTUS!-MIMOP>
 139             <SET STYPE2 STRING>
 140             <SET ELTYPE2 CHARACTER>)
 141            (<==? .PINS PUTUB!-MIMOP> <SET ELTYPE2 FIX> <SET STYPE2 BYTES>)>
 142      <COND (.IDPB? <SET OFF2 1> <SET IDPB? <3 .ARGVEC>>)
 143            (.NOPUT?)
 144            (T
 145             <SET OFF2 <2 .ARGVEC>>
 146             <COND (<OP-HINT .OP-INFO>
 147                    <SET ELTYPE2 <PARSE-HINT <OP-HINT .OP-INFO> TYPE>>)>)>
 148      <COND (.HINT
 149             <COND (<TYPE? .HINT ATOM> <SET ELTYPE1 .HINT>)
 150                   (<SET ELTYPE1 <PARSE-HINT .HINT TYPE>>)>)
 151            (<==? .STYPE1 BYTES> <SET ELTYPE1 FIX>)
 152            (<==? .STYPE1 STRING> <SET ELTYPE1 CHARACTER>)
 153            (<==? .STYPE1 UVECTOR> <SET ELTYPE1 FIX>)>
 154      <COND (<AND <MEMQ .INCINS ,RESTU>
 155                  <OR <NOT .ELTYPE1> <NOT .ELTYPE2> <N==? .ELTYPE1 .ELTYPE2>>
 156                  <OR .ILDB? .IDPB? <N==? .STRUC1 .STRUC2> <N==? .OFF1 .OFF2>>>
 157             <>)
 158            (<NTH-AOS-PUT-GEN .CINS
 159                              .INCINS
 160                              .PINS
 161                              .STRUC1
 162                              .OFF1
 163                              .STRUC2
 164                              <COND (<NOT .NOPUT?> .OFF2)>
 165                              .ADDVAL
 166                              .L
 167                              .ILDB?
 168                              .IDPB?
 169                              .STYPE1
 170                              <COND (<NOT .NOPUT?> .STYPE2)>
 171                              .ELTYPE1
 172                              <COND (<NOT .NOPUT?> .ELTYPE2)>>
 173             NORMAL)>)
 174     (<AND <SET L .CODPTR>
 175           <OR <==? .CINS ILDB!-MIMOP>
 176               <MEMQ .CINS ,NTHU>
 177               <==? .CINS NTHL!-MIMOP>>
 178           <G? <LENGTH .L> 1>
 179           <TYPE? <SET NXT <GET-NEXT-INST .L>> FORM>>
 180      <COND
 181       (<AND <OR <MEMQ <1 .NXT> ,LENU>
 182                 <SET EMPTY?
 183                      <OR <==? <1 .NXT> EMPL?!-MIMOP> <MEMQ <1 .NXT> ,EMPU>>>>
 184             <PARSE-OP .NXT .OP-INFO>
 185             <==? <1 <SET ARGVEC <OP-ARGS .OP-INFO>>> .RES>
 186             <OR <==? <1 .ARGVEC> <OP-RES .OP-INFO>>
 187                 <AND <WILL-DIE? .RES .L>
 188                      <OR <NOT .EMPTY?>
 189  ;
 190 "If empty?, make sure <3 .x> isn't used after
 191                             the branch.  WILL-DIE? on .L won't find this,
 192                             because L has already been rested past the branch."
 193                          <AND <SET TMIML <MEMQ <OP-BRANCH .OP-INFO> .L>>
 194                               <WILL-DIE? .RES .TMIML>>>>>>
 195                                      ;"Have <length <3 .x>> or <empty? <3 .x>>"
 196        <SET OL .L>
 197        <COND (.EMPTY?
 198               <FLUSH-TO .L .CODPTR>
 199               <NTH-LENGTH-COMP-GEN .CINS
 200                                    .STRUC1
 201                                    .OFF1
 202                                    .STYPE1
 203                                    0
 204                                    <1 .NXT>
 205                                    .OP-INFO>
 206               CONDITIONAL-BRANCH)
 207              (T
 208               <SET ADDVAL <OP-RES .OP-INFO>>
 209               <COND (<AND <G? <LENGTH .L> 2>
 210                           <TYPE? <SET NXT <GET-NEXT-INST .L>> FORM>
 211                           <MEMQ <1 .NXT>
 212                                 '[LESS?!-MIMOP GRTR?!-MIMOP VEQUAL?!-MIMOP]>
 213                           <PARSE-OP .NXT .OP-INFO>
 214                           <COND (<==? .ADDVAL
 215                                       <1 <SET ARGVEC <OP-ARGS .OP-INFO>>>>
 216                                  <SET CMPINS <1 .NXT>>
 217                                  <SET AMT <2 .ARGVEC>>)
 218                                 (<==? .ADDVAL <2 .ARGVEC>>
 219                                  <SET AMT <1 .ARGVEC>>
 220                                  <COND (<==? <SET CMPINS <1 .NXT>>
 221                                              LESS?!-MIMOP>
 222                                         <SET CMPINS GRTR?!-MIMOP>)
 223                                        (<==? .CMPINS GRTR?!-MIMOP>
 224                                         <SET CMPINS LESS?!-MIMOP>)
 225                                        (T)>)>
 226                           <WILL-DIE? .ADDVAL <REST .L>>>
 227                                              ;"Have length comparison of nth.."
 228                      <FLUSH-TO .L .CODPTR>
 229                      <NTH-LENGTH-COMP-GEN .CINS
 230                                           .STRUC1
 231                                           .OFF1
 232                                           .STYPE1
 233                                           .AMT
 234                                           .CMPINS
 235                                           .OP-INFO>
 236                      CONDITIONAL-BRANCH)
 237                     (T
 238                      <FLUSH-TO .OL .CODPTR>
 239                      <NTH-LENGTH-GEN .CINS .STRUC1 .OFF1 .STYPE1 .ADDVAL>
 240                      NORMAL)>)>)
 241       (<AND <OR <==? <SET NINS <1 .NXT>> ILDB!-MIMOP>
 242                 <MEMQ .NINS ,NTHU>
 243                 <==? .NINS NTHL!-MIMOP>>
 244             <NOT <EMPTY? <REST .L>>>
 245             <PARSE-OP .NXT .OP-INFO>
 246             <COND (<==? .NINS ILDB!-MIMOP>
 247                    <SET STYPE2 <PARSE-HINT <OP-HINT .OP-INFO> STRUCTURE-TYPE>>)
 248                   (<==? .NINS NTHL!-MIMOP> <SET STYPE2 LIST>)
 249                   (<SET STYPE2
 250                         <2 <MEMBER <REST <SPNAME .NINS> 3>
 251                                    '["UV"
 252                                      VECTOR
 253                                      "UU"
 254                                      UVECTOR
 255                                      "US"
 256                                      STRING
 257                                      "UB"
 258                                      BYTES]>>>)>
 259             <SET STRUC2 <1 <SET ARGVEC <OP-ARGS .OP-INFO>>>>
 260             <OR <==? .STYPE1 .STYPE2>
 261                 <AND <MEMQ .STYPE1 '[VECTOR UVECTOR LIST]>
 262                      <MEMQ .STYPE2 '[VECTOR UVECTOR LIST]>>
 263                 <AND <MEMQ .STYPE1 '[STRING BYTES]>
 264                      <MEMQ .STYPE2 '[STRING BYTES]>>>
 265             <SET OFF2 <2 .ARGVEC>>
 266             <SET RES2 <OP-RES .OP-INFO>>
 267             <WILL-DIE? .RES2 <REST .L>>
 268             <TYPE? <SET NXT <GET-NEXT-INST .L>> FORM>
 269             <MEMQ <1 .NXT> '[LESS?!-MIMOP GRTR?!-MIMOP VEQUAL?!-MIMOP]>
 270             <OR <MEMQ .RES .NXT> <MEMQ .RES2 .NXT>>>
 271        <PARSE-OP .NXT .OP-INFO>
 272        <COND (<OR <NOT <SET TMIML <MEMQ <OP-BRANCH .OP-INFO> .L>>>
 273                   <NOT <WILL-DIE? .RES2 .TMIML>>>
 274                                                 ;"See comment above for EMPTY?"
 275               <RETURN <> .NLA>)>
 276        <FLUSH-TO .L .CODPTR>
 277        <SLOT-COMPARE <COND (<==? <1 .ARGVEC> .RES> <SET RES1? 1> .STRUC1)
 278                            (<==? <1 .ARGVEC> .RES2> <SET RES2? 1> .STRUC2)
 279                            (<1 .ARGVEC>)>
 280                      <COND (<==? <2 .ARGVEC> .RES> <SET RES1? 2> .STRUC1)
 281                            (<==? <2 .ARGVEC> .RES2> <SET RES2? 2> .STRUC2)
 282                            (<2 .ARGVEC>)>
 283                      <1 .NXT>
 284                      .OP-INFO
 285                      <COND (<==? .RES1? 1> .OFF1) (<==? .RES2? 1> .OFF2)>
 286                      <COND (<==? .RES1? 1> .STYPE1) (<==? .RES2? 1> .STYPE2)>
 287                      <COND (<==? .RES1? 2> .OFF1) (<==? .RES2? 2> .OFF2)>
 288                      <COND (<==? .RES1? 2> .STYPE1) (<==? .RES2? 2> .STYPE2)>>
 289        CONDITIONAL-BRANCH)
 290       (<AND <MEMQ <1 .NXT> '[GRTR?!-MIMOP LESS?!-MIMOP VEQUAL?!-MIMOP]>
 291             <PARSE-OP .NXT .OP-INFO>
 292             <OR <==? <1 .ARGVEC> .RES> <==? <2 .ARGVEC> .RES>>
 293             <AND <WILL-DIE? .RES .L>
 294                  <SET TMIML <MEMQ <OP-BRANCH .OP-INFO> .L>>
 295                  <WILL-DIE? .RES .TMIML>>>
 296        <COND (<==? <1 .ARGVEC> .RES> <SET RES1? T>)
 297              (<==? <2 .ARGVEC> .RES> <SET RES2? T>)>
 298        <FLUSH-TO .L .CODPTR>
 299        <SLOT-COMPARE <COND (.RES1? .STRUC1) (<1 .ARGVEC>)>
 300                      <COND (.RES2? .STRUC1) (<2 .ARGVEC>)>
 301                      <1 .NXT>
 302                      .OP-INFO
 303                      <COND (.RES1? .OFF1)>
 304                      <COND (.RES1? .STYPE1)>
 305                      <COND (.RES2? .OFF1)>
 306                      <COND (.RES2? .STYPE1)>>
 307        CONDITIONAL-BRANCH)>)>>
 308
 309 <DEFINE FLUSH-TO (NL OL)
 310         #DECL ((NL OL) LIST)
 311         <SETG FLUSH-NEXT <- <LENGTH .OL> <LENGTH .NL>>>>
 312
 313 <DEFINE GET-NEXT-INST (LL)
 314         #DECL ((LL) LIST)
 315         <REPEAT (FROB)
 316                 <COND (<NOT <GETPROP <SET FROB <1 .LL>> DONE>>
 317                        <SET L <REST .LL>>
 318                        <RETURN .FROB>)>
 319                 <COND (<EMPTY? <SET LL <REST .LL>>> <RETURN <>>)>>>
 320
 321 <DEFINE PARSE-OP (FRM OP-INFO
 322                   "AUX" (ARGVEC <OP-ARGS .OP-INFO>) (RES? <>) HINT
 323                         (BRANCH? <>))
 324         #DECL ((FRM) FORM (OP-INFO) OP-INFO)
 325         <OP-HINT .OP-INFO <>>
 326         <OP-BRANCH .OP-INFO <>>
 327         <OP-RES .OP-INFO T>
 328         <MAPF <>
 329               <FUNCTION (X)
 330                       <COND (<OR <NOT <TYPE? .X LIST>> <EMPTY? .X>>
 331                              <COND (.RES? <SET RES? <>> <OP-RES .OP-INFO .X>)
 332                                    (.BRANCH?
 333                                     <SET BRANCH? <>>
 334                                     <OP-BRANCH .OP-INFO .X>)
 335                                    (<OR <==? .X -> <==? .X +>>
 336                                     <OP-DIR .OP-INFO .X>
 337                                     <SET BRANCH? T>)
 338                                    (<TYPE? .X RES-IND> <SET RES? T>)
 339                                    (<EMPTY? .ARGVEC>)
 340                                    (T
 341                                     <1 .ARGVEC .X>
 342                                     <SET ARGVEC <REST .ARGVEC>>)>)
 343                             (<OR <==? <1 .X> TYPE> <==? <1 .X> STRUCTURE-TYPE>>
 344                              <OP-HINT .OP-INFO .X>)
 345                             (<==? <1 .X> BRANCH-FALSE>
 346                              <OP-BRANCH .OP-INFO <2 .X>>
 347                              <OP-DIR .OP-INFO ->)
 348                             (<==? <1 .X> BRANCH-TRUE>
 349                              <OP-BRANCH .OP-INFO <2 .X>>
 350                              <OP-DIR .OP-INFO +>)>>
 351               <REST .FRM>>
 352         .OP-INFO>
 353
 354 <DEFINE WILL-DIE? (ARG
 355                    "OPT" (MIML .CODPTR) (BEG-LABEL T) "AUX" FOO (CP .CODPTR)
 356                          LR LABEL
 357                          (N
 358                           <COND (<==? .CP .MIML> ,FLUSH-NEXT)
 359                                 (<- ,FLUSH-NEXT
 360                                     <- <LENGTH .CP> <LENGTH .MIML>>>)>))
 361    #DECL ((BEG-LABEL) ATOM (ARG) ANY (MIML) LIST (N) FIX)
 362  <COND
 363   (,LOOKAHEAD?
 364    <REPEAT LEAVE (NXT ITM JMP?)
 365      #DECL ((NXT) <OR ATOM FORM LIST>)
 366      <COND
 367       (<EMPTY? .MIML> <RETURN T>)
 368       (<AND <L=? <LENGTH .MIML> 1>
 369             <OR <NOT <TYPE? <SET ITM <1 .MIML>> FORM>>
 370                 <AND <N==? <1 .ITM> JUMP!-MIMOP>
 371                      <NOT <MEMQ + .ITM>>
 372                      <NOT <MEMQ - .ITM>>>>>
 373        <COND (<AND <TYPE? .ITM FORM>
 374                    <==? <1 .ITM> RETURN!-MIMOP>
 375                    <==? <2 .ITM> .ARG>>
 376               <RETURN <>>)
 377              (T
 378               <RETURN T>)>)
 379       (<TYPE? <SET NXT <1 .MIML>> ATOM>
 380        <SET LR <GET-LREF .NXT T>>
 381        <COND (<MEMQ .ARG <LABEL-REF-LIVE-VARS .LR>> <RETURN <>>)
 382              (<MEMQ .ARG <LABEL-REF-DEAD-VARS .LR>> <RETURN T>)>
 383        <COND (<WILL-DIE? .ARG <REST .MIML> .NXT>
 384               <LABEL-REF-DEAD-VARS .LR (.ARG !<LABEL-REF-DEAD-VARS .LR>)>
 385               <RETURN T>)
 386              (T
 387               <LABEL-REF-LIVE-VARS .LR (.ARG !<LABEL-REF-LIVE-VARS .LR>)>
 388               <RETURN <>>)>)
 389       (<AND <TYPE?  .NXT FORM>
 390             <L? <SET N <- .N 1>> 0>
 391             <NOT <GETPROP .NXT DONE>>>
 392        <COND (<==? <SET ITM <1 .NXT>> DEAD!-MIMOP>
 393               <COND (<MEMQ .ARG <REST .NXT>>
 394                      ; "Definitely dies if DEADed"
 395                      <RETURN T>)>)
 396              (<==? .ITM RETURN!-MIMOP>
 397               ; "Dies if not returned"
 398               <RETURN <N==? <2 .NXT> .ARG>>)
 399              (<==? .ITM END!-MIMOP>
 400               ; "Dies if run out of code"
 401               <RETURN T>)
 402              (<==? .ITM SET!-MIMOP>
 403               <COND (<==? <2 .NXT> .ARG>
 404                      ; "Dies if SET"
 405                      <RETURN T>)
 406                     (<==? <3 .NXT> .ARG>
 407                      ; "Doesn't die if something set to this"
 408                      <RETURN <>>)>)
 409              (<AND <==? .ITM SETLR!-MIMOP>
 410                    <==? <2 .NXT> .ARG>>
 411               ; "If doing SETLR, current value is dead"
 412               <RETURN T>)
 413              (T
 414               <COND
 415                (<==? .ITM JUMP!-MIMOP> <SET JMP? T>)
 416                (T <SET JMP? <>>)>
 417               ; "Unconditional jump is special case, slightly"
 418               <MAPR <>
 419                  <FUNCTION (XP "AUX" (X <1 .XP>))
 420                          <COND (<TYPE? .X RES-IND>
 421                                 <COND (<==? <SET X <2 .XP>> .ARG>
 422                                        ; "Result of something, so dead"
 423                                        <RETURN T .LEAVE>)
 424                                       (T <MAPLEAVE>)>)
 425                                (<==? .X .ARG>
 426                                 ; "Arg to something, so not dead"
 427                                 <RETURN <> .LEAVE>)>>
 428                  .NXT>
 429               <COND (<==? .ITM DISPATCH!-MIMOP>
 430                      <MAPF <>
 431                        <FUNCTION (LAB)
 432                          <COND (<==? .LAB .BEG-LABEL>)
 433                                (<SET FOO <MEMQ .LAB .MIML>>
 434                                 <SET LR <GET-LREF .LAB T>>
 435                                 <COND (<MEMQ .ARG <LABEL-REF-LIVE-VARS .LR>>
 436                                        <RETURN <> .LEAVE>)
 437                                       (<MEMQ .ARG <LABEL-REF-DEAD-VARS .LR>>)
 438                                       (<WILL-DIE? .ARG <REST .FOO>>
 439                                        <LABEL-REF-DEAD-VARS
 440                                         .LR (.ARG !<LABEL-REF-DEAD-VARS .LR>)>)
 441                                       (T
 442                                        <LABEL-REF-LIVE-VARS .LR
 443                                         (.ARG !<LABEL-REF-LIVE-VARS .LR>)>
 444                                        <RETURN <> .LEAVE>)>)
 445                                (T
 446                                 <RETURN <> .LEAVE>)>>
 447                        <REST .NXT 3>>)
 448                     (<OR <AND <==? .ITM ICALL!-MIMOP>
 449                               <SET FOO .NXT>>
 450                          <SET FOO <MEMQ + <SET NXT <REST .NXT>>>>
 451                          <SET FOO <MEMQ - .NXT>>
 452                          <AND <==? .ITM NTHR!-MIMOP>
 453                               <TYPE? <SET ITM <NTH .NXT <LENGTH .NXT>>> LIST>
 454                               <==? <1 .ITM> BRANCH-FALSE>
 455                               <SET FOO <REST .ITM>>>>
 456                      ; "Jump"
 457                      <COND (<SET FOO <MEMQ <SET LABEL <2 .FOO>> .MIML>>
 458                             ; "Hair to remember who's alive/dead at each place"
 459                             <SET LR <GET-LREF .LABEL T>>
 460                             <COND (<==? .LABEL .BEG-LABEL>
 461                                    ; "If you hit a jump to the label where you
 462                                       started, and you don't know the variable
 463                                       is alive, then the jump won't make it live
 464                                       either.  If the jump is unconditional,
 465                                       the variable is dead."
 466                                    <COND (.JMP? <RETURN T>)>)
 467                                   (<MEMQ .ARG <LABEL-REF-LIVE-VARS .LR>>
 468                                    <RETURN <>>)
 469                                   (<MEMQ .ARG <LABEL-REF-DEAD-VARS .LR>>
 470                                    <COND (.JMP? <RETURN T>)>)
 471                                   (<WILL-DIE? .ARG <REST .FOO>>
 472                                    <LABEL-REF-DEAD-VARS
 473                                     .LR (.ARG !<LABEL-REF-DEAD-VARS .LR>)>
 474                                    ; "If dies at branch loc, might die here"
 475                                    <COND (.JMP?
 476                                           ; "Unconditional jump, definitely dead"
 477                                           <RETURN T>)>)
 478                                   (T
 479                                    <LABEL-REF-LIVE-VARS
 480                                     .LR (.ARG !<LABEL-REF-LIVE-VARS .LR>)>
 481                                    <RETURN <>>)>)
 482                            (T
 483                             ; "Lose, so not dead"
 484                             <RETURN <>>)>)>)>)>
 485      <SET MIML <REST .MIML>>>)>>
 486
 487 \\f
 488
 489 <DEFINE NTH-AOS-PUT-GEN NG
 490         (NTHINS INCINS PUTINS STRUC1 OFFSET1 STRUC2 OFFSET2 AMOUNT CODELIST
 491          ILDB? IDPB? STYPE1 STYPE2 ELTYPE1 ELTYPE2
 492          "AUX" SAC1 SAC2 (ADDRTUP1 <ITUPLE 4 <>>) (ADDRTUP2 <ITUPLE 4 <>>)
 493                TMPAC (SELF? <>))
 494         #DECL ((NTHINS) ATOM (INCINS) <OR ATOM FALSE> (STRUC) VARTBL)
 495         <SET SELF?
 496              <AND <==? .STRUC1 .STRUC2>
 497                   <==? .OFFSET1 .OFFSET2>
 498                   <NOT .ILDB?>
 499                   <NOT .IDPB?>>>
 500         <COND (<OR <AND .OFFSET2
 501                         <NOT .SELF?>
 502                         .INCINS
 503                         <OR <AND .ILDB? <==? .STYPE1 VECTOR>>
 504                             <AND .IDPB? <==? .STYPE2 VECTOR>>
 505                             <AND <MEMQ .STYPE1 '[VECTOR LIST UVECTOR]>
 506                                  <NOT <MEMQ .STYPE2 '[VECTOR LIST UVECTOR]>>>
 507                             <AND <MEMQ .STYPE2 '[VECTOR LIST UVECTOR]>
 508                                  <NOT <MEMQ .STYPE1 '[VECTOR
 509                                                       LIST
 510                                                       UVECTOR]>>>>>
 511                    <AND .ILDB?
 512                         .IDPB?
 513                         <NOT <OR <==? .STYPE1 .STYPE2>
 514                                  <AND <MEMQ .STYPE1 '[STRING BYTES UVECTOR]>
 515                                       <MEMQ .STYPE2
 516                                             '[STRING BYTES UVECTOR]>>>>>
 517                    <AND .ILDB? <NOT <TYPE? .OFFSET2 FIX>>>
 518                    <AND .IDPB? <NOT <TYPE? .OFFSET1 FIX>>>>
 519  ;
 520 "When we're dealing with the first element of a vector
 521  via ILDB/IDPB, might as well not try anything fancy here."
 522                <RETURN <> .NG>)>
 523         <COND (.PUTINS <FLUSH-TO .CODELIST .CODPTR>)
 524               (T
 525                <FLUSH-TO <REST .CODPTR
 526                                <- <LENGTH .CODPTR> <LENGTH .CODELIST> 1>>
 527                          .CODPTR>)>
 528         <COND (<NOT <SET SAC1 <VAR-VALUE-IN-AC? .STRUC1>>>
 529                <SET SAC1 <LOAD-VAR .STRUC1 VALUE <> PREF-VAL>>)>
 530         <PROTECT-USE .SAC1>
 531         <COND (<AND .PUTINS <NOT .SELF?>>
 532                <COND (<AND <==? .STRUC1 .STRUC2> <N==? .STYPE1 LIST>>
 533                       <SET SAC2 .SAC1>)
 534                      (<NOT <SET SAC2 <VAR-VALUE-IN-AC? .STRUC2>>>
 535                       <SET SAC2 <LOAD-VAR .STRUC2 VALUE <> PREF-VAL>>
 536                       <PROTECT-USE .SAC2>)>)>
 537  ;
 538 "Struc1 is now in sac1, appropriately rested; struc2 is in sac2,
 539            also rested.  (Two may be same, if struc1==struc2 and not rested"
 540         <GET-ADDR .ADDRTUP1
 541                   .STRUC1
 542                   .SAC1
 543                   .OFFSET1
 544                   .STYPE1
 545                   .ILDB?
 546                   <>
 547                   <NOT .INCINS>>
 548         <COND (<AND .PUTINS <NOT .SELF?>>
 549                <COND (<AND <3 .ADDRTUP1>
 550                            <==? .OFFSET1 .OFFSET2>
 551                            <OR <AND <==? .STYPE1 VECTOR> <==? .STYPE2 VECTOR>>
 552                                <AND <N==? .STYPE1 VECTOR>
 553                                     <N==? .STYPE2 VECTOR>>>>
 554                       <GET-ADDR .ADDRTUP2
 555                                 .STRUC2
 556                                 .SAC2
 557                                 .OFFSET2
 558                                 .STYPE2
 559                                 .IDPB?
 560                                 <3 .ADDRTUP1>
 561                                 <NOT .INCINS>>)
 562                      (<GET-ADDR .ADDRTUP2
 563                                 .STRUC2
 564                                 .SAC2
 565                                 .OFFSET2
 566                                 .STYPE2
 567                                 .IDPB?
 568                                 <>
 569                                 <NOT .INCINS>>)>)>
 570         <COND (<NOT .INCINS>
 571                <MOVE-ELT .ADDRTUP1
 572                          .ADDRTUP2
 573                          .STYPE1
 574                          .STYPE2
 575                          .ELTYPE1
 576                          .ELTYPE2
 577                          .IDPB?>)
 578               (<MEMQ .INCINS ,ARITH>
 579                <DO-ARITH .INCINS
 580                          .AMOUNT
 581                          <1 .ADDRTUP1>
 582                          <COND (.PUTINS <1 .ADDRTUP2>) (T .STRUC2)>
 583                          .SELF?
 584                          .STYPE1>)
 585               (T
 586                <DO-ARITH SUB!-MIMOP
 587                          .AMOUNT
 588                          <2 .ADDRTUP1>
 589                          <2 .ADDRTUP2>
 590                          .SELF?
 591                          WORD>                     ;"Decrement count on length"
 592                <COND (<TYPE? .AMOUNT FIX>
 593                       <DO-ARITH ADD!-MIMOP
 594                                 <COND (<==? .INCINS RESTUV!-MIMOP>
 595                                        <MA-IMM <* 8 .AMOUNT>>)
 596                                       (<==? .INCINS RESTUU!-MIMOP>
 597                                        <MA-IMM <* 4 .AMOUNT>>)
 598                                       (<MA-IMM .AMOUNT>)>
 599                                 <1 .ADDRTUP1>
 600                                 <1 .ADDRTUP2>
 601                                 .SELF?
 602                                 VECTOR>)
 603                      (T
 604                       <COND (<OR <==? .INCINS RESTUS!-MIMOP>
 605                                  <==? .INCINS RESTUB!-MIMOP>>
 606                              <SET TMPAC <VAR-VALUE-ADDRESS .AMOUNT>>)
 607                             (<SET TMPAC <VAR-VALUE-IN-AC? .AMOUNT>>
 608                              <MUNG-AC .TMPAC T>
 609                              <SET TMPAC <MA-REG .TMPAC>>
 610                              <EMIT ,INST-ASHL
 611                                    <COND (<==? .INCINS RESTUV!-MIMOP>
 612                                           <MA-IMM 3>)
 613                                          (<MA-IMM 2>)>
 614                                    .TMPAC
 615                                    .TMPAC>)
 616                             (T
 617                              <SET TMPAC <GET-AC PREF-VAL>>
 618                              <EMIT ,INST-ASHL
 619                                    <COND (<==? .INCINS RESTUV!-MIMOP>
 620                                           <MA-IMM 3>)
 621                                          (<MA-IMM 2>)>
 622                                    <VAR-VALUE-ADDRESS .AMOUNT>
 623                                    <SET TMPAC <MA-REG .TMPAC>>>)>
 624                       <DO-ARITH ADD!-MIMOP
 625                                 .TMPAC
 626                                 <1 .ADDRTUP1>
 627                                 <1 .ADDRTUP2>
 628                                 .SELF?
 629                                 VECTOR>)>)>
 630         <COND (.ILDB? <REST-BLOCK-GEN .STRUC1 1 .ILDB? 0 .STYPE1 T>)>
 631         <COND (.IDPB? <REST-BLOCK-GEN .STRUC2 1 .IDPB? 0 .STYPE2 T>)>
 632         NORMAL>
 633
 634 <DEFINE MOVE-ELT (TUP1 TUP2 ST1 ST2 EL1 EL2 IDPB? "AUX" INS ADDR1 ADDR2)
 635         #DECL ((TUP1 TUP2) TUPLE (ST1 ST2 EL1 EL2) <OR ATOM FALSE>)
 636         <COND (<AND <MEMQ .ST1 '[VECTOR LIST]> <MEMQ .ST2 '[VECTOR LIST]>>
 637                <SET INS ,INST-MOVQ>
 638                <SET ADDR1 <4 .TUP1>>
 639                <SET ADDR2 <4 .TUP2>>)
 640               (T
 641                <SET ADDR1 <1 .TUP1>>
 642                <SET ADDR2 <1 .TUP2>>
 643                <COND (<MEMQ .ST1 '[VECTOR LIST]>
 644                       <COND (<==? .ST2 UVECTOR>
 645                              <SET EL2 FIX>
 646                              <SET INS ,INST-MOVL>)
 647                             (<MEMQ .ST2 '[STRING BYTES]>
 648                              <COND (<==? .ST2 STRING> <SET EL2 CHARACTER>)
 649                                    (<SET EL2 FIX>)>
 650                              <SET INS ,INST-CVTLB>)>)
 651                      (<==? .ST1 UVECTOR>
 652                       <COND (<AND .IDPB?
 653                                   <==? .ST2 VECTOR>>
 654                              <EMIT ,INST-MOVL <TYPE-WORD FIX> !.ADDR2>)>
 655                       <COND (<MEMQ .ST2 '[VECTOR LIST UVECTOR]>
 656                              <SET EL2 FIX>
 657                              <SET INS ,INST-MOVL>)
 658                             (T
 659                              <COND (<==? .ST2 STRING> <SET EL2 CHARACTER>)
 660                                    (<SET EL2 FIX>)>
 661                              <SET INS ,INST-CVTLB>)>)
 662                      (T
 663                       <COND (<AND .IDPB?
 664                                   <==? .ST2 VECTOR>>
 665                              <EMIT ,INST-MOVL <TYPE-WORD FIX> !.ADDR2>)>
 666                       <COND (<MEMQ .ST2 '[VECTOR UVECTOR LIST]>
 667                              <COND (<==? .ST2 UVECTOR> <SET EL2 FIX>)>
 668                              <SET INS ,INST-MOVZBL>)
 669                             (T
 670                              <COND (<==? .ST2 STRING> <SET EL2 CHARACTER>)
 671                                    (<SET EL2 FIX>)>
 672                              <SET INS ,INST-MOVB>)>)>)>
 673         <EMIT .INS !.ADDR1 !.ADDR2>
 674         <COND (<NOT .EL2>
 675                <COND (.EL1 <EMIT ,INST-MOVW <TYPE-WORD .EL1> !<2 .TUP2>>)>)>>
 676
 677 <DEFINE DO-ARITH (INS AMOUNT ADDR1 ADDR2 SELF? STYPE1 "AUX" (VAC <>) RAC)
 678    <COND (.SELF? <SET ADDR2 .ADDR1>)>
 679    <COND (<TYPE? .ADDR2 VARTBL>
 680           <COND (<NOT <SET RAC <VAR-VALUE-IN-AC? .ADDR2>>>
 681                  <SET RAC <GET-AC PREF-VAL T>>
 682                  <PROTECT .RAC>)>
 683           <DEST-DECL .RAC .ADDR2 <COND (<MEMQ .INS ,FLOATS> FLOAT)
 684                                        (T FIX)>>)>
 685    <COND
 686     (<MEMQ .INS ,LOGIC>
 687      <COND (<TYPE? .AMOUNT FIX>
 688             <COND (<==? .INS EQV!-MIMOP>
 689                    <SET AMOUNT <CHTYPE <XORB .AMOUNT -1> FIX>>
 690                    <SET INS XOR!-MIMOP>)
 691                   (<==? .INS AND!-MIMOP>
 692                    <SET AMOUNT <CHTYPE <XORB .AMOUNT -1> FIX>>)>)
 693            (<OR <==? .INS EQV!-MIMOP> <==? .INS AND!-MIMOP>>
 694             <EMIT ,INST-MCOML !.ADDR1 <SET VAC <GET-AC PREF-VAL T>>>
 695             <COND (<==? .INS EQV!-MIMOP> <SET INS XOR!-MIMOP>)>)>
 696      <COND (.VAC
 697             <COND (<TYPE? .ADDR2 VARTBL>
 698                    <EMIT <COND (<==? .INS AND!-MIMOP> ,INST-BICL3)
 699                                (<==? .INS XOR!-MIMOP> ,INST-XORL3)
 700                                (<==? .INS OR!-MIMOP> ,INST-BISL3)>
 701                          <MA-REG .VAC>
 702                          <COND (<TYPE? .AMOUNT FIX> <MA-IMM .AMOUNT>)
 703                                (<VAR-VALUE-ADDRESS .AMOUNT>)>
 704                          <MA-REG .RAC>>)
 705                   (T
 706                    <EMIT <COND (<==? .INS AND!-MIMOP> ,INST-BICL3)
 707                                (<==? .INS XOR!-MIMOP> ,INST-XORL3)
 708                                (<==? .INS OR!-MIMOP> ,INST-BISL3)>
 709                          <MA-REG .VAC>
 710                          <COND (<TYPE? .AMOUNT FIX> <MA-IMM .AMOUNT>)
 711                                (<VAR-VALUE-ADDRESS .AMOUNT>)>
 712                          !.ADDR2>)>)
 713            (.SELF?
 714             <EMIT <COND (<==? .INS AND!-MIMOP> ,INST-BICL2)
 715                         (<==? .INS XOR!-MIMOP> ,INST-XORL2)
 716                         (<==? .INS OR!-MIMOP> ,INST-BISL2)>
 717                   <COND (<TYPE? .AMOUNT FIX> <MA-IMM .AMOUNT>)
 718                         (<VAR-VALUE-ADDRESS .AMOUNT>)>
 719                   !.ADDR1>)
 720            (T
 721             <COND (<TYPE? .ADDR2 VARTBL>
 722                    <EMIT <COND (<==? .INS AND!-MIMOP> ,INST-BICL3)
 723                                (<==? .INS XOR!-MIMOP> ,INST-XORL3)
 724                                (<==? .INS OR!-MIMOP> ,INST-BISL3)>
 725                          !.ADDR1
 726                          <COND (<TYPE? .AMOUNT FIX> <MA-IMM .AMOUNT>)
 727                                (<VAR-VALUE-ADDRESS .AMOUNT>)>
 728                          <MA-REG .RAC>>)
 729                   (T
 730                    <EMIT <COND (<==? .INS AND!-MIMOP> ,INST-BICL3)
 731                                (<==? .INS XOR!-MIMOP> ,INST-XORL3)
 732                                (<==? .INS OR!-MIMOP> ,INST-BISL3)>
 733                          !.ADDR1
 734                          <COND (<TYPE? .AMOUNT FIX> <MA-IMM .AMOUNT>)
 735                                (<VAR-VALUE-ADDRESS .AMOUNT>)>
 736                          !.ADDR2>)>)>)
 737     (<AND .SELF? <==? .AMOUNT 1>> <EMIT <PICK-ARITH .INS .STYPE1 1> !.ADDR1>)
 738     (.SELF?
 739      <EMIT <PICK-ARITH .INS .STYPE1 2>
 740            <COND (<TYPE? .AMOUNT FIX> <MA-IMM .AMOUNT>)
 741                  (<TYPE? .AMOUNT FLOAT> <FLOAT-IMM <FLOATCONVERT .AMOUNT>>)
 742                  (<TYPE? .AMOUNT VARTBL> <VAR-VALUE-ADDRESS .AMOUNT>)
 743                  (.AMOUNT)>
 744            !.ADDR1>)
 745     (T
 746      <COND (<TYPE? .ADDR2 VARTBL>
 747             <EMIT <PICK-ARITH .INS .STYPE1 3>
 748                   <COND (<TYPE? .AMOUNT FIX> <MA-IMM .AMOUNT>)
 749                         (<TYPE? .AMOUNT FLOAT>
 750                          <FLOAT-IMM <FLOATCONVERT .AMOUNT>>)
 751                         (<TYPE? .AMOUNT VARTBL> <VAR-VALUE-ADDRESS .AMOUNT>)
 752                         (.AMOUNT)>
 753                   !.ADDR1
 754                   <VAR-VALUE-ADDRESS .ADDR2>>)
 755            (T
 756             <EMIT <PICK-ARITH .INS .STYPE1 3>
 757                   <COND (<TYPE? .AMOUNT FIX> <MA-IMM .AMOUNT>)
 758                         (<TYPE? .AMOUNT FLOAT>
 759                          <FLOAT-IMM <FLOATCONVERT .AMOUNT>>)
 760                         (<TYPE? .AMOUNT VARTBL> <VAR-VALUE-ADDRESS .AMOUNT>)
 761                         (.AMOUNT)>
 762                   !.ADDR1
 763                   !.ADDR2>)>)>>
 764
 765 <SETG ADDS
 766       [[,INST-INCB ,INST-INCW ,INST-INCL]
 767        [,INST-ADDB2 ,INST-ADDW2 ,INST-ADDL2]
 768        [,INST-ADDB3 ,INST-ADDW3 ,INST-ADDL3]]>
 769
 770 <SETG SUBS
 771       [[,INST-DECB ,INST-DECW ,INST-DECL]
 772        [,INST-SUBB2 ,INST-SUBW2 ,INST-SUBL2]
 773        [,INST-SUBB3 ,INST-SUBW3 ,INST-SUBL3]]>
 774
 775 <SETG MULS
 776       [[]
 777        [,INST-MULB2 ,INST-MULW2 ,INST-MULL2]
 778        [,INST-MULB3 ,INST-MULW3 ,INST-MULL3]]>
 779
 780 <SETG DIVS
 781       [[]
 782        [,INST-DIVB2 ,INST-DIVW2 ,INST-DIVL2]
 783        [,INST-DIVB3 ,INST-DIVW3 ,INST-DIVL3]]>
 784
 785 <SETG FLOAT-OPS
 786       [[]
 787        [,INST-ADDF2 ,INST-SUBF2 ,INST-MULF2 ,INST-DIVF2]
 788        [,INST-ADDF3 ,INST-SUBF3 ,INST-MULF3 ,INST-DIVF3]]>
 789
 790 <GDECL (LOGIC) VECTOR (FLOAT-OPS ADDS SUBS MULS DIVS) <VECTOR [REST VECTOR]>>
 791
 792 <SETG LOGIC '[AND!-MIMOP OR!-MIMOP XOR!-MIMOP EQV!-MIMOP]>
 793
 794 <SETG FLOATS '[ADDF!-MIMOP SUBF!-MIMOP MULF!-MIMOP DIVF!-MIMOP]>
 795
 796 <DEFINE PICK-ARITH (OP STYPE NUMOPS "AUX" TV)
 797         #DECL ((NUMOPS) FIX (OP) ATOM (STYPE) ATOM (TV) VECTOR)
 798         <COND (<==? .OP ADD!-MIMOP> <SET TV <NTH ,ADDS .NUMOPS>>)
 799               (<==? .OP SUB!-MIMOP> <SET TV <NTH ,SUBS .NUMOPS>>)
 800               (<==? .OP MUL!-MIMOP> <SET TV <NTH ,MULS .NUMOPS>>)
 801               (<==? .OP DIV!-MIMOP> <SET TV <NTH ,DIVS .NUMOPS>>)
 802               (T
 803                <SET TV <NTH ,FLOAT-OPS .NUMOPS>>)>
 804         <COND (<MEMQ .OP ,FLOATS>
 805                <COND (<==? .OP ADDF!-MIMOP> <1 .TV>)
 806                      (<==? .OP SUBF!-MIMOP> <2 .TV>)
 807                      (<==? .OP MULF!-MIMOP> <3 .TV>)
 808                      (<==? .OP DIVF!-MIMOP> <4 .TV>)>)
 809               (<MEMQ .STYPE '[VECTOR UVECTOR LIST]> <3 .TV>)
 810               (<==? .STYPE WORD> <2 .TV>)
 811               (<1 .TV>)>>
 812
 813 <DEFINE GET-ADDR (TUP STRUC SAC OFFSET STYPE AINC?
 814                   "OPTIONAL" (RIDXAC <>) (FULL? <>)
 815                   "AUX" IDXAC)
 816         #DECL ((TUP) <TUPLE [3 ANY]> (SAC) AC (OFFSET) <OR FIX VARTBL>
 817                (STYPE) ATOM)
 818         <COND (<AND <==? .STYPE LIST> <N==? .OFFSET 1>>
 819                <COND (<TYPE? .OFFSET FIX>
 820                       <SET SAC <LIST-REST-CONSTANT-GEN .STRUC <- .OFFSET 1>>>)
 821                      (<SET SAC <LIST-REST-VAR-GEN .STRUC .OFFSET NTH>>)>
 822                <SET OFFSET 1>)>
 823         <COND (.AINC? <1 .TUP (<MA-AINC .SAC>)>)
 824               (<TYPE? .OFFSET FIX>
 825                <COND (<1? .OFFSET>
 826                       <COND (<OR <==? .STYPE VECTOR> <==? .STYPE LIST>>
 827                              <4 .TUP (<MA-REGD .SAC>)>
 828                              <2 .TUP (<MA-DISP .SAC 2>)>
 829                              <1 .TUP (<MA-DISP .SAC 4>)>)
 830                             (<1 .TUP (<MA-REGD .SAC>)>)>)
 831                      (T
 832                       <COND (<==? .STYPE VECTOR>
 833                              <4 .TUP (<MA-DISP .SAC <* 8 <- .OFFSET 1>>>)>
 834                              <2 .TUP
 835                                 (<MA-DISP .SAC <+ 2 <* 8 <- .OFFSET 1>>>>)>
 836                              <1 .TUP
 837                                 (<MA-DISP .SAC <+ 4 <* 8 <- .OFFSET 1>>>>)>)
 838                             (<==? .STYPE UVECTOR>
 839                              <1 .TUP (<MA-DISP .SAC <* 4 <- .OFFSET 1>>>)>)
 840                             (T <1 .TUP (<MA-DISP .SAC <- .OFFSET 1>>)>)>)>)
 841               (T
 842                <COND (<AND <NOT .RIDXAC>
 843                            <NOT <SET IDXAC <VAR-VALUE-IN-AC? .OFFSET>>>>
 844                       <COND (<OR <N==? .STYPE VECTOR> .FULL?>
 845                              <SET IDXAC <LOAD-VAR .OFFSET VALUE <> PREF-VAL>>)
 846                             (T
 847                              <SET IDXAC <GET-AC PREF-VAL>>
 848                              <EMIT ,INST-ASHL
 849                                    <MA-IMM 1>
 850                                    <VAR-VALUE-ADDRESS .OFFSET>
 851                                    <MA-REG .IDXAC>>)>
 852                       <PROTECT-USE .IDXAC>
 853                       <3 .TUP .IDXAC>)
 854                      (<AND <NOT .RIDXAC> <NOT .FULL?> <==? .STYPE VECTOR>>
 855                       <EMIT ,INST-ASHL
 856                             <MA-IMM 1>
 857                             <MA-REG .IDXAC>
 858                             <MA-REG .IDXAC>>
 859                       <MUNG-AC .IDXAC T>
 860                       <3 .TUP .IDXAC>)>
 861                <COND (<==? .STYPE VECTOR>
 862                       <4 .TUP (<MA-INDX .IDXAC> <MA-DISP .SAC -8>)>
 863                       <2 .TUP (<MA-INDX .IDXAC> <MA-DISP .SAC -6>)>
 864                       <1 .TUP (<MA-INDX .IDXAC> <MA-DISP .SAC -4>)>)
 865                      (<==? .STYPE UVECTOR>
 866                       <1 .TUP (<MA-INDX .IDXAC> <MA-DISP .SAC -4>)>)
 867                      (T <1 .TUP (<MA-INDX .IDXAC> <MA-DISP .SAC -1>)>)>)>>
 868
 869 \\f
 870
 871 <DEFINE ILDB-LOOKAHEAD (L)
 872    #DECL ((L) <LIST [REST <OR ATOM FORM>]>)
 873    <COND
 874     (,LOOKAHEAD?
 875      <MAPR <>
 876       <FUNCTION (LL "AUX" (FROB <1 .LL>) INS (REST? <>) (PUT? <>) NINS)
 877               <COND (<AND <TYPE? .FROB FORM> <NOT <GETPROP .FROB DONE>>>
 878                      <COND (<==? <SET INS <1 .FROB>> SETLR!-MIMOP>
 879                             <COND (<AND <NOT <EMPTY? <REST .LL>>>
 880                                         <TYPE? <SET NINS <2 .LL>> FORM>
 881                                         <==? <1 .NINS> PUSH!-MIMOP>
 882                                         <==? <2 .NINS> <2 .FROB>>
 883                                         <WILL-DIE? <2 .FROB> <REST .LL 2>>>
 884                                    <2 .FROB STACK>
 885                                    <PUTPROP .NINS DONE T>)>)
 886                            (<AND <OR <SET REST? <MEMQ .INS ,RESTU>>
 887                                      <SET PUT? <MEMQ .INS ,PUTU>>
 888                                      <MEMQ .INS ,NTHU>>
 889                                  <==? <3 .FROB> 1>>
 890                                          ;"This could be something interesting"
 891                             <ILDB-LOOKAHEAD-ONE .LL .REST? .PUT?>)>)>>
 892       .L>)>>
 893
 894 ;
 895 "Find ILDB/IDPB case, put MIMA code for it into list, kill other half of
 896    operation.  Form of ops is:
 897 <ILDB STRUC NTHRES RESTRES (STRUCTURE-TYPE FOO)>
 898 <IDPB STRUC NEWVAL RESTRES (STRUCTURE-TYPE FOO)>"
 899
 900 <DEFINE ILDB-LOOKAHEAD-ONE (L REST? PUT?
 901                             "AUX" (OP-INFO ,OP-INFO)
 902                                   (ARGVEC <OP-ARGS .OP-INFO>) STRUC RES OP
 903                                   OTHOP PUTOP)
 904    #DECL ((L) <LIST [REST <OR ATOM FORM>]> (OP-INFO) OP-INFO)
 905    <PARSE-OP <1 .L> .OP-INFO>
 906    <SET OP <1 <1 .L>>>
 907    <SET OTHOP <GETPROP .OP PAIR>>
 908    <SET PUTOP <GETPROP .OP PUT-PAIR>>
 909    <SET STRUC <1 .ARGVEC>>
 910    <SET RES <OP-RES .OP-INFO>>
 911    <MAPR <>
 912     <FUNCTION (LL "AUX" (FROB <1 .LL>) INS HINT)
 913             <COND (<TYPE? .FROB ATOM> <MAPLEAVE>)>
 914             <COND (<AND <OR <==? <1 .FROB> .OTHOP>
 915                             <AND <OR .PUT? .REST?> <==? <1 .FROB> .PUTOP>>>
 916                         <==? <2 .FROB> .STRUC>
 917                         <==? <3 .FROB> 1>>        ;"We now have the paired guy"
 918                    <COND (<MEMQ .OP ,RESTU> <SET HINT <REST <SPNAME .OP> 4>>)
 919                          (<SET HINT <REST <SPNAME .OP> 3>>)>
 920                    <COND (<=? .HINT "UV"> <SET HINT '(STRUCTURE-TYPE VECTOR)>)
 921                          (<=? .HINT "UU"> <SET HINT '(STRUCTURE-TYPE
 922                                                       UVECTOR)>)
 923                          (<=? .HINT "US"> <SET HINT '(STRUCTURE-TYPE STRING)>)
 924                          (T <SET HINT '(STRUCTURE-TYPE BYTES)>)>
 925                    <PARSE-OP .FROB .OP-INFO>
 926                    <COND (<OR .PUT? <MEMQ <1 .FROB> ,PUTU>>
 927                           <1 .L
 928                              <FORM IDPB!-MIMOP
 929                                    .STRUC
 930                                    <COND (.PUT? <4 <1 .L>>) (<3 .ARGVEC>)>
 931                                    <COND (.PUT? <OP-RES .OP-INFO>) (.RES)>
 932                                    .HINT>>
 933                           <PUTPROP .FROB DONE T>)
 934                          (<1 .L
 935                              <FORM ILDB!-MIMOP
 936                                    .STRUC
 937                                    <COND (.REST? <OP-RES .OP-INFO>) (.RES)>
 938                                    <COND (.REST? .RES) (<OP-RES .OP-INFO>)>
 939                                    .HINT>>
 940                           <PUTPROP .FROB DONE T>)>
 941                    <MAPLEAVE>)
 942                   (<OR <MEMQ .STRUC .FROB>
 943                        <MEMQ + .FROB>
 944                        <MEMQ - .FROB>
 945                        <AND <PARSE-OP .FROB .OP-INFO> <OP-BRANCH .OP-INFO>>>
 946                    <MAPLEAVE>)>>
 947     <REST .L>>>
 948
 949 "Generate ILDB/IDPB-like stuff.  Call with NTH/PUT inst, structure,
 950  result of nth/put, result of rest, flag, new value for put"
 951
 952 <DEFINE IDPB-GEN (STRUC ELVAL STRES HINT)
 953         <ILDB-GEN .STRUC .ELVAL .STRES .HINT T>>
 954
 955 <DEFINE ILDB-GEN IG (STRUC ELVAL STRES HINT
 956                      "OPTIONAL" (PUT? <>)
 957                      "AUX" EHINT VINS STRAC ELAC (ELTAC <>) (DOUBLE? <>) LVAR
 958                            TAC VAC ELADDR (NO-TYPE? <>))
 959    #DECL ((STRUC) VARTBL (ELVAL) ANY)
 960    <COND (<AND <TYPE? .ELVAL ATOM VARTBL>
 961                <NTH-LOOK-AHEAD ILDB!-MIMOP .STRUC .STRES .ELVAL <> .HINT>>
 962           <RETURN NORMAL .IG>)>
 963    <SET HINT <PARSE-HINT .HINT STRUCTURE-TYPE>>
 964    <COND (<==? .HINT VECTOR>
 965           <SET DOUBLE? T>
 966           <SET VINS ,INST-MOVQ>
 967           <SET EHINT <>>)
 968          (<==? .HINT UVECTOR> <SET VINS ,INST-MOVL> <SET EHINT FIX>)
 969          (<==? .HINT BYTES>
 970           <SET EHINT FIX>
 971           <COND (.PUT? <SET VINS ,INST-MOVB>) (<SET VINS ,INST-MOVZBL>)>)
 972          (<==? .HINT STRING>
 973           <SET EHINT CHARACTER>
 974           <COND (.PUT? <SET VINS ,INST-MOVB>) (<SET VINS ,INST-MOVZBL>)>)>
 975    <COND (<NOT <SET STRAC <VAR-VALUE-IN-AC? .STRUC>>>
 976           <SET STRAC <LOAD-VAR .STRUC VALUE <> PREF-VAL>>)>
 977                                                        ;"Get structure into AC"
 978    <PROTECT .STRAC>
 979    <COND (<N==? .STRAC ,AC-0> <PROTECT <PREV-AC .STRAC>>)>
 980    <COND
 981     (.PUT?
 982      <COND
 983       (<TYPE? .ELVAL VARTBL>
 984                           ;"Get the address to use for the thing we're putting"
 985        <COND
 986         (<SET LVAR <FIND-CACHE-VAR .ELVAL>>
 987          <COND (.DOUBLE? <SET TAC <LINKVAR-TYPE-WORD-AC .LVAR>>)
 988                (<SET TAC <>>)>
 989          <SET VAC <LINKVAR-VALUE-AC .LVAR>>
 990          <COND (<OR <NOT .DOUBLE?>
 991                     <AND .VAC .TAC <==? .VAC <NEXT-AC .TAC>>>
 992                     <AND <NOT .VAC> <NOT .TAC>>>
 993                                      ;"Case where all in acs or all not in acs"
 994                 <COND (.DOUBLE? <SET ELADDR <VAR-TYPE-ADDRESS .ELVAL>>)
 995                       (T <SET ELADDR <VAR-VALUE-ADDRESS .ELVAL>>)>)
 996                (<AND <OR <NOT .TAC> <LINKVAR-TYPE-STORED .LVAR>>
 997                      <OR <NOT .VAC> <LINKVAR-VALUE-STORED .LVAR>>>
 998                                                   ;"Everything safely on stack"
 999                 <SET ELADDR <ADDR-VAR-TYPE .ELVAL>>)
1000                (T         ;"Type and value live in separate places, can't MOVQ"
1001                 <COND (<AND .LVAR
1002                             <NOT <LINKVAR-TYPE-STORED .LVAR>>
1003                             <NOT .TAC>
1004                             <VARTBL-DECL .ELVAL>>
1005                        <SET NO-TYPE? <TYPE-WORD <VARTBL-DECL .ELVAL>>>)
1006                       (T <SET NO-TYPE? <VAR-TYPE-ADDRESS .ELVAL>>)>
1007                 <SET ELADDR <VAR-VALUE-ADDRESS .ELVAL>>)>)
1008         (.DOUBLE? <SET ELADDR <VAR-TYPE-ADDRESS .ELVAL>>)
1009         (<SET ELADDR <VAR-VALUE-ADDRESS .ELVAL>>)>)
1010       (.DOUBLE? <SET ELADDR <ADDR-TYPE-MQUOTE .ELVAL>>)
1011       (<SET ELADDR <MA-IMM .ELVAL>>)>)
1012     (<==? .ELVAL STACK>                             ;"Only happens in NTH case"
1013      <COND (<NOT .DOUBLE?> <EMIT-PUSH <TYPE-WORD .EHINT> LONG>)>
1014      <SET ELAC <MA-AINC ,AC-TP>>)
1015     (<==? .ELVAL .STRUC>
1016      <COND (.DOUBLE? <SET ELAC <GET-AC DOUBLE T>>)
1017            (<SET ELAC <GET-AC PREF-VAL T>>)>)
1018     (<NOT <AND <SET ELAC <VAR-VALUE-IN-AC? .ELVAL>>
1019                <OR <NOT .DOUBLE?>
1020                    <AND <SET ELTAC <VAR-TYPE-WORD-IN-AC? .ELVAL>>
1021                         <==? <NEXT-AC .ELTAC> .ELAC>>>>>
1022      <DEAD-VAR .ELVAL>
1023      <COND (.DOUBLE? <SET ELAC <GET-AC DOUBLE T>>)
1024            (<SET ELAC <GET-AC PREF-VAL T>>)>)
1025     (T
1026      <DEAD-VAR .ELVAL>
1027      <COND (.DOUBLE?
1028             <STORE-AC .ELTAC T <FIND-CACHE-VAR .ELVAL>>
1029             <STORE-AC .ELAC T <FIND-CACHE-VAR .ELVAL>>
1030             <SET ELAC .ELTAC>)
1031            (T <STORE-AC .ELAC T <FIND-CACHE-VAR .ELVAL>>)>)>
1032                                                         ;"Get AC[s] for result"
1033    <REST-BLOCK-GEN .STRUC
1034                    1
1035                    .STRES
1036                    0
1037                    <>
1038                    .VINS
1039                    <COND (.PUT? .ELADDR) (.ELAC)>
1040                    .PUT?
1041                    .NO-TYPE?>
1042    <COND (<AND <NOT .PUT?> <N==? .ELVAL STACK>>
1043           <COND (.DOUBLE? <DEST-PAIR <NEXT-AC .ELAC> .ELAC .ELVAL>)
1044                 (<LINK-VAR-TO-AC .ELVAL .ELAC VALUE <>>)>
1045           <COND (.EHINT <DEST-DECL .ELAC .ELVAL .EHINT>)>)>
1046    NORMAL>
1047
1048 \\f
1049
1050 <DEFINE NTH-LENGTH-GEN (CINS STRUC OFF STYPE RES
1051                         "AUX" SAC (TUP <ITUPLE 5 <>>) RAC)
1052         <COND (<NOT <SET SAC <VAR-VALUE-IN-AC? .STRUC>>>
1053                <SET SAC <LOAD-VAR .STRUC VALUE <> PREF-VAL>>)>
1054         <PROTECT-USE .SAC>
1055         <GET-ADDR .TUP .STRUC .SAC .OFF .STYPE <> <> T>
1056         <COND (<NOT <SET RAC <VAR-VALUE-IN-AC? .RES>>>
1057                <SET RAC <GET-AC PREF-VAL T>>)>
1058         <EMIT ,INST-MOVW !<2 .TUP> <MA-REG .RAC>>
1059         <LINK-VAR-TO-AC .RES .RAC VALUE <>>
1060         <DEST-DECL .RAC .RES FIX>
1061         NORMAL>
1062
1063 <DEFINE NTH-LENGTH-COMP-GEN (CINS STRUC OFF STYPE AMT CMPINS OP-INFO
1064                              "AUX" SAC (TUP <ITUPLE 5 <>>))
1065         #DECL ((OP-INFO) OP-INFO)
1066         <COND (<NOT <SET SAC <VAR-VALUE-IN-AC? .STRUC>>>
1067                <SET SAC <LOAD-VAR .STRUC VALUE <> PREF-VAL>>)>
1068         <PROTECT-USE .SAC>
1069         <GET-ADDR .TUP .STRUC .SAC .OFF .STYPE <> <> T>
1070         <COND (<==? .AMT 0>
1071                <COND (<==? .CMPINS EMPL?!-MIMOP>
1072                       <EMIT ,INST-TSTL !<1 .TUP>>)
1073                      (<EMIT ,INST-TSTW !<2 .TUP>>)>)
1074               (<TYPE? .AMT FIX> <EMIT ,INST-CMPW !<2 .TUP> <MA-IMM .AMT>>)
1075               (T <EMIT ,INST-CMPW !<2 .TUP> <VAR-VALUE-ADDRESS .AMT>>)>
1076         <GEN-TEST-INST
1077          <COMPUTE-DIRECTION <OP-DIR .OP-INFO>
1078                             <COND (<MEMQ .CMPINS ,EMPU> ,CEQ-CODE)
1079                                   (<==? .CMPINS EMPL?!-MIMOP> ,CEQ-CODE)
1080                                   (<==? .CMPINS VEQUAL?!-MIMOP> ,CEQ-CODE)
1081                                   (<==? .CMPINS LESS?!-MIMOP> ,CLT-CODE)
1082                                   (<==? .CMPINS GRTR?!-MIMOP> ,CGT-CODE)>>
1083          <OP-BRANCH .OP-INFO>
1084          <>>
1085         CONDITIONAL-BRANCH>
1086
1087 <DEFINE SLOT-COMPARE (STRUC1 STRUC2 CMPINS OP-INFO OFF1 STYPE1 OFF2 STYPE2
1088                       "AUX" (SAC1 <>) (SAC2 <>) (ADDR1 <ITUPLE 5 <>>)
1089                             (ADDR2 <ITUPLE 5 <>>) (SHORT? <>) TMP FC)
1090         #DECL ((ADDR1 ADDR2) <OR TUPLE EFF-ADDR LADDR>)
1091         <COND (<OR <MEMQ .STYPE1 '[STRING BYTES]>
1092                    <MEMQ .STYPE2 '[STRING BYTES]>>
1093                <SET SHORT? T>)>
1094         <COND (<AND .OFF2 <NOT .OFF1>>
1095                <SET OFF1 .OFF2>
1096                <SET OFF2 <>>
1097                <SET STYPE1 .STYPE2>
1098                <SET STYPE2 <>>
1099                <SET TMP .STRUC2>
1100                <SET STRUC2 .STRUC1>
1101                <SET STRUC1 .TMP>
1102                <SET CMPINS <COND (<==? .CMPINS GRTR?!-MIMOP>
1103                                   LESS?!-MIMOP)
1104                                  (<==? .CMPINS LESS?!-MIMOP>
1105                                   GRTR?!-MIMOP)
1106                                  (T .CMPINS)>>)>
1107         <COND (.OFF1
1108                <COND (<NOT <SET SAC1 <VAR-VALUE-IN-AC? .STRUC1>>>
1109                       <SET SAC1 <LOAD-VAR .STRUC1 VALUE <> PREF-VAL>>)>
1110                <PROTECT-USE .SAC1>)>
1111         <COND (.OFF2
1112                <COND (<N==? .STRUC1 .STRUC2>
1113                       <COND (<NOT <SET SAC2 <VAR-VALUE-IN-AC? .STRUC2>>>
1114                              <SET SAC2 <LOAD-VAR .STRUC2 VALUE <> PREF-VAL>>)>
1115                       <PROTECT-USE .SAC2>)
1116                      (T <SET SAC2 .SAC1>)>)>
1117         <COND (.OFF1 <GET-ADDR .ADDR1 .STRUC1 .SAC1 .OFF1 .STYPE1 <>>)
1118               (<TYPE? .STRUC1 VARTBL>
1119                <SET ADDR1 <VAR-VALUE-ADDRESS .STRUC1>>)
1120               (<FIX-CONSTANT? .STRUC1>
1121                <COND (<NOT <TYPE? .STRUC1 FLOAT>>
1122                       <SET ADDR1 <MA-IMM .STRUC1>>)
1123                      (T
1124                       <SET ADDR1 <FLOAT-IMM <FLOATCONVERT .STRUC1>>>)>)
1125               (<AND <==? <PRIMTYPE .STRUC1> LIST>
1126                     <EMPTY? .STRUC1>>
1127                <SET STRUC1 0>
1128                <SET ADDR1 <MA-IMM 0>>)
1129               (T
1130                <SET ADDR1 <ADDR-VALUE-MQUOTE .STRUC1>>)>
1131         <COND (<NOT .OFF2>
1132                <COND (<TYPE? .STRUC2 VARTBL>
1133                       <SET ADDR2 <VAR-VALUE-ADDRESS .STRUC2>>)
1134                      (<FIX-CONSTANT? .STRUC2>
1135                       <COND (<NOT <TYPE? .STRUC2 FLOAT>>
1136                              <SET ADDR2 <MA-IMM .STRUC2>>)
1137                             (T
1138                              <SET ADDR2 <FLOAT-IMM <FLOATCONVERT .STRUC2>>>)>)
1139                      (<AND <==? <PRIMTYPE .STRUC2> LIST>
1140                            <EMPTY? .STRUC2>>
1141                       <SET STRUC2 0>
1142                       <SET ADDR2 <MA-IMM 0>>)
1143                      (T
1144                       <SET ADDR2 <ADDR-VALUE-MQUOTE .STRUC2>>)>)
1145               (<AND <3 .ADDR1>                  ;"First guy had index register"
1146                     <==? .OFF1 .OFF2>
1147                     <TYPE? .OFF2 VARTBL>
1148                     <OR <==? .STYPE1 .STYPE2> .SHORT?>>
1149                <GET-ADDR .ADDR2 .STRUC2 .SAC2 .OFF2 .STYPE2 <> <3 .ADDR1>>)
1150               (T <GET-ADDR .ADDR2 .STRUC2 .SAC2 .OFF2 .STYPE2 <>>)>
1151         <COND (<OR <==? .STRUC1 0> <==? .STRUC2 0>>
1152                <EMIT <COND (.SHORT? ,INST-TSTB) (,INST-TSTL)>
1153                      !<COND (<==? .STRUC1 0> <1 .ADDR2>) (<1 .ADDR1>)>>)
1154               (<OR <==? .STRUC1 0.0> <==? .STRUC2 0.0>>
1155                <EMIT ,INST-TSTF
1156                      !<COND (<==? .STRUC1 0.0> <1 .ADDR2>) (<1 .ADDR1>)>>)
1157               (<OR <TYPE? .STRUC1 FLOAT> <TYPE? .STRUC2 FLOAT>>
1158                <EMIT ,INST-CMPF
1159                      !<COND (<TYPE? .ADDR1 TUPLE> <1 .ADDR1>)((.ADDR1))>
1160                      !<COND (<TYPE? .ADDR2 TUPLE> <1 .ADDR2>)((.ADDR2))>>)
1161               (T
1162                <EMIT <COND (.SHORT? ,INST-CMPB) (T ,INST-CMPL)>
1163                      !<COND (<TYPE? .ADDR1 TUPLE> <1 .ADDR1>) ((.ADDR1))>
1164                      !<COND (<TYPE? .ADDR2 TUPLE> <1 .ADDR2>) ((.ADDR2))>>)>
1165         <GEN-TEST-INST
1166          <COMPUTE-DIRECTION <OP-DIR .OP-INFO>
1167                             <COND (<==? .CMPINS VEQUAL?!-MIMOP> ,CEQ-CODE)
1168                                   (<==? .CMPINS LESS?!-MIMOP> ,CLT-CODE)
1169                                   (<==? .CMPINS GRTR?!-MIMOP> ,CGT-CODE)>>
1170          <OP-BRANCH .OP-INFO>
1171          <>>
1172         CONDITIONAL-BRANCH>