mim/development/mim/mimc/mimgen.mud

   1
   2 <PACKAGE "MIMGEN">
   3
   4 <ENTRY MAKE-TAG
   5        FIND-FRAME
   6        SPEC-GEN-TEMP
   7        PREV-FRAME
   8        GEN-VAL-==?
   9        GEN-==?
  10        GET-BINDING
  11        BRANCH-TAG
  12        RET-TMP-AC
  13        MIM-FCN
  14        MIM-RETURN
  15        REFERENCE
  16        GEN-TYPE?
  17        GEN-VT
  18        GEN-TC
  19        GEN-CHTYPE
  20        GEN-GVAL
  21        GEN-SETG
  22        MIM-TEMPS-HOLD
  23        MIM-TEMPS-EMIT
  24        EMIT
  25        IEMIT
  26        INSTRUCTION
  27        LABEL-TAG
  28        PUSH
  29        POP
  30        PUSH-CONSTANT
  31        GEN-FIX-BIND
  32        SPECIAL-BINDING
  33        FINISH-BINDING
  34        SET-TEMP
  35        SET-SYM
  36        CURRENT-FRAME
  37        GET-ARG-TUPLE
  38        ARG-TO-TEMP
  39        TEST-ARG
  40        MSUBR-CALL
  41        SEG-SUBR-CALL
  42        START-FRAME
  43        GEN-LIST
  44        GEN-VECTOR
  45        GEN-UVECTOR
  46        GEN-TUPLE
  47        MOVE-ARG
  48        GEN-CHTYPE
  49        D-B-TAG
  50        GEN-TEMP
  51        NTH-LIST
  52        NTH-UVECTOR
  53        NTH-VECTOR
  54        NTH-STRING
  55        NTH-RECORD
  56        NTH-BYTES
  57        REST-LIST
  58        REST-UVECTOR
  59        REST-VECTOR
  60        REST-STRING
  61        REST-BYTES
  62        REST-RECORD
  63        EMPTY-LIST
  64        EMPTY-UVECTOR
  65        EMPTY-VECTOR
  66        EMPTY-STRING
  67        EMPTY-BYTES
  68        EMPTY-RECORD
  69        PUT-LIST
  70        PUT-UVECTOR
  71        PUT-VECTOR
  72        PUT-STRING
  73        PUT-BYTES
  74        PUT-RECORD
  75        LENGTH-LIST
  76        LENGTH-UVECTOR
  77        LENGTH-VECTOR
  78        LENGTH-STRING
  79        LENGTH-BYTES
  80        LENGTH-RECORD
  81        PROTECT
  82        USE-TEMP
  83        FREE-TEMP
  84        DEALLOCATE-TEMP
  85        GEN-SHIFT
  86        GEN-ARG-NUM
  87        SET-VALUE
  88        GET-VALUE-X
  89        ATOMCHK
  90        ISPEC-BIND
  91        GEN-GASS
  92        ASS-GEN
  93        M$$VALU
  94        TYPIFY-TEMPS
  95        SPEC-IEMIT>
  96
  97 <USE "CHKDCL" "COMPDEC" "ADVMESS">
  98
  99 <SETG RAT (`RECORD-TYPE ATOM)>
 100
 101 <SETG RBN (`RECORD-TYPE LBIND)>
 102
 103 <SETG RGBN (`RECORD-TYPE GBIND)>
 104
 105 <SETG QQ-BIND <FORM QUOTE BIND>>
 106
 107 <BLOCK (<ROOT>)>
 108
 109 M$$BINDID
 110
 111 <ENDBLOCK>
 112
 113 <SETG QQ-M$$BINDID <FORM QUOTE M$$BINDID>>
 114
 115 <SETG NO-DATUM '(1)>
 116
 117 <GDECL (MIMOPS) VECTOR>
 118
 119 <SETG M$$FRM-MSUB 1>
 120
 121 <SETG M$$FRM-PC 2>
 122
 123 <SETG M$$FRM-ARGN 3>
 124
 125 <SETG M$$FRM-ID 4>
 126
 127 <SETG M$$FRM-PREV 5>
 128
 129 <SETG M$$FRM-TP 6>
 130
 131 <SETG M$$FRM-ARGS 6>
 132
 133 <SETG M$$FRM-BIND 7>
 134
 135 <SETG M$$FRM-ACTN 8>
 136
 137 <MANIFEST M$$FRM-MSUB
 138           M$$FRM-ARGN
 139           M$$FRM-ID
 140           M$$FRM-PREV
 141           M$$FRM-BIND
 142           M$$FRM-ARGS
 143           M$$FRM-ACTN
 144           M$$FRM-PC
 145           M$$FRM-TP>
 146
 147 <SETG M$$GVAL 1>
 148
 149 <SETG M$$LVAL 2>
 150
 151 <SETG M$$PNAM 3>
 152
 153 <SETG M$$OBLS 4>
 154
 155 <SETG M$$TYPE 5>
 156
 157 <SETG M$$ATML 5>
 158
 159 <MANIFEST M$$LVAL M$$GVAL M$$PNAM M$$OBLS M$$TYPE M$$ATML>
 160
 161 <SETG M$$VALU 1>
 162
 163 <SETG M$$ATOM 2>
 164
 165 <SETG M$$DECL 3>
 166
 167 <SETG M$$PBND 4>
 168
 169 <SETG M$$PATM 5>
 170
 171 <SETG M$$UBID 6>
 172
 173 <SETG M$$BNDL 6>
 174
 175 <MANIFEST M$$VALU M$$ATOM M$$DECL M$$PBND M$$PATM M$$UBID M$$BNDL>
 176
 177 <SETG MIMOPS
 178       [("PUSH" ANY)
 179        ("POP" ANY)
 180        ("SET" ANY)
 181        ("SETS" ANY)
 182        ("GETS" ANY)
 183        ("ADJ" ANY)
 184        ("FRAME" ANY)
 185        ("VFRAME" ANY)
 186        ("CFRAME" ANY)
 187        ("ARGS" TUPLE)
 188        ("TUPLE" TUPLE)
 189        ("RFRAME" NO-RETURN)
 190        ("CALL" ANY)
 191        ("ACTIVATION" ANY)
 192        ("AGAIN" NO-RETURN)
 193        ("RET" NO-RETURN)
 194        ("RTUPLE" NO-RETURN)
 195        ("JUMP" NO-RETURN)
 196        ("HALT" ANY)
 197        ("OBJECT" ANY)
 198        ("TYPE" FIX)
 199        ("TYPE?" ANY)
 200        ("CHTYPE" ANY)
 201        ("NEWTYPE" FIX)
 202        ("VALUE" FIX)
 203        ("LIST" LIST)
 204        ("UBLOCK" ANY)
 205        ("RECORD" ANY)
 206        ("NTHL" ANY)
 207        ("NTHR" ANY T)
 208        ("NTHU" ANY)
 209        ("LENL" FIX)
 210        ("LENR" FIX T)
 211        ("LENU" FIX)
 212        ("EMPL?" ANY)
 213        ("EMPR?" ANY T)
 214        ("EMPU?" ANY)
 215        ("PUTL" LIST)
 216        ("PUTU" ANY)
 217        ("PUTR" ANY T)
 218        ("RESTL" LIST)
 219        ("RESTU" ANY)
 220        ("BACKU" ANY)
 221        ("TOPU" ANY)
 222        ("CONS" LIST)
 223        ("PUTREST" LIST)
 224        ("BIND" ANY)
 225        ("SETG" ANY)
 226        ("GVAL" ANY)
 227        ("OPEN" ANY)
 228        ("CLOSE" ANY)
 229        ("READ" ANY)
 230        ("PRINT" ANY)
 231        ("SAVE" ANY)
 232        ("RESTORE" ANY)
 233        ("ADD" FIX)
 234        ("ADDF" FLOAT)
 235        ("SUB" FIX)
 236        ("SUBF" FLOAT)
 237        ("MUL" FIX)
 238        ("MULF" FLOAT)
 239        ("DIV" FIX)
 240        ("DIVF" FLOAT)
 241        ("RANDOM" FIX)
 242        ("FIX" FIX)
 243        ("FLOAT" FLOAT)
 244        ("GRTR?" ANY)
 245        ("LESS?" ANY)
 246        ("AND" FIX)
 247        ("OR" FIX)
 248        ("XOR" FIX)
 249        ("EQV" FIX)
 250        ("LSH" FIX)
 251        ("ROT" FIX)
 252        ("EQUAL?" ANY)
 253        ("VEQUAL?" ANY)
 254        ("RESET" ANY)
 255        ("ATIC" FIX)
 256        ("MARKL?" ANY)
 257        ("MARKU?" ANY)
 258        ("MARKR?" ANY)
 259        ("MARKL" ANY)
 260        ("MARKU" ANY)
 261        ("MARKR" ANY)
 262        ("MARKUV?" ANY)
 263        ("MARKUV" ANY)
 264        ("MARKUU" ANY)
 265        ("MARKUU?" ANY)
 266        ("MARKUS" ANY)
 267        ("MARKUS?" ANY)
 268        ("MARKUB" ANY)
 269        ("MARKUB?" ANY)
 270        ("SWEEP" ANY)
 271        ("RETRY" NO-RETURN)
 272        ("LOOP" ANY)
 273        ("IRECORD" ANY)
 274        ("TEMPLATE-TABLE" ANY)
 275        ("CONTENTS" ANY)
 276        ("NEXTS" FIX)
 277        ("SWNEXT" ANY)
 278        ("RELL" ANY)
 279        ("RELU" ANY)
 280        ("RELR" ANY)
 281        ("INTGO" ANY)
 282        ("PFRAME" ANY)
 283        ("NTH1" ANY)
 284        ("REST1" ANY)
 285        ("EMPTY?" ANY)
 286        ("MONAD?" ANY)
 287        ("QUIT" ANY)
 288        ("SYSCALL" ANY)
 289        ("LEGAL?" ANY)
 290        ("SETZONE" ANY)
 291        ("BLT" ANY T)
 292        ("ALLOCR" ANY T)
 293        ("ALLOCUU" ANY)
 294        ("ALLOCUV" ANY)
 295        ("ALLOCL" ANY)
 296        ("ALLOCUS" ANY)
 297        ("ALLOCUB" ANY)
 298        ("PUTS" ANY)
 299        ("SYSOP" ANY)
 300        ("MPAGES" FIX)
 301        ("ACALL" ANY)
 302        ("LOCK" ANY)
 303        ("RNTIME" FLOAT)
 304        ("TYPEW" ANY)
 305        ("TYPEWC" ANY)
 306        ("SAVTTY" ANY)
 307        ("FATAL" ANY)
 308        ("GETTTY" ANY)
 309        ("FGETBITS" ANY)
 310        ("FPUTBITS" ANY)
 311        ("PIPE" ANY)
 312        ("IFSYS" ANY)
 313        ("ENDIF" ANY)
 314        ("CGC-UVECTOR" ANY)
 315        ("CGC-VECTOR" ANY)
 316        ("CGC-STRING" ANY)
 317        ("CGC-BYTES" ANY)
 318        ("CGC-LIST" ANY)
 319        ("CGC-RECORD" ANY T)
 320        ("MOVSTK" ANY)
 321        ("GETSTK" ANY)
 322        ("ON-STACK?" FIX)
 323        ("USBLOCK" ANY)
 324        ("SBLOCK" ANY)
 325        ("UUBLOCK" ANY)
 326        ("BBIND" ANY)
 327        ("GEN-LVAL" ANY)
 328        ("GEN-SET" ANY)
 329        ("STRING-EQUAL?" ANY)
 330        ("MOVE-STRING" ANY)
 331        ("MOVE-WORDS" ANY)
 332        ("STRCOMP" ANY)
 333        ("SETSIZ" ANY)
 334        ("BIGSTACK" ANY)]>
 335
 336 <MAPF <>
 337       <FUNCTION (L "AUX" (S <1 .L>) (TYP <2 .L>) A)
 338               #DECL ((L) <LIST STRING ANY>)
 339               <COND (<NOT <SET A <LOOKUP .S ,MIM-OBL>>>
 340                      <SET A <INSERT .S ,MIM-OBL>>)>
 341               <COND (<N==? .TYP ANY> <PUTPROP .A TYPE .TYP>)>
 342               <COND (<G? <LENGTH .L> 2> <PUTPROP .A `RECORD-TYPE T>)>>
 343       ,MIMOPS>
 344
 345 "Generate function starting pseudo-op"
 346
 347 <DEFINE MIM-FCN (NAME DCL "OPT" (NEED-FR <>) "AUX" TT)
 348         #DECL ((ARGS-NEXT) LIST)
 349         <EMIT <SET TT <FORM <COND (.NEED-FR `FCN)
 350                                   (ELSE `GFCN)>
 351                             <CHTYPE .NAME FCN-ATOM>
 352                             <CHTYPE .DCL LIST>>>>
 353         <SET ARGS-NEXT <REST .TT 2>>>
 354
 355 "Generate temp pseudo-op and return pointer to list so that others can
 356  be dynamically added"
 357
 358 <DEFINE MIM-TEMPS-HOLD ()
 359         #DECL ((TMPS) <SPECIAL FORM> (TMPS-NEXT) <SPECIAL LIST>)
 360         <SET TMPS <FORM `TEMP>>
 361         <SET TMPS-NEXT <CHTYPE .TMPS LIST>>
 362         .TMPS-NEXT>
 363
 364 <DEFINE MIM-TEMPS-EMIT ()
 365         <EMIT .TMPS>
 366         <IEMIT `INTGO>>
 367
 368 "Here to change any TEMPS to ADECLs if possible"
 369
 370 <DEFINE TYPIFY-TEMPS (L)
 371         #DECL ((L) <LIST [REST TEMP]>)
 372         <MAPF <>
 373               <FUNCTION (TMP "AUX" TYP)
 374                       #DECL ((TMP) TEMP)
 375                       <COND (<AND <SET TYP <TEMP-TYPE .TMP>>
 376                                   <SET TYP <ISTYPE? .TYP>>
 377                                   <N==? .TYP NO-RETURN>
 378                                   <N==? .TYP ANY>>
 379                              <MUNG-TMP .TMP <REST <TEMP-FRAME .TMP>> .TYP>)>>
 380               .L>>
 381
 382 <DEFINE MUNG-TMP (TMP TL TYP "AUX" (NM <TEMP-NAME .TMP>))
 383         #DECL ((TMP) TEMP (TL) LIST)
 384         <MAPR <>
 385               <FUNCTION (LL "AUX" (NM1 <1 .LL>))
 386                    <COND (<==? .NM1 .NM>
 387                           <PUT .LL 1 <CHTYPE [.NM .TYP] ADECL>>
 388                           <MAPLEAVE>)>>
 389               .TL>>
 390
 391 "Here to create a temporary"
 392
 393 <DEFINE GEN-TEMP ("OPTIONAL" (ALLOCATE ANY) (NM "TEMP") (ARG-TEMP <>)
 394                              (NO-RECYC <>)
 395                   "AUX" TMP (TN .TMPS-NEXT) (FT .FREE-TEMPS))
 396    #DECL ((TMP) TEMP (EVERY-TEMP TN FT FREE-TEMPS TMPS-NEXT) LIST)
 397    <COND
 398     (<OR <EMPTY? .FT> .ARG-TEMP>
 399      <SET NM <MAKE-TAG .NM>>
 400      <COND (.ALLOCATE <PUTREST .TN <SET TMPS-NEXT (<CHTYPE .NM ATOM>)>>)>
 401      <SET TMP
 402           <CHTYPE [.NM
 403               <COND (<OR .ALLOCATE <AND .NO-RECYC .ARG-TEMP>> 1) (ELSE 0)>
 404               .TMPS
 405               <COND (<OR .ALLOCATE .ARG-TEMP> T) (ELSE <>)>
 406               .NO-RECYC
 407               <COND (.ALLOCATE <ISTYPE? .ALLOCATE>) (ELSE NO-RETURN)>]
 408              TEMP>>
 409      <SET EVERY-TEMP (.TMP !.EVERY-TEMP)>
 410      .TMP)
 411     (<AND .ALLOCATE
 412           <N==? .ALLOCATE ANY>
 413           <REPEAT ((FT .FT) (OF .FT))
 414                   <COND (<EMPTY? .FT> <RETURN <>>)>
 415                   <COND (<OR <==? <TEMP-TYPE <SET TMP <1 .FT>>> NO-RETURN>
 416                              <AND <TEMP-TYPE .TMP>
 417                                   <ISTYPE? <TYPE-MERGE <TEMP-TYPE .TMP>
 418                                                        .ALLOCATE>>>>
 419                          <COND (<==? .OF .FT> <SET FREE-TEMPS <REST .FT>>)
 420                                (ELSE <PUTREST .OF <REST .FT>>)>
 421                          <RETURN>)>
 422                   <SET FT <REST <SET OF .FT>>>>>
 423      <USE-TEMP .TMP .ALLOCATE>
 424      .TMP)
 425     (ELSE
 426      <SET TMP <1 .FT>>
 427      <SET FREE-TEMPS <REST .FT>>
 428      <COND (.ALLOCATE <USE-TEMP .TMP .ALLOCATE>)>
 429      .TMP)>>
 430
 431 ;"Special version of GEN-TEMP for in other frame"
 432
 433 <DEFINE SPEC-GEN-TEMP (TTMPS
 434                        "OPTIONAL" (ALLOCATE ANY) (NM "TEMP")
 435                        "AUX" TMP L (TMPS-NEXT .TMPS-NEXT)
 436                              (FREE-TEMPS .FREE-TEMPS) (TMPS .TMPS))
 437         #DECL ((TMPS) <SPECIAL FORM> (TMPS-NEXT FREE-TEMPS) <SPECIAL LIST>
 438                (ALL-TEMPS-LIST) <LIST [REST <LIST FORM LIST LIST ANY>]>)
 439         <COND (<N==? .TMPS .TTMPS>
 440                <SET L <FIND-FRAME <SET TMPS .TTMPS> T>>
 441                <COND (<EMPTY? .L>
 442                       <COMPILE-LOSSAGE "Bad frame model">)>
 443                <SET TMPS-NEXT <2 .L>>
 444                <SET FREE-TEMPS <3 .L>>
 445                <SET TMP <GEN-TEMP .ALLOCATE .NM>>
 446                <PUT .L 2 .TMPS-NEXT>
 447                <PUT .L 3 .FREE-TEMPS>)
 448               (ELSE <SET TMP <GEN-TEMP .ALLOCATE .NM>>)>
 449         .TMP>
 450
 451 <DEFINE FIND-FRAME (TMPS "OPTIONAL" (LOC <>) "AUX" (L .ALL-TEMPS-LIST))
 452         #DECL ((L ALL-TEMPS-LIST) <LIST [REST <LIST FORM LIST LIST TEMP>]>)
 453         <REPEAT ()
 454                 <COND (<EMPTY? .L>
 455                        <COND (.LOC <RETURN ()>)
 456                              (ELSE <COMPILE-LOSSAGE "Bad frame model">)>)>
 457                 <COND (<N==? <1 <1 .L>> .TMPS> <SET L <REST .L>>)
 458                       (ELSE <RETURN <COND (.LOC <1 .L>) (ELSE <4 <1 .L>>)>>)>>>
 459
 460 <DEFINE USE-TEMP (TMP
 461                   "OPT" (TY <>) INIT
 462                   "AUX" (NM <TEMP-NAME .TMP>) L (SPEC <CHTYPE .NM ATOM>))
 463         #DECL ((TMPS-NEXT) LIST (NM) <PRIMTYPE ATOM> (TMP) TEMP)
 464         <COND (<NOT <TEMP-ALLOC .TMP>>
 465                <COND (<==? <TEMP-FRAME .TMP> .TMPS>
 466                       <PUTREST .TMPS-NEXT <SET TMPS-NEXT (.SPEC)>>)
 467                      (ELSE
 468                       <SET L <FIND-FRAME <TEMP-FRAME .TMP> T>>
 469                       <COND (<EMPTY? .L> <COMPILE-LOSSAGE "Bad frame model">)>
 470                       <PUTREST <2 .L> <2 <PUT .L 2 (.SPEC)>>>)>
 471                <PUT .TMP ,TEMP-ALLOC T>)>
 472         <COND (<AND .TY <TEMP-TYPE .TMP>>
 473                <PUT .TMP ,TEMP-TYPE
 474                     <ISTYPE? <TYPE-MERGE <TEMP-TYPE .TMP> .TY>>>)
 475               (<NOT .TY> <PUT .TMP ,TEMP-TYPE <>>)>
 476         <PUT .TMP ,TEMP-REFS <+ <TEMP-REFS .TMP> 1>>>
 477
 478 <DEFINE FREE-TEMP (TMP "OPTIONAL" (KILL T) "AUX" REFS L)
 479         #DECL ((REFS) FIX (L FREE-TEMPS) LIST)
 480         <COND (<TYPE? .TMP TEMP>
 481                <SET REFS <TEMP-REFS .TMP>>
 482                <PUT .TMP ,TEMP-REFS <SET REFS <MAX <- .REFS 1> 0>>>
 483                <COND (<0? .REFS>
 484                       <COND (<NOT <TEMP-NO-RECYCLE .TMP>>
 485                              <COND (<AND <==? .TMPS <TEMP-FRAME .TMP>>
 486                                          <NOT <MEMQ .TMP .FREE-TEMPS>>>
 487                                     <SET FREE-TEMPS (.TMP !.FREE-TEMPS)>)
 488                                    (ELSE
 489                                     <SET L <FIND-FRAME <TEMP-FRAME .TMP> T>>
 490                                     <COND (<AND <NOT <EMPTY? .L>>
 491                                                 <NOT <MEMQ .TMP <3 .L>>>>
 492                                            <PUT .L 3 (.TMP !<3 .L>)>)>)>)>
 493                       <COND (.KILL <IEMIT `DEAD <TEMP-NAME .TMP>>)>)>)>
 494         .TMP>
 495
 496 <DEFINE DEALLOCATE-TEMP (TMP "AUX" REFS)
 497         #DECL ((REFS) FIX)
 498         <COND (<TYPE? .TMP TEMP>
 499                <SET REFS <TEMP-REFS .TMP>>
 500                <PUT .TMP ,TEMP-REFS <MAX <- .REFS 1> 0>>)>
 501         .TMP>
 502
 503 "Generate a unique atom for label, temp name, var name etc."
 504
 505 <DEFINE MAKE-TAG ("OPTIONAL" (S "TAG") "AUX" LC TC)
 506         #DECL ((S) <OR ATOM STRING>)
 507         <COND (<TYPE? .S ATOM> <SET S <SPNAME .S>>)>
 508         <SET TC <UNPARSE <SET TAG-COUNT <+ .TAG-COUNT 1>>>>
 509         <COND (<AND <G=? <SET LC <- <CHTYPE <NTH .S <LENGTH .S>> FIX>
 510                                     48>> 0>
 511                     <L=? .LC 9>>
 512                <SET S <STRING .S "-" .TC>>)
 513               (ELSE
 514                <SET S <STRING .S .TC>>)>
 515         <OR <LOOKUP .S ,TMP-OBL> <INSERT .S ,TMP-OBL>>>
 516
 517 "Add an instruction to the output code"
 518
 519 <DEFINE EMIT (THING)
 520         #DECL ((CODE-PTR) <LIST ANY>)
 521         <PUTREST .CODE-PTR <SET CODE-PTR (.THING !<REST .CODE-PTR>)>>>
 522
 523 <SETG INSTRUCTION ,FORM>
 524
 525 <DEFINE IEMIT ("TUPLE" X) <REAL-IEMIT <> .X>>
 526
 527 <DEFINE SPEC-IEMIT ("TUPLE" X) <REAL-IEMIT T .X>>
 528
 529 <DEFINE REAL-IEMIT (SKIP-DEAD X
 530                     "AUX" (DEAD-TEMPS ()) (INS <1 .X>) (PAST= <>) FOR-SETRL
 531                           (DO-LATER-SETRL <>) (FREED-TEMPS ()) TMP CP)
 532    #DECL ((X) <TUPLE ANY> (DEAD-TEMPS FREED-TEMPS) LIST (CP CODE-PTR) LIST)
 533    <COND
 534     (<OR
 535       <EMPTY? <REST .X>>
 536       <MAPR <>
 537        <FUNCTION (XP "AUX" (Y <1 .XP>) Z)
 538           #DECL ((XP) <PRIMTYPE VECTOR> (Z) TEMP)
 539           <COND (<==? .Y => <SET PAST= T>)>
 540           <COND
 541            (<TYPE? .Y MIM-SPECIAL> <PUT .XP 1 <CHTYPE .Y ATOM>>)
 542            (<TYPE? .Y TEMP>
 543             <COND
 544              (<AND <N==? <TEMP-FRAME .Y> .TMPS>
 545                    <OR <N==? .INS `SETRL> <N==? .XP <REST .X 2>>>>
 546               <COND (<==? .INS `SET>
 547                      <COND (<==? .XP <REST .X>>
 548                             <IEMIT `SETRL
 549                                    <FIND-FRAME <TEMP-FRAME .Y>>
 550                                    <TEMP-NAME .Y>
 551                                    <2 .XP>
 552                                    !<REST .X 3>>)
 553                            (ELSE
 554                             <IEMIT `SETLR
 555                                    <2 .X>
 556                                    <FIND-FRAME <TEMP-FRAME .Y>>
 557                                    <TEMP-NAME .Y>
 558                                    !<REST .X 3>>)>
 559                      <MAPLEAVE <>>)
 560                     (<NOT .PAST=>
 561                      <SET FREED-TEMPS (<SET Z <LOOP-FRAME .Y>> !.FREED-TEMPS)>
 562                      <SET DEAD-TEMPS (<TEMP-NAME .Z> !.DEAD-TEMPS)>)
 563                     (ELSE
 564                      <SET DO-LATER-SETRL <GEN-TEMP>>
 565                      <SET Z .DO-LATER-SETRL>
 566                      <SET FOR-SETRL .Y>)>)
 567              (ELSE <SET Z .Y>)>
 568             <PUT .XP 1 <TEMP-NAME .Z>>
 569             <COND (<==? <TEMP-REFS .Y> 0>
 570                    <SET DEAD-TEMPS (<TEMP-NAME .Y> !.DEAD-TEMPS)>)>)
 571            (<AND <TYPE? .Y ATOM>
 572                  <N==? .Y =>
 573                  <N==? .Y +>
 574                  <N==? .Y ->
 575                  <N==? .Y `COMPERR>
 576                  <N==? .Y `UNWCONT>
 577                  <N==? .Y ,POP-STACK>
 578                  <N==? <OBLIST? .Y> ,TMP-OBL>>
 579             <PUT .XP 1 <FORM QUOTE .Y>>)>
 580           1>
 581        <REST .X>>>
 582      <SET INS <INSTRUCTION .INS !<REST .X>>>
 583      <COND (<AND .SKIP-DEAD
 584                  <TYPE? <SET TMP <1 <SET CP .CODE-PTR>>> FORM>
 585                  <NOT <EMPTY? .TMP>>
 586                  <==? <1 .TMP> `DEAD>>
 587             <PUT .CP 1 .INS>
 588             <SET INS .TMP>)>
 589      <EMIT .INS>
 590      <COND (.DO-LATER-SETRL
 591             <IEMIT `SETRL
 592                    <FIND-FRAME <TEMP-FRAME .FOR-SETRL>>
 593                    <TEMP-NAME .FOR-SETRL>
 594                    .DO-LATER-SETRL>)>)>
 595    <MAPF <>
 596          <FUNCTION (TMP) #DECL ((TMP) TEMP) <FREE-TEMP .TMP <>>>
 597          .FREED-TEMPS>
 598    <COND (<NOT <EMPTY? .DEAD-TEMPS>>
 599           <EMIT <CHTYPE (`DEAD !.DEAD-TEMPS) FORM>>)>
 600    T>
 601
 602 <DEFINE LOOP-FRAME (TMP
 603                     "OPTIONAL" LTMP (TNAME <TEMP-NAME <4 <1 .ALL-TEMPS-LIST>>>)
 604                     "AUX" (XTMP
 605                            <COND (<ASSIGNED? LTMP> .LTMP) (ELSE <GEN-TEMP>)>)
 606                           (TMPS <1 <1 .ALL-TEMPS-LIST>>)
 607                           (ALL-TEMPS-LIST <REST .ALL-TEMPS-LIST>))
 608         #DECL ((TMPS) <SPECIAL FORM>
 609                (ALL-TEMPS-LIST) <SPECIAL <LIST [REST
 610                                                 <LIST FORM LIST LIST TEMP>]>>)
 611         <COND (<N==? .TMPS <TEMP-FRAME .TMP>>
 612                <IEMIT `SETLR
 613                       <TEMP-NAME .XTMP>
 614                       .TNAME
 615                       <TEMP-NAME <4 <1 .ALL-TEMPS-LIST>>>>
 616                <LOOP-FRAME .TMP .XTMP <TEMP-NAME .XTMP>>)
 617               (ELSE <IEMIT `SETLR <TEMP-NAME .XTMP> .TNAME <TEMP-NAME .TMP>>)>
 618         .XTMP>
 619
 620 "Generate a label in the code"
 621
 622 <DEFINE LABEL-TAG (TG) <EMIT .TG>>
 623
 624 "Generate jump to label"
 625
 626 <DEFINE BRANCH-TAG (TG) <IEMIT `JUMP + .TG>>
 627
 628 "Generate code to PUSH something onto stack.  It can be called with various
 629  arguments:
 630         1) #TEMP - refernce to a named temporary
 631         3) #MIM-SPECIAL atom - MIM special variable
 632         4) other - quoted object "
 633
 634 <DEFINE PUSH (ITM)
 635         <COND (<TYPE? .ITM MIM-SPECIAL> <IEMIT `PUSH <CHTYPE .ITM ATOM>>)
 636               (<TYPE? .ITM TEMP> <IEMIT `PUSH .ITM>)
 637               (<==? .ITM ,POP-STACK>)
 638               (ELSE <IEMIT `PUSH <ATOMCHK .ITM>>)>
 639         ,TOP-STACK>
 640
 641 <DEFINE POP (ITM)
 642         <COND (<TYPE? .ITM TEMP> <IEMIT `POP = <TEMP-NAME .ITM>>)
 643               (<==? .ITM FLUSHED> <IEMIT `ADJ -2>)
 644               (<AND <N==? .ITM ,TOP-STACK> <N==? .ITM DONT-CARE>>
 645                <COMPILE-LOSSAGE "Bad arg to POP" .ITM>)
 646               (ELSE <SET ITM ,POP-STACK>)>
 647         .ITM>
 648
 649 <DEFINE PUSH-CONSTANT (X) <PUSH <ATOMCHK .X>>>
 650
 651 " Generate FIXBIND to wrap bindings pending by linking up atoms."
 652
 653 <DEFINE GEN-FIX-BIND () <IEMIT `FIXBIND>>
 654
 655 " Generate code for optional arguments."
 656
 657 <DEFINE GEN-ARG-NUM (N) #DECL ((N) FIX) <IEMIT `ARGNUM .N>>
 658
 659 <DEFINE SPECIAL-BINDING (SYM FIXB "OPTIONAL" INIT)
 660         <COND (<ASSIGNED? INIT>
 661                <IEMIT `BBIND
 662                       <ATOMCHK <NAME-SYM .SYM>>
 663                       <ATOMCHK <DECL-SYM .SYM>>
 664                       <COND (.FIXB ''FIX) (ELSE <>)>
 665                       .INIT>)
 666               (ELSE
 667                <IEMIT `BBIND
 668                       <ATOMCHK <NAME-SYM .SYM>>
 669                       <ATOMCHK <DECL-SYM .SYM>>
 670                       <COND (.FIXB ''FIX) (ELSE <>)>>)>>
 671
 672 "Get the value of a special variable bound in the current function"
 673
 674 <DEFINE GET-VALUE-X (ATM TMP
 675                      "OPT" (EXT <>)
 676                      "AUX" (BTMP <COND (<AND <TYPE? .TMP TEMP>
 677                                              <OR <NOT <TEMP-NO-RECYCLE .TMP>>
 678                                                  <==? <TEMP-NO-RECYCLE .TMP>
 679                                                       ANY>>
 680                                              <NOT <TEMP-TYPE .TMP>>
 681                                              <==? <TEMP-FRAME .TMP> .TMPS>>
 682                                         .TMP)
 683                                        (ELSE <GEN-TEMP>)>) (FQA <ATOMCHK .ATM>)
 684                             (TG1 <MAKE-TAG>) (TG2 <MAKE-TAG>) BIDTMP1 BIDTMP2)
 685         #DECL ((BTMP BIDTMP1 BIDTMP2) TEMP)
 686         <COND (.EXT
 687                <IEMIT `GEN-LVAL .FQA = .TMP>)
 688               (ELSE
 689                <USE-TEMP .BTMP <>>
 690                <DEALLOCATE-TEMP .BTMP>
 691                <IEMIT `NTHR .FQA ,M$$LVAL = .BTMP ,RAT '(`TYPE LBIND)>
 692                <IEMIT `NTHR .BTMP ,M$$VALU = .TMP ,RBN>
 693                <COND (<N==? .TMP .BTMP> <FREE-TEMP .BTMP>)>)>
 694         .TMP>
 695
 696 "See if a special variable is assigned"
 697
 698 <DEFINE ASS-GEN (ATM TG DIR
 699                  "OPT" (EXT <>)
 700                  "AUX" (BTMP <GEN-TEMP>) (FQA <ATOMCHK .ATM>) BIDTMP1 BIDTMP2
 701                        (TGX <COND (.DIR <MAKE-TAG>) (ELSE .TG)>))
 702         #DECL ((BTMP BIDTMP1 BIDTMP2) TEMP)
 703         <COND (.EXT <IEMIT `GEN-ASSIGNED? .FQA <COND (.DIR +) (ELSE -)> .TG>)
 704               (ELSE
 705                <IEMIT `NTHR .FQA ,M$$LVAL = .BTMP ,RAT '(`TYPE LBIND)>
 706                <IEMIT `NTHR .BTMP ,M$$VALU = .BTMP ,RBN>
 707                <GEN-TYPE? .BTMP UNBOUND .TG <NOT .DIR>>
 708                <FREE-TEMP .BTMP>)>>
 709
 710 "Set the value of a special variable bound in the current function"
 711
 712 <DEFINE SET-VALUE (ATM TMP
 713                    "OPT" (EXT <>)
 714                    "AUX" BTMP
 715                          (FQA <ATOMCHK .ATM>) (TG1 <MAKE-TAG>) (TG2 <MAKE-TAG>)
 716                          BIDTMP1 BIDTMP2)
 717         #DECL ((BTMP BIDTMP1 BIDTMP2) TEMP)
 718         <COND (.EXT
 719                <IEMIT `GEN-SET .FQA .TMP>)
 720               (ELSE
 721                <SET BTMP <GEN-TEMP LBIND>>
 722                <IEMIT `NTHR .FQA ,M$$LVAL = .BTMP ,RAT '(`TYPE LBIND)>
 723                <IEMIT `PUTR .BTMP ,M$$VALU <ATOMCHK .TMP> ,RBN>
 724                <FREE-TEMP .BTMP>)>
 725         .TMP>
 726
 727 "Generate code to set a MIM local"
 728
 729 <DEFINE SET-SYM (SYM "OPTIONAL" VAL (USE-IT <>)
 730                  "AUX" (TMP <TEMP-NAME-SYM .SYM>) (TY ANY)
 731                        (REFS <TEMP-REFS .TMP>))
 732         #DECL ((SYM) SYMTAB (TMP) TEMP (REFS) FIX)
 733         <COND (<ASSIGNED? VAL>
 734                <SET TY <COND (<TYPE? .VAL TEMP> <TEMP-TYPE .VAL>)
 735                              (ELSE <TYPE .VAL>)>>
 736                <SET-TEMP .TMP .VAL>)>
 737         <COND (.USE-IT
 738                <USE-TEMP .TMP .TY>
 739                <PUT .TMP ,TEMP-REFS <+ .REFS 1>>)>>
 740
 741 <DEFINE SET-TEMP (TMP "OPTIONAL" VAL XTRA "AUX" REFS (TY ANY))
 742         #DECL ((TMP) TEMP (REFS) FIX)
 743         <COND (<ASSIGNED? VAL>
 744                <SET TY
 745                     <COND (<TYPE? .VAL TEMP> <TEMP-TYPE .VAL>)
 746                           (ELSE <TYPE .VAL>)>>)>
 747         <USE-TEMP .TMP .TY>
 748         <COND (<ASSIGNED? VAL>
 749                <COND (<TYPE? .VAL MIM-SPECIAL> <SET VAL <CHTYPE .VAL ATOM>>)
 750                      (ELSE <SET VAL <ATOMCHK .VAL>>)>
 751                <COND (<ASSIGNED? XTRA> <IEMIT `SET .TMP .VAL .XTRA>)
 752                      (ELSE <IEMIT `SET .TMP .VAL>)>)>>
 753
 754 "Quote atom to protect the MIM assembler"
 755
 756 <DEFINE ATOMCHK (X)
 757         <COND (<REPEAT ((Y .X))
 758                        <COND (<TYPE? .Y ATOM> <RETURN T>)>
 759                        <COND (<AND <TYPE? .Y FORM>
 760                                    <==? <LENGTH .Y> 2>
 761                                    <==? <1 .Y> QUOTE>>
 762                               <SET Y <2 .Y>>)
 763                              (ELSE <RETURN <>>)>>
 764                <FORM QUOTE .X>)
 765               (ELSE .X)>>
 766
 767 " Return currently running FRAME "
 768
 769 <DEFINE CURRENT-FRAME ("OPTIONAL" (FR <GEN-TEMP FRAME>))
 770         <IEMIT `CFRAME = .FR '(`TYPE FRAME)> .FR>
 771
 772 " Return TUPLE of arguments"
 773
 774 <DEFINE GET-ARG-TUPLE (FR)
 775         <USE-TEMP .FR TUPLE>
 776         <PUT .TMPS 1 `MAKTUP>
 777         <SET TMP-DEST <TEMP-NAME .FR>>
 778         .FR>
 779
 780 "Compare # of args supplied with a constant and jump in appropriate case"
 781
 782 <DEFINE TEST-ARG (TMP TG)
 783         #DECL ((TMP) TEMP (TG) ATOM)
 784         <GEN-TYPE? .TMP UNBOUND .TG <>>
 785         T>
 786
 787 "Get current binding at top of world"
 788
 789 <DEFINE GET-BINDING (WHERE) <IEMIT `GETS ,QQ-BIND = .WHERE '(`TYPE LBIND)>>
 790
 791 "Get an arg by arg number and mung into a local"
 792
 793 <DEFINE ARG-TO-TEMP (SYM
 794                      "AUX" (TMP <TEMP-NAME-SYM .SYM>)
 795                            (ATMP <ARG-NAME-SYM .SYM>))
 796         #DECL ((SYM) SYMTAB (TMP) TEMP)
 797         <IEMIT `SET <TEMP-NAME .TMP> <TEMP-NAME .ATMP>>>
 798
 799 "Generate call to MSUBR"
 800
 801 <DEFINE MSUBR-CALL (NAM NARGS W)
 802         <SET NAM <CHTYPE .NAM FCN-ATOM>>
 803         <COND (<==? .W FLUSHED>
 804                <IEMIT `CALL <FORM QUOTE .NAM> .NARGS>)
 805               (ELSE <IEMIT `CALL <FORM QUOTE .NAM> .NARGS = .W>)>>
 806
 807 <DEFINE SEG-SUBR-CALL (NAM NARGS W COUNT LABEL)
 808         <SET NAM <CHTYPE .NAM FCN-ATOM>>
 809         <IEMIT `SCALL <FORM QUOTE .NAM> .NARGS = .W + .LABEL .COUNT>>
 810
 811 "Begin building a FRAME for a future call"
 812
 813 <DEFINE START-FRAME ("OPT" (NAME <>))
 814          <COND (.NAME <IEMIT `FRAME <FORM QUOTE <CHTYPE .NAME FCN-ATOM>>>)
 815                (ELSE <IEMIT `FRAME>)>>
 816
 817 "Generate a VECTOR of the top N things on the stack"
 818
 819 <DEFINE GEN-VECTOR (N V "OPT" (S? <>))
 820         <IEMIT <COND (.S? `SBLOCK)
 821                      (ELSE `UBLOCK)> '<`TYPE-CODE VECTOR> .N = .V>
 822         .V>
 823
 824 <DEFINE GEN-UVECTOR (N V "OPT" (S? <>))
 825         <IEMIT <COND (.S? `SBLOCK)
 826                      (ELSE `UBLOCK)> '<`TYPE-CODE UVECTOR> .N = .V>
 827         .V>
 828
 829 "Same for TUPLE"
 830
 831 <DEFINE GEN-TUPLE (N V)
 832         <IEMIT `TUPLE .N = .V '(`TYPE TUPLE)>
 833         .V>
 834
 835 "Same for LIST"
 836
 837 <DEFINE GEN-LIST (N L) <IEMIT `LIST .N = .L '(`TYPE LIST)>>
 838
 839 "Generate code to move datum from place to place"
 840
 841 <DEFINE MOVE-ARG (FROM TO "OPT" XTRA "AUX" (TY ANY))
 842         <COND (<AND <NOT <ASSIGNED? XTRA>> <NOT <TYPE? .FROM TEMP>>>
 843                <SET XTRA <COND (<AND <TYPE? .FROM FORM>
 844                                      <==? <LENGTH .FROM> 2>
 845                                      <==? <1 .FROM> QUOTE>
 846                                      <TYPE? <2 .FROM> ATOM>>
 847                                 '(`TYPE ATOM))
 848                                (ELSE (`TYPE <TYPE .FROM>))>>
 849                <SET TY <2 .XTRA>>)
 850               (<AND <ASSIGNED? XTRA> <TYPE? .XTRA LIST>> <SET TY <2 .XTRA>>)
 851               (<TYPE? .FROM TEMP> <SET TY <TEMP-TYPE .FROM>>)
 852               (ELSE <SET TY <TYPE .FROM>>)>
 853         <COND (<==? .TO FLUSHED>
 854                <COND (<==? .FROM ,POP-STACK> <POP FLUSHED>)>
 855                <FREE-TEMP .FROM>
 856                ,NO-DATUM)
 857               (<TYPE? .TO LIST>
 858                <MAPF <>
 859                      <FUNCTION (TTO) <MOVE-ARG .FROM .TTO .XTRA>>
 860                      .TO>)
 861               (<N==? .TO .FROM>
 862                <COND (<==? .TO ,POP-STACK> <PUSH .FROM> <FREE-TEMP .FROM> .TO)
 863                      (<AND <ASSIGNED? THE-BOOL> <==? .THE-BOOL .TO>>
 864                       <COND (<NOT .FROM>
 865                              <IEMIT `AND .THE-BOOL .THE-BIT = .THE-BOOL>)
 866                             (<==? .FROM T>
 867                              <IEMIT `OR .THE-BOOL .THE-BIT = .THE-BOOL>)
 868                             (ELSE <ERROR OH-SHIT!-ERRORS>)>
 869                       .TO)
 870                      (<TYPE? .TO TEMP>
 871                       <USE-TEMP .TO .TY>
 872                       <COND (<TYPE? .FROM TEMP>
 873                              <COND (<ASSIGNED? XTRA>
 874                                     <IEMIT `SET  .TO .FROM .XTRA>)
 875                                    (ELSE
 876                                     <IEMIT `SET .TO .FROM>)>
 877                              <FREE-TEMP .FROM>)
 878                             (ELSE
 879                              <COND (<ASSIGNED? XTRA>
 880                                     <IEMIT `SET .TO <ATOMCHK  .FROM> .XTRA>)
 881                                    (ELSE
 882                                     <IEMIT `SET .TO <ATOMCHK  .FROM>>)>)>
 883                       .TO)
 884                      (<==? .TO DONT-CARE>
 885                       <COND (<==? .FROM ,TOP-STACK> ,POP-STACK)
 886                             (ELSE .FROM)>)>)
 887               (ELSE .TO)>>
 888
 889 <DEFINE REFERENCE (X) .X>
 890
 891 "Generate a TYPE? instruction"
 892
 893 <DEFINE GEN-TYPE? (ITM TYP TG DIR)
 894         <IEMIT `TYPE?
 895                .ITM
 896                <COND (<TYPE? .TYP TEMP> .TYP) (ELSE <FORM `TYPE-CODE .TYP>)>
 897                <COND (.DIR +) (ELSE -)>
 898                .TG>>
 899
 900 <DEFINE GEN-VT (ITM TG DIR
 901                 "OPT" RTMP
 902                 "AUX" TMP (SIGN <COND (.DIR -) (+)>))
 903         <COND (<ASSIGNED? RTMP> <SET TMP .RTMP>)
 904               (ELSE <SET TMP <GEN-TEMP <>>>)>
 905         <USE-TEMP .TMP>
 906         <IEMIT `NTHR .ITM ,M$$TYPE = .TMP ,RAT (`BRANCH-FALSE .SIGN .TG)>
 907         <SPEC-IEMIT `TYPE? .TMP '<`TYPE-CODE FALSE>
 908                     <COND (.DIR -)(ELSE +)> .TG>
 909         <COND (<NOT <ASSIGNED? RTMP>> <FREE-TEMP .TMP>)>>
 910
 911 <DEFINE GEN-TC (TMP "OPT" RTMP)
 912         <COND (<ASSIGNED? RTMP> <USE-TEMP .RTMP TYPE-C>)
 913               (ELSE <SET RTMP <GEN-TEMP TYPE-C>>)>
 914         <COND (.CAREFUL
 915                <IEMIT `NTHR .TMP ,M$$TYPE = .RTMP ,RAT
 916                       '(`BRANCH-FALSE + `COMPERR)>
 917                <SPEC-IEMIT `TYPE? .RTMP '<`TYPE-CODE FALSE> + `COMPERR>)
 918               (ELSE
 919                <IEMIT `NTHR
 920                       .TMP
 921                       ,M$$TYPE
 922                       =
 923                       .RTMP
 924                       ,RAT
 925                       '(`TYPE TYPE-C)>)>
 926         .RTMP>
 927
 928 "Generate SETG/GVAL things"
 929
 930 <DEFINE GEN-GVAL (ATM W "OPT" (TYP <>) "AUX" TEM TG1 TG2)
 931         <COND (<TYPE? .ATM ATOM> <SET ATM <FORM QUOTE .ATM>>)>
 932         <COND (.TYP <IEMIT `GVAL .ATM = .W (`TYPE .TYP)>)
 933               (ELSE <IEMIT `GVAL .ATM = .W>)>>
 934
 935 <DEFINE GEN-GASS (ATM TG DIR NM "AUX" (TG1 <COND (<N==? .NM GASSIGNED?> .TG)
 936                                                  (.DIR <MAKE-TAG>)
 937                                                  (ELSE .TG)>) (SIGN +) TEM)
 938         <COND (<AND .DIR <N==? .NM GASSIGNED?>> <SET SIGN ->)>
 939         <IEMIT `NTHR <COND (<TYPE? .ATM ATOM> <FORM QUOTE .ATM>)
 940                            (ELSE .ATM)>
 941                ,M$$GVAL = <SET TEM <GEN-TEMP>> ,RAT
 942                (`BRANCH-FALSE .SIGN .TG1)>
 943         <SPEC-IEMIT `TYPE? .TEM '<`TYPE-CODE FALSE> .SIGN .TG1>
 944         <COND (<==? .NM GASSIGNED?>
 945                <IEMIT `NTHR .TEM ,M$$VALU = .TEM ,RGBN>
 946                <GEN-TYPE? .TEM UNBOUND .TG <NOT .DIR>>)>
 947         <COND (<N==? .TG .TG1> <LABEL-TAG .TG1>)>
 948         <FREE-TEMP .TEM>>
 949
 950
 951 <DEFINE GEN-SETG (ATM VAL DCL WHERE "AUX" TEM TG1 TG2)
 952         <COND (<TYPE? .ATM ATOM>
 953                <IEMIT `SETG <FORM QUOTE .ATM> <ATOMCHK .VAL>>)
 954               (ELSE
 955                <IEMIT `NTHR .ATM ,M$$GVAL = <SET TEM <GEN-TEMP>> ,RAT
 956                       (`BRANCH-FALSE + <SET TG1 <MAKE-TAG>>)>
 957                <SPEC-IEMIT `TYPE? .TEM '<`TYPE-CODE FALSE> + .TG1>
 958                <IEMIT `PUTR .TEM ,M$$VALU .VAL ,RGBN>
 959                <COND (.DCL
 960                       <IEMIT .TEM `PUTR ,M$$DECL .DCL ,RGBN>)>
 961                <BRANCH-TAG <SET TG2 <MAKE-TAG>>>
 962                <LABEL-TAG .TG1>
 963                <START-FRAME SETG>
 964                <PUSH .ATM>
 965                <PUSH .VAL>
 966                <COND (.DCL <PUSH .DCL>)>
 967                <COND (<N==? .WHERE FLUSHED>
 968                       <MSUBR-CALL SETG <COND (.DCL 3) (ELSE 2)> .VAL>)
 969                      (ELSE
 970                       <MSUBR-CALL SETG <COND (.DCL 3) (ELSE 2)> FLUSHED>)>
 971                <LABEL-TAG .TG2>
 972                <FREE-TEMP .TEM>)>>
 973
 974 "Generate CHTYPE"
 975
 976 <DEFINE GEN-CHTYPE (ITM TYP W)
 977         <IEMIT `CHTYPE .ITM <COND (<AND <TYPE? .TYP ATOM>
 978                                         <VALID-TYPE? .TYP>>
 979                                    <FORM `TYPE-CODE .TYP>)
 980                                   (ELSE .TYP)> = .W>>
 981
 982 <DEFINE D-B-TAG (BR WH DIR TYP)
 983         <COND (<AND <NOT <TYPE-OK? .TYP '<FALSE ANY>>>
 984                     <SET TYP <TYPE-AND .TYP '<NOT FALSE>>>
 985                     <NOT <TYPE-OK? .TYP '<PRIMTYPE FIX>>>
 986                     <OR <NOT <SET TYP <TYPE-AND .TYP '<PRIMTYPE LIST>>>>
 987                         <G? <MINL .TYP> 0>>>
 988                <IEMIT `VEQUAL? .WH 0 <COND (.DIR -)(ELSE +)> .BR>)
 989               (ELSE
 990                <GEN-TYPE? .WH FALSE .BR <NOT .DIR>>)>>
 991
 992 <DEFINE MIM-RETURN ("OPTIONAL" (VAL ,POP-STACK))
 993         <IEMIT `RETURN <ATOMCHK .VAL>>>
 994
 995 <DEFINE RET-TMP-AC (X) .X>
 996
 997 <DEFINE GEN-SHIFT (DAT AMT W) <IEMIT `LSH .DAT .AMT = .W '(`TYPE FIX)>>
 998
 999 <DEFINE NTH-LIST (SRC DST AMT "OPT" (RESTYP <>))
1000         <COND (.RESTYP <IEMIT `NTHL .SRC .AMT = .DST (`TYPE .RESTYP)>)
1001               (ELSE <IEMIT `NTHL .SRC .AMT = .DST>)>>
1002
1003 <DEFINE NTH-UVECTOR (SRC DST AMT "OPT" (RESTYP <>))
1004         <COND (.RESTYP <IEMIT `NTHUU .SRC .AMT = .DST (`TYPE .RESTYP)>)
1005               (ELSE <IEMIT `NTHUU .SRC .AMT = .DST>)>>
1006
1007 <DEFINE NTH-VECTOR (SRC DST AMT "OPT" (RESTYP <>))
1008         <COND (.RESTYP <IEMIT `NTHUV .SRC .AMT = .DST (`TYPE .RESTYP)>)
1009               (ELSE <IEMIT `NTHUV .SRC .AMT = .DST>)>>
1010
1011 <DEFINE NTH-STRING (SRC DST AMT "OPT" (RESTYP <>))
1012         <COND (.RESTYP <IEMIT `NTHUS .SRC .AMT = .DST (`TYPE .RESTYP)>)
1013               (ELSE <IEMIT `NTHUS .SRC .AMT = .DST>)>>
1014
1015 <DEFINE NTH-BYTES (SRC DST AMT "OPT" (RESTYP <>))
1016         <COND (.RESTYP <IEMIT `NTHUB .SRC .AMT = .DST (`TYPE .RESTYP)>)
1017               (ELSE <IEMIT `NTHUB .SRC .AMT = .DST>)>>
1018
1019 <DEFINE NTH-RECORD (SRC DST AMT TPS "OPT" (RESTYP <>))
1020         <COND (.RESTYP
1021                <IEMIT `NTHR .SRC .AMT = .DST (`RECORD-TYPE .TPS)
1022                       (`TYPE .RESTYP)>)
1023               (ELSE
1024                <IEMIT `NTHR .SRC .AMT = .DST (`RECORD-TYPE .TPS)>)>>
1025
1026 <DEFINE REST-LIST (SRC DST AMT) <IEMIT `RESTL .SRC .AMT = .DST
1027                                        '(`TYPE LIST)>>
1028
1029 <DEFINE REST-UVECTOR (SRC DST AMT) <IEMIT `RESTUU .SRC .AMT = .DST
1030                                           '(`TYPE UVECTOR) >>
1031
1032 <DEFINE REST-VECTOR (SRC DST AMT "OPT" TY)
1033         <COND (<ASSIGNED? TY>
1034                <IEMIT `RESTUV .SRC .AMT = .DST (`TYPE .TY)>)
1035               (ELSE
1036                <IEMIT `RESTUV .SRC .AMT = .DST>)>>
1037
1038 <DEFINE REST-STRING (SRC DST AMT) <IEMIT `RESTUS .SRC .AMT = .DST
1039                                          '(`TYPE STRING) >>
1040
1041 <DEFINE REST-BYTES (SRC DST AMT) <IEMIT `RESTUB .SRC .AMT = .DST
1042                                          '(`TYPE BYTES) >>
1043
1044 <DEFINE EMPTY-LIST (SRC TG DIR "OPT" (TY <>))
1045         <COND (.TY
1046                <IEMIT `EMPL? .SRC <COND (.DIR +) (ELSE -)> .TG
1047                       (`TYPE .TY)>)
1048               (ELSE
1049                <IEMIT `EMPL? .SRC <COND (.DIR +) (ELSE -)> .TG>)>>
1050
1051 <DEFINE EMPTY-UVECTOR (SRC TG DIR "OPT" (TY <>))
1052         <COND (.TY
1053                <IEMIT `EMPUU? .SRC <COND (.DIR +) (ELSE -)> .TG
1054                       (`TYPE .TY)>)
1055               (ELSE
1056                <IEMIT `EMPUU? .SRC <COND (.DIR +) (ELSE -)> .TG>)>>
1057
1058 <DEFINE EMPTY-VECTOR (SRC TG DIR "OPT" (TY <>))
1059         <COND (.TY
1060                <IEMIT `EMPUV? .SRC <COND (.DIR +) (ELSE -)> .TG
1061                       (`TYPE .TY)>)
1062               (ELSE
1063                <IEMIT `EMPUV? .SRC <COND (.DIR +) (ELSE -)> .TG>)>>
1064
1065 <DEFINE EMPTY-STRING (SRC TG DIR "OPT" (TY <>))
1066         <COND (.TY
1067                <IEMIT `EMPUS? .SRC <COND (.DIR +) (ELSE -)> .TG
1068                       (`TYPE .TY)>)
1069               (ELSE
1070                <IEMIT `EMPUS? .SRC <COND (.DIR +) (ELSE -)> .TG>)>>
1071
1072 <DEFINE EMPTY-BYTES (SRC TG DIR "OPT" (TY <>))
1073         <COND (.TY
1074                <IEMIT `EMPUB? .SRC <COND (.DIR +) (ELSE -)> .TG
1075                       (`TYPE .TY)>)
1076               (ELSE
1077                <IEMIT `EMPUB? .SRC <COND (.DIR +) (ELSE -)> .TG>)>>
1078
1079 <DEFINE EMPTY-RECORD (SRC TG DIR TPS)
1080         <IEMIT `EMPR? .SRC <COND (.DIR +) (ELSE -)> .TG
1081                (`RECORD-TYPE .TPS)>>
1082
1083 <DEFINE LENGTH-LIST (SRC DST) <IEMIT `LENL .SRC = .DST '(`TYPE FIX)>>
1084
1085 <DEFINE LENGTH-UVECTOR (SRC DST) <IEMIT `LENUU .SRC = .DST '(`TYPE FIX)>>
1086
1087 <DEFINE LENGTH-VECTOR (SRC DST) <IEMIT `LENUV .SRC = .DST '(`TYPE FIX)>>
1088
1089 <DEFINE LENGTH-STRING (SRC DST) <IEMIT `LENUS .SRC = .DST '(`TYPE FIX)>>
1090
1091 <DEFINE LENGTH-BYTES (SRC DST) <IEMIT `LENUB .SRC = .DST '(`TYPE FIX)>>
1092
1093 <DEFINE LENGTH-RECORD (SRC DST TPS) <IEMIT `LENR .SRC = .DST
1094                                            (`RECORD-TYPE .TPS) '(`TYPE FIX)>>
1095
1096 <DEFINE PUT-LIST (SRC NUM NEW "OPT" (TY <>))
1097         <COND (.TY <IEMIT `PUTL .SRC .NUM <ATOMCHK .NEW> .TY>)
1098               (ELSE <IEMIT `PUTL .SRC .NUM <ATOMCHK .NEW>>)>>
1099
1100 <DEFINE PUT-VECTOR (SRC NUM NEW "OPT" (TY <>))
1101         <COND (.TY <IEMIT `PUTUV .SRC .NUM <ATOMCHK .NEW> .TY>)
1102               (ELSE <IEMIT `PUTUV .SRC .NUM <ATOMCHK .NEW>>)>>
1103
1104 <DEFINE PUT-UVECTOR (SRC NUM NEW) <IEMIT `PUTUU .SRC .NUM .NEW>>
1105
1106 <DEFINE PUT-STRING (SRC NUM NEW) <IEMIT `PUTUS .SRC .NUM .NEW>>
1107
1108 <DEFINE PUT-BYTES (SRC NUM NEW) <IEMIT `PUTUB .SRC .NUM .NEW>>
1109
1110 <DEFINE PUT-RECORD (SRC NUM NEW TPS "OPT" (TY <>))
1111         <COND (.TY <IEMIT `PUTR .SRC .NUM <ATOMCHK .NEW> (`RECORD-TYPE .TPS) .TY>)
1112               (ELSE <IEMIT `PUTR .SRC .NUM <ATOMCHK .NEW> (`RECORD-TYPE .TPS)>)>>
1113
1114 <DEFINE PROTECT (ITM)
1115         <COND (<AND <TYPE? .ITM TEMP>
1116                     <0? <TEMP-REFS .ITM>>>
1117                .ITM)
1118               (ELSE
1119                 <PUSH .ITM>)>>
1120
1121 <DEFINE GEN-VAL-==? (D1 D2 DIR BR)
1122         <IEMIT `VEQUAL? <ATOMCHK .D1> <ATOMCHK .D2> <COND (.DIR +) (ELSE -)> .BR>>
1123
1124 <DEFINE GEN-==? (D1 D2 DIR BR)
1125         <IEMIT `EQUAL? <ATOMCHK .D1> <ATOMCHK .D2> <COND (.DIR +) (ELSE -)> .BR>>
1126
1127
1128 <DEFINE PREV-FRAME (WHERE)
1129         <IEMIT `CFRAME = .WHERE>
1130         <IEMIT `NTHR .WHERE ,M$$FRM-PREV = .WHERE (`RECORD-TYPE FRAME)>
1131         .WHERE>
1132
1133 <ENDPACKAGE>