mim/development/mim/mimc/codgen.mud

   1 <PACKAGE "CODGEN">
   2
   3 <ENTRY GEN
   4        CODE-GEN
   5        SEQ-GEN
   6        SEGMENT-STACK
   7        GOOD-TUPLE
   8        NO-KILL
   9        DELAY-KILL
  10        BASEF
  11        LADDR
  12        TRUE-FALSE
  13        SUBR-GEN
  14        BIND-CODE
  15        NPRUNE
  16        ARG?
  17        OPT?
  18        COND-GEN
  19        OR-GEN
  20        AND-GEN
  21        ASSIGNED?-GEN
  22        BIND-B
  23        ACT-B
  24        AUX1-B
  25        AUX2-B
  26        SMSUBR-CALL
  27        CALL-GEN
  28        T-NAME
  29        GASSIGNED?-GEN
  30        INTERFERE?
  31        INTERF-CHANGE
  32        SEGLABEL
  33        SEGCALLED
  34        COUNTMP
  35        SET-GEN
  36        PSEQ-GEN>
  37
  38 <USE "CHKDCL"
  39      "COMPDEC"
  40      "MIMGEN"
  41      "STRGEN"
  42      "MAPGEN"
  43      "MMQGEN"
  44      "BUILDL"
  45      "BITSGEN"
  46      "LNQGEN"
  47      "CARGEN"
  48      "NOTGEN"
  49      "ALLR"
  50      "SUBRTY"
  51      "NEWREP"
  52      "ADVMESS"
  53      "CASECOMP">
  54
  55 <SETG THE-UNBOUND <CHTYPE 0 T$UNBOUND>>
  56
  57 "       This file contains the major general codde generators.  These include
  58  variable access functions (LVAL, SETG etc.), FSUBRs (COND, AND, REPEAT)
  59  and a few assorted others."
  60
  61 " Main generator, dispatches to specific code generators. "
  62
  63 <DEFINE GEN (NOD "OPT" (WHERE DONT-CARE) "AUX" TEMP)
  64         #DECL ((NOD) NODE)
  65         <SET TEMP <GEN-DISPATCH .NOD .WHERE>>
  66         <OR <ASSIGNED? NPRUNE> <PUT .NOD ,KIDS ()>>
  67         .TEMP>
  68
  69 " Generate a sequence of nodes flushing all values except the ladt."
  70
  71 <DEFINE SEQ-GEN (L WHERE
  72                  "OPTIONAL" (INPROG <>) (SINPROG <>) (INCODE-GEN <>)
  73                  "AUX" K (WSET <>))
  74    #DECL ((K L) <LIST [REST NODE]> (LAST) NODE)
  75    <MAPR <>
  76     <FUNCTION (N "AUX" (ND <1 .N>) NX W)
  77        #DECL ((N) <LIST NODE> (ND) NODE)
  78        <COND (<NOT <EMPTY? <REST .N>>>
  79               <SET NX <2 .N>>
  80               <COND (<AND <==? <NODE-TYPE .NX> ,CALL-CODE>
  81                           <G=? <LENGTH <SET K <KIDS .NX>>> 2>
  82                           <==? <NODE-NAME <1 .K>> `ENDIF>>
  83                      <SET W <GEN .ND .WHERE>>
  84                      <COND (<AND <NOT .WSET>
  85                                  <N==? .WHERE FLUSHED>
  86                                  <N==? .W ,NO-DATUM>
  87                                  <N==? .WHERE ,POP-STACK>>
  88                             <SET WHERE <FIXUP-TEMP .WHERE .W>>
  89                             <SET WSET T>)>
  90                      <COND (<NOT <EMPTY? <REST .N 2>>>
  91                             <DEALLOCATE-TEMP .WHERE>)>)
  92                     (<OR <AND <G=? <LENGTH .ND>
  93                                    <CHTYPE <INDEX ,SIDE-EFFECTS> FIX>>
  94                               <SIDE-EFFECTS .ND>>
  95                          <GETPROP .ND DONT-FLUSH-ME>
  96                          ,DONT-FLUSH-ME>
  97                      <GEN .ND FLUSHED>)>)
  98              (<AND <==? <NODE-TYPE .ND> ,CALL-CODE>
  99                    <G=? <LENGTH <SET K <KIDS .ND>>> 2>
 100                    <==? <NODE-NAME <1 .K>> `ENDIF>>
 101               <GEN .ND FLUSHED>)
 102              (ELSE <SET WHERE <GEN .ND .WHERE>>)>>
 103     .L>
 104    .WHERE>
 105
 106 " The main code generation entry (called from CDRIVE).  Sets up initial
 107  stack model, calls to generate code for the bindings and generates code for
 108  the function's body."
 109
 110 <DEFINE CODE-GEN (BASEF EXTRA-CODE
 111                   "AUX" (K <KIDS .BASEF>) CD (NO-KILL ()) (KILL-LIST ())
 112                         (ATAG <MAKE-TAG "AGAIN">) (RTAG <MAKE-TAG "RETURN">)
 113                         (CODE-START .EXTRA-CODE) (CODE-PTR .CODE-START)
 114                         (EVERY-TEMP ()) ARGS-NEXT TMPS TMPS-NEXT (STK 0)
 115                         (FREE-TEMPS ()) (ALL-TEMPS-LIST ()) TMP-DEST SPECD
 116                         BNDTMP STKTMP (STK-CHARS7 0) (STK-CHARS8 0))
 117         #DECL ((STK-CHARS7 STK-CHARS8 STK) <SPECIAL FIX> (STKTMP) <SPECIAL
 118                                                                    ANY>
 119                (BASEF) <SPECIAL NODE>
 120                (KILL-LIST NO-KILL CODE-START CODE-PTR TMPS-NEXT ARGS-NEXT
 121                 EVERY-TEMP ALL-TEMPS-LIST) <SPECIAL LIST> (TMPS) <SPECIAL
 122                                                                   FORM>
 123                (K) <LIST [REST NODE]> (ATAG RTAG) ATOM
 124                (TMP-DEST) <SPECIAL ATOM> (SPECD) <SPECIAL ANY>
 125                (FREE-TEMPS) <SPECIAL <LIST [REST TEMP]>>)
 126         <MIM-FCN <NODE-NAME .BASEF>
 127                  <RSUBR-DECLS .BASEF>
 128                  <OR <ACTIVATED .BASEF>
 129                      <ACTIV? <BINDING-STRUCTURE .BASEF>>
 130                      <GETPROP <NODE-NAME .BASEF> FRAME>
 131                      <GETPROP .BASEF UNWIND>>>
 132         <MIM-TEMPS-HOLD>
 133         <SET SPECD <BIND-CODE .BASEF <> <SET BNDTMP <GEN-TEMP <>>>>>
 134         <COND (<AGND .BASEF> <IEMIT `LOOP>)>
 135         <LABEL-TAG .ATAG>
 136         <PUT .BASEF ,DST DONT-CARE>
 137         <PUT .BASEF ,CDST DONT-CARE>
 138         <PUT .BASEF ,ATAG .ATAG>
 139         <PUT .BASEF ,RTAG .RTAG>
 140         <COND (<N==? <SET CD <SEQ-GEN .K DONT-CARE <> <> T>> ,NO-DATUM>)
 141               (ELSE <SET CD <CDST .BASEF>>)>
 142         <COND (<N==? <CDST .BASEF> .CD> <SET CD <MOVE-ARG .CD <CDST .BASEF>>>)>
 143         <LABEL-TAG .RTAG>
 144         <COND (<ASSIGNED? TMP-DEST> <PUTREST .TMPS-NEXT (= .TMP-DEST)>)>
 145         <FREE-TEMP .CD <>>
 146         <COND (.SPECD <IEMIT `UNBIND .BNDTMP> <FREE-TEMP .BNDTMP>)>
 147         <COND (<N==? .STK-CHARS8 0>
 148                <SET STK-CHARS8 <+ .STK-CHARS8 .STK>>
 149                <SET STK-CHARS7 <+ .STK-CHARS7 .STK>>
 150                <SET STK 0>)>
 151         <COND (<ASSIGNED? STKTMP>
 152                <COND (<N==? .STK 0>
 153                       <IEMIT `SUB .STKTMP .STK = .STKTMP (`TYPE FIX)>)
 154                      (<N==? .STK-CHARS7 0>
 155                       <IEMIT `IFSYS "TOPS20">
 156                       <IEMIT `SUB .STKTMP .STK-CHARS7 = .STKTMP>
 157                       <IEMIT `ENDIF "TOPS20">
 158                       <IEMIT `IFSYS "UNIX">
 159                       <IEMIT `SUB .STKTMP .STK-CHARS8 = .STKTMP>
 160                       <IEMIT `ENDIF "UNIX">)>
 161                <IEMIT `ADJ .STKTMP>
 162                <FREE-TEMP .STKTMP>)
 163               (<N==? .STK 0> <IEMIT `ADJ <- .STK>>)
 164               (<N==? .STK-CHARS8 0>
 165                <IEMIT `IFSYS "TOPS20">
 166                <IEMIT `ADJ <- .STK-CHARS7>>
 167                <IEMIT `ENDIF "TOPS20">
 168                <IEMIT `IFSYS "UNIX">
 169                <IEMIT `ADJ <- .STK-CHARS8>>
 170                <IEMIT `ENDIF "UNIX">)>
 171         <MIM-RETURN .CD>
 172         <TYPIFY-TEMPS .EVERY-TEMP>
 173         <IEMIT `END <CHTYPE <NODE-NAME .BASEF> FCN-ATOM>>
 174         .CODE-START>
 175
 176 " Generate code for setting up and binding agruments."
 177
 178 <DEFINE BIND-CODE (NOD
 179                    "OPTIONAL" (FORPROG <>) BNDTMP
 180                    "AUX" (BST <BINDING-STRUCTURE .NOD>) (NPRUNE T) (LARG <>)
 181                          (ANY-ARG <>) (ANY-SPEC <>) (OPTS? <>) (OL ()) T-NAME
 182                          (TUP? <>))
 183    #DECL ((NOD) NODE (BST B) <LIST [REST SYMTAB]> (NPRUNE) <SPECIAL ANY>
 184           (INAME) <UVECTOR [REST ATOM]> (BASEF) NODE (TMPS-NEXT OL) LIST
 185           (T-NAME) <SPECIAL ANY>)
 186    <COND
 187     (<NOT .FORPROG>
 188      <SET OL
 189           <MAPF ,LIST
 190                 <FUNCTION (SYM)
 191                         #DECL ((SYM) SYMTAB)
 192                         <COND (<OPT? .SYM> <MAKE-TAG "OPT">)
 193                               (ELSE
 194                                <COND (<==? <CODE-SYM .SYM> ,ARGL-TUPLE>
 195                                       <SET TUP? <TOTARGS .NOD>>)>
 196                                <MAPRET>)>>
 197                 .BST>>
 198      <COND (<NOT <EMPTY? .OL>>
 199             <PUTREST <REST .OL <- <LENGTH .OL> 1>> (<MAKE-TAG "OPT">)>
 200             <IEMIT `OPT-DISPATCH <REQARGS .NOD> .TUP? !.OL>)>
 201      <MAPF <>
 202       <FUNCTION (SYM "AUX" (NT 0))
 203          #DECL ((SYM) SYMTAB (NT) FIX)
 204          <PUT .SYM
 205               ,TEMP-NAME-SYM
 206               <GEN-TEMP <> <NAME-SYM .SYM> T <DECL-SYM .SYM>>>
 207          <COND
 208           (<OPT? .SYM>
 209            <LABEL-TAG <1 .OL>>
 210            <SET OL <REST .OL>>
 211            <COND (<AND <NOT <SPEC-SYM .SYM>>
 212                        <N==? <CODE-SYM .SYM> ,ARGL-OPT>
 213                        <N==? <CODE-SYM .SYM> ,ARGL-QOPT>
 214                        <OR <==? <SET NT <NODE-TYPE <INIT-SYM .SYM>>>
 215                                 ,QUOTE-CODE>
 216                            <==? .NT ,LVAL-CODE>>>
 217                   <GEN <INIT-SYM .SYM> ,POP-STACK>)
 218                  (ELSE <PUSH ,THE-UNBOUND>)>
 219            <COND (<EMPTY? <REST .OL>> <LABEL-TAG <1 .OL>>)>)>>
 220       .BST>
 221      <COND (<==? <NODE-TYPE .NOD> ,FUNCTION-CODE> <MIM-TEMPS-EMIT>)>)>
 222    <MAPR <>
 223          <FUNCTION (BS
 224                     "AUX" (SYM <1 .BS>) TMP (A? <ARG? .SYM>) (O? <OPT? .SYM>))
 225                  #DECL ((SYM) SYMTAB (TMP) TEMP (BS) <LIST SYMTAB>)
 226                  <COND (<NOT <USED-AT-ALL .SYM>>
 227                         <COND (<SPEC-SYM .SYM>
 228                                <COMPILE-NOTE "Special variable never used: "
 229                                              <NAME-SYM .SYM>>)
 230                               (ELSE
 231                                <COMPILE-WARNING
 232                                 "Variable never used: " <NAME-SYM .SYM>>)>)>
 233                  <COND (<AND <NOT .LARG> <NOT .A?> <NOT .O?>>
 234                         <COND (<AND .ANY-SPEC .ANY-ARG> <GEN-FIX-BIND>)>
 235                         <SET LARG T>)>
 236                  <COND (<NOT <TYPE? <TEMP-NAME-SYM .SYM> TEMP>>
 237                         <PUT .SYM
 238                              ,TEMP-NAME-SYM
 239                              <GEN-TEMP <> <NAME-SYM .SYM> T <DECL-SYM .SYM>>>)>
 240                  <COND (<AND .O? <NOT .OPTS?>> <SET OPTS? T>)>
 241                  <COND (<AND <ASSIGNED? BNDTMP>
 242                              <SPEC-SYM .SYM>
 243                              <NOT .ANY-SPEC>>
 244                         <SET ANY-SPEC T>
 245                         <USE-TEMP .BNDTMP LBIND>
 246                         <GET-BINDING .BNDTMP>)>
 247                  <PUT <SET TMP <TEMP-NAME-SYM .SYM>>
 248                       ,TEMP-TYPE
 249                       <COND (<ASS? .SYM> ANY) (ELSE <COMPOSIT-TYPE .SYM>)>>
 250                  <COND (<OR .A? .O?>
 251                         <PUTREST .ARGS-NEXT
 252                                  <SET ARGS-NEXT
 253                                       (<CHTYPE <TEMP-NAME .TMP> ATOM>)>>)>
 254                  <COND (<OR .A? .O?> <SET ANY-ARG T>)>
 255                  <SET T-NAME <TEMP-NAME .TMP>>
 256                  <COND (<AND <BIND-GENERATE .SYM .FORPROG>
 257                              <NOT .A?>
 258                              <NOT .O?>
 259                              <NOT <SPEC-SYM .SYM>>>
 260                         <PUTREST .TMPS-NEXT <SET TMPS-NEXT (.T-NAME)>>
 261                         <USE-TEMP .TMP <ISTYPE? <COMPOSIT-TYPE .SYM>>>
 262                         <PUT .TMP ,TEMP-REFS 1>)>
 263                  <COND (<AND <NOT .LARG> <EMPTY? <REST .BS>>>
 264                         <COND (<AND .ANY-SPEC .ANY-ARG> <GEN-FIX-BIND>)>
 265                         <SET LARG T>)>>
 266          .BST>
 267    <COND (<ACTIVATED .NOD> <IEMIT `ACTIVATION>)>
 268    <COND (<AND <ASSIGNED? BNDTMP> <NOT .ANY-SPEC> <PUTPROP .NOD UNWIND>>
 269           <USE-TEMP .BNDTMP LBIND>
 270           <GET-BINDING .BNDTMP>)>
 271    <COND (.ANY-SPEC .BNDTMP)>>
 272
 273 " Generate \"BIND\" binding code."
 274
 275 <DEFINE BIND-B (SYM "AUX" TMP FTMP)
 276         #DECL ((STK) FIX (SYM) SYMTAB (BASEF) NODE)
 277         <COND (<SPEC-SYM .SYM>
 278                <SET FTMP <PREV-FRAME <GEN-TEMP FRAME>>>
 279                <SPECIAL-BINDING .SYM T .FTMP>
 280                <SET STK <+ .STK ,BINDING-LENGTH>>
 281                <FREE-TEMP .FTMP>)
 282               (ELSE
 283                <PREV-FRAME <TEMP-NAME-SYM .SYM>>
 284                <USE-TEMP <TEMP-NAME-SYM .SYM>>)>
 285         T>
 286
 287 " Do code generation for normal  arguments."
 288
 289 <DEFINE NORM-B (SYM)
 290         #DECL ((SYM) SYMTAB (STK) FIX)
 291         <COND (<SPEC-SYM .SYM>
 292                <SPECIAL-BINDING .SYM <> <TEMP-NAME-SYM .SYM>>
 293                <SET STK <+ .STK ,BINDING-LENGTH>>)>
 294         T>
 295
 296 " Initialized optional argument binder."
 297
 298 <DEFINE OPT1-B (SYM "AUX" NT)
 299         #DECL ((SYM) SYMTAB)
 300         <COND (<OR <SPEC-SYM .SYM>
 301                    <AND <N==? <SET NT <NODE-TYPE <INIT-SYM .SYM>>> ,QUOTE-CODE>
 302                         <N==? .NT ,LVAL-CODE>>>
 303                <OPTBIND .SYM <INIT-SYM .SYM>>)>>
 304
 305 " Uninitialized optional argument binder."
 306
 307 <DEFINE OPT2-B (SYM)
 308         #DECL ((SYM) SYMTAB)
 309         <COND (<SPEC-SYM .SYM> <OPTBIND .SYM>)>
 310         T>
 311
 312 " Create a binding for either intitialized or unitialized optional."
 313
 314 <DEFINE OPTBIND (SYM
 315                  "OPTIONAL" DVAL
 316                  "AUX" (GIVE <MAKE-TAG>) (DEF <MAKE-TAG>) DV TMP
 317                        (SPEC <SPEC-SYM .SYM>) BLBL)
 318         #DECL ((STK) FIX (SYM) SYMTAB (BASEF DVAL) NODE (GIVE DEF) ATOM)
 319         <COND (<OR <ASSIGNED? DVAL> .SPEC>
 320                <COND (.SPEC
 321                       <SET TMP <GEN-TEMP FIX>>
 322                       <IEMIT `SET .TMP 0>)>
 323                <TEST-ARG <TEMP-NAME-SYM .SYM> .GIVE>
 324                <COND (<ASSIGNED? DVAL>
 325                       <GEN .DVAL <TEMP-NAME-SYM .SYM>>)>
 326                <COND (.SPEC
 327                       <IEMIT `SET .TMP 1>
 328                       <FREE-TEMP <TEMP-NAME-SYM .SYM> <>>)>
 329                <LABEL-TAG .GIVE>)>
 330         <COND (.SPEC
 331                <SPECIAL-BINDING .SYM <> <TEMP-NAME-SYM .SYM>>
 332                <SET STK <+ .STK ,BINDING-LENGTH>>
 333                <IEMIT `VEQUAL? .TMP 0 + <SET BLBL <MAKE-TAG>>>
 334                <GEN-FIX-BIND>
 335                <LABEL-TAG .BLBL>
 336                <FREE-TEMP .TMP>)>
 337         T>
 338
 339 " Do a binding for a named activation."
 340
 341 <DEFINE ACT-B (SYM "AUX" TMP FTMP)
 342         #DECL ((STK) FIX (SYM) SYMTAB (BASEF) NODE)
 343         <COND (<SPEC-SYM .SYM>
 344                <SET FTMP <CURRENT-FRAME>>
 345                <SPECIAL-BINDING .SYM T .FTMP>
 346                <SET STK <+ .STK ,BINDING-LENGTH>>
 347                <FREE-TEMP .FTMP>
 348                <PUT .BASEF ,ACTIVATED T>)
 349               (<OR <ACTIVATED .BASEF> <ACTIV? <BINDING-STRUCTURE .BASEF>>>
 350                <PUT .BASEF ,ACTIVATED T>
 351                <CURRENT-FRAME <TEMP-NAME-SYM .SYM>>
 352                <USE-TEMP <TEMP-NAME-SYM .SYM>>)>
 353         T>
 354
 355 " Bind an \"AUX\" variable."
 356
 357 <DEFINE AUX1-B (SYM
 358                 "OPT" (FORCE-INIT <>)
 359                 "AUX" (TMP <TEMP-NAME-SYM .SYM>) TY PT INIT
 360                       (NOD <INIT-SYM .SYM>))
 361         #DECL ((SYM) SYMTAB (NOD) NODE (STK) FIX)
 362         <COND (<AND <SET TY <ISTYPE? <COMPOSIT-TYPE .SYM>>>
 363                     <OR <==? <SET PT <TYPEPRIM .TY>> FIX>
 364                         <==? .PT WORD>
 365                         <==? .PT LIST>>
 366                     <NOT <ASS? .SYM>>>)
 367               (ELSE <SET TY <>>)>
 368         <COND (<SPEC-SYM .SYM>
 369                <SPECIAL-BINDING .SYM T <SET INIT <GEN .NOD>>>
 370                <SET STK <+ .STK ,BINDING-LENGTH>>
 371                <FREE-TEMP .INIT>)
 372               (<AND <NOT .FORCE-INIT> <==? <NODE-TYPE .NOD> ,QUOTE-CODE>>
 373                <USE-TEMP .TMP .TY>
 374                <SET T-NAME
 375                     (<COND (.TY <CHTYPE [<TEMP-NAME .TMP> .TY] ADECL>)
 376                            (ELSE <TEMP-NAME .TMP>)>
 377                      <ATOMCHK <NODE-NAME .NOD>>)>)
 378               (ELSE
 379                <COND (.TY <SET T-NAME <CHTYPE [<TEMP-NAME .TMP> .TY] ADECL>>)>
 380                <GEN .NOD <TEMP-NAME-SYM .SYM>>)>
 381         T>
 382
 383 " Do a binding for an uninitialized \"AUX\" "
 384
 385 <DEFINE AUX2-B (SYM FP "AUX" TMP)
 386         #DECL ((SYM) SYMTAB (STK) FIX)
 387         <COND (<SPEC-SYM .SYM>
 388                <SPECIAL-BINDING .SYM T>
 389                <SET STK <+ .STK ,BINDING-LENGTH>>)
 390               (<AND .FP <ASS? .SYM>> <SET-SYM .SYM ,THE-UNBOUND T> T)
 391               (<ASS? .SYM>)
 392               (ELSE
 393                <SET TMP <PUT <TEMP-NAME-SYM .SYM> ,TEMP-ALLOC <>>>
 394                <PUT .TMP ,TEMP-REFS 0>
 395                <>)>>
 396
 397 " Do a \"TUPLE\" binding."
 398
 399 <DEFINE TUPL-B (SYM "AUX" (TMP1 <TEMP-NAME-SYM .SYM>) TMP2)
 400         #DECL ((SYM) SYMTAB (STK) FIX)
 401         <GET-ARG-TUPLE .TMP1>
 402         <COND (<SPEC-SYM .SYM>
 403                <SPECIAL-BINDING .SYM T .TMP1>
 404                <SET STK <+ .STK ,BINDING-LENGTH>>)>
 405         T>
 406
 407 " Dispatch table for binding generation code."
 408
 409 <DEFINE BIND-GENERATE (SYM FORPROG "AUX" (COD <CODE-SYM .SYM>))
 410         #DECL ((SYM) SYMTAB (COD) FIX)
 411         <CASE ,==?
 412               .COD
 413               (,ARGL-ACT <ACT-B .SYM>)
 414               (,ARGL-IAUX <AUX1-B .SYM .FORPROG>)
 415               (,ARGL-AUX <AUX2-B .SYM .FORPROG>)
 416               (,ARGL-TUPLE <TUPL-B .SYM>)
 417               (,ARGL-ARGS <NORM-B .SYM>)
 418               (,ARGL-QIOPT <OPT1-B .SYM>)
 419               (,ARGL-IOPT <OPT1-B .SYM>)
 420               (,ARGL-QOPT <OPT2-B .SYM>)
 421               (,ARGL-OPT <OPT2-B .SYM>)
 422               (,ARGL-CALL <NORM-B .SYM>)
 423               (,ARGL-BIND <BIND-B .SYM>)
 424               (,ARGL-QUOTE <NORM-B .SYM>)
 425               (,ARGL-ARG <NORM-B .SYM>)>>
 426
 427 " Appliacation of a form could still be an NTH."
 428
 429 <DEFINE FORM-F-GEN (NOD WHERE "AUX" (K <KIDS .NOD>) TY)
 430         #DECL ((NOD) NODE)
 431         <COND (<==? <ISTYPE? <SET TY <RESULT-TYPE <1 .K>>>> FIX>
 432                <PUT .NOD ,NODE-NAME INTH>
 433                <PUT .NOD ,NODE-TYPE <NODE-SUBR .NOD>>
 434                <PUT .NOD ,NODE-SUBR ,NTH>
 435                <COND (<OR <==? <NODE-TYPE .NOD> ,ALL-REST-CODE>
 436                           <==? <NODE-TYPE .NOD> ,NTH-CODE>>
 437                       <SET K (<2 .K> <1 .K>)>)>
 438                <PUT .NOD ,KIDS .K>
 439                <GEN .NOD .WHERE>)
 440               (.TY <FORM-GEN .NOD .WHERE>)
 441               (ELSE
 442                <COMPILE-ERROR "Non-applicabe object type "
 443                               <NODE-NAME .NOD>
 444                               .NOD>)>>
 445
 446 " Generate a call to EVAL for uncompilable FORM."
 447
 448 <DEFINE FORM-GEN (NOD WHERE)
 449         #DECL ((NOD) NODE)
 450         <COND (<==? .WHERE DONT-CARE> <SET WHERE <GEN-TEMP>>)>
 451         <START-FRAME EVAL>
 452         <PUSH <REFERENCE <NODE-NAME .NOD>>>
 453         <MSUBR-CALL EVAL 1 .WHERE>
 454         .WHERE>
 455
 456 " Generate code for LIST/VECTOR etc. evaluation."
 457
 458 <GDECL (COPIERS) <UVECTOR [REST ATOM]>>
 459
 460 <DEFINE COPY-GEN (NOD WHERE
 461                   "AUX" (I 0) (ARGS <KIDS .NOD>) SEGTYP (SEGLABEL <MAKE-TAG>)
 462                         (INAME <NODE-NAME .NOD>) SEGTMP COUNTMP RES X
 463                         (SEGCALLED <>)
 464                         (STACK?
 465                          <COND
 466                           (<AND <TYPE? <SET X <PARENT .NOD>> NODE>
 467                                 <OR <==? <NODE-TYPE .X> ,STACK-CODE>
 468                                     <AND <==? <NODE-TYPE .X> ,CHTYPE-CODE>
 469                                          <TYPE? <SET X <PARENT .X>> NODE>
 470                                          <==? <NODE-TYPE .X>
 471                                               ,STACK-CODE>>>>)
 472                           (<==? .INAME TUPLE>)>))
 473    #DECL ((GT) <OR FALSE FIX> (NOD) NODE (ARGS) <LIST [REST NODE]> (I) FIX
 474           (SEGCALLED SEGLABEL COUNTMP) <SPECIAL ANY> (STK) FIX)
 475    <SET I
 476         <MAPF ,+
 477               <FUNCTION (N)
 478                       #DECL ((N) NODE)
 479                       <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE> 0) (ELSE 1)>>
 480               .ARGS>>
 481    <COND
 482     (<REPEAT (N)
 483              #DECL ((N) NODE (STK) FIX)
 484              <COND (<EMPTY? .ARGS> <RETURN>)>
 485              <COND
 486               (<==? <NODE-TYPE <SET N <1 .ARGS>>> ,SEGMENT-CODE>
 487                <COND (<NOT <ASSIGNED? SEGTMP>>
 488                       <SET SEGTMP <GEN-TEMP <>>>
 489                       <SET COUNTMP <GEN-TEMP FIX>>
 490                       <SET-TEMP .COUNTMP .I '(`TYPE FIX)>)>
 491                <SET RES <GEN <SET N <1 <KIDS .N>>> .SEGTMP>>
 492                <SET SEGTYP <STRUCTYP-SEG <RESULT-TYPE .N>>>
 493                <COND (<AND <==? <NODE-NAME .NOD> LIST>
 494                            <EMPTY? <REST .ARGS>>
 495                            <OR <NOT .SEGTYP> <==? .SEGTYP LIST>>
 496                            <N==? .RES ,NO-DATUM>>
 497                       <COND (<==? .WHERE DONT-CARE>
 498                              <SET WHERE <GEN-TEMP LIST>>)
 499                             (<TYPE? .WHERE TEMP> <USE-TEMP .WHERE LIST>)>
 500                       <SEGMENT-LIST .SEGTMP
 501                                     .COUNTMP
 502                                     .SEGTYP
 503                                     .WHERE
 504                                     .SEGLABEL
 505                                     .RES>
 506                       <FREE-TEMP .SEGTMP>
 507                       <FREE-TEMP .COUNTMP>
 508                       <RETURN <>>)
 509                      (<AND <N==? .RES ,NO-DATUM> <N==? .SEGTYP MULTI>>
 510                       <SEGMENT-STACK .SEGTMP
 511                                      .COUNTMP
 512                                      .SEGTYP
 513                                      <ISTYPE? <RESULT-TYPE .N>>
 514                                      .SEGLABEL>
 515                       <SET SEGLABEL <MAKE-TAG>>)
 516                      (.SEGCALLED
 517                       <LABEL-TAG .SEGLABEL>
 518                       <SET SEGLABEL <MAKE-TAG>>)>)
 519               (ELSE <GEN <1 .ARGS> ,POP-STACK>)>
 520              <SET ARGS <REST .ARGS>>>
 521      <COND (<ASSIGNED? SEGTMP>
 522             <FREE-TEMP .SEGTMP>
 523             <COND (<NOT .STACK?> <FREE-TEMP .COUNTMP>)>)>
 524      <COND (<==? .WHERE DONT-CARE> <SET WHERE <GEN-TEMP .INAME>>)
 525            (<TYPE? .WHERE TEMP> <USE-TEMP .WHERE .INAME>)>
 526      <COND (<==? .INAME VECTOR>
 527             <GEN-VECTOR <COND (<ASSIGNED? SEGTMP> .COUNTMP) (ELSE .I)>
 528                         .WHERE
 529                         .STACK?>)
 530            (<==? .INAME LIST>
 531             <GEN-LIST <COND (<ASSIGNED? SEGTMP> .COUNTMP) (ELSE .I)> .WHERE>)
 532            (<==? .INAME UVECTOR>
 533             <GEN-UVECTOR <COND (<ASSIGNED? SEGTMP> .COUNTMP) (ELSE .I)>
 534                          .WHERE
 535                          .STACK?>)
 536            (<==? .INAME TUPLE>
 537             <GEN-TUPLE <COND (<ASSIGNED? SEGTMP> .COUNTMP) (ELSE .I)> .WHERE>)
 538            (ELSE <ERROR "NOT READY YET">)>
 539      <COND
 540       (.STACK?
 541        <COND (<ASSIGNED? SEGTMP>
 542               <COND (<N==? .INAME UVECTOR>
 543                      <IEMIT `LSH
 544                             .COUNTMP
 545                             1
 546                             =
 547                             <COND (<G? <TEMP-REFS .COUNTMP> 1>
 548                                    <FREE-TEMP .COUNTMP <>>
 549                                    <SET COUNTMP <GEN-TEMP FIX>>)>>)>
 550               <FREE-TEMP .COUNTMP <>>
 551               <COND (<ASSIGNED? STKTMP>
 552                      <IEMIT `SUB .STKTMP .COUNTMP = .STKTMP>)
 553                     (ELSE
 554                      <IEMIT `SUB 0 .COUNTMP = <SET STKTMP <GEN-TEMP FIX>>>)>
 555               <SET STK <+ .STK 2>>)
 556              (ELSE
 557               <SET STK
 558                    <+ .STK
 559                       <COND (<==? .INAME UVECTOR> .I) (ELSE <* .I 2>)>
 560                       2>>)>)>)>
 561    .WHERE>
 562
 563 "Generate code for a call to a SUBR."
 564
 565 <DEFINE SUBR-GEN (NOD WHERE "AUX" N ST)
 566         #DECL ((NOD) NODE)
 567         <COND (<AND <TYPE? <SET N <PARENT .NOD>> NODE>
 568                     <==? <NODE-TYPE .N> ,SEGMENT-CODE>
 569                     <OR <==? <SET ST <STRUCTYP-SEG <RESULT-TYPE .NOD>>> MULTI>
 570                         <NOT .ST>>>
 571                <SET SEGCALLED T>
 572                <COMP-SUBR-CALL .NOD <KIDS .NOD> .WHERE .COUNTMP .SEGLABEL>)
 573               (ELSE <COMP-SUBR-CALL .NOD <KIDS .NOD> .WHERE <> <>>)>>
 574
 575 " Compile call to a SUBR that doesn't compile or PUSHJ."
 576
 577 <DEFINE COMP-SUBR-CALL (N OBJ W PARENT-COUNT PARENT-LABEL
 578                         "AUX" (I 0) SEGTMP COUNTMP (SEGLABEL <MAKE-TAG>) RES
 579                               (SUBR <NODE-NAME .N>) (SEGCALLED <>) X (SLNT 0)
 580                               (STACK?
 581                                <COND
 582                                 (<AND
 583                                   <TYPE? <SET X <PARENT .N>> NODE>
 584                                   <OR <==? <NODE-TYPE .X> ,STACK-CODE>
 585                                       <AND
 586                                        <==? <NODE-TYPE .X> ,CHTYPE-CODE>
 587                                        <TYPE? <SET X <PARENT .X>> NODE>
 588                                        <==? <NODE-TYPE .X> ,STACK-CODE>>>>)>))
 589    #DECL ((I) FIX (OBJ) <LIST [REST NODE]> (UNK) <OR FALSE ATOM> (N) NODE
 590           (SEGCALLED SEGLABEL COUNTMP) <SPECIAL ANY>)
 591    <SET I
 592         <MAPF ,+
 593               <FUNCTION (N)
 594                       #DECL ((N) NODE)
 595                       <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE>
 596                              <SET SLNT <>>
 597                              0)
 598                             (ELSE
 599                              <COND (<AND <==? .SUBR STRING>
 600                                          <TYPE? .SLNT FIX>
 601                                          <==? <NODE-TYPE .N> ,QUOTE-CODE>>
 602                                     <SET SLNT <+ .SLNT
 603                                                  <LENGTH <CHTYPE <NODE-NAME .N>
 604                                                                  STRING>>>>)
 605                                    (ELSE <SET SLNT <>>)>
 606                              1)>>
 607               .OBJ>>
 608    <COND (<NOT <MEMQ .SUBR '[LIST VECTOR UVECTOR TUPLE BYTES STRING]>>
 609           <COND (.PARENT-COUNT <IEMIT `SFRAME <FORM QUOTE .SUBR>>)
 610                 (ELSE <START-FRAME .SUBR>)>)>
 611    <MAPF <>
 612     <FUNCTION (OB)
 613        #DECL ((OB) NODE (I STA) FIX)
 614        <COND
 615         (<==? <NODE-TYPE .OB> ,SEGMENT-CODE>
 616          <COND (<NOT <ASSIGNED? SEGTMP>>
 617                 <SET SEGTMP <GEN-TEMP <>>>
 618                 <SET COUNTMP <GEN-TEMP <>>>
 619                 <SET-TEMP .COUNTMP .I '(`TYPE FIX)>)>
 620          <SET RES <GEN <SET OB <1 <KIDS .OB>>> .SEGTMP>>
 621          <COND (<AND <N==? .RES ,NO-DATUM>
 622                      <N==? <STRUCTYP-SEG <RESULT-TYPE .OB>> MULTI>>
 623                 <SEGMENT-STACK
 624                  .SEGTMP
 625                  .COUNTMP
 626                  <STRUCTYP <RESULT-TYPE .OB>>
 627                  <ISTYPE? <RESULT-TYPE .OB>>
 628                  .SEGLABEL>)
 629                (.SEGCALLED <LABEL-TAG .SEGLABEL>)>
 630          <SET SEGLABEL <MAKE-TAG>>)
 631         (ELSE <GEN .OB ,POP-STACK>)>>
 632     .OBJ>
 633    <COND (<ASSIGNED? SEGTMP>
 634           <FREE-TEMP .SEGTMP>
 635           <COND (<NOT .STACK?> <FREE-TEMP .COUNTMP <>>)>)>
 636    <COND (<==? .W DONT-CARE> <SET W <GEN-TEMP <RESULT-TYPE .N>>>)
 637          (<TYPE? .W TEMP> <USE-TEMP .W <RESULT-TYPE .N>>)>
 638    <COND (.PARENT-COUNT
 639           <SEG-SUBR-CALL .SUBR
 640                          <COND (<ASSIGNED? COUNTMP> .COUNTMP) (ELSE .I)>
 641                          .W
 642                          .PARENT-COUNT
 643                          .PARENT-LABEL>)
 644          (ELSE
 645           <SMSUBR-CALL .SUBR
 646                        <COND (<ASSIGNED? COUNTMP> .COUNTMP) (ELSE .I)>
 647                        .W
 648                        .STACK?
 649                        .SLNT>)>
 650    .W>
 651
 652 "\f"
 653
 654 <DEFINE SEGMENT-STACK (SEGTMP COUNTMP SEGTYP SEGTYP2
 655                        "OPT" (TG1 <MAKE-TAG>)
 656                        "AUX" (TG2 <MAKE-TAG>) TMP)
 657         <COND (<NOT .SEGTYP>
 658                <IEMIT `LOOP
 659                       (<TEMP-NAME .SEGTMP> TYPE VALUE LENGTH)
 660                       (<TEMP-NAME .COUNTMP> VALUE)>)
 661               (<==? .SEGTYP LIST>
 662                <IEMIT `LOOP
 663                       (<TEMP-NAME .SEGTMP> VALUE)
 664                       (<TEMP-NAME .COUNTMP> VALUE)>)
 665               (ELSE
 666                <IEMIT `LOOP
 667                       (<TEMP-NAME .SEGTMP> VALUE LENGTH)
 668                       (<TEMP-NAME .COUNTMP> VALUE)>)>
 669         <LABEL-TAG .TG2>
 670         <IEMIT `INTGO>
 671         <COND (.SEGTYP <EMPTY-CHECK .SEGTYP .SEGTMP .SEGTYP2 T .TG1>)
 672               (ELSE <IEMIT `EMPTY? .SEGTMP + .TG1>)>
 673         <COND (.SEGTYP
 674                <NTH-DO .SEGTYP .SEGTMP ,POP-STACK 1 .SEGTYP2>
 675                <REST-DO .SEGTYP .SEGTMP .SEGTMP 1 .SEGTYP2>)
 676               (ELSE
 677                <IEMIT `NTH1 .SEGTMP = ,POP-STACK>
 678                <IEMIT `REST1 .SEGTMP = .SEGTMP>)>
 679         <IEMIT `ADD .COUNTMP 1 = .COUNTMP (`TYPE FIX)>
 680         <BRANCH-TAG .TG2>
 681         <LABEL-TAG .TG1>>
 682
 683 <DEFINE SEGMENT-LIST (SEGTMP COUNTMP LIST? W
 684                       "OPT" (TGX <MAKE-TAG>) (RES <>)
 685                       "AUX" (TG1 <MAKE-TAG>) (TG2 <MAKE-TAG>) (TG3 <MAKE-TAG>)
 686                             (TG4 <MAKE-TAG>) (OTMP <GEN-TEMP>))
 687         <COND (<NOT .LIST?>
 688                <IEMIT `TYPE .SEGTMP = .OTMP>
 689                <IEMIT `AND .OTMP 7 = .OTMP>
 690                <IEMIT `VEQUAL? .OTMP 1 + .TG1>
 691                <SEGMENT-STACK .SEGTMP .COUNTMP <> <>>
 692                <GEN-LIST .COUNTMP .W>
 693                <BRANCH-TAG .TG2>
 694                <LABEL-TAG .TGX>
 695                <SET-TEMP .SEGTMP 0>
 696                <LABEL-TAG .TG1>)>
 697         <IEMIT `LOOP>
 698         <LABEL-TAG .TG4>
 699         <IEMIT `VEQUAL? .COUNTMP 0 + .TG3>
 700         <IEMIT `POP = .OTMP>
 701         <IEMIT `CONS .OTMP .SEGTMP = .SEGTMP '(`TYPE LIST)>
 702         <IEMIT `SUB .COUNTMP 1 = .COUNTMP '(`TYPE FIX)>
 703         <BRANCH-TAG .TG4>
 704         <LABEL-TAG .TG3>
 705         <FREE-TEMP .OTMP>
 706         <MOVE-ARG .SEGTMP .W>
 707         <COND (<NOT .LIST?> <LABEL-TAG .TG2>)>
 708         .W>
 709
 710 <GDECL (SUBRS TEMPLATES) VECTOR>
 711
 712 <DEFINE SIDES (L)
 713         #DECL ((L) <LIST [REST NODE]>)
 714         <MAPF <>
 715               <FUNCTION (N)
 716                       <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE> <>)
 717                             (<OR <==? <NODE-TYPE .N> ,ISUBR-CODE>
 718                                  <MEMQ ALL <SIDE-EFFECTS .N>:<OR LIST FALSE>>>
 719                              <MAPLEAVE T>)>>
 720               .L>>
 721
 722 " Generate code for a COND."
 723
 724 <DEFINE COND-GEN (NOD W
 725                   "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
 726                   "AUX" NW (RW .W) LOCN (COND <MAKE-TAG "COND">) W2 (WSET <>)
 727                         (KK <CLAUSES .NOD>) (SDIR .DIR))
 728    #DECL ((NOD) NODE (COND) ATOM (KK) <LIST [REST NODE]>)
 729    <COND (.NOTF <SET DIR <NOT .DIR>>)>
 730    <COND (<OR <==? .W ,POP-STACK>
 731               <AND <TYPE? .W TEMP>
 732                    <TEMP-NO-RECYCLE .W>
 733                    <N==? <TEMP-NO-RECYCLE .W> ANY>>>
 734           <SET W DONT-CARE>)>
 735    <MAPR <>
 736     <FUNCTION (BRN
 737                "AUX" (LAST <EMPTY? <REST .BRN>>) (BR <1 .BRN>) NEXT
 738                      (PRED-TRUE <>) (K <CLAUSES .BR>) (PR <PREDIC .BR>)
 739                      (NO-SEQ <>) (LEAVE <>) FLG K2 PR2 BR2 PRT2 (BRNCHED <>)
 740                      (PRT <RESULT-TYPE .PR>) CT)
 741        #DECL ((BR2 PR2 PR BR) NODE (BRN) <LIST NODE> (K) <LIST [REST NODE]>)
 742        <COND
 743         (<AND
 744           <NOT .LAST>
 745           <TYPE-OK? .PRT FALSE>
 746           <NOT
 747            <TYPE-OK?
 748             <SET PRT2 <RESULT-TYPE <SET PR2 <PREDIC <SET BR2 <2 .BRN>>>>>>
 749             FALSE>>
 750           <OR <AND <EMPTY? <SET K2 <CLAUSES .BR2>>> <NOT .PRT2>>
 751               <AND <NOT <EMPTY? .K2>>
 752                    <NOT <RESULT-TYPE <NTH .K2 <LENGTH .K2>>>>>>>
 753          <COND-COMPLAIN "Predicate assumed true to avoid type mismatch" .PR>
 754          <SET PRED-TRUE T>)>
 755        <COND
 756         (<EMPTY? .K>
 757          <COND
 758           (<OR <SET FLG <OR <NOT <TYPE-OK? .PRT FALSE>> .PRED-TRUE>> .LAST>
 759            <COND (<NOT .LAST>
 760                   <COND-COMPLAIN "NON REACHABLE COND CLAUSE(S) " <2 .BRN>>)>
 761            <COND
 762             (<AND .FLG .BRANCH>
 763              <SET LOCN <GEN .PR <COND (<==? .RW FLUSHED> FLUSHED) (ELSE .W)>>>
 764              <COND (<AND <NOT .WSET> <N==? .LOCN ,NO-DATUM> <N==? .RW FLUSHED>>
 765                     <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
 766                     <SET WSET T>)>
 767              <COND (.DIR <BRANCH-TAG .BRANCH>)>)
 768             (<AND .BRANCH .LAST>
 769              <SET LOCN
 770                   <PRED-BRANCH-GEN
 771                    .BRANCH
 772                    .PR
 773                    .SDIR
 774                    <COND (<==? .RW FLUSHED> FLUSHED)
 775                          (<OR .WSET <AND <TYPE? .W TEMP> <0? <TEMP-REFS .W>>>>
 776                           <SET WSET T>
 777                           .W)
 778                          (ELSE <SET WSET T> <SET W <GEN-TEMP <>>>)>
 779                    .NOTF>>)
 780             (ELSE
 781              <SET LOCN <GEN .PR <COND (<==? .RW FLUSHED> FLUSHED) (ELSE .W)>>>
 782              <COND (<AND <NOT .WSET> <N==? .LOCN ,NO-DATUM> <N==? .RW FLUSHED>>
 783                     <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
 784                     <SET WSET T>)>)>
 785            <MAPLEAVE>)
 786           (<NOT .PRT>
 787            <COND-COMPLAIN "Predicate assumed FALSE to satisfy type constraint "
 788                           .PR>
 789            <GEN .PR FLUSHED>)
 790           (<==? <ISTYPE? .PRT> FALSE> <GEN .PR FLUSHED>)
 791           (<==? .RW FLUSHED>
 792            <PRED-BRANCH-GEN <COND (<AND .BRANCH .SDIR> .BRANCH) (ELSE .COND)>
 793                             .PR
 794                             T
 795                             FLUSHED
 796                             .NOTF>)
 797           (ELSE
 798            <COND
 799             (<AND .BRANCH .SDIR>
 800              <FREE-TEMP <PRED-BRANCH-GEN .BRANCH .PR T FLUSHED .NOTF>>)
 801             (ELSE
 802              <SET LOCN
 803                   <PRED-BRANCH-GEN
 804                    .COND
 805                    .PR
 806                    T
 807                    <COND (<OR .WSET <AND <TYPE? .W TEMP> <0? <TEMP-REFS .W>>>>
 808                           <SET WSET T>
 809                           .W)
 810                          (ELSE <SET WSET T> <SET W <GEN-TEMP <>>>)>
 811                    .NOTF>>
 812              <COND (<NOT .LAST> <DEALLOCATE-TEMP .LOCN>)>)>)>)
 813         (ELSE
 814          <SET NEXT <MAKE-TAG "PHRASE">>
 815          <SET CT <RESULT-TYPE <NTH .K <LENGTH .K>>>>
 816          <COND
 817           (<OR <AND <N==? <ISTYPE? .PRT> FALSE>
 818                     <NOT .CT>
 819                     <COND-COMPLAIN
 820 "Predicate assumed FALSE to satisfy type constraibnt"
 821                                    .PR>>
 822                <AND <==? <ISTYPE? .PRT> FALSE>
 823                     <COND-COMPLAIN "COND PREDICATE ALWAYS FALSE" .PR>>>
 824            <COND (<AND .BRANCH .LAST <NOT .DIR>>
 825                   <SET LOCN <GEN .PR .W>>
 826                   <COND (<AND <NOT .WSET>
 827                               <N==? .LOCN ,NO-DATUM>
 828                               <N==? .RW FLUSHED>>
 829                          <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
 830                          <SET WSET T>)>
 831                   <BRANCH-TAG .BRANCH>)
 832                  (ELSE
 833                   <COND (<AND .LAST <NOT <==? .RW FLUSHED>>>
 834                          <SET LOCN <GEN .PR .W>>
 835                          <COND (<AND <NOT .WSET> <N==? .LOCN ,NO-DATUM>>
 836                                 <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
 837                                 <SET WSET T>)>)
 838                         (ELSE <SET LOCN <GEN .PR FLUSHED>>)>
 839                   <COND (<N==? .PRT NO-RETURN> <BRANCH-TAG .NEXT>)>)>
 840            <SET NO-SEQ T>)
 841           (<AND <TYPE-OK? FALSE .PRT> <NOT .PRED-TRUE>>
 842            <COND
 843             (<AND .LAST <NOT .DIR> .BRANCH>
 844              <SET LOCN
 845                   <PRED-BRANCH-GEN
 846                    .BRANCH
 847                    .PR
 848                    <>
 849                    <COND (<==? .RW FLUSHED> FLUSHED)
 850                          (<OR .WSET <AND <TYPE? .W TEMP> <0? <TEMP-REFS .W>>>>
 851                           <SET WSET T>
 852                           .W)
 853                          (ELSE <SET WSET T> <SET W <GEN-TEMP <>>>)>
 854                    .NOTF>>
 855              <DEALLOCATE-TEMP .LOCN>)
 856             (<AND .LAST .BRANCH>
 857              <FREE-TEMP <PRED-BRANCH-GEN .NEXT .PR <> FLUSHED>>)
 858             (<AND .LAST <NOT <==? .RW FLUSHED>>>
 859              <SET LOCN
 860                   <PRED-BRANCH-GEN
 861                    .NEXT
 862                    .PR
 863                    <>
 864                    <COND (<==? .RW FLUSHED> FLUSHED)
 865                          (<OR .WSET <AND <TYPE? .W TEMP> <0? <TEMP-REFS .W>>>>
 866                           <SET WSET T>
 867                           .W)
 868                          (ELSE <SET WSET T> <SET W <GEN-TEMP <>>>)>>>
 869              <DEALLOCATE-TEMP .LOCN>)
 870             (ELSE <PRED-BRANCH-GEN .NEXT .PR <> FLUSHED>)>)
 871           (ELSE
 872            <SET K (.PR !.K)>
 873            <COND (<NOT .LAST>
 874                   <SET LEAVE T>
 875                   <COND-COMPLAIN "NON REACHABLE COND CLAUSE(S)" <2 .BRN>>)>)>
 876          <COND
 877           (.BRANCH
 878            <OR
 879             .NO-SEQ
 880             <COND
 881              (<OR
 882                <SET FLG
 883                     <NOT <TYPE-OK?
 884                           <RESULT-TYPE <SET PR <NTH .K <LENGTH .K>>>>
 885                           FALSE>>>
 886                <NOT <TYPE-OK? <RESULT-TYPE .PR> '<NOT FALSE>>>>
 887               <COND (.NOTF
 888                      <SEQ-GEN .K FLUSHED>
 889                      <COND (<==? .RW FLUSHED> <SET LOCN ,NO-DATUM>)
 890                            (ELSE
 891                             <SET LOCN <MOVE-ARG <REFERENCE <NOT .FLG>> .W>>
 892                             <COND (<AND <NOT .WSET> <N==? .LOCN ,NO-DATUM>>
 893                                    <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
 894                                    <SET WSET T>)>)>)
 895                     (ELSE
 896                      <SET LOCN
 897                           <SEQ-GEN .K
 898                                    <COND (<OR <==? .RW FLUSHED>
 899                                               <N==? .SDIR .FLG>>
 900                                           FLUSHED)
 901                                          (ELSE .W)>>>
 902                      <COND (<AND <NOT .WSET>
 903                                  <N==? .RW FLUSHED>
 904                                  <N==? .LOCN ,NO-DATUM>>
 905                             <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
 906                             <SET WSET T>)>)>
 907               <COND (<==? .FLG .SDIR> <SET BRNCHED T> <BRANCH-TAG .BRANCH>)>)
 908              (ELSE
 909               <SET LOCN
 910                    <PSEQ-GEN .K
 911                              <COND (<==? .RW FLUSHED> FLUSHED) (ELSE .W)>
 912                              .BRANCH
 913                              .SDIR
 914                              .NOTF>>
 915               <COND (<AND <NOT .WSET>
 916                           <N==? .LOCN ,NO-DATUM>
 917                           <N==? .RW FLUSHED>>
 918                      <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
 919                      <SET WSET T>)>)>>)
 920           (<NOT .NO-SEQ>
 921            <SET LOCN
 922                 <PSEQ-GEN .K
 923                           <COND (<==? .RW FLUSHED> FLUSHED) (ELSE .W)>
 924                           .BRANCH
 925                           .SDIR
 926                           .NOTF>>
 927            <COND (<AND <NOT .WSET> <N==? .LOCN ,NO-DATUM> <N==? .RW FLUSHED>>
 928                   <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
 929                   <SET WSET T>)>)>
 930          <COND (<AND <NOT .LAST>
 931                      <N==? <RESULT-TYPE <NTH .K <LENGTH .K>>> NO-RETURN>>
 932                 <OR .NO-SEQ <DEALLOCATE-TEMP .LOCN>>
 933                 <OR .BRNCHED .NO-SEQ <BRANCH-TAG .COND>>)>
 934          <LABEL-TAG .NEXT>)>
 935        <COND (<NOT <ASSIGNED? NPRUNE>> <PUT .BR ,CLAUSES ()>)>
 936        <AND .LEAVE <MAPLEAVE>>>
 937     .KK>
 938    <COND (<NOT <ASSIGNED? NPRUNE>> <PUT .NOD ,CLAUSES ()>)>
 939    <LABEL-TAG .COND>
 940    <SET NW
 941         <COND (<==? <RESULT-TYPE .NOD> NO-RETURN> ,NO-DATUM)
 942               (ELSE <MOVE-ARG .W .RW>)>>
 943    .NW>
 944
 945 <DEFINE FIXUP-TEMP (W LOCN)
 946         <COND (<AND <TYPE? .LOCN TEMP> <L=? <TEMP-REFS .LOCN> 1>> .LOCN)
 947               (<==? .LOCN .W> .LOCN)
 948               (ELSE <MOVE-ARG .LOCN <GEN-TEMP <>>>)>>
 949
 950 <DEFINE PSEQ-GEN (L W B D NF "AUX" (WSET <>) WW)
 951    #DECL ((L) <LIST [REST NODE]>)
 952    <MAPR <>
 953     <FUNCTION (N "AUX" (ND <1 .N>) NX K)
 954             #DECL ((N) <LIST NODE> (ND) NODE)
 955             <COND (<NOT <EMPTY? <REST .N>>>
 956                    <SET NX <2 .N>>
 957                    <COND (<AND <==? <NODE-TYPE .NX> ,CALL-CODE>
 958                                <G=? <LENGTH <SET K <KIDS .NX>>> 2>
 959                                <==? <NODE-NAME <1 .K>> `ENDIF>>
 960                           <SET WW <GEN .ND .W>>
 961                           <COND (<AND <NOT .WSET>
 962                                       <N==? .W FLUSHED>
 963                                       <N==? .WW ,NO-DATUM>
 964                                       <N==? .W ,POP-STACK>>
 965                                  <SET W <FIXUP-TEMP .W .WW>>
 966                                  <SET WSET T>)>
 967                           <COND (<NOT <EMPTY? <REST .N 2>>>
 968                                  <DEALLOCATE-TEMP .W>)>)
 969                          (<OR <AND <G=? <LENGTH .ND> <INDEX ,SIDE-EFFECTS>>
 970                                    <SIDE-EFFECTS .ND>>
 971                               <GETPROP .ND DONT-FLUSH-ME>
 972                               ,DONT-FLUSH-ME>
 973                           <GEN .ND FLUSHED>)>)
 974                   (<AND <==? <NODE-TYPE .ND> ,CALL-CODE>
 975                         <G=? <LENGTH <SET K <KIDS .ND>>> 2>
 976                         <==? <NODE-NAME <1 .K>> `ENDIF>>
 977                    <GEN .ND FLUSHED>)
 978                   (ELSE
 979                    <SET W
 980                         <COND (.B <PRED-BRANCH-GEN .B .ND .D .W .NF>)
 981                               (ELSE <GEN .ND .W>)>>)>>
 982     .L>
 983    .W>
 984
 985 <DEFINE COND-COMPLAIN (MSG N1) #DECL ((N1) NODE) <COMPILE-NOTE .MSG .N1>>
 986
 987 " Generate code for OR use BOOL-GEN to do work."
 988
 989 <DEFINE OR-GEN (NOD WHERE "OPTIONAL" (NF <>) (BR <>) (DIR T))
 990         #DECL ((NOD) NODE)
 991         <BOOL-GEN .NOD <CLAUSES .NOD> T .WHERE .NF .BR .DIR>>
 992
 993 " Generate code for AND use BOOL-GEN to do work."
 994
 995 <DEFINE AND-GEN (NOD WHERE "OPTIONAL" (NF <>) (BR <>) (DIR <>))
 996         #DECL ((NOD) NODE)
 997         <BOOL-GEN .NOD <CLAUSES .NOD> <> .WHERE .NF .BR .DIR>>
 998
 999 <DEFINE BOOL-GEN (NOD PREDS RESULT W NOTF BRANCH DIR
1000                   "AUX" (RW .W) (BOOL <MAKE-TAG "BOOL">)
1001                         (FLUSH <==? .RW FLUSHED>) (WSET <>)
1002                         (FLS <AND <NOT .BRANCH> .FLUSH>) RTF SRES LOCN FIN)
1003    #DECL ((PREDS) <LIST [REST NODE]> (NOTF DIR FLUSH FLS RTF) ANY (BOOL) ATOM
1004           (BRANCH) <OR ATOM FALSE> (NOD) NODE (LOCN) ANY (SRES RESULT) ANY)
1005    <COND (<OR <==? .W ,POP-STACK>
1006               <AND <TYPE? .W TEMP>
1007                    <TEMP-NO-RECYCLE .W>
1008                    <N==? <TEMP-NO-RECYCLE .W> ANY>>>
1009           <SET W DONT-CARE>)>
1010    <COND (.NOTF <SET RESULT <NOT .RESULT>>)>
1011    <SET SRES .RESULT>
1012    <SET RTF
1013         <AND <NOT .FLUSH>
1014              <==? .SRES .DIR>
1015              <TYPE-OK? <RESULT-TYPE .NOD> FALSE>>>
1016    <COND (.DIR <SET RESULT <NOT .RESULT>>)>
1017    <COND
1018     (<EMPTY? .PREDS> <SET LOCN <MOVE-ARG <REFERENCE .RESULT> .W>>)
1019     (ELSE
1020      <MAPR <>
1021       <FUNCTION (BRN
1022                  "AUX" (BR <1 .BRN>) (LAST <EMPTY? <REST .BRN>>)
1023                        (RT <RESULT-TYPE .BR>) (RTFL <>) TY)
1024          #DECL ((BRN) <LIST NODE [REST NODE]> (BR) NODE)
1025          <COND
1026           (<AND .FLUSH
1027                 <NOT .LAST>
1028                 <EMPTY? <REST .BRN 2>>
1029                 <OR <AND <==? <ISTYPE? <SET TY <RESULT-TYPE <2 .BRN>>>> FALSE>
1030                          <NOT .SRES>
1031                          <SET TY FALSE>>
1032                     <AND .SRES <NOT <TYPE-OK? .TY FALSE>>>>
1033                 <OR <L? <LENGTH <2 .BRN>> <INDEX ,SIDE-EFFECTS>>
1034                     <NOT <SIDE-EFFECTS <2 .BRN>>>>>
1035            <COND (<==? .TY FALSE> <SET RT ATOM>) (ELSE <SET RT FALSE>)>)>
1036          <COND
1037           (<AND <TYPE-OK? .RT FALSE>
1038                 <NOT <SET RTFL <==? <ISTYPE? .RT> FALSE>>>>
1039            <COND
1040             (<OR .BRANCH <AND .FLS <NOT .LAST>>>
1041              <COND
1042               (.LAST
1043                <SET LOCN
1044                 <PRED-BRANCH-GEN
1045                  .BRANCH
1046                  .BR
1047                  .DIR
1048                  <COND (.FLUSH FLUSHED)
1049                        (<OR .WSET <AND <TYPE? .W TEMP> <0? <TEMP-REFS .W>>>>
1050                         <SET WSET T>
1051                         .W)
1052                        (ELSE <SET WSET T> <SET W <GEN-TEMP <>>>)>
1053                  .NOTF>>)
1054               (ELSE
1055                <SET LOCN
1056                 <PRED-BRANCH-GEN
1057                  <COND (.FLS .BOOL) (.RESULT .BOOL) (ELSE .BRANCH)>
1058                  .BR
1059                  .SRES
1060                  <COND (<OR .FLUSH <NOT .RTF>> FLUSHED)
1061                        (<OR .WSET <AND <TYPE? .W TEMP> <0? <TEMP-REFS .W>>>>
1062                         <SET WSET T>
1063                         .W)
1064                        (ELSE <SET WSET T> <SET W <GEN-TEMP <>>>)>
1065                  .NOTF>>
1066                <DEALLOCATE-TEMP .LOCN>)>)
1067             (.LAST
1068              <SET LOCN <GEN .BR .W>>
1069              <COND (<AND <NOT .FLUSH> <N==? .LOCN ,NO-DATUM> <NOT .WSET>>
1070                     <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
1071                     <SET WSET T>)>
1072              .LOCN)
1073             (ELSE
1074              <SET LOCN
1075                   <PRED-BRANCH-GEN
1076                    .BOOL
1077                    .BR
1078                    .DIR
1079                    <COND (.FLUSH FLUSHED)
1080                          (<OR .WSET <AND <TYPE? .W TEMP> <0? <TEMP-REFS .W>>>>
1081                           <SET WSET T>
1082                           .W)
1083                          (ELSE <SET WSET T> <SET W <GEN-TEMP <>>>)>
1084                    .NOTF>>
1085              <DEALLOCATE-TEMP .LOCN>)>)
1086           (<OR <N==? .SRES <COND (.NOTF <SET RTFL <NOT .RTFL>>) (ELSE .RTFL)>>
1087                .LAST>
1088            <COND (<NOT .LAST>
1089                   <COMPILE-NOTE "NON REACHABLE AND/OR CLAUSE" <2 .BRN>>)>
1090            <COND (.BRANCH
1091                   <SET LOCN
1092                        <GEN .BR <COND (<N==? .DIR .RTFL> .W) (ELSE FLUSHED)>>>
1093                   <COND (<AND <NOT .FLUSH>
1094                               <N==? .LOCN ,NO-DATUM>
1095                               <NOT .WSET>
1096                               <N==? .DIR .RTFL>>
1097                          <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
1098                          <SET WSET T>)>
1099                   <COND (<AND <N==? .DIR .RTFL>
1100                               <N==? <RESULT-TYPE .BR> NO-RETURN>>
1101                          <BRANCH-TAG .BRANCH>)>)
1102                  (ELSE
1103                   <SET LOCN <GEN .BR .W>>
1104                   <COND (<AND <NOT .FLUSH> <N==? .LOCN ,NO-DATUM> <NOT .WSET>>
1105                          <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
1106                          <SET WSET T>)>
1107                   .LOCN)>
1108            <MAPLEAVE>)
1109           (ELSE
1110            <COND (<OR <L? <LENGTH .BR> <INDEX ,SIDE-EFFECTS>>
1111                       <NOT <SIDE-EFFECTS .BR>>
1112                       <==? .BRN .PREDS>>
1113                   <COMPILE-NOTE <STRING "PREDICATE ALWAYS "
1114                                         <COND (.RTFL "FALSE")
1115                                               (ELSE "TRUE")>  " IN AND/OR">
1116                                 .BR>)>
1117            <GEN .BR FLUSHED>)>>
1118       .PREDS>)>
1119    <COND (<NOT <ASSIGNED? NPRUNE>> <PUT .NOD ,CLAUSES ()>)>
1120    <COND (<NOT <AND .BRANCH <NOT .RESULT>>> <LABEL-TAG .BOOL>)>
1121    <SET FIN
1122         <COND (<==? <RESULT-TYPE .NOD> NO-RETURN> ,NO-DATUM)
1123               (ELSE <MOVE-ARG .W .RW>)>>
1124    .FIN>
1125
1126 " Generate code for ASSIGNED?"
1127
1128 <DEFINE ASSIGNED?-GEN (N W
1129                        "OPTIONAL" (NF <>) (BR <>) (DIR <>) (SETF <>)
1130                        "AUX" (A <NODE-NAME .N>) (SDIR .DIR)
1131                              (FLS <==? .W FLUSHED>) B2 TMP (GLOBAL T))
1132         #DECL ((N) NODE)
1133         <COND (<==? .W DONT-CARE> <SET W <GEN-TEMP <>>>)>
1134         <COND (.NF <SET DIR <NOT .DIR>>)>
1135         <COND (.SETF <DEALLOCATE-TEMP <MOVE-ARG <REFERENCE <NOT .SDIR>>
1136                                                 .W>>)>
1137         <SET DIR <COND (<AND .BR <NOT .FLS>> <NOT .DIR>) (ELSE .DIR)>>
1138         <COND (<AND <TYPE? .A SYMTAB> <NOT <SPEC-SYM .A>>>
1139                <SET A <LADDR .A>>
1140                <COND (<AND .BR .FLS>
1141                       <GEN-TYPE? .A UNBOUND .BR <NOT .DIR>>
1142                       FLUSHED)
1143                      (.BR
1144                       <GEN-TYPE? .A UNBOUND <SET B2 <MAKE-TAG>> <NOT .DIR>>
1145                       <SET W <MOVE-ARG <REFERENCE .SDIR> .W>>
1146                       <BRANCH-TAG .BR>
1147                       <LABEL-TAG .B2>
1148                       .W)
1149                      (ELSE
1150                       <GEN-TYPE? .A UNBOUND <SET BR <MAKE-TAG>> <NOT .DIR>>
1151                       <TRUE-FALSE .N .BR .W>)>)
1152               (ELSE
1153                <COND (<TYPE? .A SYMTAB>
1154                       <COND (<N==? <CODE-SYM .A> -1> <SET GLOBAL <>>)>
1155                       <SET A <NAME-SYM .A>>)
1156                      (ELSE <SET A <GEN <1 <KIDS .N>>>>)>
1157                <COND (<AND .BR .FLS>
1158                       <ASS-GEN .A .BR .DIR .GLOBAL>
1159                       <FREE-TEMP .A>
1160                       FLUSHED)
1161                      (.BR
1162                       <ASS-GEN .A <SET B2 <MAKE-TAG>> .DIR .GLOBAL>
1163                       <SET W <MOVE-ARG <REFERENCE .SDIR> .W>>
1164                       <BRANCH-TAG .BR>
1165                       <LABEL-TAG .B2>
1166                       <FREE-TEMP .A>
1167                       .W)
1168                      (ELSE
1169                       <ASS-GEN .A <SET BR <MAKE-TAG>> .DIR .GLOBAL>
1170                       <FREE-TEMP .A>
1171                       <TRUE-FALSE .N .BR .W>)>)>>
1172
1173 <DEFINE GASSIGNED?-GEN (N W
1174                         "OPTIONAL" (NF <>) (BR <>) (DIR <>) (SETF <>)
1175                         "AUX" (A <NODE-NAME .N>) (SDIR .DIR)
1176                               (NM <NODE-NAME .N>) (FLS <==? .W FLUSHED>) B2
1177                               TMP)
1178         #DECL ((N) NODE)
1179         <COND (<==? .W DONT-CARE> <SET W <GEN-TEMP <>>>)>
1180         <COND (.NF <SET DIR <NOT .DIR>>)>
1181         <COND (.SETF <DEALLOCATE-TEMP <MOVE-ARG <REFERENCE <NOT .SDIR>> .W>>)>
1182         <SET DIR <COND (<AND .BR <NOT .FLS>> <NOT .DIR>) (ELSE .DIR)>>
1183         <SET A <GEN <1 <KIDS .N>>>>
1184         <COND (<AND .BR .FLS> <GEN-GASS .A .BR .DIR .NM> FLUSHED)
1185               (.BR
1186                <GEN-GASS .A <SET B2 <MAKE-TAG>> .DIR .NM>
1187                <SET W <MOVE-ARG <REFERENCE .SDIR> .W>>
1188                <BRANCH-TAG .BR>
1189                <LABEL-TAG .B2>
1190                .W)
1191               (ELSE
1192                <GEN-GASS .A <SET BR <MAKE-TAG>> .DIR .NM>
1193                <TRUE-FALSE .N .BR .W>)>>
1194
1195 <DEFINE TRUE-FALSE (N B W "OPTIONAL" (THIS T) "AUX" (RW .W) (B2 <MAKE-TAG>))
1196         #DECL ((N) NODE (B2 B) ATOM)
1197         <MOVE-ARG <REFERENCE .THIS> .W>
1198         <BRANCH-TAG .B2>
1199         <LABEL-TAG .B>
1200         <MOVE-ARG <REFERENCE <NOT .THIS>> .W>
1201         <LABEL-TAG .B2>
1202         <DEALLOCATE-TEMP .W>
1203         <MOVE-ARG .W .RW>>
1204
1205 " Generate code for LVAL."
1206
1207 <DEFINE LVAL-GEN (NOD WHERE
1208                   "AUX" (SYM <NODE-NAME .NOD>) TT (ADDR <>) REFS
1209                         (LIVE
1210                          <COND (<==? <LENGTH <SET TT <TYPE-INFO .NOD>>> 2>
1211                                 <2 .TT>)
1212                                (ELSE T)>) TMP)
1213    #DECL ((NOD) NODE (SYM) SYMTAB (NO-KILL) LIST (REFS) FIX)
1214    <COND (<==? <RESULT-TYPE .NOD> NO-RETURN>
1215           <COMPILE-ERROR "Variable referenced before initialization: "
1216                          <NAME-SYM .SYM>
1217                          .NOD>)>
1218    <SET TT
1219     <MOVE-ARG
1220      <COND
1221       (<AND <SPEC-SYM .SYM> <N==? <CODE-SYM .SYM> -1>>
1222        <SET TMP
1223             <COND (<TYPE? .WHERE TEMP> .WHERE)
1224                   (<==? .WHERE ,POP-STACK> .WHERE)
1225                   (ELSE <GEN-TEMP <>>)>>
1226        <COND (<TYPE? .TMP TEMP> <USE-TEMP .TMP <DECL-SYM .SYM>>)>
1227        <GET-VALUE-X <NAME-SYM .SYM> .TMP>
1228        .TMP)
1229       (<SPEC-SYM .SYM>
1230        <SET TMP <COND (<TYPE? .WHERE TEMP> .WHERE) (ELSE <GEN-TEMP <>>)>>
1231        <USE-TEMP .TMP>
1232        <START-FRAME LVAL>
1233        <PUSH-CONSTANT <NAME-SYM .SYM>>
1234        <MSUBR-CALL LVAL 1 .TMP>
1235        .TMP)
1236       (ELSE
1237        <SET ADDR <LADDR .SYM>>
1238        <COND (<TYPE? .ADDR TEMP>
1239               <COND (<AND ,DEATH
1240                           <NOT .LIVE>
1241                           <NOT <SPEC-SYM .SYM>>
1242                           <NOT <MAPF <>
1243                                      <FUNCTION (LL)
1244                                              #DECL ((LL) LIST)
1245                                              <AND <==? <1 .LL> .SYM>
1246                                                   <PUT .LL 2 T>
1247                                                   <MAPLEAVE>>>
1248                                      .NO-KILL>>>)
1249                     (<0? <SET REFS <TEMP-REFS .ADDR>>> <USE-TEMP .ADDR>)
1250                     (ELSE <PUT .ADDR ,TEMP-REFS <+ .REFS 1>>)>)>
1251        .ADDR)>
1252      .WHERE>>
1253    .TT>
1254
1255 <DEFINE DELAY-KILL (L1 L2 "AUX" TT TAC SYM)
1256         #DECL ((L1 L2) <LIST [REST !<LIST SYMTAB <OR ATOM FALSE>>]>
1257                (SYM) SYMTAB)
1258         <REPEAT ()
1259                 <COND (<OR <==? .L1 .L2> <NOT ,DEATH>> <RETURN>)>
1260                 <COND (<2 <SET TT <1 .L1>>>
1261                        <SET TT <TEMP-NAME-SYM <SET SYM <1 .TT>>>>
1262                        <FREE-TEMP .TT>)>
1263                 <SET L1 <REST .L1>>>>
1264
1265 " Generate LVAL for free variable."
1266
1267 <DEFINE FLVAL-GEN (NOD WHERE "AUX" TMP T1)
1268         #DECL ((NOD) NODE)
1269         <SET TMP <COND (<==? .WHERE DONT-CARE> <GEN-TEMP <>>) (ELSE .WHERE)>>
1270         <COND (<TYPE? .TMP TEMP> <USE-TEMP .TMP>)>
1271         <COND (<TYPE? <SET T1 <NODE-NAME .NOD>> SYMTAB>
1272                <SET T1 <NAME-SYM .T1>>)
1273               (<==? <NODE-TYPE <1 <KIDS .NOD>>> ,QUOTE-CODE>
1274                <SET T1 <NODE-NAME <1 <KIDS .NOD>>>>)
1275               (ELSE <SET T1 <GEN <1 <KIDS .NOD>>>>)>
1276         <GET-VALUE-X .T1 .TMP T>
1277         <FREE-TEMP .T1>
1278         <MOVE-ARG .TMP .WHERE>>
1279
1280 <DEFINE FSET-GEN (NOD WHERE "AUX" TT (TEM <>) T1)
1281         #DECL ((NOD) NODE (TEM) <OR FALSE NODE>)
1282         <COND (<==? <NODE-SUBR .NOD> ,SET> <SET TEM <2 <KIDS .NOD>>>)>
1283         <COND (<TYPE? <SET TT <NODE-NAME .NOD>> SYMTAB>
1284                <SET TT <NAME-SYM .TT>>)
1285               (<==? <NODE-TYPE <SET T1 <1 <KIDS .NOD>>>> ,QUOTE-CODE>
1286                <SET TT <NODE-NAME .T1>>)
1287               (ELSE
1288                <SET TT <GEN .T1>>
1289                <COND (.TEM <SET TT <INTERF-CHANGE .TT .TEM>>)>)>
1290         <COND (.TEM
1291                <SET T1
1292                     <GEN .TEM <COND (<TYPE? .WHERE TEMP> .WHERE)
1293                                     (ELSE DONT-CARE)>>>)
1294               (ELSE
1295                <SET T1 ,THE-UNBOUND>)>
1296         <SET T1 <SET-VALUE .TT .T1 T>>
1297         <FREE-TEMP .TT>
1298         <MOVE-ARG <COND (<==? .T1 ,THE-UNBOUND> .TT) (ELSE .T1)> .WHERE>>
1299
1300 " Generate code for an internal SET."
1301
1302 <DEFINE SET-GEN (NOD WHERE "OPT" (NOTF <>) (BRANCH <>) (DIR <>)
1303                  "AUX" (SYM <NODE-NAME .NOD>) TY PT TEM (TT <>) REFS
1304                                  (NM <2 <CHTYPE <NODE-SUBR .NOD> MSUBR>>))
1305         #DECL ((NOD) NODE (SYM) SYMTAB)
1306         <COND
1307          (<AND <SPEC-SYM .SYM> <N==? <CODE-SYM .SYM> -1>>
1308           <COND (<==? .NM SET>
1309                  <SET TEM
1310                       <GEN <2 <KIDS .NOD>>
1311                            <COND (<TYPE? .WHERE TEMP> .WHERE) (ELSE DONT-CARE)>>>
1312                  <SET-VALUE <NAME-SYM .SYM> .TEM>)
1313                 (ELSE
1314                  <SET-VALUE <NAME-SYM .SYM> ,THE-UNBOUND>
1315                  <SET TEM <NAME-SYM .SYM>>)>
1316           <MOVE-ARG .TEM .WHERE>)
1317          (<AND <SPEC-SYM .SYM> <==? .NM UNASSIGN>>
1318           <START-FRAME UNASSIGN>
1319           <PUSH-CONSTANT <NAME-SYM .SYM>>
1320           <COND (<==? .WHERE DONT-CARE>
1321                  <SET WHERE <GEN-TEMP <RESULT-TYPE .NOD>>>)
1322                 (<TYPE? .WHERE TEMP> <USE-TEMP .WHERE <RESULT-TYPE .NOD>>)>
1323           <MSUBR-CALL UNASSIGN 1 .WHERE>
1324           <COND (<==? .WHERE FLUSHED> ,NO-DATUM) (ELSE .WHERE)>)
1325          (<SPEC-SYM .SYM>
1326           <START-FRAME SET>
1327           <PUSH-CONSTANT <NAME-SYM .SYM>>
1328           <GEN <2 <KIDS .NOD>> ,POP-STACK>
1329           <COND (<==? .WHERE DONT-CARE>
1330                  <SET WHERE <GEN-TEMP <RESULT-TYPE .NOD>>>)
1331                 (<TYPE? .WHERE TEMP> <USE-TEMP .WHERE <RESULT-TYPE .NOD>>)>
1332           <MSUBR-CALL SET 2 .WHERE>
1333           <COND (<==? .WHERE FLUSHED> ,NO-DATUM) (ELSE .WHERE)>)
1334          (ELSE
1335           <SET TEM <LADDR .SYM>>
1336           <COND (<AND <NOT <TEMP-ALLOC .TEM>>
1337                       <COND (<AND <SET TY <ISTYPE? <DECL-SYM .SYM>>>
1338                                   <OR <==? <SET PT <TYPEPRIM .TY>> FIX>
1339                                       <==? .PT WORD>
1340                                       <==? .PT LIST>>>
1341                              .TY)>>
1342                  <DEALLOCATE-TEMP <USE-TEMP .TEM .TY>>)>
1343           <COND (<==? .NM SET>
1344                  <COND (.BRANCH
1345                         <COND (.NOTF <SET DIR <NOT .DIR>>)>
1346                         <PRED-BRANCH-GEN .BRANCH <2 <KIDS .NOD>> .DIR .TEM
1347                                           <> T>)
1348                        (ELSE
1349                         <SET TEM <GEN <2 <KIDS .NOD>> .TEM>>)>)
1350                 (ELSE
1351                  <MOVE-ARG ,THE-UNBOUND .TEM>)>
1352           <COND (<TYPE? .TEM TEMP>
1353                  <COND (<0? <SET REFS <TEMP-REFS .TEM>>> <SET REFS 1>)>
1354                  <PUT .TEM ,TEMP-REFS <+ .REFS 1>>)>
1355           <MOVE-ARG .TEM .WHERE>)>>
1356
1357 <DEFINE ARG? (SYM) #DECL ((SYM) SYMTAB) <1? <NTH ,ARGTBL <CODE-SYM .SYM>>>>
1358
1359 <DEFINE OPT? (SYM) #DECL ((SYM) SYMTAB) <1? <NTH ,OPTBL <CODE-SYM .SYM>>>>
1360
1361 <SETG OPTBL ![0 0 0 0 0 1 1 1 1 0 0 0 0]>
1362
1363 <SETG ARGTBL ![0 0 0 0 1 0 0 0 0 1 0 1 1]>
1364
1365 <GDECL (OPTBL ARGTBL) <UVECTOR [REST FIX]>>
1366
1367 " Compute the address of a local variable using the stack model."
1368
1369 <DEFINE LADDR (S) #DECL ((S) SYMTAB) <TEMP-NAME-SYM .S>>
1370
1371 " Generate obscure stuff."
1372
1373 <DEFINE DEFAULT-GEN (NOD WHERE)
1374         #DECL ((NOD) NODE)
1375         <MOVE-ARG <REFERENCE <NODE-NAME .NOD>> .WHERE>>
1376
1377 " Do GVAL using direct locative reference."
1378
1379 <DEFINE GVAL-GEN (N W "AUX" (RT <RESULT-TYPE .N>) (TYP <ISTYPE? .RT>))
1380         #DECL ((N) NODE)
1381         <GEN-GVAL <NODE-NAME <1 <KIDS .N>>>
1382                   <COND (<==? .W DONT-CARE>
1383                          <SET W <GEN-TEMP .RT>>)
1384                         (<TYPE? .W TEMP> <USE-TEMP .W .RT> .W)
1385                         (ELSE .W)>
1386                   .TYP>
1387         .W>
1388
1389 " Do SETG using direct locative reference."
1390
1391 <DEFINE SETG-GEN (N W "AUX" TEM)
1392         #DECL ((N) NODE)
1393         <SET TEM <GEN <2 <KIDS .N>>>>
1394         <GEN-SETG <NODE-NAME <1 <KIDS .N>>>
1395                   .TEM
1396                   <COND (<==? <LENGTH <KIDS .N>> 3>
1397                          <GEN <3 <KIDS .N>> DONT-CARE>)
1398                         (ELSE <>)>
1399                   FLUSHED>
1400         <MOVE-ARG .TEM .W>>
1401
1402 " Generate GVAL calls."
1403
1404 <DEFINE FGVAL-GEN (N W "AUX" TEM)
1405         #DECL ((N) NODE)
1406         <GEN-GVAL <SET TEM <GEN <1 <KIDS .N>>>>
1407                   <COND (<==? .W DONT-CARE>
1408                          <SET W <GEN-TEMP <RESULT-TYPE .N>>>)
1409                         (<TYPE? .W TEMP> <USE-TEMP .W <RESULT-TYPE .N>> .W)
1410                         (ELSE .W)>>
1411         <FREE-TEMP .TEM>
1412         .W>
1413
1414 " Generate a SETG call."
1415
1416 <DEFINE FSETG-GEN (NOD W "AUX" TEM ATM)
1417         #DECL ((NOD) NODE)
1418         <SET ATM <GEN <1 <KIDS .NOD>>>>
1419         <SET ATM <INTERF-CHANGE .ATM <2 <KIDS .NOD>>>>
1420         <SET TEM
1421              <GEN <2 <KIDS .NOD>>
1422                   <COND (<TYPE? .W TEMP> .W) (ELSE DONT-CARE)>>>
1423         <GEN-SETG .ATM
1424                   .TEM
1425                   <COND (<==? <LENGTH <KIDS .NOD>> 3>
1426                          <GEN <3 <KIDS .NOD>> DONT-CARE>)
1427                         (ELSE <>)>
1428                   .W>
1429         <FREE-TEMP .ATM>
1430         <MOVE-ARG .TEM .W>>
1431
1432 <DEFINE CHTYPE-GEN (NOD WHERE
1433                     "AUX" (TYP <ISTYPE? <RESULT-TYPE .NOD>>)
1434                           (N <1 <KIDS .NOD>>) N2 TEM TT)
1435         #DECL ((NOD N) NODE)
1436         <COND (<AND .TYP
1437                     <TYPE? <PARENT .NOD> NODE>
1438                     <MEMQ <NODE-TYPE <PARENT .NOD>> ,CHTYPE-FOR-FREE>
1439                     <OR <==? .WHERE ,POP-STACK> <==? .WHERE DONT-CARE>>>
1440                <GEN .N .WHERE>)
1441               (ELSE
1442                <SET TEM <GEN .N>>
1443                <COND (<AND <G? <LENGTH <KIDS .NOD>> 1>
1444                            <N==? <NODE-TYPE <SET N2 <2 <KIDS .NOD>>>>
1445                                  ,QUOTE-CODE>>
1446                       <SET TEM <INTERF-CHANGE .TEM .N2>>
1447                       <SET TT <GEN <1 <KIDS .N2>>>>)>
1448                <COND (<==? .WHERE DONT-CARE>
1449                       <COND (<AND <TYPE? .TEM TEMP> <L=? <TEMP-REFS .TEM> 1>>
1450                              <DEALLOCATE-TEMP <SET WHERE .TEM>>
1451                              <USE-TEMP .TEM .TYP>)
1452                             (ELSE
1453                              <SET WHERE <GEN-TEMP <COND (.TYP) (ELSE ANY)>>>)>)
1454                      (<TYPE? .WHERE TEMP> <USE-TEMP .WHERE .TYP>)>
1455                <COND (<AND <ASSIGNED? N2> <N==? <NODE-TYPE .N2> ,QUOTE-CODE>>
1456                       <COND (<NOT <TYPE? .TT TEMP>>
1457                              <SET TT <MOVE-ARG .TT <GEN-TEMP <>>>>)>
1458                       <GEN-CHTYPE .TEM <FORM `TYPE <TEMP-NAME .TT>> .WHERE>
1459                       <FREE-TEMP .TT>)
1460                      (ELSE <GEN-CHTYPE .TEM .TYP .WHERE>)>
1461                <COND (<N==? .TEM .WHERE> <FREE-TEMP .TEM>)>
1462                .WHERE)>>
1463
1464 <GDECL (CHTYPE-FOR-FREE) <VECTOR [REST FIX]>>
1465
1466 <SETG CHTYPE-FOR-FREE
1467       [,NTH-CODE
1468        ,ARITH-CODE
1469        ,0-TST-CODE
1470        ,1?-CODE
1471        ,TEST-CODE
1472        ,LNTH-CODE
1473        ,MT-CODE
1474        ,REST-CODE
1475        ,MOD-CODE
1476        ,BITS-CODE
1477        ,BITL-CODE
1478        ,ROT-CODE
1479        ,LSH-CODE
1480        ,BIT-TEST-CODE]>
1481
1482 " Generate do-nothing piece of code."
1483
1484 <DEFINE ID-GEN (N W) #DECL ((N) NODE) <GEN <1 <KIDS .N>> .W>>
1485
1486 " Generate call to READ etc. with eof condition."
1487
1488 <DEFINE READ2-GEN (N W "AUX" (I 0) SPOB BRANCH TMP CF)
1489         #DECL ((N) NODE (I) FIX (SPOB) NODE)
1490         <COND (<AND <TYPE? .W TEMP> <L? <TEMP-REFS .W> 1>> <SET TMP .W>)
1491               (ELSE <SET TMP <GEN-TEMP <>>>)>
1492         <START-FRAME <NODE-NAME .N>>
1493         <MAPF <>
1494               <FUNCTION (OB)
1495                       #DECL ((OB SPOB) NODE (I) FIX)
1496                       <COND (<==? <NODE-TYPE .OB> ,EOF-CODE>
1497                              <SET SPOB .OB>
1498                              <CURRENT-FRAME ,POP-STACK>)
1499                             (ELSE <GEN .OB ,POP-STACK>)>
1500                       <SET I <+ .I 1>>>
1501               <KIDS .N>>
1502         <USE-TEMP .TMP>
1503         <MSUBR-CALL <NODE-NAME .N> .I .TMP>
1504         <GEN-==? <SET CF <CURRENT-FRAME>> .TMP <> <SET BRANCH <MAKE-TAG>>>
1505         <FREE-TEMP .CF>
1506         <DEALLOCATE-TEMP .TMP>
1507         <GEN .SPOB .TMP>
1508         <LABEL-TAG .BRANCH>
1509         <MOVE-ARG .TMP .W>>
1510
1511 <DEFINE GET-GEN (N W) <GETGET .N .W T>>
1512
1513 <DEFINE GET2-GEN (N W) <GETGET .N .W <>>>
1514
1515 <GDECL (GETTERS) UVECTOR>
1516
1517 <DEFINE GETGET (N W REV
1518                 "AUX" (K <KIDS .N>) (BR <MAKE-TAG>) TMP (LN <LENGTH .K>) CF)
1519         #DECL ((N) NODE (K) <LIST NODE NODE [REST NODE]> (LN) FIX)
1520         <START-FRAME <NODE-NAME .N>>
1521         <GEN <1 .K> ,POP-STACK>
1522         <GEN <2 .K> ,POP-STACK>
1523         <COND (<==? .LN 3> <CURRENT-FRAME ,POP-STACK>)>
1524         <MSUBR-CALL <NODE-NAME .N>
1525                     .LN
1526                     <COND (<AND <TYPE? .W TEMP>
1527                                 <OR <L? .LN 3> <L? <TEMP-REFS .W> 1>>>
1528                            <USE-TEMP <SET TMP .W>>)
1529                           (ELSE <SET TMP <GEN-TEMP>>)>>
1530         <COND (<==? .LN 3>
1531                <GEN-==? <SET CF <CURRENT-FRAME>> .TMP <> <SET BR <MAKE-TAG>>>
1532                <FREE-TEMP .CF>
1533                <COND (.REV
1534                       <START-FRAME EVAL>
1535                       <GEN <3 .K> ,POP-STACK>
1536                       <DEALLOCATE-TEMP <MSUBR-CALL EVAL 1 .TMP>>)
1537                      (ELSE <DEALLOCATE-TEMP <GEN <3 .K> .TMP>>)>
1538                <LABEL-TAG .BR>)>
1539         <MOVE-ARG .TMP .W>>
1540
1541 '<SETG GETTERS [,GET ,GETL ,GETPROP ,GETPL]>
1542
1543 <SETG STACK-INS [`CALL `UBLOCK `LIST `SYSCALL]>
1544
1545 <GDECL (STACK-INS) <VECTOR [REST ATOM]>>
1546
1547 <DEFINE CALL-GEN (NOD WHERE
1548                   "OPT" (NOTF <>) (B <>) (D <>)
1549                   "AUX" (K <KIDS .NOD>) (INS <NODE-NAME <1 .K>>) L RECSPEC
1550                         (ON-STACK <>) COUNTMP SEGTMP I INS1 (REC? <>))
1551    #DECL ((NOD) NODE (K) <LIST NODE [REST NODE]>)
1552    <COND (.NOTF <SET D <NOT .D>>)>
1553    <COND
1554     (<MEMQ .INS ,STACK-INS>
1555      <SET ON-STACK T>
1556      <COND (<OR <==? .INS `CALL> <==? .INS `SCALL>>
1557             <COND (<AND <==? <NODE-TYPE <SET INS1 <2 .K>>> ,QUOTE-CODE>
1558                         <TYPE? <NODE-NAME .INS1> ATOM>>
1559                    <IEMIT <COND (<==? .INS `CALL> `FRAME) (ELSE `SFRAME)>
1560                           <FORM QUOTE
1561                                 <SET INS1
1562                                      <CHTYPE <NODE-NAME .INS1> FCN-ATOM>>>>
1563                    <SET INS1 <FORM QUOTE .INS1>>)
1564                   (ELSE
1565                    <IEMIT <COND (<==? .INS `CALL> `FRAME) (ELSE `SFRAME)>>
1566                    <SET INS1 <GEN .INS1>>)>
1567             <SET K <REST .K>>)
1568            (<==? .INS `SYSCALL> <SET INS1 <GEN <2 .K>>> <SET K <REST .K>>)>)>
1569    <COND (<GETPROP .INS `RECORD-TYPE> <SET REC? T>)>
1570    <SET I
1571         <MAPF ,+
1572               <FUNCTION (N)
1573                       #DECL ((N) NODE)
1574                       <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE> 0) (ELSE 1)>>
1575               <REST .K>>>
1576    <SET L
1577     <MAPR ,LIST
1578      <FUNCTION (NL "AUX" (N <1 .NL>) TMP)
1579         #DECL ((N) NODE (NL) <LIST NODE>)
1580         <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE>
1581                <COND (<NOT <ASSIGNED? SEGTMP>>
1582                       <SET SEGTMP <GEN-TEMP <>>>
1583                       <SET COUNTMP <GEN-TEMP <>>>
1584                       <SET-TEMP .COUNTMP .I '(`TYPE FIX)>)>
1585                <GEN <1 <KIDS .N>> .SEGTMP>
1586                <SEGMENT-STACK
1587                 .SEGTMP
1588                 .COUNTMP
1589                 <STRUCTYP <RESULT-TYPE <1 <KIDS .N>>>>
1590                 <ISTYPE? <RESULT-TYPE <1 <KIDS .N>>>>>)
1591               (ELSE
1592                <SET TMP
1593                     <GEN .N <COND (.ON-STACK ,POP-STACK) (ELSE DONT-CARE)>>>
1594                <COND (<NOT .ON-STACK>
1595                       <MAPF <>
1596                             <FUNCTION (NN) <SET TMP <INTERF-CHANGE .TMP .NN>>>
1597                             <REST .NL>>)>
1598                .TMP)>>
1599      <REST .K>>>
1600    <COND (<NOT .ON-STACK> <MAPF <> <FUNCTION (X) <FREE-TEMP .X <>>> .L>)>
1601    <COND (<OR <==? .WHERE FLUSHED> <==? <RESULT-TYPE .NOD> NO-RETURN>>
1602           <COND (.ON-STACK
1603                  <COND (<ASSIGNED? INS1>
1604                         <IEMIT .INS
1605                                .INS1
1606                                <COND (<ASSIGNED? COUNTMP> .COUNTMP) (ELSE .I)>>
1607                         <FREE-TEMP .INS1>)
1608                        (ELSE
1609                         <IEMIT .INS
1610                                <COND (<ASSIGNED? COUNTMP> .COUNTMP)
1611                                      (ELSE .I)>>)>)
1612                 (.B <IEMIT .INS !.L <COND (.D +) (ELSE -)> .B>)
1613                 (ELSE <IEMIT .INS !.L>)>
1614           <SET WHERE ,NO-DATUM>)
1615          (ELSE
1616           <COND (<ASSIGNED? COUNTMP>
1617                  <FREE-TEMP .COUNTMP <>>
1618                  <FREE-TEMP .SEGTMP <>>)>
1619           <COND (<==? .WHERE DONT-CARE>
1620                  <SET WHERE <GEN-TEMP <RESULT-TYPE .NOD>>>)
1621                 (<TYPE? .WHERE TEMP> <USE-TEMP .WHERE <RESULT-TYPE .NOD>>)>
1622           <COND (.ON-STACK
1623                  <COND (<ASSIGNED? INS1>
1624                         <IEMIT .INS
1625                                .INS1
1626                                <COND (<ASSIGNED? COUNTMP> .COUNTMP) (ELSE .I)>
1627                                =
1628                                .WHERE>
1629                         <FREE-TEMP .INS1>)
1630                        (ELSE
1631                         <IEMIT .INS
1632                                <COND (<ASSIGNED? COUNTMP> .COUNTMP) (ELSE .I)>
1633                                =
1634                                .WHERE>)>)
1635                 (<AND .REC?
1636                       <TYPE? <SET RECSPEC <NTH .L <LENGTH .L>>> LIST>
1637                       <==? <LENGTH .RECSPEC> 2>
1638                       <=? <SPNAME <1 .RECSPEC>> "RECORD-TYPE">>
1639                  <COND (<==? <LENGTH .L> 1> <SET L ()>)
1640                        (ELSE <PUTREST <REST .L <- <LENGTH .L> 2>> ()>)>
1641                  <IEMIT .INS !.L = .WHERE .RECSPEC>)
1642                 (.B <IEMIT .INS !.L = .WHERE <COND (.D +) (ELSE -)> .B>)
1643                 (ELSE <IEMIT .INS !.L = .WHERE>)>)>
1644    .WHERE>
1645
1646 <DEFINE CHANNEL-OP-GEN (NOD WHERE
1647                         "AUX" (CTY <NODE-SUBR .NOD>) (K <KIDS .NOD>) L I)
1648    #DECL ((NOD) NODE (K) <LIST NODE [REST NODE]> (L) LIST)
1649    <SET I <+ <LENGTH .K> 1>>
1650    <SET L
1651     <MAPR ,LIST
1652      <FUNCTION (NL "AUX" (N <1 .NL>) TMP)
1653              #DECL ((N) NODE (NL) <LIST NODE>)
1654              <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE>
1655                     <COND (<TYPE? <SET TMP <NODE-NAME .N>> ATOM>
1656                            <FORM QUOTE .TMP>)
1657                           (ELSE .TMP)>)
1658                    (ELSE
1659                     <SET TMP <GEN .N DONT-CARE>>
1660                     <MAPF <>
1661                           <FUNCTION (NN) <SET TMP <INTERF-CHANGE .TMP .NN>>>
1662                           <REST .NL>>
1663                     .TMP)>>
1664      .K>>
1665    <MAPF <> <FUNCTION (X) <FREE-TEMP .X <>>> .L>
1666    <COND (<OR <==? .WHERE FLUSHED> <==? <RESULT-TYPE .NOD> NO-RETURN>>
1667           <IEMIT `CHANNEL-OP <FORM QUOTE .CTY> <2 .L> <1 .L> !<REST .L 2>>)
1668          (ELSE
1669           <COND (<==? .WHERE DONT-CARE>
1670                  <SET WHERE <GEN-TEMP <RESULT-TYPE .NOD>>>)
1671                 (<TYPE? .WHERE TEMP> <USE-TEMP .WHERE <RESULT-TYPE .NOD>>)>
1672           <IEMIT `CHANNEL-OP
1673                  <FORM QUOTE .CTY>
1674                  <2 .L>
1675                  <1 .L>
1676                  !<REST .L 2>
1677                  =
1678                  .WHERE>)>
1679    .WHERE>
1680
1681 <DEFINE SMSUBR-CALL (SUBRC NARGS WHERE "OPT" (STACK? <>) (SLNT <>)
1682                      "AUX"  (W <COND (<AND <==? .SUBRC STRING>
1683                                            <NOT .SLNT>
1684                                            .STACK?
1685                                            <NOT <TYPE? .WHERE TEMP>>>
1686                                       <GEN-TEMP STRING>)
1687                                      (ELSE .WHERE)>))
1688         #DECL ((STK STK-CHARS7 STK-CHARS8) FIX)
1689         <COND (<OR <==? .SUBRC VECTOR>
1690                    <==? .SUBRC UVECTOR>
1691                    <==? .SUBRC STRING>
1692                    <==? .SUBRC BYTES>
1693                    <==? .SUBRC TUPLE>>
1694                <IEMIT <COND (.STACK? `SBLOCK) (ELSE `UBLOCK)>
1695                       <FORM `TYPE-CODE .SUBRC>
1696                       .NARGS
1697                       =
1698                       .W
1699                       (`TYPE .SUBRC)>
1700                <COND (.STACK?
1701                       <COND (<OR <TYPE? .NARGS TEMP>
1702                                  <AND <NOT .SLNT>
1703                                       <==? .SUBRC STRING>
1704                                       <SET NARGS <GEN-TEMP FIX>>>>
1705                              <COND (<OR <==? .SUBRC VECTOR> <==? .SUBRC TUPLE>>
1706                                     <IEMIT `DIV .NARGS 2 = .NARGS>)
1707                                    (<==? .SUBRC BYTES>
1708                                     <IEMIT `ADD .NARGS 3 =.NARGS>
1709                                     <IEMIT `DIV .NARGS 4 = .NARGS>)
1710                                    (<==? .SUBRC STRING>
1711                                     <IEMIT `LENUS .W = .NARGS>
1712                                     <IEMIT `IFSYS "TOPS20">
1713                                     <IEMIT `ADD .NARGS 4 = .NARGS>
1714                                     <IEMIT `DIV .NARGS 5 = .NARGS>
1715                                     <IEMIT `ENDIF "TOPS20">
1716                                     <IEMIT `IFSYS "UNIX">
1717                                     <IEMIT `ADD .NARGS 3 = .NARGS>
1718                                     <IEMIT `DIV .NARGS 4 = .NARGS>
1719                                     <IEMIT `ENDIF "UNIX">)>
1720                              <FREE-TEMP .NARGS <>>
1721                              <COND (<ASSIGNED? STKTMP>
1722                                     <IEMIT `SUB .STKTMP .NARGS = .STKTMP>)
1723                                    (ELSE
1724                                     <IEMIT `SUB 0 .NARGS =
1725                                            <SET STKTMP <GEN-TEMP FIX>>>)>
1726                              <SET STK <+ .STK 2>>)
1727                             (<==? .SUBRC STRING>
1728                              <SET STK-CHARS7
1729                                   <+ </ <+ .SLNT 4> 5> .STK-CHARS7>>
1730                              <SET STK-CHARS8
1731                                   <+ </ <+ .SLNT 3> 4> .STK-CHARS8>>
1732                              <SET STK <+ .STK 2>>)
1733                             (ELSE
1734                              <SET STK
1735                                   <+ .STK
1736                                      <COND (<==? .SUBRC UVECTOR> .NARGS)
1737                                            (<==? .SUBRC BYTES>
1738                                             </ <+ .NARGS 3> 4>)
1739                                            (ELSE <* .NARGS 2>)>
1740                                      2>>)>)>
1741                <COND (<N==? .W .WHERE> <MOVE-ARG .W .WHERE>)>)
1742               (<==? .SUBRC LIST> <IEMIT `LIST .NARGS = .WHERE '(`TYPE LIST)>)
1743               (ELSE <MSUBR-CALL .SUBRC .NARGS .WHERE>)>>
1744
1745 <DEFINE APPLY-GEN (NOD WHERE
1746                    "AUX" (K <KIDS .NOD>) COUNTMP SEGTMP (SEGLABEL <MAKE-TAG>)
1747                          (SEGCALLED <>) I MS)
1748    #DECL ((NOD) NODE (K) <LIST NODE [REST NODE]>
1749           (COUNTMP SEGCALLED SEGLABEL) <SPECIAL ANY>)
1750    <START-FRAME>
1751    <SET MS <GEN <1 .K>>>
1752    <SET I
1753         <MAPF ,+
1754               <FUNCTION (N)
1755                       #DECL ((N) NODE)
1756                       <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE> 0) (ELSE 1)>>
1757               <REST .K>>>
1758    <MAPF <>
1759     <FUNCTION (N "AUX" RES)
1760        #DECL ((N) NODE (NL) <LIST NODE>)
1761        <COND
1762         (<==? <NODE-TYPE .N> ,SEGMENT-CODE>
1763          <COND (<NOT <ASSIGNED? SEGTMP>>
1764                 <SET SEGTMP <GEN-TEMP <>>>
1765                 <SET COUNTMP <GEN-TEMP <>>>
1766                 <SET-TEMP .COUNTMP .I '(`TYPE FIX)>)>
1767          <SET RES <GEN <SET N <1 <KIDS .N>>> .SEGTMP>>
1768          <COND (<AND <N==? .RES ,NO-DATUM>
1769                      <N==? <STRUCTYP-SEG <RESULT-TYPE .N>> MULTI>>
1770                 <SEGMENT-STACK
1771                  .SEGTMP
1772                  .COUNTMP
1773                  <STRUCTYP <RESULT-TYPE .N>>
1774                  <ISTYPE? <RESULT-TYPE .N>>
1775                  .SEGLABEL>)
1776                (.SEGCALLED <LABEL-TAG .SEGLABEL>)>
1777          <SET SEGLABEL <MAKE-TAG>>)
1778         (ELSE <GEN .N ,POP-STACK>)>>
1779     <REST .K>>
1780    <COND (<ASSIGNED? COUNTMP> <FREE-TEMP .COUNTMP <>> <FREE-TEMP .SEGTMP <>>)>
1781    <COND (<OR <==? .WHERE FLUSHED> <==? <RESULT-TYPE .NOD> NO-RETURN>>
1782           <IEMIT `ACALL .MS <COND (<ASSIGNED? COUNTMP> .COUNTMP) (ELSE .I)>>
1783           <FREE-TEMP .MS>)
1784          (ELSE
1785           <COND (<==? .WHERE DONT-CARE>
1786                  <SET WHERE <GEN-TEMP <RESULT-TYPE .NOD>>>)
1787                 (<TYPE? .WHERE TEMP> <USE-TEMP .WHERE <RESULT-TYPE .NOD>>)>
1788           <IEMIT `ACALL
1789                  .MS
1790                  <COND (<ASSIGNED? COUNTMP> .COUNTMP) (ELSE .I)>
1791                  =
1792                  .WHERE>
1793           <FREE-TEMP .MS>)>
1794    .WHERE>
1795
1796 <DEFINE UNWIND-GEN (N W
1797                     "AUX" (UNBRANCH <MAKE-TAG>) (NOUNWIND <MAKE-TAG>)
1798                           (K1 <1 <KIDS .N>>) (K2 <2 <KIDS .N>>) W1 BND LBL)
1799         #DECL ((N K1 K2) NODE (BND) TEMP (STK) FIX)
1800         <SET SPECD T>
1801         <IEMIT `LOCATION + .UNBRANCH = <SET LBL <GEN-TEMP>>>
1802         <IEMIT `BBIND
1803                <FORM QUOTE UNWIND>
1804                .LBL
1805                <FORM QUOTE FIX>
1806                <CURRENT-FRAME>>
1807         <SET STK <+ .STK ,BINDING-LENGTH>>
1808         <SET W1 <GEN .K1 .W>>
1809         <SET-VALUE UNWIND 0>
1810         <FREE-TEMP .LBL>
1811         <BRANCH-TAG .NOUNWIND>
1812         <LABEL-TAG .UNBRANCH>
1813         <GEN .K2 FLUSHED>
1814         <BRANCH-TAG `UNWCONT>
1815         <LABEL-TAG .NOUNWIND>
1816         .W1>
1817
1818 <DEFINE INTERFERE? (TMP N "AUX" L)
1819    #DECL ((N) NODE (TMP) TEMP (L) <OR FALSE LIST>)
1820    <AND
1821     <G=? <LENGTH .N> <INDEX ,SIDE-EFFECTS>>
1822     <SET L <SIDE-EFFECTS .N>>
1823     <MAPF <>
1824      <FUNCTION (NN "AUX" SYM)
1825              #DECL ((SYM) SYMTAB)
1826              <COND (<AND <TYPE? .NN NODE>
1827                          <==? <NODE-TYPE .NN> ,SET-CODE>
1828                          <NOT <SPEC-SYM <SET SYM <NODE-NAME .NN>>>>
1829                          <N==? <CODE-SYM .SYM> -1>
1830                          <==? <TEMP-NAME-SYM .SYM> .TMP>>
1831                     <MAPLEAVE T>)>>
1832      <CHTYPE .L LIST>>>>
1833
1834 <DEFINE INTERF-CHANGE (TMP N)
1835         #DECL ((N) NODE)
1836         <COND (<AND <TYPE? .TMP TEMP> <INTERFERE? .TMP .N>>
1837                <MOVE-ARG .TMP <GEN-TEMP <>>>)
1838               (ELSE .TMP)>>
1839
1840 <DEFINE ADECL-GEN (NOD WHERE "AUX" (N <1 <KIDS .NOD>>)) <GEN .N .WHERE>>
1841
1842 <DEFINE STACK-GEN (N W) <GEN <1 <KIDS .N>> .W>>
1843
1844 "ILIST, IVECTOR, IUVECTOR AND ISTRING."
1845
1846 <DEFINE ISTRUC-GEN (N W
1847                     "AUX" (NAM <NODE-NAME .N>) (K <KIDS .N>)
1848                           (NT <NODE-TYPE .N>) (LEN <1 .K>) EL
1849                           (TY <RESULT-TYPE .N>) NT-M NT-E EL-TMP EV-TMP STRT
1850                           NSTR STR END STR2 OBJ (CALL-EV <>) (GEN-EACH-TIME <>)
1851                           X EMP-INS PUT-INS REST-INS (ISTY <ISTYPE? .TY>)
1852                           CONS-T1 CONS-T2 CONS-TMP NT-S
1853                           (STACK?
1854                            <COND
1855                             (<AND
1856                               <TYPE? <SET X <PARENT .N>> NODE>
1857                               <OR <==? <NODE-TYPE .X> ,STACK-CODE>
1858                                   <AND <==? <NODE-TYPE .X> ,CHTYPE-CODE>
1859                                        <TYPE? <SET X <PARENT .X>> NODE>
1860                                        <==? <NODE-TYPE .X> ,STACK-CODE>>>>)>))
1861    #DECL ((N LEN EL) NODE (K) <LIST NODE [OPT NODE]>
1862           (STK STK-CHARS7 STK-CHARS8) FIX (STR) <OR FIX TEMP>)
1863    <COND (<==? .NAM ITUPLE> <SET STACK? T>)>
1864    <COND (<AND <==? <LENGTH .K> 1> <N==? .NAM ILIST>>
1865           <IEMIT <COND (.STACK? `USBLOCK) (ELSE `UUBLOCK)>
1866                  <FORM `TYPE-CODE .ISTY>
1867                  <SET STR <GEN .LEN DONT-CARE>>
1868                  =
1869                  <COND (<TYPE? .W TEMP> <USE-TEMP .W .ISTY> .W)
1870                        (<==? .W DONT-CARE>
1871                         <SET W <GEN-TEMP <COND (.ISTY) (ANY)>>>)
1872                        (ELSE .W)>
1873                  (`TYPE .ISTY)>
1874           <COND (<NOT .STACK?> <FREE-TEMP .STR>)>)
1875          (ELSE
1876           <COND (<OR <==? .NAM IVECTOR> <==? .NAM ITUPLE>>
1877                  <SET REST-INS `RESTUV>
1878                  <SET PUT-INS `PUTUV>
1879                  <SET EMP-INS `EMPUV?>)
1880                 (<==? .NAM IUVECTOR>
1881                  <SET REST-INS `RESTUU>
1882                  <SET PUT-INS `PUTUU>
1883                  <SET EMP-INS `EMPUU?>)
1884                 (<==? .NAM ISTRING>
1885                  <SET REST-INS `RESTUS>
1886                  <SET PUT-INS `PUTUS>
1887                  <SET EMP-INS `EMPUS?>)
1888                 (<==? .NAM IBYTES>
1889                  <SET REST-INS `RESTUB>
1890                  <SET PUT-INS `PUTUB>
1891                  <SET EMP-INS `EMPUB?>)
1892                 (ELSE
1893                  <SET REST-INS `RESTL>
1894                  <SET PUT-INS `PUTL>
1895                  <SET EMP-INS `EMPL?>)>
1896           <COND (<EMPTY? <REST .K>> <SET EL-TMP 0>)
1897                 (<OR <AND <==? <SET NT-M <NODE-TYPE .N>> ,ISTRUC2-CODE>
1898                           <OR <L? <LENGTH <SET EL <2 .K>>>
1899                                   <INDEX ,SIDE-EFFECTS>>
1900                               <AND <NOT <SIDE-EFFECTS .EL>>
1901                                    <N==? <SET NT-S <NODE-TYPE .EL>> ,COPY-CODE>
1902                                    <N==? .NT-S ,CHTYPE-CODE>
1903                                    ; "TAA 11/5/85--otherwise
1904                                       <IVECTOR .FOO '<CHTYPE [1 2 3] BAR>>
1905                                       doesn't generate a new frob each time"
1906                                    <N==? .NT-S ,ISTRUC-CODE>
1907                                    <N==? .NT-S ,ISTRUC2-CODE>>>>
1908                      <AND <==? .NT-M ,ISTRUC-CODE>
1909                           <NOT <TYPE-OK?
1910                                 <RESULT-TYPE <SET EL <2 .K>>>
1911                                 '<OR FORM LIST VECTOR UVECTOR LVAL GVAL>>>>>
1912                  <SET EL-TMP <GEN .EL>>)
1913                 (<==? .NT-M ,ISTRUC-CODE>
1914                  <SET EV-TMP <GEN .EL>>
1915                  <SET CALL-EV T>)
1916                 (ELSE <SET GEN-EACH-TIME T>)>
1917           <SET STR <GEN .LEN>>
1918           <COND (<==? .NAM ILIST>
1919                  <IEMIT `SET
1920                         <COND (<TYPE? .W TEMP> <USE-TEMP <SET OBJ .W> .ISTY>)
1921                               (ELSE <SET OBJ <GEN-TEMP>>)> ()>
1922                  <COND (<OR <TYPE? .STR FIX>
1923                             <G? <TEMP-REFS .STR> 1>>
1924                         <IEMIT `SET <SET STR2 <GEN-TEMP FIX>> .STR>
1925                         <SET STR .STR2>)>
1926                  <IEMIT `SET <SET STR2 <GEN-TEMP LIST>> ()>)
1927                 (ELSE
1928                  <IEMIT <COND (.STACK? `USBLOCK) (ELSE `UUBLOCK)>
1929                         <FORM `TYPE-CODE .ISTY>
1930                         .STR
1931                         =
1932                         <COND (<TYPE? .W TEMP> <USE-TEMP <SET OBJ .W> .ISTY>)
1933                               (ELSE <SET OBJ <GEN-TEMP>>)>>
1934                  <COND (<NOT .STACK?> <FREE-TEMP .STR>)>
1935                  <IEMIT `SET <SET STR2 <GEN-TEMP>> .OBJ>)>
1936           <IEMIT `LOOP
1937                  (<TEMP-NAME .STR2> VALUE LENGTH)
1938                  !<COND (.CALL-EV ((<TEMP-NAME .EV-TMP> TYPE VALUE LENGTH)))
1939                         (<AND <NOT .GEN-EACH-TIME> <TYPE? .EL-TMP TEMP>>
1940                          ((<TEMP-NAME .EL-TMP> TYPE VALUE LENGTH)))
1941                         (ELSE ())>
1942                  !<COND (<==? .NAM ILIST> ((<TEMP-NAME .STR> VALUE)))
1943                         (ELSE ())>>
1944           <LABEL-TAG <SET STRT <MAKE-TAG "ISTR">>>
1945           <COND (<==? .NAM ILIST>
1946                  <IEMIT `VEQUAL? .STR 0 + <SET END <MAKE-TAG "ISTRE">>>)
1947                 (ELSE
1948                  <IEMIT .EMP-INS .STR2 + <SET END <MAKE-TAG "ISTRE">>>)>
1949           <COND (.CALL-EV
1950                  <START-FRAME EVAL>
1951                  <PUSH .EV-TMP>
1952                  <MSUBR-CALL EVAL 1 <SET EL-TMP <GEN-TEMP>>>)
1953                 (.GEN-EACH-TIME <SET EL-TMP <GEN .EL>>)>
1954           <COND (<==? .NAM ILIST>
1955                  <IEMIT `CONS .EL-TMP () = <SET CONS-TMP <GEN-TEMP LIST>>>
1956                  <IEMIT `EMPL? .STR2 + <SET CONS-T1 <MAKE-TAG>>>
1957                  <IEMIT `PUTREST .STR2 .CONS-TMP>
1958                  <IEMIT `SET .STR2 .CONS-TMP>
1959                  <BRANCH-TAG <SET CONS-T2 <MAKE-TAG>>>
1960                  <LABEL-TAG .CONS-T1>
1961                  <IEMIT `SET .STR2 .CONS-TMP>
1962                  <IEMIT `SET .OBJ .CONS-TMP>
1963                  <LABEL-TAG .CONS-T2>
1964                  <IEMIT `SUB .STR 1 = .STR>)
1965                 (ELSE
1966                  <IEMIT .PUT-INS .STR2 1 .EL-TMP>
1967                  <IEMIT .REST-INS .STR2 1 = .STR2>)>
1968           <COND (<OR .CALL-EV .GEN-EACH-TIME> <FREE-TEMP .EL-TMP>)>
1969           <BRANCH-TAG .STRT>
1970           <LABEL-TAG .END>
1971           <FREE-TEMP .STR2>
1972           <COND (.CALL-EV <FREE-TEMP .EV-TMP>)
1973                 (<NOT .GEN-EACH-TIME> <FREE-TEMP .EL-TMP>)>
1974           <SET W <MOVE-ARG .OBJ .W>>)>
1975    <COND (.STACK?
1976           <COND (<TYPE? .STR TEMP>
1977                  <COND (<AND <N==? .NAM IUVECTOR> <G? <TEMP-REFS .STR> 1>>
1978                         <SET NSTR <GEN-TEMP FIX>>)
1979                        (ELSE <SET NSTR .STR>)>
1980                  <COND (<OR <==? .NAM IVECTOR> <==? .NAM ITUPLE>>
1981                         <IEMIT `LSH .STR 1 = .NSTR>)
1982                        (<==? .NAM IBYTES>
1983                         <IEMIT `ADD .STR 3 = .NSTR>
1984                         <IEMIT `LSH .NSTR -2 = .NSTR>)
1985                        (<==? .NAM ISTRING>
1986                         <IEMIT `IFSYS "TOPS20">
1987                         <IEMIT `ADD .STR 4 = .NSTR>
1988                         <IEMIT `DIV .NSTR 5 = .NSTR>
1989                         <IEMIT `ENDIF "TOPS20">
1990                         <IEMIT `IFSYS "UNIX">
1991                         <IEMIT `ADD .STR 3 = .NSTR>
1992                         <IEMIT `LSH .NSTR -2 = .NSTR>
1993                         <IEMIT `ENDIF "UNIX">)>
1994                  <FREE-TEMP .STR <>>
1995                  <COND (<ASSIGNED? STKTMP>
1996                         <IEMIT `SUB .STKTMP .NSTR = .STKTMP>)
1997                        (ELSE
1998                         <IEMIT `SUB 0 .NSTR = <SET STKTMP <GEN-TEMP FIX>>>)>
1999                  <COND (<N==? .STR .NSTR> <FREE-TEMP .NSTR>)>
2000                  <SET STK <+ .STK 2>>)
2001                 (<==? .NAM ISTRING>
2002                  <SET STK-CHARS7 <+ </ <+ .STR 4> 5> .STK-CHARS7>>
2003                  <SET STK-CHARS8 <+ </ <+ .STR 3> 4> .STK-CHARS8>>
2004                  <SET STK <+ .STK 2>>)
2005                 (ELSE
2006                  <SET STK
2007                       <+ .STK
2008                          <COND (<==? .NAM IUVECTOR> .STR)
2009                                (<==? .NAM IBYTES> </ <+ .STR 3> 4>)
2010                                (ELSE <* .STR 2>)>
2011                          2>>)>)>
2012    .W>
2013
2014
2015 <DEFINE MULTI-SET-GEN (N:NODE W
2016                        "AUX" (K:<LIST [REST NODE]> <KIDS .N>) (SEG? <>)
2017                              (SIDE-E <>) (MX:FIX 0) (MN:FIX 0)
2018                              (VARS:<LIST [REST LIST]> <NODE-NAME .N>) TL:LIST
2019                              (VLN:FIX <LENGTH .VARS>) NT:FIX SEGTYP LCL
2020                              (LV:<OR ATOM SYMTAB> <1 <NTH .VARS .VLN>>) (I:FIX 0))
2021    <MAPF <>
2022     <FUNCTION (N:NODE "AUX" RT)
2023             <COND (<OR <==? <SET NT <NODE-TYPE .N>> ,SEG-CODE>
2024                        <==? .NT ,SEGMENT-CODE>>
2025                    <SET SEG? T>
2026                    <SET MX <MAX <+ <MAXL <SET RT <RESULT-TYPE <1 <KIDS .N>>>>> .MX>
2027                                 ,MAX-LENGTH>>
2028                    <SET MN <+ <MINL .RT> .MN>>)
2029                   (ELSE
2030                    <SET I <+ .I 1>>
2031                    <SET MN <+ .MN 1>>
2032                    <SET MX <MAX <+ .MX 1> ,MAX-LENGTH>>)>
2033             <COND (<AND <G=? <LENGTH .N> <INDEX ,SIDE-EFFECTS>>
2034                         <SIDE-EFFECTS .N>>
2035                    <SET SIDE-E T>)>>
2036     <SET K <REST .K>>>
2037    <COND
2038     (.SEG?
2039      <PROG ((SEGLABEL <MAKE-TAG>) COUNTMP (SEGCALLED <>) SEGTMP)
2040        #DECL ((SEGLABEL COUNTMP SEGCALLED) <SPECIAL ANY>)
2041        <MAPF <>
2042         <FUNCTION (NN:NODE "AUX" (NT <NODE-TYPE .NN>) RES)
2043            <COND
2044             (<OR <==? .NT ,SEG-CODE> <==? .NT ,SEGMENT-CODE>>
2045              <COND (<NOT <ASSIGNED? SEGTMP>>
2046                     <SET SEGTMP <GEN-TEMP <>>>
2047                     <SET COUNTMP <GEN-TEMP FIX>>
2048                     <SET-TEMP .COUNTMP .I '(`TYPE FIX)>)>
2049              <SET RES <GEN <SET NN <1 <KIDS .NN>>> .SEGTMP>>
2050              <SET SEGTYP <STRUCTYP-SEG <RESULT-TYPE .NN>>>
2051              <COND (<AND <N==? .RES ,NO-DATUM> <N==? .SEGTYP MULTI>>
2052                     <SEGMENT-STACK .SEGTMP
2053                                    .COUNTMP
2054                                    .SEGTYP
2055                                    <ISTYPE? <RESULT-TYPE .NN>>
2056                                    .SEGLABEL>
2057                     <SET SEGLABEL <MAKE-TAG>>)
2058                    (.SEGCALLED
2059                     <LABEL-TAG .SEGLABEL>
2060                     <SET SEGLABEL <MAKE-TAG>>)>)
2061             (ELSE
2062              <GEN .NN ,POP-STACK>)>>
2063         .K>
2064        <COND (<AND .CAREFUL <N==? .MX .MN>>
2065               <IEMIT `VEQUAL? .COUNTMP .VLN - `COMPERR>)>
2066        <REPEAT (TVAR TSYM TMP)
2067                <COND (<AND
2068                        <TYPE? <SET TSYM <1 <SET TVAR <NTH .VARS .VLN>>>>
2069                               SYMTAB>
2070                        <NOT <SPEC-SYM .TSYM>>
2071                        <N==? <CODE-SYM .TSYM> -1>>
2072                       <USE-TEMP <SET TMP <TEMP-NAME-SYM .TSYM>>
2073                                 <OR <2 .TVAR> T>>
2074                       <IEMIT `POP = .TMP>)
2075                      (ELSE
2076                       <IEMIT `POP = <SET TMP <GEN-TEMP <OR <2 .TVAR> T>>>>
2077                       <SET-VALUE <COND (<TYPE? .TSYM SYMTAB> <NAME-SYM .TSYM>)
2078                                        (ELSE .TSYM)>
2079                                  .TMP
2080                                  <NOT <AND <TYPE? .TSYM SYMTAB>
2081                                            <N==? <CODE-SYM .TSYM> -1>>>>
2082                       <FREE-TEMP .TMP>)>
2083                <COND (<==? <SET VLN <- .VLN 1>> 0> <RETURN>)>>>)
2084     (.SIDE-E
2085      <SET TL
2086           <MAPF ,LIST
2087                 <FUNCTION (NN:NODE SYP:<LIST <OR ATOM SYMTAB>>
2088                            "AUX" (TY <RESULT-TYPE .NN>) PT
2089                                  (SY:<OR ATOM SYMTAB> <1 .SYP>))
2090                         <COND (<TYPE? .SY SYMTAB>
2091                                <SET TY <TYPE-AND <2 .SYP> .TY>>)>
2092                         <COND (<AND <SET TY <ISTYPE? .TY>>
2093                                     <OR <==? <SET PT <TYPEPRIM .TY>> FIX>
2094                                         <==? .PT LIST>>>)
2095                               (ELSE <SET TY ANY>)>
2096                         <GEN .NN <GEN-TEMP .TY>>>
2097                 .K
2098                 .VARS>>
2099      <MAPF <>
2100            <FUNCTION (SYP:<LIST <OR ATOM SYMTAB>> TMP:TEMP
2101                       "AUX" (SY:<OR ATOM SYMTAB> <1 .SYP>) (LCL <>))
2102                    <COND (<AND <TYPE? .SY SYMTAB>
2103                                <N==? <CODE-SYM .SY> -1>
2104                                <SET LCL T>
2105                                <NOT <SPEC-SYM .SY>>>
2106                           <IEMIT `SET <TEM-NAME-SYM .SY> .TMP>
2107                           <FREE-TEMP .TMP>)
2108                          (ELSE
2109                           <COND (<TYPE? .SY SYMTAB> <SET SY <NAME-SYM .SY>>)>
2110                           <SET-VALUE .SY .TMP <NOT .LCL>>
2111                           <FREE-TEMP .TMP>)>>
2112            .VARS
2113            .TL>)
2114     (ELSE
2115      <PROG (NL-LATER:LIST SL-LATER:LIST ANY-DONE (MUCH-LATER:LIST ())
2116             TTMP:TEMP)
2117        <SET NL-LATER <SET SL-LATER ()>>
2118        <SET ANY-DONE <>>
2119        <MAPR <>
2120         <FUNCTION (SL NL
2121                    "AUX" (SYP:<LIST <OR ATOM SYMTAB TEMP>> <1 .SL>) (LCL <>) TY
2122                          (N:NODE <1 .NL>) (SY:<OR ATOM SYMTAB TEMP> <1 .SYP>) TMP)
2123                 <COND (<OR <TYPE? .SY TEMP>
2124                            <AND <NOT <REF? .SY <REST .NL>>>
2125                                 <NOT <REF? .SY .NL-LATER>>>>
2126                        <SET ANY-DONE T>
2127                        <COND (<OR <AND <TYPE? .SY SYMTAB>
2128                                        <N==? <CODE-SYM .SY> -1>
2129                                        <SET LCL T>
2130                                        <NOT <SPEC-SYM .SY>>
2131                                        <SET TMP <TEMP-NAME-SYM .SY>>>
2132                                   <AND <TYPE? .SY TEMP> <SET TMP .SY>>>
2133                               <GEN .N .TMP>)
2134                              (ELSE
2135                               <COND (<TYPE? .SY SYMTAB>
2136                                      <SET SY <NAME-SYM .SY>>)>
2137                               <SET-VALUE .SY <GEN .N DONT-CARE> <NOT .LCL>>)>)
2138                       (ELSE
2139                        <SET SL-LATER (.SYP !.SL-LATER)>
2140                        <SET NL-LATER (.N !.NL-LATER)>)>>
2141         .VARS
2142         .K>
2143        <COND (<AND .ANY-DONE <NOT <EMPTY? .SL-LATER>>>
2144               <SET VARS .SL-LATER>
2145               <SET K .NL-LATER>
2146               <AGAIN>)
2147              (<NOT <EMPTY? .SL-LATER>>
2148               <SET MUCH-LATER
2149                    ((<1 .SL-LATER> <SET TTMP <GEN-TEMP <>>>) !.MUCH-LATER)>
2150               <SET VARS ((.TTMP) !<REST .SL-LATER>)>
2151               <SET K .NL-LATER>
2152               <AGAIN>)>
2153        <MAPF <>
2154              <FUNCTION (L:LIST
2155                         "AUX" (SY:<OR ATOM SYMTAB> <1 <1 .L>>) (LCL <>)
2156                               (TMP:TEMP <2 .L>))
2157                      <COND (<AND <TYPE? .SY SYMTAB>
2158                                  <N==? <CODE-SYM .SY> -1>
2159                                  <SET LCL T>
2160                                  <NOT <SPEC-SYM .SY>>>
2161                             <IEMIT `SET <TEMP-NAME-SYM .SY> .TMP>
2162                             <FREE-TEMP .TMP>)
2163                            (ELSE
2164                             <COND (<TYPE? .SY SYMTAB> <SET SY <NAME-SYM .SY>>)>
2165                             <SET-VALUE .SY .TMP <NOT .LCL>>
2166                             <FREE-TEMP .TMP>)>>
2167              .MUCH-LATER>>)>
2168    <COND (<N==? .W FLUSHED>
2169           <SET LCL <>>
2170           <COND (<AND <TYPE? .LV SYMTAB>
2171                       <N==? <CODE-SYM .LV> -1>
2172                       <SET LCL T>
2173                       <NOT <SPEC-SYM .LV>>>
2174                  <TEMP-REFS .LV <+ <TEMP-REFS .LV> 1>>
2175                  <MOVE-ARG .LV .W>)
2176                 (ELSE
2177                  <COND (<TYPE? .LV SYMTAB> <SET LV <NAME-SYM .LV>>)>
2178                  <COND (<==? .W DONT-CARE> <SET W <GEN-TEMP <>>>)>
2179                  <GET-VALUE-X .LV .W <NOT .LCL>>)>)
2180          (ELSE .W)>>
2181
2182 <DEFINE REF? (SY:<OR ATOM SYMTAB> L:<LIST [REST NODE]>)
2183         <MAPF <>
2184               <FUNCTION (N:NODE "AUX" (NT:FIX <NODE-TYPE .N>) NN)
2185                     <PROG ()
2186                           <COND (<OR <==? .NT ,LVAL-CODE>
2187                                      <==? .NT ,ASSIGNED?-CODE>
2188                                      <==? .NT ,SET-CODE>>
2189                                  <COND (<==? <NODE-NAME .N> .SY> <MAPLEAVE>)>)
2190                                 (<OR <==? .NT ,FLVAL-CODE> <==? .NT ,FSET-CODE>>
2191                                  <COND (<OR <==? <NODE-NAME .N> .SY>
2192                                             <COND (<==? <NODE-TYPE
2193                                                          <SET NN <1 <KIDS .N>>>>
2194                                                         ,QUOTE-CODE>
2195                                                    <==? <NODE-NAME .NN> .SY>)
2196                                                   (ELSE
2197                                                    <OR <TYPE? .SY ATOM>
2198                                                        <==? <CODE-SYM .SY> -1>
2199                                                        <SPEC-SYM .SY>>)>>
2200                                         <MAPLEAVE T>)>)
2201                                 (<AND <G? <LENGTH .N> <INDEX ,SIDE-EFFECTS>>
2202                                       <MEMQ ALL <CHTYPE <SIDE-EFFECTS .N>
2203                                                         LIST>>
2204                                       <OR <TYPE? .SY ATOM>
2205                                           <SPEC-SYM .SY>
2206                                           <==? <CODE-SYM .SY> -1>>>
2207                                  <MAPLEAVE T>)
2208                                 (ELSE
2209                                  <COND (<REF? .SY <KIDS .N>> <MAPLEAVE T>)>
2210                                  <COND (<==? .NT ,BRANCH-CODE>
2211                                         <SET NT <NODE-TYPE <SET N <PREDIC .N>>>>
2212                                         <AGAIN>)>)>>>
2213               .L>>
2214
2215 <DEFINE GEN-DISPATCH (N W)
2216         <CASE ,==?
2217               <NODE-TYPE .N>
2218               (,FORM-CODE <FORM-GEN .N .W>)
2219               (,PROG-CODE <PROG-REP-GEN .N .W>)
2220               (,SUBR-CODE <SUBR-GEN .N .W>)
2221               (,COND-CODE <COND-GEN .N .W>)
2222               (,LVAL-CODE <LVAL-GEN .N .W>)
2223               (,SET-CODE <SET-GEN .N .W>)
2224               (,OR-CODE <OR-GEN .N .W>)
2225               (,AND-CODE <AND-GEN .N .W>)
2226               (,RETURN-CODE <RETURN-GEN .N .W>)
2227               (,COPY-CODE <COPY-GEN .N .W>)
2228               (,AGAIN-CODE <AGAIN-GEN .N .W>)
2229               (,ARITH-CODE <ARITH-GEN .N .W>)
2230               (,RSUBR-CODE <SUBR-GEN .N .W>)
2231               (,0-TST-CODE <0-TEST .N .W>)
2232               (,NOT-CODE <NOT-GEN .N .W>)
2233               (,1?-CODE <1?-GEN .N .W>)
2234               (,TEST-CODE <TEST-GEN .N .W>)
2235               (,EQ-CODE <==-GEN .N .W>)
2236               (,TY?-CODE <TYPE?-GEN .N .W>)
2237               (,LNTH-CODE <LNTH-GEN .N .W>)
2238               (,MT-CODE <MT-GEN .N .W>)
2239               (,REST-CODE <REST-GEN .N .W>)
2240               (,NTH-CODE <NTH-GEN .N .W>)
2241               (,PUT-CODE <PUT-GEN .N .W>)
2242               (,PUTR-CODE <PUTREST-GEN .N .W>)
2243               (,FLVAL-CODE <FLVAL-GEN .N .W>)
2244               (,FSET-CODE <FSET-GEN .N .W>)
2245               (,FGVAL-CODE <FGVAL-GEN .N .W>)
2246               (,FSETG-CODE <FSETG-GEN .N .W>)
2247               (,MIN-MAX-CODE <MIN-MAX .N .W>)
2248               (,CHTYPE-CODE <CHTYPE-GEN .N .W>)
2249               (,FIX-CODE <FIX-GEN .N .W>)
2250               (,FLOAT-CODE <FLOAT-GEN .N .W>)
2251               (,ABS-CODE <ABS-GEN .N .W>)
2252               (,MOD-CODE <MOD-GEN .N .W>)
2253               (,ID-CODE <ID-GEN .N .W>)
2254               (,ASSIGNED?-CODE <ASSIGNED?-GEN .N .W>)
2255               (,BITL-CODE <BITLOG-GEN .N .W>)
2256               (,ISUBR-CODE <SUBR-GEN .N .W>)
2257               (,EOF-CODE <ID-GEN .N .W>)
2258               (,READ-EOF2-CODE <READ2-GEN .N .W>)
2259               (,READ-EOF-CODE <SUBR-GEN .N .W>)
2260               (,GET2-CODE <GET2-GEN .N .W>)
2261               (,GET-CODE <GET-GEN .N .W>)
2262               (,IPUT-CODE <SUBR-GEN .N .W>)
2263               (,MAP-CODE <MAPFR-GEN .N .W>)
2264               (,MARGS-CODE <MPARGS-GEN .N .W>)
2265               (,MAPLEAVE-CODE <MAPLEAVE-GEN .N .W>)
2266               (,MAPRET-STOP-CODE <MAPRET-STOP-GEN .N .W>)
2267               (,UNWIND-CODE <UNWIND-GEN .N .W>)
2268               (,GVAL-CODE <GVAL-GEN .N .W>)
2269               (,SETG-CODE <SETG-GEN .N .W>)
2270               (,MEMQ-CODE <MEMQ-GEN .N .W>)
2271               (,LENGTH?-CODE <LENGTH?-GEN .N .W>)
2272               (,FORM-F-CODE <FORM-F-GEN .N .W>)
2273               (,ALL-REST-CODE <ALL-REST-GEN .N .W>)
2274               (,COPY-LIST-CODE <LIST-BUILD .N .W>)
2275               (,PUT-SAME-CODE <PUT-GEN .N .W>)
2276               (,BACK-CODE <BACK-GEN .N .W>)
2277               (,TOP-CODE <TOP-GEN .N .W>)
2278               (,ROT-CODE <ROT-GEN .N .W>)
2279               (,LSH-CODE <LSH-GEN .N .W>)
2280               (,BIT-TEST-CODE <BIT-TEST-GEN .N .W>)
2281               (,CALL-CODE <CALL-GEN .N .W>)
2282               (,MONAD-CODE <MONAD?-GEN .N .W>)
2283               (,GASSIGNED?-CODE <GASSIGNED?-GEN .N .W>)
2284               (,APPLY-CODE <APPLY-GEN .N .W>)
2285               (,ADECL-CODE <ADECL-GEN .N .W>)
2286               (,MULTI-RETURN-CODE <MULTI-RETURN-GEN .N .W>)
2287               (,VALID-CODE <VALID-TYPE?-GEN .N .W>)
2288               (,TYPE-C-CODE <TYPE-C-GEN .N .W>)
2289               (,=?-STRING-CODE <=?-STRING-GEN .N .W>)
2290               (,CASE-CODE <CASE-GEN .N .W>)
2291               (,FGETBITS-CODE <FGETBITS-GEN .N .W>)
2292               (,FPUTBITS-CODE <FPUTBITS-GEN .N .W>)
2293               (,ISTRUC-CODE <ISTRUC-GEN .N .W>)
2294               (,ISTRUC2-CODE <ISTRUC-GEN .N .W>)
2295               (,STACK-CODE <STACK-GEN .N .W>)
2296               (,CHANNEL-OP-CODE <CHANNEL-OP-GEN .N .W>)
2297               (,ATOM-PART-CODE <ATOM-PART-GEN .N .W>)
2298               (,OFFSET-PART-CODE <OFFSET-PART-GEN .N .W>)
2299               (,PUT-GET-DECL-CODE <PUT-GET-DECL-GEN .N .W>)
2300               (,SUBSTRUC-CODE <SUBSTRUC-GEN .N .W>)
2301               (,MULTI-SET-CODE <MULTI-SET-GEN .N .W>)
2302               DEFAULT
2303               (<DEFAULT-GEN .N .W>)>>
2304
2305 <ENDPACKAGE>