<mdl.comp>/codgen.mud.8

   1 <PACKAGE "CODGEN">
   2
   3 <ENTRY GEN CODE-GEN STB SEQ-GEN MERGE-STATES FRMS LVAL-UP GOOD-TUPLE
   4         UPDATE-WHERE NSLOTS NTSLOTS STFIXIT STK GET-TMPS PRE
   5         STACK:L NO-KILL DELAY-KILL BSTB TOT-SPEC BASEF AC-HACK BINDUP SPECD LADDR
   6         ADD:STACK GENERATORS GOODACS FRMID RES-FLS STORE-SET TRUE-FALSE ACFIX
   7         SUBR-GEN BIND-CODE SPEC-LIST BTP NPRUNE REG? ARG? ARGS-TO-ACS>
   8
   9 <USE "CACS" "CHKDCL" "COMCOD" "COMPDEC" "STRGEN" "MAPGEN" "MMQGEN" "BUILDL" "BITSGEN"
  10      "LNQGEN" "ISTRUC" "CARGEN" "NOTGEN" "COMSUB" "BITTST" "CBACK" "ALLR"
  11      "CUP" "SUBRTY" "NEWREP" "CPRINT" "INFCMP" "CASE" "SPCGEN">
  12
  13 <SETG FUDGE <>>
  14
  15 ;"DISABLE FUNNY COND./BOOL FEATURE"
  16
  17 "       This file contains the major general codde generators.  These include
  18  variable access functions (LVAL, SETG etc.), FSUBRs (COND, AND, REPEAT)
  19  and a few assorted others."
  20
  21 "       All generators are called with a node and a destination for the
  22  result.  The destinations are either DATUMs (lists of ACs or types)
  23  or the special atoms DONT-CARE or FLUSHED.  Generators for
  24  SUBRs that can be predicates may have additional arguments when they
  25  are being invoked for their branching effect."
  26
  27 "       The atom STK always points to a list that specifies the model
  28  of the TP stack."
  29
  30 " Main generator, dispatches to specific code generators. "
  31
  32 <SETG OTBSAV
  33       <PROG (TEM)
  34             <COND (<AND <SET TEM <LOOKUP "OTBSAV" <GET MUDDLE OBLIST>>>
  35                         <GASSIGNED? .TEM>>
  36                    ,.TEM)
  37                   (ELSE <SQUOTA |OTBSAV >)>>>
  38
  39 <GDECL (OTBSAV) FIX>
  40
  41 <DEFINE GEN (NOD WHERE "AUX" TEMP)
  42         #DECL ((NOD) NODE (WHERE) <OR ATOM DATUM>)
  43         <SET TEMP <APPLY <NTH ,GENERATORS <NODE-TYPE .NOD>> .NOD .WHERE>>
  44         <OR <ASSIGNED? NPRUNE> <PUT .NOD ,KIDS ()>>
  45         .TEMP>
  46
  47 " Generate a sequence of nodes flushing all values except the ladt."
  48
  49 <DEFINE SEQ-GEN (L WHERE "OPTIONAL" (INPROG <>) (SINPROG <>) (INCODE-GEN <>))
  50    #DECL ((L) <LIST [REST NODE]> (WHERE) <OR ATOM DATUM>)
  51    <MAPR <>
  52     <FUNCTION (N "AUX" (ND <1 .N>))
  53             #DECL ((N) <LIST NODE> (ND) NODE)
  54             <COND (<AND .INPROG
  55                         <==? <NODE-TYPE .ND> ,QUOTE-CODE>
  56                         <==? <RESULT-TYPE .ND> ATOM>
  57                         <OR <NOT <EMPTY? <REST .N>>>
  58                             <ISTAG? <NODE-NAME .ND>>>>
  59                    <MESSAGE WARNING " TAG SEEN IN PROG/REPEAT " .ND>
  60                    <REGSTO T>
  61                    <LABEL:TAG <UNIQUE:TAG <NODE-NAME .ND> T>>
  62                    <COND (<EMPTY? <REST .N>>
  63                           <SET WHERE
  64                                <GEN .ND
  65                                     <COND (<TYPE? .WHERE DATUM> <DATUM !.WHERE>)
  66                                           (ELSE .WHERE)>>>)>)
  67                   (<EMPTY? <REST .N>>
  68                    <SET WHERE
  69                         <GEN .ND
  70                              <COND (<AND .INPROG <TYPE? .WHERE DATUM>>
  71                                     <DATUM !.WHERE>)
  72                                    (ELSE .WHERE)>>>)
  73                   (ELSE <RET-TMP-AC <GEN .ND FLUSHED>>)>>
  74     .L>
  75    <COND (<AND <NOT .INPROG> <NOT .INCODE-GEN>> <VAR-STORE>)>
  76    .WHERE>
  77
  78 " The main code generation entry (called from CDRIVE).  Sets up initial
  79  stack model, calls to generate code for the bindings and generates code for
  80  the function's body."
  81
  82 <DEFINE CODE-GEN (BASEF
  83                   "AUX" (TOT-SPEC 0) (NTSLOTS (<FORM GVAL <TMPLS .BASEF>>))
  84                         (IDT 0) XX (STB (0)) (STK (0 !.STB)) (PRE <>) (FRMID 1)
  85                         BTP (FRMS (1 .STK .BASEF 0 .NTSLOTS)) (BSTB .STB)
  86                         (SPECD <>)
  87                         (TMPS <COND (<ACTIVATED .BASEF> (2)) (ELSE (0))>)
  88                         START:TAG (AC-HACK <ACS .BASEF>) (K <KIDS .BASEF>)
  89                         (CD <>)
  90                         (DEST
  91                          <COND (<ACTIVATED .BASEF> <FUNCTION:VALUE>)
  92                                (ELSE <GOODACS .BASEF <FUNCTION:VALUE>>)>)
  93                         (ATAG <MAKE:TAG "AGAIN">) (RTAG <MAKE:TAG "EXIT">)
  94                         (SPEC-LIST ()) (RET <>) (NO-KILL ()) (KILL-LIST ()))
  95         #DECL ((TOT-SPEC IDT) <SPECIAL FIX> (BASEF) <SPECIAL NODE>
  96                (SPEC-LIST KILL-LIST STK BSTB NTSLOTS) <SPECIAL LIST>
  97                (PRE SPECD) <SPECIAL ANY> (FRMID TMPS) <SPECIAL ANY>
  98                (START:TAG) <SPECIAL ATOM> (AC-HACK) <SPECIAL <PRIMTYPE LIST>>
  99                (FRMS NO-KILL) <SPECIAL LIST> (K) <LIST [REST NODE]> (BTP) LIST
 100                (CD) <OR DATUM FALSE>)
 101         <BEGIN-FRAME <TMPLS .BASEF>
 102                      <ACTIVATED .BASEF>
 103                      <PRE-ALLOC .BASEF>>
 104         <PUT .BASEF ,STK-B .STB>
 105         <BIND-CODE .BASEF .AC-HACK>
 106         <VAR-STORE>
 107         <LABEL:TAG .ATAG>
 108         <SET SPEC-LIST (.BASEF .SPECD <SPECS-START .BASEF>)>
 109         <SET STK (0 !<SET BTP .STK!>)>
 110         <COND (.AC-HACK <EMIT '<INTGO!-OP!-PACKAGE>>)>
 111         <PUT .BASEF ,ATAG .ATAG>
 112         <PUT .BASEF ,RTAG .RTAG>
 113         <PUT .BASEF ,BTP-B .BTP>
 114         <PUT .BASEF ,DST .DEST>
 115         <PUT .BASEF ,PRE-ALLOC .PRE>
 116         <PUT .BASEF ,SPCS-X .SPECD>
 117         <COND (<N==? <SET CD
 118                           <SEQ-GEN .K
 119                                    <COND (<TYPE? .DEST DATUM> <DATUM !.DEST>)
 120                                          (ELSE .DEST)>
 121                                    <>
 122                                    <>
 123                                    T>>
 124                      ,NO-DATUM>
 125                <SET RET T>
 126                <ACFIX .DEST .CD>)
 127               (ELSE <SET CD <CDST .BASEF>>)>
 128         <COND (<AND <TYPE? .DEST DATUM>
 129                     .CD
 130                     <ISTYPE? <DATTYP .DEST>>
 131                     <TYPE? <DATTYP .CD> AC>>
 132                <RET-TMP-AC <DATTYP .CD> .CD>)>
 133         <COND (<AND .RET .AC-HACK>
 134                <UNBIND:LOCS .STK .STB <=? .AC-HACK '(FUNNY-STACK)>>)>
 135         <LABEL:TAG .RTAG>
 136         <COND (.CD
 137                <AND <TYPE? <DATTYP .DEST> AC>
 138                     <FIX-ACLINK <DATTYP .DEST> .DEST .CD>>
 139                <AND <TYPE? <DATVAL .DEST> AC>
 140                     <FIX-ACLINK <DATVAL .DEST> .DEST .CD>>)>
 141         <MAPF <>
 142               <FUNCTION (AC)
 143                       #DECL ((AC) AC)
 144                       <MAPF <>
 145                             <FUNCTION (ITEM)
 146                                     <COND (<TYPE? .ITEM SYMTAB>
 147                                            <PUT .ITEM ,STORED T>)>>
 148                             <ACRESIDUE .AC>>>
 149               ,ALLACS>
 150         <SET XX <RET-TMP-AC <MOVE:ARG .DEST <FUNCTION:VALUE>>>>
 151         <END-FRAME>
 152         .XX>
 153
 154
 155 " Update ACs with respect to their datums."
 156
 157 <DEFINE ACFIX (OLD1 NEW1 "AUX" OLD NEW)
 158         #DECL ((OLD NEW) DATUM)
 159         <COND (<TYPE? .OLD1 DATUM>
 160                <SET NEW .NEW1>
 161                <SET OLD .OLD1>
 162                <COND (<==? <DATTYP .OLD> ANY-AC>
 163                       <PUT .OLD ,DATTYP <DATTYP .NEW>>)>
 164                <COND (<==? <DATVAL .OLD> ANY-AC>
 165                       <PUT .OLD ,DATVAL <DATVAL .NEW>>)>)>
 166         T>
 167
 168 " Generate code for setting up and binding agruments."
 169
 170 <DEFINE BIND-CODE (NOD
 171                    "OPTIONAL" (FLG <>)
 172                    "AUX" (BST <BINDING-STRUCTURE .NOD>) B (NPRUNE T)
 173                          (NSLOTS <SSLOTS .NOD>) (TSLOTS <TMPLS .NOD>) (LARG <>)
 174                          INAME GOOD-OPTS
 175                          (SFLG
 176                           <AND .FLG <MEMBER .FLG '![(STACK) (FUNNY-STACK)!]>>)
 177                          (STB <STK-B .NOD>))
 178    #DECL ((NOD) NODE (BST B) <LIST [REST SYMTAB]> (NPRUNE) <SPECIAL ANY>
 179           (NSLOTS) <SPECIAL FIX> (TSLOTS) ATOM (INAME) <UVECTOR [REST ATOM]>
 180           (FRMS) <LIST [5 ANY]> (TOT-SPEC) FIX (BASEF) NODE)
 181    <AND <ACTIVATED .NOD> <ACT:INITIAL> <ADD:STACK 2>>
 182    <OR .PRE .FLG <PROG ()
 183                        <SALLOC:SLOTS .TSLOTS>
 184                        <ADD:STACK .TSLOTS>>>
 185    <AND .FLG <SET INAME <NODE-NAME .NOD>>>
 186    <COND
 187     (<AND .SFLG <L? <TOTARGS .NOD> 0>>
 188      <EMIT <INSTRUCTION INTERNAL-ENTRY!-OP!-PACKAGE <1 .INAME> -1>>
 189      <EMIT '<`SUBM  `M*  `(P) >>
 190      <ADD:STACK PSTACK>
 191      <ADD:STACK 4>
 192      <PUT .FRMS 2 <SET BSTB <SET STB <SET STK (0 !.STK)>>>>
 193      <TUPLE1-B <1 .BST>>
 194      <PUT <1 .BST> ,POTLV <>>
 195      <SET BST <REST .BST>>)
 196     (.SFLG
 197      <SET GOOD-OPTS
 198           <OPT-CHECK <REST .BST <REQARGS .NOD>>
 199                      <- <TOTARGS .NOD> <REQARGS .NOD>>
 200                      .INAME>>
 201      <ADD:STACK <* 2 <TOTARGS .NOD>>>
 202      <SET TMPS <STACK:L .STK .STB>>
 203      <ADD:STACK .TSLOTS>
 204      <REPEAT ((I (.TSLOTS 0)) (TG <MAKE:TAG>) (TRG <TOTARGS .NOD>) (OPS 0)
 205               (OSTK .STK))
 206        #DECL ((TG) ATOM (OPS TRG) FIX (STK OSTK) LIST)
 207        <EMIT <INSTRUCTION INTERNAL-ENTRY!-OP!-PACKAGE <1 .INAME> .TRG>>
 208        <SET STK (0 !.STK)>
 209        <EMIT '<`SUBM  `M*  `(P) >>
 210        <SALLOC:SLOTS <2 .I>>
 211        <ALLOC:SLOTS <1 .I>>
 212        <SET B .BST>
 213        <REPEAT ((TRG .TRG) (OPS .OPS) SYM T1)
 214          #DECL ((TRG OPS) FIX (SYM) SYMTAB (T1) ADDRESS:C)
 215          <COND (<EMPTY? .B> <RETURN>) (ELSE <SET SYM <1 .B>>)>
 216          <PUT .SYM ,POTLV <>>
 217          <COND (<OR <==? <CODE-SYM .SYM> 7>
 218                     <==? <CODE-SYM .SYM> 8>
 219                     <==? <CODE-SYM .SYM> 9>>
 220                 <TUPCHK <INIT-SYM .SYM> T>)>
 221          <COND
 222           (<NOT <0? .TRG>>
 223            <AND
 224             <SPEC-SYM .SYM>
 225             <PUSH:BIND
 226              <NAME-SYM .SYM>
 227              <DATUM
 228               <COND (<=? .AC-HACK '(FUNNY-STACK)>
 229                      <SET T1
 230                           <ADDRESS:C <- -3
 231                                         <* 2
 232                                            <- <TOTARGS .NOD>
 233                                               <ARGNUM-SYM .SYM>>>>
 234                                      `(FRM) >>)
 235                     (<SET T1
 236                           <ADDRESS:C <FORM -
 237                                            <* 2 <ARGNUM-SYM .SYM>>
 238                                            !<STACK:L .STK .BSTB>
 239                                            3>
 240                                      `(TP) >>)>
 241               .T1>
 242              <DECL-SYM .SYM>>
 243             <ADD:STACK 6>
 244             <VAR-STORE>
 245             <BIND:END>
 246             <SET SPECD T>
 247             <SET TOT-SPEC <+ .TOT-SPEC 6>>>
 248            <SET TRG <- .TRG 1>>)
 249           (<NOT <0? .OPS>>
 250            <COND (<L=? <CODE-SYM .SYM> 7>
 251                   <COND (<SPEC-SYM .SYM> <AUX1-B .SYM>)
 252                         (ELSE <GEN <INIT-SYM .SYM> <LADDR .SYM T <>>>)>)
 253                  (ELSE
 254                   <COND (<SPEC-SYM .SYM> <AUX2-B .SYM>)
 255                         (ELSE
 256                          <MOVE:ARG <REFERENCE:UNBOUND> <LADDR .SYM T <>>>)>)>
 257            <VAR-STORE>
 258            <SET OPS <- .OPS 1>>)
 259           (ELSE <RETURN>)>
 260          <AND <OR .GOOD-OPTS <1? <LENGTH .INAME>>>
 261               <SPEC-SYM .SYM>
 262               <PUT .SYM ,ARGNUM-SYM <TMPLS .BASEF>>>
 263          <SET B <REST .B>>>
 264        <PUT .I 2 <+ <CHTYPE <2 .I> FIX> 2>>
 265        <SET TRG <- .TRG 1>>
 266        <SET OPS <+ .OPS 1>>
 267        <COND (<OR .GOOD-OPTS <EMPTY? <SET INAME <REST .INAME>>>>
 268               <LABEL:TAG .TG>
 269               <SET BST .B>
 270               <RETURN>)
 271              (ELSE <SET STK .OSTK> <BRANCH:TAG .TG>)>>
 272      <SET LARG T>)
 273     (.FLG <LABEL:TAG <1 .INAME>> <EMIT '<`SUBM  `M*  `(P) >>)>
 274    <REPEAT ((COD 0) SYM)
 275            #DECL ((COD) FIX (SYM) SYMTAB)
 276            <COND (<EMPTY? .BST>
 277                   <COND (<AND .FLG
 278                               <NOT .LARG>
 279                               <COND (.SPECD <VAR-STORE> <BIND:END> T) (ELSE T)>>
 280                          <SALLOC:SLOTS .TSLOTS>
 281                          <SET TMPS <STACK:L .STK .STB>>
 282                          <ADD:STACK .TSLOTS>)>
 283                   <OR .PRE
 284                       <0? .NSLOTS>
 285                       <PROG ()
 286                             <COND (<G? .NSLOTS 0>
 287                                    <SALLOC:SLOTS <- .NSLOTS .TOT-SPEC>>
 288                                    <ADD:STACK <- .NSLOTS .TOT-SPEC>>)>
 289                             <SET PRE T>
 290                             <EMIT-PRE T>>>
 291                   <AND <ACTIVATED .NOD> <ACT:FINAL>>
 292                   <RETURN>)>
 293            <SET COD <CODE-SYM <SET SYM <1 .BST>>>>
 294            <PUT .SYM ,POTLV <>>
 295            <COND (<L? .COD 0>
 296                   <PUT .SYM ,CODE-SYM <SET COD <- .COD>>>
 297                   <COND (<G? .NSLOTS 0>
 298                          <SALLOC:SLOTS <- .NSLOTS .TOT-SPEC>>
 299                          <ADD:STACK <- .NSLOTS .TOT-SPEC>>)>
 300                   <SET PRE T>
 301                   <EMIT-PRE T>)>
 302            <COND (<AND .FLG
 303                        <NOT .LARG>
 304                        <0? <NTH '![0 0 0 0 1 0 0 0 0 1 0 1 1!] .COD>>
 305                        <SET LARG T>
 306                        <COND (.SPECD <VAR-STORE> <BIND:END> T) (ELSE T)>>
 307                   <SET TMPS <STACK:L .STK .STB>>
 308                   <SALLOC:SLOTS .TSLOTS>
 309                   <ADD:STACK .TSLOTS>)>
 310            <APPLY <NTH ,BINDERS .COD> .SYM>
 311            <OR .PRE <PUT .SYM ,SPEC-SYM FUDGE>>
 312            <SET BST <REST .BST>>>
 313    .TOT-SPEC>
 314
 315 <DEFINE OPT-CHECK (B NUM LBLS "AUX" (N .NUM) (RQ <REQARGS .BASEF>) NOD S)
 316    #DECL ((B) <LIST [REST SYMTAB]> (N NUM RQ) FIX (LBLS) <UVECTOR [REST ATOM]>
 317           (NOD BASEF) NODE (S) SYMTAB)
 318    <COND
 319     (<AND
 320       <NOT <0? .NUM>>
 321       <MAPF <>
 322        <FUNCTION (S)
 323                #DECL ((S) SYMTAB)
 324                <PUT .S ,POTLV <>>
 325                <COND (<L? <SET N <- .N 1>> 0> <MAPLEAVE>)>
 326                <COND (<AND <OR <==? <CODE-SYM .S> 6> <==? <CODE-SYM .S> 7>>
 327                            <NOT <MEMQ <NODE-TYPE <CHTYPE <INIT-SYM .S> NODE>> ,SNODES>>>
 328                       <MAPLEAVE <>>)
 329                      (ELSE T)>>
 330        .B>>
 331      <REPEAT (ADDR OFFS)
 332        #DECL ((OFFS) FIX)
 333        <SET S <1 .B>>
 334        <SET B <REST .B>>
 335        <EMIT <INSTRUCTION INTERNAL-ENTRY!-OP!-PACKAGE
 336                           <NTH .LBLS <+ .NUM 1>>
 337                           .RQ>>
 338        <COND (<OR <==? <CODE-SYM .S> 6> <==? <CODE-SYM .S> 7>>
 339               <COND (<==? <NODE-TYPE <SET NOD <INIT-SYM .S>>> ,LVAL-CODE>
 340                      <SET OFFS <* <- .RQ
 341                                      <ARGNUM-SYM <CHTYPE <NODE-NAME .NOD> SYMTAB>>> 2>>
 342                      <SET ADDR <ADDRESS:C <- -1 .OFFS> `(TP) >>
 343                      <SET ADDR <DATUM .ADDR .ADDR>>)
 344                     (ELSE <SET ADDR <GEN .NOD DONT-CARE>>)>)
 345              (ELSE <SET ADDR <REFERENCE:UNBOUND>>)>
 346        <STACK:ARGUMENT .ADDR>
 347        <COND (<L=? <SET NUM <- .NUM 1>> 0> <RETURN>)>
 348        <SET RQ <+ .RQ 1>>>)>>
 349
 350 " Generate \"BIND\" binding code."
 351
 352 <DEFINE BIND-B (SYM) #DECL ((SYM) SYMTAB) <BINDUP .SYM <MAKE:ENV>>>
 353
 354 " Do code generation for normal  arguments."
 355
 356 <DEFINE NORM-B (SYM)
 357         #DECL ((SYM) SYMTAB (AC-HACK) <PRIMTYPE LIST>)
 358         <COND (.AC-HACK
 359                <BINDUP .SYM <DATUM !<NTH .AC-HACK <ARGNUM-SYM .SYM>>> <>>)
 360               (<TYPE? <ADDR-SYM .SYM> DATUM>)
 361               (ELSE <BINDUP .SYM <REFERENCE:ARG <ARGNUM-SYM .SYM>>>)>>
 362
 363 " Initialized optional argument binder."
 364
 365 <DEFINE OPT1-B (SYM)
 366         #DECL ((SYM) SYMTAB)
 367         <TUPCHK <INIT-SYM .SYM>>
 368         <OPTBIND .SYM <INIT-SYM .SYM>>>
 369
 370 " Uninitialized optional argument binder."
 371
 372 <DEFINE OPT2-B (SYM) #DECL ((SYM) SYMTAB) <OPTBIND .SYM>>
 373
 374 " Create a binding either by pushing or moving if slots PRE created."
 375
 376 <DEFINE BINDUP (SYM SRC "OPTIONAL" (SPCB T))
 377         #DECL ((SYM) SYMTAB (SRC) DATUM (TOT-SPEC) FIX)
 378         <COND (<SPEC-SYM .SYM>
 379                <SET SPECD T>
 380                <COND (.PRE
 381                       <PUT .SYM ,ADDR-SYM <- <CHTYPE <ADDR-SYM .SYM> FIX> .TOT-SPEC>>
 382                       <STORE:BIND .SYM .SRC>)
 383                      (ELSE
 384                       <PUSH:BIND <NAME-SYM .SYM> .SRC <DECL-SYM .SYM>>
 385                       <SET TOT-SPEC <+ .TOT-SPEC 6>>
 386                       <ADD:STACK 6>
 387                       <AND .SPCB <VAR-STORE> <BIND:END>>)>)
 388               (ELSE <CLOB:PAIR .SYM .PRE .SRC>)>
 389         <RET-TMP-AC .SRC>>
 390
 391 " Push or store a non special argument."
 392
 393 <DEFINE CLOB:PAIR (SYM PRE SRC)
 394         #DECL ((SYM) SYMTAB (SRC) DATUM (TOT-SPEC) FIX)
 395         <COND (.PRE
 396                <PUT .SYM ,ADDR-SYM <- <CHTYPE <ADDR-SYM .SYM> FIX> .TOT-SPEC>>
 397                <STORE:PAIR .SYM .SRC>)
 398               (ELSE <PUSH:PAIR .SRC> <ADD:STACK 2>)>>
 399
 400 " Create a binding for either intitialized or unitialized optional."
 401
 402 <DEFINE OPTBIND (SYM
 403                  "OPTIONAL" DVAL
 404                  "AUX" (GIVE <MAKE:TAG>) (DEF <MAKE:TAG>) DV (LPRE .PRE))
 405    #DECL ((SYM) SYMTAB (BASEF DVAL) NODE (GIVE DEF) ATOM (DV) DATUM (TOT-SPEC) FIX)
 406    <COND (<SPEC-SYM .SYM>
 407           <SET SPECD T>
 408           <OR .LPRE <PUSH:ATB <NAME-SYM .SYM>>>)>
 409    <TEST:ARG <ARGNUM-SYM .SYM> .DEF>
 410    <COND
 411     (.LPRE
 412      <COND
 413       (<SPEC-SYM .SYM>
 414        <MOVE:ARG <REFERENCE:ARG <ARGNUM-SYM .SYM>>
 415                  <FUNCTION:VALUE>>)
 416       (ELSE
 417        <MOVE:ARG
 418         <REFERENCE:ARG <ARGNUM-SYM .SYM>>
 419         <REFERENCE:STACK
 420          (<ADDR-SYM .SYM>
 421           <COND (<TYPE? <ARGNUM-SYM .SYM> ATOM>
 422                  <FORM GVAL <ARGNUM-SYM .SYM>>)
 423                 (ELSE 0)>)>>)>)
 424     (ELSE <PUSH:PAIR <REFERENCE:ARG <ARGNUM-SYM .SYM>>>)>
 425    <BRANCH:TAG .GIVE>
 426    <LABEL:TAG .DEF>
 427    <SET DV
 428         <COND (<ASSIGNED? DVAL>
 429                <GEN .DVAL <COND (.LPRE <FUNCTION:VALUE>) (ELSE DONT-CARE)>>)
 430               (ELSE <REFERENCE:UNBOUND>)>>
 431    <AND <OR <NOT .LPRE> <NOT <SPEC-SYM .SYM>>>
 432         <CLOB:PAIR .SYM .LPRE .DV>>
 433    <LABEL:TAG .GIVE>
 434    <AND <SPEC-SYM .SYM>
 435         <COND (.LPRE <STORE:BIND .SYM .DV>)
 436               (ELSE
 437                <PUSH:PAIR <REFERENCE <DECL-SYM .SYM>>>
 438                <ADD:STACK 4>
 439                <VAR-STORE>
 440                <BIND:END>)>>
 441    <VAR-STORE>
 442    <COND (<AND <NOT .LPRE> <SPEC-SYM .SYM>>
 443           <SET TOT-SPEC <+ .TOT-SPEC 6>>)>
 444    <RET-TMP-AC .DV>>
 445
 446 " Do a binding for a named activation."
 447
 448 <DEFINE ACT-B (SYM)
 449         #DECL ((SYM) SYMTAB)
 450         <AND <ASSIGNED? START:TAG> <BINDUP .SYM <MAKE:ACT>>>>
 451
 452 " Bind an \"AUX\" variable."
 453
 454 <DEFINE AUX1-B (SYM "AUX" TT TEM TY)
 455    #DECL ((SYM) SYMTAB (TT) DATUM (FCN) NODE (TOT-SPEC) FIX)
 456    <PUT .SYM ,POTLV <>>
 457    <TUPCHK <INIT-SYM .SYM>>
 458    <COND
 459     (<AND <NOT .PRE> <SPEC-SYM .SYM>>
 460      <PUSH:ATB <NAME-SYM .SYM>>
 461      <ADD:STACK 2>
 462      <PUSH:PAIR <SET TT <GEN <INIT-SYM .SYM> DONT-CARE>>>
 463      <PUSH:PAIR <REFERENCE <DECL-SYM .SYM>>>
 464      <SET SPECD T>
 465      <ADD:STACK 4>
 466      <VAR-STORE>
 467      <BIND:END>
 468      <SET TOT-SPEC <+ .TOT-SPEC 6>>
 469      <RET-TMP-AC .TT>)
 470     (<TYPE? <ADDR-SYM .SYM> TEMPV>
 471      <SET TY <CREATE-TMP <SET TEM <ISTYPE-GOOD? <1 <DECL-SYM .SYM>>>>>>
 472      <PUT .SYM
 473           ,ADDR-SYM
 474           <CHTYPE (.BSTB
 475                    .TY
 476                    <COND (<=? .AC-HACK '(FUNNY-STACK)> <* <TOTARGS .FCN> -2>)
 477                          (ELSE 0)>
 478                    !.TMPS)
 479                   TEMPV>>
 480      <SET TT
 481       <GEN
 482        <INIT-SYM .SYM>
 483        <DATUM <COND (<OR <ISTYPE-GOOD? <RESULT-TYPE <INIT-SYM .SYM>>> .TEM>)
 484                     (ELSE ANY-AC)>
 485               ANY-AC>>>
 486      <SMASH-INACS .SYM .TT>
 487      <PUT .SYM ,STORED <>>
 488      <PUT <SET TEM <CHTYPE <DATVAL .TT> AC>> ,ACRESIDUE (.SYM !<ACRESIDUE .TEM>)>
 489      <COND (<TYPE? <SET TEM <DATTYP .TT>> AC>
 490             <PUT .TEM ,ACRESIDUE (.SYM !<ACRESIDUE .TEM>)>)>
 491      <RET-TMP-AC .TT>)
 492     (ELSE <BINDUP .SYM <GEN <INIT-SYM .SYM> DONT-CARE>>)>>
 493
 494 " Do a binding for an uninitialized \"AUX\" "
 495
 496 <DEFINE AUX2-B (SYM "AUX" ADR TY)
 497         #DECL ((SYM) SYMTAB (FCN) NODE)
 498         <PUT .SYM ,POTLV <>>
 499         <TUPCHK <INIT-SYM .SYM>>
 500         <COND (<TYPE? <ADDR-SYM .SYM> TEMPV>
 501                <SET TY <CREATE-TMP <ISTYPE-GOOD? <1 <DECL-SYM .SYM>>>>>
 502                <COND (<ISTYPE-GOOD? <1 <DECL-SYM .SYM>>>
 503                       <PUT .SYM ,INIT-SYM T>)>
 504                <PUT .SYM
 505                     ,ADDR-SYM
 506                     <CHTYPE (.BSTB
 507                              .TY
 508                              <COND (<=? .AC-HACK '(FUNNY-STACK)>
 509                                     <* <TOTARGS .FCN> -2>)
 510                                    (ELSE 0)>
 511                              !.TMPS)
 512                             TEMPV>>)
 513               (<AND <SET TY <ISTYPE-GOOD? <1 <DECL-SYM .SYM>>>>
 514                     <NOT <ASS? .SYM>>
 515                     <NOT <SPEC-SYM .SYM>>>
 516                <SET ADR <ADDRESS:PAIR <FORM TYPE-WORD!-OP!-PACKAGE .TY> '[0]>>
 517                <PUT .SYM ,INIT-SYM T>
 518                <BINDUP .SYM <DATUM .ADR .ADR>>)
 519               (ELSE <BINDUP .SYM <REFERENCE:UNBOUND>>)>>
 520
 521 <DEFINE TUPCHK (TUP "OPTIONAL" (OPT <>) "AUX" (NS .NSLOTS) (TS .TOT-SPEC))
 522         #DECL ((TUP) <OR FALSE NODE> (NS TS) FIX)
 523         <OR .PRE
 524             <COND (<AND <TYPE? .TUP NODE>
 525                         <OR <==? <NODE-NAME .TUP> ITUPLE>
 526                             <==? <NODE-NAME .TUP> TUPLE>>>
 527                    <COND (<OR .OPT
 528                               <==? <NODE-TYPE .TUP> ,ISTRUC-CODE>
 529                               <NOT <GOOD-TUPLE .TUP>>>
 530                           <COND (<G? .NS 0>
 531                                  <SALLOC:SLOTS <- .NS .TS>>
 532                                  <ADD:STACK <- .NS .TS>>)>
 533                           <EMIT-PRE <SET PRE T>>)>)>>>
 534
 535 <DEFINE GOOD-TUPLE (TUP "AUX" (K <KIDS .TUP>) NT (WD 0))
 536         #DECL ((NT) FIX (TUP) NODE (K) <LIST [REST NODE]>)
 537         <AND <NOT <==? <NODE-TYPE .TUP> ,ISTRUC-CODE>>
 538              <COND (<==? <NODE-SUBR .TUP> ,ITUPLE>
 539                     <AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
 540                          <OR <==? <SET NT <NODE-TYPE <2 .K>>> ,QUOTE-CODE>
 541                              <==? .NT ,FLVAL-CODE>
 542                              <==? .NT ,FGVAL-CODE>
 543                              <==? .NT ,GVAL-CODE>
 544                              <==? .NT ,LVAL-CODE>>
 545                          <* <NODE-NAME <1 .K>> 2>>)
 546                    (ELSE
 547                     <MAPF <>
 548                           <FUNCTION (K)
 549                                   <COND (<==? <NODE-TYPE .K> ,SEGMENT-CODE>
 550                                          <MAPLEAVE <>>)
 551                                         (ELSE <SET WD <+ .WD 2>>)>>
 552                           .K>)>>>
 553
 554 " Do a \"TUPLE\" binding."
 555
 556 <DEFINE TUPLE1-B (SYM)
 557         #DECL ((SYM) SYMTAB)
 558         <EMIT '<`PUSH  `P*  `A >>
 559         <EMIT '<`PUSHJ  `P*  |MAKTU2 >>
 560         <COND (<SPEC-SYM .SYM>
 561                <EMIT '<`POP  `TP*  `B >>
 562                <EMIT '<`POP  `TP*  `A >>
 563                <BINDUP .SYM <FUNCTION:VALUE T>>)>>
 564
 565 <DEFINE TUPL-B (SYM "AUX" (SK <* 2 <- <ARGNUM-SYM .SYM> 1>>))
 566         #DECL ((SYM) SYMTAB (SK) FIX)
 567         <EMIT '<`MOVE  `B*  `AB >>
 568         <OR <L=? .SK 0>
 569             <EMIT <INSTRUCTION `ADD  `B*  [<FORM .SK (.SK)>]>>>
 570         <EMIT '<`HLRZ  `A*  |OTBSAV  `(TB) >>
 571         <EMIT '<`HRLI  `A*  <TYPE-CODE!-OP!-PACKAGE TUPLE>>>
 572         <BINDUP .SYM <FUNCTION:VALUE T>>>
 573
 574 " Generate the code to actually build a TUPLE."
 575
 576 <DEFINE BUILD:TUPLE (NUM "AUX" (STAG <MAKE:TAG>) (ETAG <MAKE:TAG>))
 577         #DECL ((NUM) FIX (STAG ETAG) ATOM)
 578         <COPY:ARGPNTR>
 579         <AND <NOT <1? .NUM>> <BUMP:ARGPNTR <- .NUM 1>>>
 580         <LABEL:TAG .STAG>
 581         <TEST:ARGPNTR .ETAG>
 582         <STACK:ARGUMENT <REFERENCE:ARGPNTR>>
 583         <BUMP:ARGPNTR>
 584         <BUMP:CNTR>
 585         <BRANCH:TAG .STAG>
 586         <LABEL:TAG .ETAG>
 587         <TUPLE:FINAL>>
 588
 589 " Dispatch table for binding generation code."
 590
 591 <SETG BINDERS
 592       ![,ACT-B ,AUX1-B ,AUX2-B ,TUPL-B ,NORM-B ,OPT1-B ,OPT1-B ,OPT2-B ,OPT2-B
 593         ,NORM-B ,BIND-B ,NORM-B ,NORM-B!]>
 594
 595 <DEFINE MENTROPY (N R) T>
 596
 597 <COND (<GASSIGNED? NOTIMP>
 598        <SETG MBINDERS
 599              [,ACT-B
 600               ,AUX1-B
 601               ,AUX2-B
 602               ,NOTIMP
 603               ,MENTROPY
 604               ,MOPTG
 605               ,MOPTG
 606               ,MOPTG2
 607               ,MOPTG2
 608               ,MENTROPY
 609               ,BIND-B
 610               ,MENTROPY
 611               ,MENTROPY]>)>
 612
 613 " Appliacation of a form could still be an NTH."
 614
 615 <DEFINE FORM-F-GEN (NOD WHERE "AUX" (K <KIDS .NOD>) TY)
 616         #DECL ((NOD) NODE)
 617         <COND (<==? <ISTYPE? <SET TY <RESULT-TYPE <1 .K>>>> FIX>
 618                <PUT .NOD ,NODE-NAME INTH>
 619                <PUT .NOD ,NODE-TYPE <NODE-SUBR .NOD>>
 620                <PUT .NOD ,NODE-SUBR ,NTH>
 621                <COND (<OR <==? <NODE-TYPE .NOD> ,ALL-REST-CODE>
 622                           <==? <NODE-TYPE .NOD> ,NTH-CODE>>
 623                       <SET K (<2 .K> <1 .K>)>)>
 624                <PUT .NOD ,KIDS .K>
 625                <GEN .NOD .WHERE>)
 626               (.TY <FORM-GEN .NOD .WHERE>)
 627               (ELSE
 628                <MESSAGE ERROR
 629                         " NON APPLICABLE OBJECT "
 630                         <NODE-NAME .NOD>
 631                         .NOD>)>>
 632
 633 " Generate a call to EVAL for uncompilable FORM."
 634
 635 <DEFINE FORM-GEN (NOD WHERE "AUX" (SSTK .STK) TEM (STK (0 !.STK)))
 636         #DECL ((NOD) NODE (WHERE) <OR ATOM DATUM> (TEM) DATUM
 637                (STK) <SPECIAL LIST> (SSTK) LIST)
 638         <RET-TMP-AC <STACK:ARGUMENT <REFERENCE <NODE-NAME .NOD>>>>
 639         <ADD:STACK 2>
 640         <REGSTO T>
 641         <SET TEM <FUNCTION:VALUE T>>
 642         <SUBR:CALL EVAL 1>
 643         <SET STK .SSTK>
 644         <MOVE:ARG .TEM .WHERE>>
 645
 646 " Generate code for LIST/VECTOR etc. evaluation."
 647
 648 <GDECL (COPIERS) <UVECTOR [REST ATOM]>>
 649
 650 <DEFINE COPY-GEN (NOD WHERE
 651                   "AUX" GT RES (I 0) (ARGS <KIDS .NOD>) (UNK <>)
 652                         (TYP  <ISTYPE? <RESULT-TYPE .NOD>>)
 653                         (INAME
 654                          <NTH
 655                           '[|IILIST  |CIVEC  |CIUVEC  TUPLE]
 656                           <LENGTH <CHTYPE <MEMQ .TYP ,COPIERS> UVECTOR>>>))
 657    #DECL ((GT) <OR FALSE FIX> (NOD) NODE (WHERE) <OR ATOM DATUM>
 658           (ARGS) <LIST [REST NODE]> (I) FIX (VALUE RES) DATUM)
 659    <PROG ((STK (0 !.STK)))
 660      #DECL ((STK) <SPECIAL LIST>)
 661      <COND
 662       (<REPEAT ()
 663                <AND <EMPTY? .ARGS> <RETURN>>
 664                <COND (<==? <NODE-TYPE <1 .ARGS>> ,SEGMENT-CODE>
 665                       <RET-TMP-AC <GEN <1 <KIDS <1 .ARGS>>> <FUNCTION:VALUE>>>
 666                       <COND (<AND <==? <NODE-NAME .NOD> LIST>
 667                                   <EMPTY? <REST .ARGS>>>
 668                              <REGSTO T>
 669                              <SEGMENT:LIST .I .UNK>
 670                              <SET RES <FUNCTION:VALUE T>>
 671                              <RETURN <>>)
 672                             (ELSE
 673                              <REGSTO T>
 674                              <SEGMENT:STACK </ <STACKS .NOD> 2> .UNK>
 675                              <ADD:STACK <- <STACKS .NOD>>>
 676                              <ADD:STACK PSTACK>
 677                              <SET UNK T>)>)
 678                      (ELSE
 679                       <RET-TMP-AC <STACK:ARGUMENT <GEN <1 .ARGS> DONT-CARE>>>
 680                       <ADD:STACK 2>
 681                       <SET I <+ .I 1>>)>
 682                <SET ARGS <REST .ARGS>>>
 683        <REGSTO T>
 684        <SET RES <FUNCTION:VALUE T>>
 685        <COND (.UNK
 686               <AND <NOT <==? .INAME TUPLE>>
 687                    <EMIT <INSTRUCTION `POP
 688                                       `P*
 689                                       <COND (<==? .INAME TUPLE> `D )
 690                                             (ELSE `A )>>>>)
 691              (ELSE
 692               <EMIT <INSTRUCTION `MOVEI
 693                                  <COND (<==? .INAME TUPLE> `D* ) (ELSE `A* )>
 694                                  <COND (<==? .INAME TUPLE> <+ .I .I>)
 695                                        (ELSE .I)>>>)>
 696        <COND (<==? .INAME TUPLE>
 697               <COND (.UNK
 698                      <EMIT <INSTRUCTION `MOVE  `D*  `(P) >>
 699                      <EMIT <INSTRUCTION `ASH  `D*  1>>)>
 700               <EMIT <INSTRUCTION `PUSHJ  `P*  |MAKTUP >>)
 701              (ELSE <EMIT <INSTRUCTION `PUSHJ  `P*  .INAME>>)>)>>
 702    <COND (<==? .INAME TUPLE>
 703           <COND (<SET GT <GOOD-TUPLE .NOD>> <ADD:STACK <+ 2 .GT>>)
 704                 (ELSE <EMIT <INSTRUCTION `AOS  `(P) >> <ADD:STACK PSTACK>)>)>
 705    <MOVE:ARG .RES .WHERE>>
 706
 707 <SETG COPIERS ![TUPLE UVECTOR VECTOR LIST!]>
 708
 709 "Generate code for a call to a SUBR."
 710
 711 <DEFINE SUBR-GEN (NOD WHERE)
 712         #DECL ((WHERE) <OR ATOM DATUM> (NOD) NODE)
 713         <COMP:SUBR:CALL <NODE-NAME .NOD>
 714                         <KIDS .NOD>
 715                         <STACKS .NOD>
 716                         .WHERE>>
 717
 718 " Compile call to a SUBR that doesn't compile or PUSHJ."
 719
 720 <DEFINE COMP:SUBR:CALL (SUBR OBJ STA W
 721                         "AUX" RES (I 0) (UNK <>) (OS .STK) (STK (0 !.STK)))
 722    #DECL ((STA I) FIX (OBJ) <LIST [REST NODE]> (UNK) <OR FALSE ATOM>
 723           (STK) <SPECIAL LIST> (OS) LIST (RES) DATUM)
 724    <MAPF <>
 725     <FUNCTION (OB)
 726             #DECL ((OB) NODE (I STA) FIX)
 727             <COND (<==? <NODE-TYPE .OB> ,SEGMENT-CODE>
 728                    <RET-TMP-AC <GEN <1 <KIDS .OB>> <FUNCTION:VALUE>>>
 729                    <REGSTO T>
 730                    <SEGMENT:STACK </ .STA 2> .UNK>
 731                    <ADD:STACK <- .STA>>
 732                    <ADD:STACK PSTACK>
 733                    <SET UNK T>)
 734                   (ELSE
 735                    <RET-TMP-AC <STACK:ARGUMENT <GEN .OB DONT-CARE>>>
 736                    <ADD:STACK 2>
 737                    <SET I <+ .I 1>>)>>
 738     .OBJ>
 739    <REGSTO T>
 740    <SET RES <FUNCTION:VALUE T>>
 741    <COND (.UNK <SEGMENT:FINAL .SUBR>)
 742          (ELSE <SUBR:CALL .SUBR .I>)>
 743    <SET STK .OS>
 744    <MOVE:ARG .RES .W>>
 745
 746
 747 <GDECL (SUBRS TEMPLATES) UVECTOR>
 748
 749 <DEFINE GET-TMPS (SUB "AUX" (LS <MEMQ .SUB ,SUBRS>))
 750         #DECL ((VALUE) <LIST ANY ANY> (LS) <OR FALSE UVECTOR>)
 751         <COND (.LS <NTH ,TEMPLATES <LENGTH .LS>>)
 752               (ELSE '(ANY ANY))>>
 753
 754 " Generate calls to SUBRs using the internal PUSHJ feature."
 755
 756 <DEFINE ISUBR-GEN (NOD WHERE
 757                    "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
 758                    "AUX" (TMPL <GET-TMPS <NODE-SUBR .NOD>>) W (SDIR .DIR) B2
 759                          (OS .STK) (STK (0 !.STK)) W2 (TP <4 .TMPL>))
 760    #DECL ((NOD) NODE (WHERE W2) <OR ATOM DATUM> (W) DATUM
 761           (TMPL) <LIST ANY ANY ANY ANY ANY ANY> (UNK) <OR FALSE ATOM>
 762           (STA ARGS) FIX (STK) <SPECIAL LIST> (OS) LIST)
 763    <AND .NOTF <SET DIR <NOT .DIR>>>
 764    <COND (<==? <NODE-NAME .NOD> INTH> <SET TP (<2 <CHTYPE .TP LIST>>
 765                                                <1 <CHTYPE .TP LIST>>)>)>
 766    <COND (<=? .TP STACK> <STACK-ARGS .NOD T>)
 767          (<NOT <AC-ARGS .NOD .TP>> <AC-SEG-CALL .TP>)>
 768    <REGSTO T>
 769    <EMIT <INSTRUCTION `PUSHJ  `P*  <6 .TMPL>>>
 770    <SET STK .OS>
 771    <COND (<AND .BRANCH <5 .TMPL>>
 772           <COND (<==? .WHERE FLUSHED>
 773                  <COND (.DIR <EMIT '<`SKIPA >> <BRANCH:TAG .BRANCH>)
 774                        (ELSE <BRANCH:TAG .BRANCH>)>)
 775                 (ELSE
 776                  <COND (.DIR <BRANCH:TAG <SET B2 <MAKE:TAG>>>)
 777                        (<OR .NOTF
 778                             <NOT <OR <==? .WHERE DONT-CARE>
 779                                      <AND <TYPE? .WHERE DATUM>
 780                                           <SET W .WHERE>
 781                                           <==? <LENGTH .W> 2>
 782                                           <OR <==? <DATTYP .W> ANY-AC>
 783                                               <==? <DATTYP .W> ,AC-A>>
 784                                           <OR <==? <DATVAL .W> ANY-AC>
 785                                               <==? <DATVAL .W> ,AC-B>>>>>>
 786                         <EMIT '<`SKIPA >>
 787                         <BRANCH:TAG <SET B2 <MAKE:TAG>>>)>
 788                  <SET WHERE
 789                       <MOVE:ARG <COND (.NOTF <REFERENCE .SDIR>)
 790                                       (ELSE <FUNCTION:VALUE T>)>
 791                                 .WHERE>>
 792                  <BRANCH:TAG .BRANCH>
 793                  <COND (<ASSIGNED? B2> <LABEL:TAG .B2>)>
 794                  .WHERE)>)
 795          (.BRANCH
 796           <OR <==? .WHERE FLUSHED> <SET DIR <NOT .DIR>>>
 797           <D:B:TAG <COND (<==? .WHERE FLUSHED> .BRANCH)
 798                          (ELSE <SET B2 <MAKE:TAG>>)>
 799                    <FUNCTION:VALUE>
 800                    .DIR
 801                    <RESULT-TYPE .NOD>>
 802           <SET W2
 803                <MOVE:ARG <COND (.NOTF <REFERENCE .SDIR>)
 804                                (ELSE <FUNCTION:VALUE T>)>
 805                          .WHERE>>
 806           <COND (<N==? .WHERE FLUSHED>
 807                  <BRANCH:TAG .BRANCH>
 808                  <LABEL:TAG .B2>)>
 809           .W2)
 810          (<5 .TMPL>
 811           <GEN:FALSE>
 812           <MOVE:ARG <FUNCTION:VALUE T> .WHERE>)
 813          (ELSE <MOVE:ARG <FUNCTION:VALUE T> .WHERE>)>>
 814
 815 <DEFINE STACK-ARGS (NOD PASN
 816                     "AUX" (UNK <>) (ARGS 0) (STA <STACKS .NOD>) N
 817                           (K <KIDS .NOD>))
 818         #DECL ((NOD N) NODE (ARGS STA) FIX (K) <LIST [REST NODE]>)
 819         <REPEAT ()
 820                 <AND <EMPTY? .K> <RETURN>>
 821                 <COND (<==? <NODE-TYPE <SET N <1 .K>>> ,SEGMENT-CODE>
 822                        <RET-TMP-AC <GEN <1 <KIDS .N>> <FUNCTION:VALUE>>>
 823                        <REGSTO T>
 824                        <SEGMENT:STACK </ .STA 2> .UNK>
 825                        <ADD:STACK <- .STA>>
 826                        <ADD:STACK PSTACK>
 827                        <SET UNK T>)
 828                       (ELSE
 829                        <RET-TMP-AC <STACK:ARGUMENT <GEN .N DONT-CARE>>>
 830                        <ADD:STACK 2>
 831                        <SET ARGS <+ .ARGS 1>>)>
 832                 <SET K <REST .K>>>
 833         <REGSTO T>
 834         <COND (.UNK <EMIT '<`POP  `P*  `A >>)
 835               (.PASN <EMIT <INSTRUCTION `MOVEI  `A*  .ARGS>>)>
 836         <COND (<NOT .UNK> .ARGS)>>
 837
 838 " Get a bunch of goodies into ACs for a PUSHJ call."
 839
 840 <DEFINE AC-ARGS (NOD ACTMP "AUX" WHS)
 841    #DECL ((WHS) <LIST [REST DATUM]> (NOD) NODE (ACTMP) LIST)
 842    <COND
 843     (<SEGS .NOD> <STACK-ARGS .NOD <>>)
 844     (<SET WHS
 845       <MAPR ,LIST
 846        <FUNCTION (NL WL
 847                   "AUX" (N <1 .NL>) (W <1 .WL>) (SD <SIDES <REST .NL>>)
 848                         (RT <ISTYPE-GOOD? <DATTYP .W>>))
 849           #DECL ((N) NODE (W) <OR DATUM LIST> (RT) <OR ATOM FALSE>)
 850           <SET W
 851            <GEN .N
 852                 <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE> DONT-CARE)
 853                       (.SD
 854                        <DATUM <COND (<ISTYPE-GOOD? <RESULT-TYPE .N>>)
 855                                     (ELSE ANY-AC)>
 856                               ANY-AC>)
 857                       (ELSE <DATUM !.W>)>>>
 858           <AND .SD <REGSTO <>>>
 859           <COND (.RT <DATTYP-FLUSH .W> <PUT .W ,DATTYP .RT>)>
 860           .W>
 861        <KIDS .NOD>
 862        .ACTMP>>
 863      <SET WHS
 864           <MAPF ,LIST
 865                 <FUNCTION (W1 W2)
 866                         #DECL ((W1) DATUM (W2) LIST)
 867                         <MOVE:ARG .W1 <DATUM !.W2>>>
 868                 .WHS
 869                 .ACTMP>>
 870      <MAPF <> ,RET-TMP-AC .WHS>
 871      T)>>
 872
 873 <DEFINE SIDES (L)
 874         #DECL ((L) <LIST [REST NODE]>)
 875         <MAPF <>
 876               <FUNCTION (N)
 877                       <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE> <>)
 878                             (<OR <==? <NODE-TYPE .N> ,ISUBR-CODE>
 879                                  <MEMQ ALL <SIDE-EFFECTS .N>>>
 880                              <MAPLEAVE T>)>>
 881               .L>>
 882
 883 " Generate code for a call to an RSUBR (maybe PUSHJ)."
 884
 885 <DEFINE RSUBR-GEN (N W
 886                    "AUX" (IT <NODE-NAME .N>) ACST RN KNWN (OS .STK)
 887                          (STK (0 !.STK)))
 888         #DECL ((N RN) NODE (W) <OR ATOM DATUM> (STK) <SPECIAL LIST> (OS) LIST)
 889         <MAPF <>
 890               <FUNCTION (ARG)
 891                       #DECL ((ARG) NODE)
 892                       <OR <RESULT-TYPE .ARG>
 893                           <==? <NODE-TYPE .ARG> ,SEGMENT-CODE>
 894                           <MESSAGE ERROR "BAD ARG TO " <NODE-NAME .N> .ARG>>>
 895               <KIDS .N>>
 896         <COND (<AND <TYPE? <NODE-SUBR .N> FUNCTION>
 897                     <SET ACST <ACS <SET RN <GET .IT .IND>>>>
 898                     <OR <ASSIGNED? GROUP-NAME> <==? .FCN .RN>>>
 899                <COND (<OR <=? .ACST '(STACK)> <=? .ACST '(FUNNY-STACK)>>
 900                       <SET KNWN <STACK-ARGS .N <>>>
 901                       <REGSTO T>
 902                       <SET STK .OS>
 903                       <STACK-CALL <REQARGS .RN>
 904                                   <TOTARGS .RN>
 905                                   <NODE-NAME .RN>
 906                                   .KNWN <>>)
 907                      (ELSE
 908                       <OR <AC-ARGS .N .ACST> <AC-SEG-CALL .ACST>>
 909                       <REGSTO T>
 910                       <SET STK .OS>
 911                       <EMIT <INSTRUCTION `PUSHJ  `P*  <1 <CHTYPE <NODE-NAME .RN>
 912                                                                  UVECTOR>>>>)>
 913                <MOVE:ARG <FUNCTION:VALUE T> .W>)
 914               (ELSE <SUBR-GEN .N .W>)>>
 915
 916 " Generate a call to an internal compiled goodies using a PUSHJ."
 917
 918 <DEFINE IRSUBR-GEN (NOD WHERE
 919                     "AUX" KNWN (N <NODE-SUBR .NOD>) (AN <2 .N>) (OS .STK)
 920                           (STK (0 !.STK)))
 921         #DECL ((NOD) NODE (WHERE) <OR ATOM DATUM> (STK) <SPECIAL LIST> (OS) LIST
 922                (N) <IRSUBR ANY <LIST [REST FIX]>> (AN) <LIST [REST FIX]>)
 923         <REGSTO T>
 924         <SET KNWN <STACK-ARGS .NOD <>>>
 925         <STACK-CALL <MIN !.AN>
 926                     <MAX !.AN>
 927                     '![!]
 928                     .KNWN
 929                     <NODE-NAME .NOD>>
 930         <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>
 931
 932 " Get the arguemnts to a FUNCTION into the ACs."
 933
 934 <DEFINE ARGS-TO-ACS (NOD
 935                      "AUX" (RQRG <REQARGS .NOD>) (INAME <NODE-NAME .NOD>) (N 1)
 936                            (ACST <ACS .NOD>) TG1 TG2 TG)
 937    #DECL ((N RQRG) FIX (INAME) <UVECTOR [REST ATOM]> (ACST) LIST (NOD) NODE)
 938    <COND
 939     (<MEMBER .ACST '![(STACK) (FUNNY-STACK)!]>
 940      <COND (<AND <EMPTY? <REST .INAME>> <NOT <L? .RQRG 0>>>
 941             <REPEAT ()
 942                     <AND <G? .N .RQRG> <RETURN>>
 943                     <STACK:ARGUMENT <REFERENCE:ARG .N>>
 944                     <SET N <+ .N 1>>>
 945             <EMIT <INSTRUCTION `PUSHJ  `P*  <1 .INAME>>>
 946             <EMIT '<`JRST  |FINIS >>)
 947            (ELSE
 948             <EMIT '<`MOVE  `A*  `AB >>
 949             <AND <L=? .RQRG 0>
 950                  <EMIT <INSTRUCTION `JUMPGE  `AB*  <SET TG1 <MAKE:TAG>>>>>
 951             <LABEL:TAG <SET TG2 <MAKE:TAG>>>
 952             <AND <L? .RQRG 0> <EMIT '<INTGO!-OP>>>
 953             <STACK:ARGUMENT <REFERENCE:ARG 1>>
 954             <EMIT <INSTRUCTION `ADD  `AB*  '[<2 (2)>]>>
 955             <EMIT <INSTRUCTION `JUMPL  `AB*  .TG2>>
 956             <AND <L=? .RQRG 0> <LABEL:TAG .TG1>>
 957             <EMIT '<`HLRES  `A >>
 958             <EMIT '<`ASH  `A*  -1>>
 959             <COND (<G=? .RQRG 0>
 960                    <EMIT <INSTRUCTION `ADDI  `A*  <SET TG <MAKE:TAG>>>>
 961                    <EMIT <INSTRUCTION `PUSHJ  `P*  `@  .RQRG '`(A) >>)
 962                   (ELSE
 963                    <EMIT '<`MOVMS  `A >>
 964                    <EMIT <INSTRUCTION `PUSHJ  `P*  <1 .INAME>>>)>
 965             <EMIT '<`JRST  |FINIS >>
 966             <COND (<G=? .RQRG 0>
 967                    <REPEAT ()
 968                            <AND <EMPTY? <REST .INAME>> <LABEL:TAG .TG>>
 969                            <EMIT <INSTRUCTION `SETZ <1 .INAME>>>
 970                            <AND <EMPTY? <SET INAME <REST .INAME>>>
 971                                 <RETURN>>>)>)>)
 972     (ELSE
 973      <REPEAT ()
 974              <AND <EMPTY? .ACST> <RETURN>>
 975              <RET-TMP-AC <MOVE:ARG <REFERENCE:ARG .N> <DATUM !<1 .ACST>>>>
 976              <SET N <+ .N 1>>
 977              <SET ACST <REST .ACST>>>
 978      <EMIT <INSTRUCTION `PUSHJ  `P*  <1 .INAME>>>
 979      <EMIT '<`JRST  |FINIS >>)>>
 980
 981 " Push the args supplied in ACs onto the stack."
 982
 983 <DEFINE ACS-TO-STACK (ACST "AUX" (N 0))
 984         #DECL ((N) FIX (ACST) LIST (VALUE) FIX)
 985         <MAPF <>
 986               <FUNCTION (W)
 987                       #DECL ((N) FIX)
 988                       <STACK:ARGUMENT <DATUM !.W>>
 989                       <SET N <+ .N 1>>>
 990               .ACST>
 991         .N>
 992
 993 <DEFINE AC-SEG-CALL (ACS "AUX" (NARG <LENGTH .ACS>) TT OFFS)
 994         #DECL ((OFFS NARG) FIX (ACS) LIST (TT) ADDRESS:C)
 995         <COND (.CAREFUL
 996                <EMIT <INSTRUCTION `CAIE  `A*  .NARG>>
 997                <EMIT '<`JRST  |COMPER >>)>
 998         <SET OFFS <- 1 <SET NARG <* .NARG 2>>>>
 999         <MAPF <>
1000               <FUNCTION (X)
1001                       #DECL ((X) LIST)
1002                       <SET TT <ADDRESS:C .OFFS '`(TP) >>
1003                       <SET OFFS <+ .OFFS 2>>
1004                       <RET-TMP-AC <MOVE:ARG <DATUM .TT .TT> <DATUM !.X>>>>
1005               .ACS>
1006         <EMIT <INSTRUCTION `SUB  `TP*  [<FORM .NARG (.NARG)>]>>>
1007
1008 " Generate PUSHJ in stack arg case (may go different places)"
1009
1010 <DEFINE STACK-CALL (RQRG TRG INAME KNWN INT)
1011    #DECL ((TRG RQRG) FIX (INAME) <UVECTOR [REST ATOM]> (KNWN) <OR FIX FALSE>
1012           (INT) <OR ATOM FALSE>)
1013    <COND
1014     (<L? .TRG 0>                                                       ;"TUPLE?"
1015      <COND (.KNWN <EMIT <INSTRUCTION `MOVEI  `A*  .KNWN>>)>
1016      <EMIT <COND (.INT
1017                   <INSTRUCTION `PUSHJ
1018                                `P*
1019                                `@
1020                                <FORM MQUOTE!-OP!-PACKAGE
1021                                      <INTERNAL-RSUBR .INT -1 T>>>)
1022                  (ELSE <INSTRUCTION `PUSHJ  `P*  <1 .INAME>>)>>)
1023     (ELSE
1024      <COND
1025       (<NOT .KNWN>
1026        <COND
1027         (<==? .RQRG .TRG>
1028          <COND (.CAREFUL
1029                 <EMIT <INSTRUCTION `CAIE  `A*  .RQRG>>
1030                 <EMIT '<`JRST  |COMPER >>)>
1031          <EMIT <COND (.INT
1032                       <INSTRUCTION `PUSHJ
1033                                    `P*
1034                                    `@
1035                                    <FORM MQUOTE!-OP!-PACKAGE
1036                                          <INTERNAL-RSUBR .INT .RQRG T>>>)
1037                      (ELSE <INSTRUCTION `PUSHJ  `P*  <1 .INAME>>)>>)
1038         (ELSE
1039          <COND (.CAREFUL
1040                 <EMIT <INSTRUCTION `CAIG  `A*  .TRG>>
1041                 <EMIT <INSTRUCTION `CAIGE  `A*  .RQRG>>
1042                 <EMIT '<`JRST  |COMPER >>)>
1043          <EMIT
1044           <INSTRUCTION
1045            `ADDI
1046            `A*
1047            <PROG ((I <+ <- .TRG .RQRG> 2>))
1048              #DECL ((I) FIX)
1049              <IVECTOR
1050               <- .I 1>
1051               '<COND
1052                 (.INT
1053                  <FORM `@
1054                        <FORM MQUOTE!-OP!-PACKAGE
1055                              <INTERNAL-RSUBR .INT
1056                                              <- .TRG <SET I <- .I 1>>>
1057                                              T>>>)
1058                 (ELSE <FORM <NTH .INAME <SET I <- .I 1>>>>)>>>>>
1059          <EMIT <INSTRUCTION `PUSHJ  `P*  `@  <- .RQRG> `(A) >>)>)
1060       (ELSE
1061        <EMIT <COND (.INT
1062                     <INSTRUCTION `PUSHJ
1063                                  `P*
1064                                  `@
1065                                  <FORM MQUOTE!-OP!-PACKAGE
1066                                        <INTERNAL-RSUBR .INT .KNWN T>>>)
1067                    (ELSE
1068                     <INSTRUCTION `PUSHJ
1069                                  `P*
1070                                  <NTH .INAME <- .TRG .KNWN -1>>>)>>)>)>>
1071
1072
1073 " Generate code for a stackform."
1074
1075 <DEFINE STACKFORM-GEN (NOD WHERE
1076                        "AUX" (K <KIDS .NOD>) TT T1 T2 TTT (PRE T) (OS .STK)
1077                              (STK (0 !.STK))
1078                              (SUBRC
1079                               <AND
1080                                <==? <NODE-TYPE <SET TT <1 .K>>> ,FGVAL-CODE>
1081                                <==? <NODE-TYPE <SET TT <1 <KIDS .TT>>>>
1082                                     ,QUOTE-CODE>
1083                                <GASSIGNED? <SET TTT <NODE-NAME .TT>>>
1084                                <TYPE? ,.TTT SUBR>
1085                                .TTT>))
1086         #DECL ((NOD TT) NODE (K) <LIST [REST NODE]> (PRE) <SPECIAL ANY>
1087                (WHERE) <OR ATOM DATUM> (STK) <SPECIAL LIST> (OS) LIST)
1088         <REGSTO T>
1089         <COND (<NOT .SUBRC>
1090                <RET-TMP-AC <STACK:ARGUMENT <GEN <1 .K> DONT-CARE>>>)>
1091         <PCOUNTER <COND (.SUBRC 0) (ELSE 1)>>
1092         <ADD:STACK PSTACK>
1093         <LABEL:TAG <SET T1 <MAKE:TAG>>>
1094         <PRED:BRANCH:GEN <SET T2 <MAKE:TAG>> <3 .K> <>>
1095         <RET-TMP-AC <STACK:ARGUMENT <GEN <2 .K> DONT-CARE>>>
1096         <COUNTP>
1097         <BRANCH:TAG .T1>
1098         <LABEL:TAG .T2>
1099         <SEGMENT:FINAL <COND (.SUBRC .SUBRC) (ELSE APPLY)>>
1100         <SET STK .OS>
1101         <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>
1102
1103 " Generate code for a COND."
1104
1105 <DEFINE COND-GEN (NOD WHERE
1106                   "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
1107                   "AUX" SACS NWHERE (ALLSTATES ()) (SSTATE #SAVED-STATE ())
1108                         (RW .WHERE) LOCN (COND <MAKE:TAG "COND">) W2
1109                         (KK <CLAUSES .NOD>) (SDIR .DIR) (SACS-OK T)
1110                         (SNUMSYM ()))
1111    #DECL ((NOD) NODE (WHERE RW) <OR ATOM DATUM> (COND) ATOM (W2) DATUM
1112           (KK) <LIST [REST NODE]> (ALLSTATES) <LIST [REST SAVED-STATE]>
1113           (SSTATE) SAVED-STATE (LOCN) DATUM)
1114    <AND .NOTF <SET DIR <NOT .DIR>>>
1115    <COND (<AND ,FUDGE .BRANCH> <VAR-STORE>) (ELSE <SET SACS <SAVE:RES>> <REGSTO <>>)>
1116    <PREFER-DATUM .WHERE>
1117    <SET WHERE <GOODACS .NOD .WHERE>>
1118    <COND (<AND <TYPE? .WHERE DATUM>
1119                <SET W2 .WHERE>
1120                <OR <==? <ISTYPE? <RESULT-TYPE .NOD>> FALSE>
1121                    <==? <ISTYPE? <DATTYP .W2>> FALSE>>>
1122           <SET WHERE <DATUM ANY-AC <DATVAL .W2>>>)>
1123    <MAPR <>
1124     <FUNCTION (BRN
1125                "AUX" (LAST <EMPTY? <REST .BRN>>) (BR <1 .BRN>) NEXT
1126                      (K <CLAUSES .BR>) (PR <PREDIC .BR>) (NO-SEQ <>) (LEAVE <>)
1127                      (W
1128                       <COND (<TYPE? .WHERE DATUM> <DATUM !.WHERE>)
1129                             (ELSE .WHERE)>) FLG (BRNCHED <>))
1130        #DECL ((PR BR) NODE (BRN) <LIST NODE> (K) <LIST [REST NODE]>)
1131        <OR <AND ,FUDGE .BRANCH> <SET SNUMSYM <SAVE-NUM-SYM .SACS>>>
1132        <RESTORE-STATE .SSTATE <AND <ASSIGNED? LOCN> <==? .LOCN ,NO-DATUM>>>
1133        <COND
1134         (<EMPTY? .K>
1135          <COND
1136           (<OR <SET FLG <NOT <TYPE-OK? <RESULT-TYPE .PR> FALSE>>> .LAST>
1137            <OR .LAST <COND-COMPLAIN "NON REACHABLE COND CLAUSE(S) " <2 .BRN>>>
1138            <COND (<AND .FLG .BRANCH>
1139                   <SET LOCN
1140                        <GEN .PR <COND (<==? .RW FLUSHED> FLUSHED) (ELSE .W)>>>
1141                   <COND (.DIR <BRANCH:TAG .BRANCH>)>)
1142                  (<AND .BRANCH .LAST>
1143                   <SET LOCN
1144                        <PRED:BRANCH:GEN .BRANCH
1145                                         .PR
1146                                         .SDIR
1147                                         <COND (<==? .RW FLUSHED> FLUSHED)
1148                                               (ELSE .W)>
1149                                         .NOTF>>)
1150                  (ELSE
1151                   <SET LOCN
1152                        <GEN .PR <COND (<==? .RW FLUSHED> FLUSHED) (ELSE .W)>>>
1153                   <ACFIX .WHERE .W>
1154                   <VAR-STORE <>>)>
1155            <COND (<==? .LOCN ,NO-DATUM>
1156                   <SET SACS-OK <SAVE-TYP .PR>>
1157                   <OR <AND ,FUDGE .BRANCH> <FIX-NUM-SYM .SNUMSYM .SACS>>)
1158                  (<NOT <AND ,FUDGE .BRANCH>><SET ALLSTATES (<SAVE-STATE> !.ALLSTATES)>)>
1159            <MAPLEAVE>)
1160           (<==? <ISTYPE? <RESULT-TYPE .PR>> FALSE> <GEN .PR FLUSHED>)
1161           (<==? .RW FLUSHED>
1162            <PRED:BRANCH:GEN <COND (<AND .BRANCH .SDIR> .BRANCH) (ELSE .COND)>
1163                             .PR
1164                             T
1165                             FLUSHED
1166                             .NOTF>)
1167           (ELSE
1168            <COND
1169             (<AND .BRANCH .SDIR>
1170              <RET-TMP-AC <PRED:BRANCH:GEN .BRANCH .PR T FLUSHED .NOTF>>)
1171             (ELSE
1172              <RET-TMP-AC
1173               <PRED:BRANCH:GEN
1174                .COND
1175                .PR
1176                T
1177                <COND (<AND <TYPE? .W DATUM> <ISTYPE? <DATTYP .W>>>
1178                       <PUT .W ,DATTYP ANY-AC>
1179                       .W)
1180                      (ELSE .W)>
1181                .NOTF>>)>)>
1182          <SET SSTATE <SAVE-STATE>>
1183          <OR <==? <RESULT-TYPE .PR> FLUSHED>
1184              <AND ,FUDGE .BRANCH>
1185              <SET ALLSTATES (.SSTATE !.ALLSTATES)>>
1186          <VAR-STORE <>>)
1187         (ELSE
1188          <SET NEXT <MAKE:TAG "PHRASE">>
1189          <COND (<==? <ISTYPE? <RESULT-TYPE .PR>> FALSE>
1190                 <COND (<AND .BRANCH .LAST <NOT .DIR>>
1191                        <SET LOCN <GEN .PR .W>>
1192                        <BRANCH:TAG .BRANCH>)
1193                       (ELSE
1194                        <COND (<AND .LAST <NOT <==? .RW FLUSHED>>>
1195                               <SET LOCN <GEN .PR .W>>)
1196                              (ELSE <SET LOCN <GEN .PR FLUSHED>>)>
1197                        <AND <N==? .LOCN ,NO-DATUM> <BRANCH:TAG .NEXT>>)>
1198                 <SET NO-SEQ T>
1199                 <OR <AND ,FUDGE .BRANCH> <SET ALLSTATES (<SAVE-STATE> !.ALLSTATES)>>
1200                 <COND-COMPLAIN "COND PREDICATE ALWAYS FALSE" .PR>)
1201                (<TYPE-OK? FALSE <RESULT-TYPE .PR>>
1202                 <COND (<AND .LAST <NOT .DIR> .BRANCH>
1203                        <RET-TMP-AC <PRED:BRANCH:GEN .BRANCH .PR <> .W .NOTF>>)
1204                       (<AND .LAST .BRANCH>
1205                        <RET-TMP-AC <PRED:BRANCH:GEN .NEXT .PR <> FLUSHED>>)
1206                       (<AND .LAST <NOT <==? .RW FLUSHED>>>
1207                        <RET-TMP-AC <PRED:BRANCH:GEN .NEXT .PR <> .W>>)
1208                       (ELSE <PRED:BRANCH:GEN .NEXT .PR <> FLUSHED>)>
1209                 <COND (<AND .LAST <N==? <RESULT-TYPE .PR> NO-RETURN>>
1210                        <OR <AND ,FUDGE .BRANCH>
1211                            <SET ALLSTATES (<SAVE-STATE> !.ALLSTATES)>>)
1212                       (<==? <RESULT-TYPE .PR> NO-RETURN>
1213                        <SET SACS-OK <SAVE-TYP <NTH .K <LENGTH .K>>>>
1214                        <OR <AND ,FUDGE .BRANCH> <FIX-NUM-SYM .SNUMSYM .SACS>>)>)
1215                (ELSE
1216                 <SET K (.PR !.K)>
1217                 <COND (<NOT .LAST>
1218                        <SET LEAVE T>
1219                        <COND-COMPLAIN "NON REACHABLE COND CLAUSE(S)"
1220                                       <2 .BRN>>)>)>
1221          <SET SSTATE <SAVE-STATE>>
1222          <VAR-STORE <>>
1223          <COND
1224           (.BRANCH
1225            <OR
1226             .NO-SEQ
1227             <COND
1228              (<OR
1229                <SET FLG
1230                     <NOT <TYPE-OK?
1231                           <RESULT-TYPE <SET PR <NTH .K <LENGTH .K>>>> FALSE>>>
1232                <NOT <TYPE-OK? <RESULT-TYPE .PR> '<NOT FALSE>>>>
1233               <COND (.NOTF
1234                      <SEQ-GEN .K FLUSHED>
1235                      <COND (<==? .RW FLUSHED> <SET LOCN ,NO-DATUM>)
1236                            (ELSE
1237                             <SET LOCN <MOVE:ARG <REFERENCE <NOT .FLG>> .W>>)>)
1238                     (<SET LOCN
1239                           <SEQ-GEN .K
1240                                    <COND (<OR <==? .RW FLUSHED>
1241                                               <N==? .SDIR .FLG>>
1242                                           FLUSHED)
1243                                          (ELSE .W)>>>)>
1244               <AND <==? .FLG .SDIR> <SET BRNCHED T> <BRANCH:TAG .BRANCH>>)
1245              (ELSE
1246               <SET LOCN
1247                    <PSEQ-GEN .K
1248                              <COND (<==? .RW FLUSHED> FLUSHED) (ELSE .W)>
1249                              .BRANCH
1250                              .SDIR
1251                              .NOTF>>)>>
1252            <AND .LAST .NO-SEQ <NOT .DIR> <BRANCH:TAG .BRANCH>>)
1253           (<NOT .NO-SEQ>
1254            <SET LOCN
1255                 <PSEQ-GEN .K
1256                           <COND (<==? .RW FLUSHED> FLUSHED) (ELSE .W)>
1257                           .BRANCH
1258                           .SDIR
1259                           .NOTF>>)>
1260          <VAR-STORE <>>
1261          <COND (<N==? .LOCN ,NO-DATUM>
1262                 <OR <AND ,FUDGE .BRANCH> <SET ALLSTATES (<SAVE-STATE> !.ALLSTATES)>>)
1263                (ELSE
1264                 <SET SACS-OK <SAVE-TYP <NTH .K <LENGTH .K>>>>
1265                 <OR <AND ,FUDGE .BRANCH> <FIX-NUM-SYM .SNUMSYM .SACS>>
1266                 <RESTORE-STATE .SSTATE T>)>
1267          <COND (<AND <NOT .LAST> <N==? .LOCN ,NO-DATUM>>
1268                 <OR .NO-SEQ <RET-TMP-AC .LOCN>>
1269                 <OR .BRNCHED <BRANCH:TAG .COND>>)>
1270          <LABEL:TAG .NEXT>)>
1271        <ACFIX .WHERE .W>
1272        <OR <ASSIGNED? NPRUNE> <PUT .BR ,CLAUSES ()>>
1273        <AND .LEAVE <MAPLEAVE>>>
1274     .KK>
1275    <OR <ASSIGNED? NPRUNE> <PUT .NOD ,CLAUSES ()>>
1276    <COND (<AND <TYPE? .WHERE DATUM> <N==? <RESULT-TYPE .NOD> NO-RETURN>>
1277           <SET W2 .WHERE>
1278           <AND <ISTYPE? <DATTYP .W2>>
1279                <TYPE? <DATTYP .LOCN> AC>
1280                <NOT <==? <DATTYP .W2> <DATTYP .LOCN>>>
1281                <RET-TMP-AC <DATTYP .LOCN> .LOCN>>
1282           <AND <TYPE? <DATTYP .W2> AC> <FIX-ACLINK <DATTYP .W2> .W2 .LOCN>>
1283           <AND <TYPE? <DATVAL .W2> AC> <FIX-ACLINK <DATVAL .W2> .W2 .LOCN>>)>
1284    <LABEL:TAG .COND>
1285    <SET NWHERE
1286         <COND (<==? <RESULT-TYPE .NOD> NO-RETURN> ,NO-DATUM)
1287               (ELSE <MOVE:ARG .WHERE .RW>)>>
1288    <AND <N==? .NWHERE ,NO-DATUM> <NOT <AND ,FUDGE .BRANCH>> <MERGE-STATES .ALLSTATES>>
1289    <OR .BRANCH <CHECK:VARS .SACS .SACS-OK>>
1290    .NWHERE>
1291
1292 <DEFINE PSEQ-GEN (L W B D N)
1293         #DECL ((L) <LIST [REST NODE]>)
1294         <REPEAT ()
1295                 <COND (<EMPTY? <REST .L>>
1296                        <RETURN <COND (.B <PRED:BRANCH:GEN .B <1 .L> .D .W .N>)
1297                                      (ELSE <GEN <1 .L> .W>)>>)>
1298                 <RET-TMP-AC <GEN <1 .L> FLUSHED>>
1299                 <SET L <REST .L>>>>
1300
1301 <DEFINE COND-COMPLAIN (MSG N1) #DECL ((N1) NODE) <MESSAGE NOTE .MSG .N1>>
1302
1303 <DEFINE SAVE-TYP (NOD)
1304         #DECL ((NOD) NODE)
1305         <==? <NODE-TYPE .NOD> ,RETURN-CODE>>
1306
1307 <DEFINE MERGE-STATES (ALLSTATES)
1308    #DECL ((ALLSTATES) LIST)
1309    <COND
1310     (<EMPTY? .ALLSTATES>
1311      <MAPF <>
1312            <FUNCTION (AC "AUX" (NRES <ACRESIDUE .AC>))
1313                    <COND (.NRES
1314                           <MAPF <> <FUNCTION (X) <SMASH-INACS .X <>>> .NRES>)>
1315                    <PUT .AC ,ACRESIDUE <>>>
1316            ,ALLACS>)
1317     (ELSE <MAPF <> <FUNCTION (X) <MERGE-STATE .X>> .ALLSTATES>)>>
1318
1319 " Fixup where its going better or something?"
1320
1321 <DEFINE UPDATE-WHERE (NOD WHERE "AUX" TYP)
1322         #DECL ((NOD) NODE (WHERE VALUE) <OR ATOM DATUM>)
1323         <COND (<==? .WHERE FLUSHED> DONT-CARE)
1324               (<SET TYP <ISTYPE? <RESULT-TYPE .NOD>>> <REG? .TYP .WHERE>)
1325               (<==? .WHERE DONT-CARE> <DATUM ANY-AC ANY-AC>)
1326               (ELSE .WHERE)>>
1327
1328 " Generate code for OR use BOOL-GEN to do work."
1329
1330 <DEFINE OR-GEN (NOD WHERE "OPTIONAL" (NF <>) (BR <>) (DIR T))
1331         #DECL ((NOD) NODE)
1332         <BOOL-GEN .NOD <CLAUSES .NOD> T .WHERE .NF .BR .DIR>>
1333
1334 " Generate code for AND use BOOL-GEN to do work."
1335
1336 <DEFINE AND-GEN (NOD WHERE "OPTIONAL" (NF <>) (BR <>) (DIR <>))
1337         #DECL ((NOD) NODE)
1338         <BOOL-GEN .NOD <CLAUSES .NOD> <> .WHERE .NF .BR .DIR>>
1339
1340 <DEFINE BOOL-GEN (NOD PREDS RESULT WHERE NOTF BRANCH DIR
1341                   "AUX" SACS (SSTATE ()) (SS #SAVED-STATE ()) (RW .WHERE)
1342                         (BOOL <MAKE:TAG "BOOL">) (FLUSH <==? .RW FLUSHED>)
1343                         (FLS <AND <NOT .BRANCH> .FLUSH>) RTF SRES
1344                         (LOCN <DATUM ANY ANY>) FIN (SACS-OK T))
1345    #DECL ((PREDS) <LIST [REST NODE]> (SSTATE) <LIST [REST SAVED-STATE]>
1346           (SS) SAVED-STATE (NOTF DIR FLUSH FLS RTF) ANY (BOOL) ATOM
1347           (BRANCH) <OR ATOM FALSE> (WHERE RW) <OR DATUM ATOM> (NOD) NODE
1348           (LOCN) ANY (SRES RESULT) ANY)
1349    <COND (<AND ,FUDGE .BRANCH> <VAR-STORE <>>) (ELSE <SET SACS <SAVE:RES>> <REGSTO <>>)>
1350    <PREFER-DATUM .WHERE>
1351    <AND .NOTF <SET RESULT <NOT .RESULT>>>
1352    <SET SRES .RESULT>
1353    <SET RTF
1354         <AND <NOT .FLUSH> <==? .SRES .DIR> <TYPE-OK? <RESULT-TYPE .NOD> FALSE>>>
1355    <AND .DIR <SET RESULT <NOT .RESULT>>>
1356    <SET WHERE <GOODACS .NOD .WHERE>>
1357    <COND
1358     (<EMPTY? .PREDS> <SET LOCN <MOVE:ARG <REFERENCE .RESULT> .WHERE>>)
1359     (ELSE
1360      <MAPR <>
1361       <FUNCTION (BRN
1362                  "AUX" (BR <1 .BRN>) (LAST <EMPTY? <REST .BRN>>)
1363                        (RT <RESULT-TYPE .BR>)
1364                        (W
1365                         <COND (<AND <TYPE? .WHERE DATUM>
1366                                     <ISTYPE? <DATTYP .WHERE>>
1367                                     <NOT .LAST>>
1368                                <GOODACS .BR <DATUM ANY-AC <DATVAL .WHERE>>>)
1369                               (<AND <OR <NOT .RTF> .LAST> <TYPE? .WHERE DATUM>>
1370                                <DATUM !.WHERE>)
1371                               (<==? .RW FLUSHED> FLUSHED)
1372                               (ELSE .WHERE)>) (RTFL <>))
1373          #DECL ((BRN) <LIST NODE> (BR) NODE (W) <OR ATOM DATUM>)
1374          <SET SS <SAVE-STATE>>
1375          <COND
1376           (<AND <TYPE-OK? .RT FALSE> <NOT <SET RTFL <==? <ISTYPE? .RT> FALSE>>>>
1377            <COND
1378             (<OR .BRANCH <AND .FLS <NOT .LAST>>>
1379              <COND (.LAST
1380                     <SET LOCN
1381                          <PRED:BRANCH:GEN .BRANCH
1382                                           .BR
1383                                           .DIR
1384                                           <COND (.FLUSH FLUSHED) (ELSE .W)>
1385                                           .NOTF>>)
1386                    (ELSE
1387                     <RET-TMP-AC
1388                      <PRED:BRANCH:GEN <COND (.FLS .BOOL)
1389                                             (.RESULT .BOOL)
1390                                             (ELSE .BRANCH)>
1391                                       .BR
1392                                       .SRES
1393                                       <COND (.RTF .W) (ELSE FLUSHED)>
1394                                       .NOTF>>)>
1395              <COND (<AND <NOT <AND ,FUDGE .BRANCH>> <N==? .RT NO-RETURN>>
1396                     <SET SSTATE (<SAVE-STATE> !.SSTATE)>)
1397                    (<==? .RT NO-RETURN>
1398                     <SET SACS-OK <SAVE-TYP .BR>>
1399                     <RESTORE-STATE .SS T>)>)
1400             (.LAST
1401              <SET LOCN <GEN .BR .W>>
1402              <COND (<AND <NOT <AND ,FUDGE .BRANCH>> <N==? .RT NO-RETURN>>
1403                     <SET SSTATE (<SAVE-STATE> !.SSTATE)>)
1404                    (<==? .RT NO-RETURN>
1405                     <SET SACS-OK <SAVE-TYP .BR>>
1406                     <RESTORE-STATE .SS T>)>
1407              .LOCN)
1408             (ELSE
1409              <SET LOCN <PRED:BRANCH:GEN .BOOL .BR .DIR .W .NOTF>>
1410              <COND (<AND <NOT <AND ,FUDGE .BRANCH>> <N==? .RT NO-RETURN>>
1411                     <SET SSTATE (<SAVE-STATE> !.SSTATE)>)
1412                    (<==? .RT NO-RETURN>
1413                     <SET SACS-OK <SAVE-TYP .BR>>
1414                     <RESTORE-STATE .SS T>)>
1415              <RET-TMP-AC .LOCN>)>)
1416           (<OR <N==? .SRES <COND (.NOTF <SET RTFL <NOT .RTFL>>) (ELSE .RTFL)>>
1417                .LAST>
1418            <OR .LAST <MESSAGE NOTE "NON REACHABLE AND/OR CLAUSE" <2 .BRN>>>
1419            <COND (.BRANCH
1420                   <SET LOCN
1421                        <GEN .BR <COND (<N==? .DIR .RTFL> .W) (ELSE FLUSHED)>>>
1422                   <AND <N==? .DIR .RTFL>
1423                        <N==? .LOCN ,NO-DATUM>
1424                        <PROG ()
1425                              <VAR-STORE>
1426                              T>
1427                        <BRANCH:TAG .BRANCH>>)
1428                  (ELSE <SET LOCN <GEN .BR .W>>)>
1429            <ACFIX .WHERE .W>
1430            <VAR-STORE>
1431            <MAPLEAVE>)
1432           (ELSE <RET-TMP-AC <GEN .BR FLUSHED>>)>
1433          <ACFIX .WHERE .W>
1434          <VAR-STORE <>>>
1435       .PREDS>)>
1436    <OR <ASSIGNED? NPRUNE> <PUT .NOD ,CLAUSES ()>>
1437    <COND (<AND <TYPE? .WHERE DATUM> <TYPE? .LOCN DATUM>>
1438           <AND <NOT <==? <DATTYP .WHERE> <DATTYP .LOCN>>>
1439                <ISTYPE? <DATTYP .WHERE>>
1440                <TYPE? <DATTYP .LOCN> AC>
1441                <RET-TMP-AC <DATTYP .LOCN> .LOCN>>
1442           <AND <TYPE? <DATTYP .WHERE> AC>
1443                <FIX-ACLINK <DATTYP .WHERE> .WHERE .LOCN>>
1444           <AND <TYPE? <DATVAL .WHERE> AC>
1445                <FIX-ACLINK <DATVAL .WHERE> .WHERE .LOCN>>)>
1446    <OR <AND .BRANCH <NOT .RESULT>> <LABEL:TAG .BOOL>>
1447    <SET FIN
1448         <COND (<==? <RESULT-TYPE .NOD> NO-RETURN> ,NO-DATUM)
1449               (ELSE <OR <AND ,FUDGE .BRANCH>
1450                         <MERGE-STATES .SSTATE>> <MOVE:ARG .WHERE .RW>)>>
1451    <OR <AND ,FUDGE .BRANCH> <CHECK:VARS .SACS .SACS-OK>>
1452    .FIN>
1453
1454 " Get the best set of acs around for this guy."
1455
1456 <DEFINE GOODACS (N W1 "AUX" W)
1457         #DECL ((N) NODE (W) DATUM)
1458         <COND (<==? .W1 FLUSHED> DONT-CARE)
1459               (<TYPE? .W1 DATUM>
1460                <SET W .W1>
1461                <DATUM <COND (<OR <ISTYPE-GOOD? <DATTYP .W>>
1462                                  <ISTYPE-GOOD? <RESULT-TYPE .N>>>)
1463                             (<TYPE? <DATTYP .W> AC> <DATTYP .W>)
1464                             (ELSE ANY-AC)>
1465                       <COND (<TYPE? <DATVAL .W> AC> <DATVAL .W>)
1466                             (ELSE ANY-AC)>>)
1467               (ELSE
1468                <DATUM <COND (<ISTYPE-GOOD? <RESULT-TYPE .N>>) (ELSE ANY-AC)>
1469                       ANY-AC>)>>
1470
1471 " Generate code for ASSIGNED?"
1472
1473 <DEFINE ASSIGNED?-GEN (N W
1474                        "OPTIONAL" (NF <>) (BR <>) (DIR <>)
1475                        "AUX" (A <LOCAL-ADDR .N <>>) (SDIR .DIR)
1476                              (FLS <==? .W FLUSHED>) B2)
1477         #DECL ((A) DATUM (N) NODE)
1478         <AND .NF <SET DIR <NOT .DIR>>>
1479         <SET DIR
1480              <COND (<AND .BR <NOT .FLS>> <NOT .DIR>) (ELSE .DIR)>>
1481         <EMIT <INSTRUCTION GETYP!-OP `O*  !<ADDR:TYPE .A>>>
1482         <EMIT <INSTRUCTION <COND (.DIR `CAIE ) (ELSE `CAIN )>
1483                            `O*
1484                            '<TYPE-CODE!-OP!-PACKAGE UNBOUND>>>
1485         <RET-TMP-AC .A>
1486         <COND (<AND .BR .FLS> <BRANCH:TAG .BR> FLUSHED)
1487               (.BR
1488                <BRANCH:TAG <SET B2 <MAKE:TAG>>>
1489                <SET W <MOVE:ARG <REFERENCE .SDIR> .W>>
1490                <BRANCH:TAG .BR>
1491                <LABEL:TAG .B2>
1492                .W)
1493               (ELSE
1494                <BRANCH:TAG <SET BR <MAKE:TAG>>>
1495                <TRUE-FALSE .N .BR .W>)>>
1496
1497 <DEFINE TRUE-FALSE (N B W "OPTIONAL" (THIS T) "AUX" (RW .W) (B2 <MAKE:TAG>))
1498         #DECL ((N) NODE (B2 B) ATOM (W) <OR DATUM ATOM>)
1499         <SET W <UPDATE-WHERE .N .W>>
1500         <MOVE:ARG <REFERENCE .THIS> .W>
1501         <RET-TMP-AC .W>
1502         <BRANCH:TAG .B2>
1503         <LABEL:TAG .B>
1504         <MOVE:ARG <REFERENCE <NOT .THIS>> .W>
1505         <LABEL:TAG .B2>
1506         <MOVE:ARG .W .RW>>
1507
1508 " Generate code for LVAL."
1509
1510 <DEFINE LVAL-GEN (NOD WHERE
1511                   "AUX" (SYM <NODE-NAME .NOD>) (TAC <>) (VAC <>) TT ADDR
1512                         (LIVE
1513                          <COND (<==? <LENGTH <SET TT <TYPE-INFO .NOD>>> 2>
1514                                 <2 .TT>)
1515                                (ELSE T)>))
1516         #DECL ((NOD) NODE (SYM) SYMTAB (ADDR) <OR FALSE DATUM>
1517                (TAC VAC) <OR FALSE AC> (NO-KILL) LIST)
1518         <LVAL-UP .SYM>
1519         <COND (<SET ADDR <INACS .SYM>>
1520                <AND <TYPE? <DATTYP <SET ADDR <DATUM !.ADDR>>> AC>
1521                     <PUT <SET TAC <DATTYP .ADDR>>
1522                          ,ACLINK
1523                          (.ADDR !<ACLINK .TAC>)>>
1524                <AND <TYPE? <DATVAL .ADDR> AC>
1525                     <PUT <SET VAC <DATVAL .ADDR>>
1526                          ,ACLINK
1527                          (.ADDR !<ACLINK .VAC>)>>
1528                <SET ADDR <MOVE:ARG .ADDR .WHERE>>)
1529               (ELSE
1530                <SET ADDR <MOVE:ARG <LADDR .SYM <> <>> .WHERE>>
1531                <COND (<AND <TYPE? <SET TT <DATVAL .ADDR>> AC> <SET VAC .TT>>
1532                       <AND <TYPE? <SET TT <DATTYP .ADDR>> AC> <SET TAC .TT>>
1533                       <COND (<N==? <DATTYP .ADDR> DONT-CARE>
1534                              <SMASH-INACS .SYM <DATUM !.ADDR>>
1535                              <AND .TAC <PUT .TAC ,ACRESIDUE (.SYM)>>
1536                              <AND .VAC <PUT .VAC ,ACRESIDUE (.SYM)>>)>)>)>
1537         <COND (<AND ,DEATH
1538                     <NOT .LIVE>
1539                     <NOT <MAPF <>
1540                                <FUNCTION (LL)
1541                                        #DECL ((LL) LIST)
1542                                        <AND <==? <1 .LL> .SYM>
1543                                             <PUT .LL 2 T>
1544                                             <MAPLEAVE>>>
1545                                .NO-KILL>>>
1546                <OR <STORED .SYM> <EMIT <MAKE:TAG <SPNAME <NAME-SYM .SYM>>>>>
1547                <SMASH-INACS .SYM <> <>>
1548                <AND .TAC
1549                     <ACRESIDUE .TAC>
1550                     <PUT .TAC ,ACRESIDUE <RES-FLS <ACRESIDUE .TAC> .SYM>>>
1551                <AND .VAC
1552                     <ACRESIDUE .VAC>
1553                     <PUT .VAC ,ACRESIDUE <RES-FLS <ACRESIDUE .VAC> .SYM>>>)>
1554         .ADDR>
1555
1556 <DEFINE DELAY-KILL (L1 L2 "AUX" TT TAC SYM)
1557         #DECL ((L1 L2) <LIST [REST !<LIST SYMTAB <OR ATOM FALSE>>]> (SYM) SYMTAB)
1558         <REPEAT ()
1559                 <COND (<OR <==? .L1 .L2> <NOT ,DEATH>> <RETURN>)>
1560                 <COND (<2 <SET TT <1 .L1>>>
1561                        <OR <STORED <SET SYM <1 .TT>>>
1562                            <EMIT <MAKE:TAG <SPNAME <NAME-SYM .SYM>>>>>
1563                        <COND (<SET TT <INACS .SYM>>
1564                               <AND <TYPE? <SET TAC <DATTYP .TT>> AC>
1565                                    <ACRESIDUE .TAC>
1566                                    <PUT .TAC
1567                                         ,ACRESIDUE
1568                                         <RES-FLS <ACRESIDUE .TAC> .SYM>>>
1569                               <AND <TYPE? <SET TAC <DATVAL .TT>> AC>
1570                                    <ACRESIDUE .TAC>
1571                                    <PUT .TAC
1572                                         ,ACRESIDUE
1573                                         <RES-FLS <ACRESIDUE .TAC> .SYM>>>
1574                               <SMASH-INACS .SYM <>>)>)>
1575                 <SET L1 <REST .L1>>>>
1576
1577 <DEFINE RES-FLS (L S)
1578    #DECL ((L) <LIST [REST <OR TEMP SYMTAB COMMON>]> (S) SYMBOL)
1579    <COND
1580     (<EMPTY? .L> <>)
1581     (ELSE
1582      <REPEAT ((L1 .L) (LL .L))
1583        #DECL ((LL L1) <LIST [REST <OR TEMP SYMTAB COMMON>]>)
1584        <COND (<==? <1 .LL> .S>
1585               <COND (<==? .LL .L>
1586                      <RETURN <COND (<NOT <EMPTY? <SET L <REST .L>>>> .L)>>)
1587                     (ELSE <PUTREST .L <REST .LL>> <RETURN .L1>)>)>
1588        <AND <EMPTY? <SET LL <REST <SET L .LL>>>> <RETURN .L1>>>)>>
1589
1590 " Generate LVAL for free variable."
1591
1592 <DEFINE FLVAL-GEN (NOD WHERE "AUX" T2 T1 TT)
1593         #DECL ((NOD) NODE (TT) SYMTAB (T2) DATUM)
1594         <REGSTO T>
1595         <COND (<TYPE? <SET T1 <NODE-NAME .NOD>> SYMTAB>
1596                <SET TT .T1>
1597                <MOVE:ARG <REFERENCE <NAME-SYM .TT>>
1598                          <SET T2 <DATUM ATOM <2 ,ALLACS>>>>)
1599               (ELSE <SET T2 <GEN <1 <KIDS .NOD>> <DATUM ATOM <2 ,ALLACS>>>>)>
1600         <FAST:VAL>
1601         <RET-TMP-AC .T2>
1602         <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>
1603
1604 <DEFINE FSET-GEN (NOD WHERE "AUX" TT TEM T1 T2)
1605         #DECL ((NOD TEM) NODE (T1) SYMTAB (T2) DATUM)
1606         <REGSTO T>
1607         <COND (<TYPE? <SET TT <NODE-NAME .NOD>> SYMTAB>
1608                <SET T1 .TT>
1609                <SET T2 <MOVE:ARG <REFERENCE <NAME-SYM .T1>> DONT-CARE>>
1610                <SET TEM <2 <KIDS .NOD>>>)
1611               (ELSE
1612                <SET T2 <GEN <1 <KIDS .NOD>> DONT-CARE>>
1613                <SET TEM <2 <KIDS .NOD>>>)>
1614         <SET TT <GEN .TEM <FUNCTION:VALUE>>>
1615         <SET T2 <MOVE:ARG .T2 <DATUM ATOM <3 ,ALLACS>>>>
1616         <FAST:SET>
1617         <RET-TMP-AC .T2>
1618         <MOVE:ARG .TT .WHERE>>
1619
1620 " Generate code for an internal SET."
1621
1622 <DEFINE SET-GEN (NOD WHERE
1623                  "AUX" (SYM <NODE-NAME .NOD>)
1624                        (TY <ISTYPE-GOOD? <1 <TYPE-INFO .NOD>>>) TEM
1625                        (TYAC ANY-AC) (STORE-SET <>) (VAC ANY-AC) DAT1 (TT <>))
1626         #DECL ((NOD) NODE (ADDR TEM) DATUM (SYM) SYMTAB
1627                (STORE-SET) <SPECIAL ANY>)
1628         <COND (<TYPE? .WHERE DATUM>
1629                <AND <==? <DATVAL .WHERE> DONT-CARE> <PUT .WHERE ,DATVAL ANY-AC>>
1630                <AND <==? <DATTYP .WHERE> DONT-CARE> <PUT .WHERE ,DATTYP ANY-AC>>
1631                <AND <TYPE? <DATTYP .WHERE> AC> <SET TYAC <DATTYP .WHERE>>>
1632                <AND <TYPE? <DATVAL .WHERE> AC> <SET VAC <DATVAL .WHERE>>>)>
1633         <COND (<TYPE? .TYAC AC>
1634                <COND (<MEMQ .SYM <ACRESIDUE .TYAC>>
1635                       <MAPF <>
1636                             <FUNCTION (S)
1637                                     #DECL ((S) SYMTAB)
1638                                     <OR <==? .S .SYM> <STOREV .SYM>>>
1639                             <ACRESIDUE .TYAC>>
1640                       <PUT .TYAC ,ACRESIDUE (.SYM)>)
1641                      (ELSE <MUNG-AC .TYAC .WHERE>)>)>
1642         <COND (<TYPE? .VAC AC>
1643                <COND (<MEMQ .SYM <ACRESIDUE .VAC>>
1644                       <MAPF <>
1645                             <FUNCTION (S)
1646                                     #DECL ((S) SYMTAB)
1647                                     <OR <==? .S .SYM> <STOREV .SYM>>>
1648                             <CHTYPE <ACRESIDUE .VAC> LIST>>
1649                       <PUT .VAC ,ACRESIDUE (.SYM)>)
1650                      (ELSE <MUNG-AC .VAC .WHERE>)>)>
1651         <OR .TY
1652             <AND <OR <==? <SPEC-SYM .SYM> FUDGE> <NOT <SPEC-SYM .SYM>>>
1653                  <OR <ARG? .SYM> <INIT-SYM .SYM>>
1654                  <SET TY <ISTYPE-GOOD? <1 <DECL-SYM .SYM>>>>>>
1655         '<COND (<AND <SET TT <INACS .SYM>>
1656                     <==? .TYAC ANY-AC>
1657                     <==? .VAC ANY-AC>
1658                     <PROG-AC .SYM>
1659                     <MEMQ .SYM <LOOP-VARS <1 <PROG-AC .SYM>>>>
1660                     <OR <==? .TY <DATTYP .TT>>
1661                         <AND <NOT .TY>
1662                              <TYPE? <DATTYP .TT> AC>
1663                              <SET TYAC <DATTYP .TT>>>>>
1664                <SET VAC <DATVAL .TT>>)>
1665         <SET TEM
1666              <GEN <2 <KIDS .NOD>>
1667                   <COND (.TY <DATUM .TY .VAC>)
1668                         (ELSE <SET TY <>> <DATUM .TYAC .VAC>)>>>
1669         <REPEAT ((TT .TEM) AC)
1670                 #DECL ((TT) <PRIMTYPE LIST> (AC) AC)
1671                 <COND (<EMPTY? .TT> <RETURN>)
1672                       (<TYPE? <1 .TT> AC>
1673                        <OR <MEMQ .TEM <ACLINK <SET AC <1 .TT>>>>
1674                            <PUT .AC ,ACLINK (.TEM !<ACLINK .AC>)>>
1675                        <OR <MEMQ .SYM <ACRESIDUE .AC>>
1676                            <PUT .AC ,ACRESIDUE (.SYM !<ACRESIDUE .AC>)>>)>
1677                 <SET TT <REST .TT>>>
1678         <COND (<SET DAT1 <INACS .SYM>>
1679                <COND (<TYPE? <DATTYP .DAT1> AC>
1680                       <OR <MEMQ <DATTYP .DAT1> .TEM>
1681                           <FLUSH-RESIDUE <DATTYP .DAT1> .SYM>>)>
1682                <COND (<TYPE? <DATVAL .DAT1> AC>
1683                       <OR <MEMQ <DATVAL .DAT1> .TEM>
1684                           <FLUSH-RESIDUE <DATVAL .DAT1> .SYM>>)>)>
1685         <COND (<TYPE? <DATVAL .TEM> AC> <SMASH-INACS .SYM <DATUM !.TEM>>)>
1686         <PUT .SYM ,STORED .STORE-SET>
1687         <KILL-LOOP-AC .SYM>
1688         <FLUSH-COMMON-SYMT .SYM>
1689         <MOVE:ARG .TEM .WHERE>>
1690
1691
1692 <DEFINE ARG? (SYM) #DECL ((SYM) SYMTAB) <1? <NTH ,ARGTBL <CODE-SYM .SYM>>>>
1693
1694 <SETG ARGTBL ![0 0 0 0 1 0 0 0 0 1 0 1 1!]>
1695
1696 <GDECL (ARGTBL) <UVECTOR [REST FIX]>>
1697
1698 " Update the stack model with a FIX or an ATOM."
1699
1700 <DEFINE ADD:STACK (THING)
1701         #DECL ((STK) <LIST FIX>)
1702         <COND (<TYPE? .THING FIX> <PUT .STK 1 <+ <1 .STK> .THING>>)
1703               (<OR <==? .THING PSLOT> <==? .THING PSTACK>>
1704                <SET STK (0 .THING !.STK)>)
1705               (<TYPE? .THING ATOM>
1706                <SET STK (0 <FORM GVAL .THING> !.STK)>)
1707               (ELSE <MESSAGE INCONSISTENCY "BAD CALL TO ADD:STACK ">)>>
1708
1709 " Return the current distance between two stack places."
1710
1711 <DEFINE STACK:L (FROM TO "AUX" (LN 0) (TF 0) (LF ()))
1712         #DECL ((LN TF) FIX (FROM TO) LIST (VALUE) <OR FALSE LIST>)
1713         <REPEAT (T)
1714                 <AND <==? <SET T <1 .FROM>> PSTACK> <RETURN <>>>
1715                 <COND (<N==? .T PSLOT>
1716                        <COND (<NOT <TYPE? .T FIX>> <SET LF (.T !.LF)>)
1717                              (ELSE <SET TF .T> <SET LN <+ .LN .TF>>)>)>
1718                 <AND <==? .TO .FROM> <RETURN (.LN !.LF)>>
1719                 <SET FROM <REST .FROM>>>>
1720
1721 " Compute the address of a local variable using the stack model."
1722
1723 <DEFINE LOCAL-ADDR (NOD STYP "AUX" (S <NODE-NAME .NOD>))
1724         #DECL ((NOD) NODE (S) SYMTAB)
1725         <LADDR .S <> .STYP>>
1726
1727 <DEFINE LADDR (S LOSER STYP
1728                "OPTIONAL" (NOSTORE T)
1729                "AUX" TEM T2 T3 T4 (FRMS .FRMS) (AC-HACK .AC-HACK)
1730                      (NTSLOTS .NTSLOTS))
1731    #DECL ((S) SYMTAB (T4) ADDRESS:C (VALUE TEM) DATUM (FRMS NTSLOTS) LIST)
1732    <SET TEM
1733     <COND
1734      (<SET T2 <INACS .S>>
1735       <COND (<TYPE? <DATTYP <SET T2 <DATUM !.T2>>> AC>
1736              <PUT <DATTYP .T2> ,ACLINK (.T2 !<ACLINK <DATTYP .T2>>)>)>
1737       <COND (<TYPE? <DATVAL .T2> AC>
1738              <PUT <DATVAL .T2> ,ACLINK (.T2 !<ACLINK <DATVAL .T2>>)>)>
1739       <SET LOSER T>
1740       .T2)
1741      (ELSE
1742       <COND (<AND .NOSTORE <TYPE? <NUM-SYM .S> LIST> <1 <NUM-SYM .S>>>
1743              <PUT <NUM-SYM .S> 1 <>>)>
1744       <COND
1745        (<AND <TYPE? <ADDR-SYM .S> TEMPV> <==? <1 .FRMS> <FRMNO .S>>>
1746         <COND
1747          (<=? .AC-HACK '(STACK)>
1748           <SET T4
1749                <ADDRESS:C
1750                 !<FIX:ADDR (-1 !<STACK:L .STK <1 <ADDR-SYM .S>>>)
1751                            <REST <ADDR-SYM .S>>>
1752                 `(TP) >>)
1753          (<SET T4
1754                <ADDRESS:C !<REST <ADDR-SYM .S>>
1755                           <COND (<=? .AC-HACK '(FUNNY-STACK)> `(FRM) )
1756                                 (ELSE `(TB) )>
1757                           <COND (<=? .AC-HACK '(FUNNY-STACK)> 1) (ELSE 0)>>>)>
1758         <DATUM .T4 .T4>)
1759        (<TYPE? <ADDR-SYM .S> DATUM> <DATUM !<ADDR-SYM .S>>)
1760        (<TYPE? <ADDR-SYM .S> FIX TEMPV>
1761         <COND
1762          (<AND .AC-HACK <=? .AC-HACK '(STACK)> <==? <1 .FRMS> <FRMNO .S>>>
1763           <SET T4
1764            <ADDRESS:C
1765             !<FIX:ADDR (-1 !<STACK:L .STK .BSTB>)
1766                        (<ADDR-SYM .S>
1767                         !<COND (<TYPE? <ARGNUM-SYM .S> ATOM>
1768                                 <MEMBER <FORM GVAL <ARGNUM-SYM .S>> .NTSLOTS>)
1769                                (ELSE (0))>)>
1770             `(TP) >>
1771           <DATUM .T4 .T4>)
1772          (<==? <1 .FRMS> <FRMNO .S>>
1773           <SPEC:REFERENCE:STACK
1774            .AC-HACK
1775            (<ADDR-SYM .S>
1776             !<COND (<TYPE? <ARGNUM-SYM .S> FIX>
1777                     <COND (<NOT .AC-HACK>
1778                            <REST .NTSLOTS <- <LENGTH .NTSLOTS> 1>>)
1779                           (ELSE '(-2))>)
1780                    (<AND .PRE <NOT <SPEC-SYM .S>>> .NTSLOTS)
1781                    (ELSE <MEMBER <FORM GVAL <ARGNUM-SYM .S>> .NTSLOTS>)>)>)
1782          (<REPEAT ((FRMS .FRMS) NNTSLTS (LB <>) (OFFS (0 ())) (CURR <>))
1783             #DECL ((FRMS NNTSLTSJ) LIST (OFFS) <LIST [2 <OR FIX LIST>]>)
1784             <COND
1785              (<SET CURR <==? <4 .FRMS> FUZZ>>
1786               <COND (.LB
1787                      <SET T3
1788                           <SPEC-OFFPTR
1789                            <- ,OTBSAV <1 .OFFS> 1>
1790                            <DATUM <ADDRESS:PAIR |$TTB > .T3>
1791                            VECTOR
1792                            (<FORM - 0 !<2 .OFFS>>)>>
1793                      <SET OFFS (0 ())>)
1794                     (ELSE
1795                      <SET LB T>
1796                      <SET T3
1797                           <SPEC-OFFPTR
1798                            <- ,OTBSAV <1 .OFFS> 1>
1799                            <DATUM <ADDRESS:PAIR |$TTB >
1800                                   <ADDRESS:PAIR |$TTB  `TB >>
1801                            VECTOR
1802                            (<FORM - 0 !<2 .OFFS>>)>>
1803                      <SET OFFS (0 ())>)>)
1804              (ELSE <SET OFFS <STFIXIT .OFFS <4 .FRMS>>>)>
1805             <AND <EMPTY? <SET FRMS <REST .FRMS 5>>>
1806                  <MESSAGE INCONSISTANCY "BAD FRAME MODEL ">>
1807             <AND
1808              <==? <FRMNO .S> <1 .FRMS>>
1809              <SET OFFS
1810                   (<COND (<TYPE? <ADDR-SYM .S> FIX>
1811                           (<+ <ADDR-SYM .S> <- <1 .OFFS>>>))
1812                          (ELSE
1813                           <FIX:ADDR (<1 .OFFS>)
1814                                     <REST <CHTYPE <ADDR-SYM .S> LIST>>>)>
1815                    (<FORM - 0 !<2 .OFFS>>))>
1816              <SET NNTSLTS <5 .FRMS>>
1817              <RETURN
1818               <COND
1819                (.LB
1820                 <SET T3
1821                  <SPEC-OFFPTR
1822                   !<1 .OFFS>
1823                   <DATUM <ADDRESS:PAIR |$TTB > .T3>
1824                   VECTOR
1825                   (!<2 .OFFS>
1826                    !<COND (<TYPE? <ARGNUM-SYM .S> ATOM>
1827                            <MEMBER <FORM GVAL <ARGNUM-SYM .S>> .NNTSLTS>)
1828                           (ELSE <REST .NNTSLTS <- <LENGTH .NNTSLTS> 1>>)>)>>
1829                 <DATUM .T3 .T3>)
1830                (ELSE
1831                 <REFERENCE:STACK
1832                  (!<1 .OFFS>
1833                   !<COND (<TYPE? <ARGNUM-SYM .S> ATOM>
1834                           <MEMBER <FORM GVAL <ARGNUM-SYM .S>> .NNTSLTS>)
1835                          (<AND <TYPE? <ADDR-SYM .S> FIX>
1836                                <G=? <CODE-SYM .S> 6>
1837                                <L=? <CODE-SYM .S> 9>
1838                                <N=? <ACS <3 .FRMS>> '(STACK)>>
1839                           <REST .NNTSLTS <- <LENGTH .NNTSLTS> 1>>)
1840                          (ELSE '(0))>
1841                   !<2 .OFFS>)>)>>>>)>)
1842        (ELSE <MESSAGE INCONSISTENCY "BAD VARIABLE ADDRESS ">)>)>>
1843    <COND (<AND <NOT .LOSER>
1844                <NOT <SPEC-SYM .S>>
1845                <OR <ARG? .S> <INIT-SYM .S>>
1846                <SET T2 <ISTYPE-GOOD? <1 <DECL-SYM .S>>>>>
1847           <DATUM .T2 <DATVAL .TEM>>)
1848          (<AND <NOT .LOSER> .STYP <SET T2 <ISTYPE-GOOD? .STYP>>>
1849           <DATUM .T2 <DATVAL .TEM>>)
1850          (ELSE .TEM)>>
1851
1852 <DEFINE STFIXIT (OFF FRM "AUX" (NF 0) (NX ()))
1853         #DECL ((NF) FIX (NX) LIST (OFF) <LIST FIX LIST> (FRM) LIST)
1854         <MAPF <>
1855               <FUNCTION (IT)
1856                       <COND (<TYPE? .IT FIX> <SET NF <+ .NF .IT>>)
1857                             (ELSE <SET NX (.IT !.NX)>)>>
1858               .FRM>
1859         (<+ <1 .OFF> .NF> (!.NX !<2 .OFF>))>
1860
1861 " Generate obscure stuff."
1862
1863 <DEFINE DEFAULT-GEN (NOD WHERE)
1864         #DECL ((NOD) NODE)
1865         <MOVE:ARG <REFERENCE <NODE-NAME .NOD>> .WHERE>>
1866
1867 " Do GVAL using direct locative reference."
1868
1869 <DEFINE GVAL-GEN (N W
1870                   "AUX" (GD <GLOC? <NODE-NAME <1 <KIDS .N>>>>)
1871                         (RT <ISTYPE-GOOD? <RESULT-TYPE .N>>))
1872         #DECL ((N) NODE)
1873         <SET GD <OFFPTR 0 .GD VECTOR>>
1874         <MOVE:ARG <DATUM <COND (.RT) (ELSE .GD)> .GD> .W>>
1875
1876 " Do SETG using direct locative reference."
1877
1878 <DEFINE SETG-GEN (N W
1879                   "AUX" GD DD (NN <2 <KIDS .N>>) (FA <FREE-ACS T>)
1880                         (RT <ISTYPE-GOOD? <RESULT-TYPE .N>>)
1881                         (D
1882                          <GEN
1883                           .NN
1884                           <COND (<==? .W FLUSHED> DONT-CARE)
1885                                 (<G=? .FA 3>
1886                                  <SET DD <GOODACS .N .W>>
1887                                  <COND (<NOT <TYPE? <DATTYP .DD> AC>>
1888                                         <PUT .DD ,DATTYP ANY-AC>)>
1889                                  .DD)
1890                                 (<AND .RT <G=? .FA 2>> <GOODACS .N .W>)
1891                                 (ELSE DONT-CARE)>>))
1892         #DECL ((N NN) NODE (D) DATUM (FA) FIX)
1893         <SET GD <OFFPTR 0 <SET GD <GLOC? <NODE-NAME <1 <KIDS .N>>>>> VECTOR>>
1894         <MOVE:ARG .D <SET GD <DATUM .GD .GD>> T>
1895         <COND (<AND <OR <AND <TYPE? <DATTYP .D> ATOM>
1896                              <ISTYPE-GOOD? <DATTYP .D>>>
1897                         <TYPE? <DATTYP .D> AC>>
1898                     <TYPE? <DATVAL .D> AC>>
1899                <RET-TMP-AC .GD>
1900                <MOVE:ARG .D .W>)
1901               (ELSE <RET-TMP-AC .D> <MOVE:ARG .GD .W>)>>
1902
1903 <BLOCK (<ROOT>)>
1904
1905 RGLOC
1906
1907 <ENDBLOCK>
1908
1909 <DEFINE GLOC? (ATM "AUX" GL)
1910         #DECL ((GL) DATUM)
1911         <COND (.GLUE
1912                <SET GL
1913                     <MOVE:ARG <REFERENCE <RGLOC .ATM T>> <DATUM LOCR ANY-AC>>>
1914                <EMIT <INSTRUCTION `ADD
1915                                   <ACSYM <CHTYPE <DATVAL .GL> AC>>
1916                                   |GLOTOP
1917                                   1 >>
1918                <RET-TMP-AC <DATTYP .GL> .GL>
1919                <PUT .GL ,DATTYP VECTOR>
1920                .GL)
1921               (ELSE <REFERENCE <GLOC .ATM T>>)>>
1922
1923 <SETG USE-RGLOC T>
1924
1925 " Generate GVAL calls."
1926
1927 <DEFINE FGVAL-GEN (NOD WHERE)
1928         #DECL ((NOD) NODE)
1929         <RET-TMP-AC <GEN <1 <KIDS .NOD>> <DATUM ATOM ,AC-B>>>
1930         <REGSTO T>
1931         <FAST:GVAL>
1932         <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>
1933
1934 " Generate a SETG call."
1935
1936 <DEFINE FSETG-GEN (NOD WHERE "AUX" TT TEM)
1937         #DECL ((NOD) NODE (TT TEM) DATUM)
1938         <SET TT <GEN <1 <KIDS .NOD>> DONT-CARE>>
1939         <SET TEM <GEN <2 <KIDS .NOD>> <FUNCTION:VALUE>>>
1940         <SET TT <MOVE:ARG .TT <DATUM ATOM <3 ,ALLACS>>>>
1941         <PUT <3 ,ALLACS> ,ACPROT T>
1942         <MOVE:ARG .TEM <SET TEM <FUNCTION:VALUE>>>
1943         <PUT <3 ,ALLACS> ,ACPROT <>>
1944         <RET-TMP-AC .TT>
1945         <REGSTO T>
1946         <FAST:SETG>
1947         <MOVE:ARG .TEM .WHERE>>
1948
1949 <DEFINE CHTYPE-GEN (NOD WHERE
1950                     "AUX" (TYP <ISTYPE? <RESULT-TYPE .NOD>>) (N <1 <KIDS .NOD>>)
1951                           TEM
1952                           (ITYP
1953                            <COND (<ISTYPE? <RESULT-TYPE .N>>)
1954                                  (<MEMQ <NODE-TYPE .N> ,SNODES> DONT-CARE)
1955                                  (ELSE ANY-AC)>))
1956    #DECL ((NOD N) NODE (TEM) DATUM (WHERE) <OR ATOM DATUM>)
1957    <COND (<TYPE? .WHERE ATOM>
1958           <COND (<ISTYPE-GOOD? .TYP>
1959                  <SET TEM <GEN .N DONT-CARE>>
1960                  <DATTYP-FLUSH .TEM>
1961                  <PUT .TEM ,DATTYP .TYP>)
1962                 (ELSE
1963                  <SET TEM <GEN .N <DATUM ANY-AC ANY-AC>>>
1964                  <MUNG-AC <DATTYP .TEM> .TEM>
1965                  <EMIT <INSTRUCTION `HRLI
1966                                     <ACSYM <CHTYPE <DATTYP .TEM> AC>>
1967                                     <FORM TYPE-CODE!-OP!-PACKAGE .TYP>>>
1968                  <MOVE:ARG .TEM .WHERE>)>)
1969          (<ISTYPE-GOOD? .TYP>
1970           <COND (<AND <==? <LENGTH .WHERE> 2> <TYPE? <DATVAL .WHERE> AC>>
1971                  <DATTYP-FLUSH <SET TEM <GEN .N <DATUM .ITYP <DATVAL .WHERE>>>>>
1972                  <PUT .TEM ,DATTYP .TYP>
1973                  <MOVE:ARG .TEM .WHERE>)
1974                 (ELSE
1975                  <DATTYP-FLUSH <SET TEM <GEN .N <DATUM .ITYP ANY-AC>>>>
1976                  <PUT .TEM ,DATTYP .TYP>
1977                  <MOVE:ARG .TEM .WHERE>)>)
1978          (ELSE
1979           <SET TEM <GEN .N <DATUM ANY-AC ANY-AC>>>
1980           <MUNG-AC <DATTYP .TEM> .TEM>
1981           <EMIT <INSTRUCTION `HRLI
1982                              <ACSYM <CHTYPE <DATTYP .TEM> AC>>
1983                              <FORM TYPE-CODE!-OP!-PACKAGE .TYP>>>
1984           <MOVE:ARG .TEM .WHERE>)>>
1985
1986 " Generate do-nothing piece of code."
1987
1988 <DEFINE ID-GEN (N W) #DECL ((N) NODE) <GEN <1 <KIDS .N>> .W>>
1989
1990 <DEFINE UNWIND-GEN (N W
1991                     "AUX" (OSTK .STK) (STK (0 !.STK)) (UNBRANCH <MAKE:TAG>)
1992                           (NOUNWIND <MAKE:TAG>) W1)
1993         #DECL ((N) NODE (STK) <SPECIAL LIST> (OSTK) LIST (W1) DATUM)
1994         <SGETREG ,AC-C <>>
1995         <EMIT <INSTRUCTION `MOVEI  `C*  .UNBRANCH>>
1996         <EMIT <INSTRUCTION `SUBI  `C*  `(M) >>
1997         <EMIT <INSTRUCTION `PUSHJ  `P*  |IUNWIN >>
1998         <ADD:STACK 10>
1999         <RET-TMP-AC <SET W1 <GEN <1 <KIDS .N>> <GOODACS .N .W>>>>
2000         <VAR-STORE>
2001         <SGETREG ,AC-E <>>
2002         <EMIT '<`PUSHJ `P* |POPUNW>>
2003         <BRANCH:TAG .NOUNWIND>
2004         <LABEL:TAG .UNBRANCH>
2005         <GEN <2 <KIDS .N>> FLUSHED>
2006         <VAR-STORE>
2007         <EMIT '<`JRST  |UNWIN2 >>
2008         <LABEL:TAG .NOUNWIND>
2009         <AND <TYPE? <DATTYP .W1> AC> <SGETREG <DATTYP .W1> .W1>>
2010         <AND <TYPE? <DATVAL .W1> AC> <SGETREG <DATVAL .W1> .W1>>
2011         <POP:LOCS .STK .OSTK>
2012         <SET STK .OSTK>
2013         <MOVE:ARG .W1 .W>>
2014
2015 " Generate call to READ etc. with eof condition."
2016
2017 <DEFINE READ2-GEN (N W
2018                    "AUX" (OSTK .STK) (STK (0 !.STK)) (I 0) SPOB BRANCH
2019                          (PSJ <MEMQ <NODE-NAME .N> '![READCHR NEXTCHR!]>))
2020    #DECL ((N) NODE (STK) <SPECIAL LIST> (OSTK) LIST (I) FIX (SPOB) NODE)
2021    <MAPF <>
2022     <FUNCTION (OB)
2023        #DECL ((OB SPOB) NODE (I) FIX)
2024        <COND (.PSJ
2025               <COND (<==? <NODE-TYPE .OB> ,EOF-CODE> <SET SPOB .OB>)
2026                     (ELSE <RET-TMP-AC <GEN .OB <DATUM ,AC-A ,AC-B>>>)>)
2027              (ELSE
2028               <COND (<==? <NODE-TYPE .OB> ,EOF-CODE>
2029                      <SET SPOB .OB>
2030                      <ADD:STACK PSLOT>
2031                      <TIME:STACK>)
2032                     (ELSE <RET-TMP-AC <STACK:ARGUMENT <GEN .OB DONT-CARE>>>)>
2033               <ADD:STACK 2>
2034               <SET I <+ .I 1>>)>>
2035     <KIDS .N>>
2036    <REGSTO T>
2037    <COND (.PSJ
2038           <EMIT <INSTRUCTION `PUSHJ
2039                              `P*
2040                              <COND (<==? <NODE-NAME .N> READCHR> |CREADC )
2041                                    (ELSE |CNXTCH )>>>
2042           <EMIT '<`CAIA >>
2043           <BRANCH:TAG <SET BRANCH <MAKE:TAG>>>)
2044          (ELSE
2045           <SUBR:CALL <NODE-NAME .N> .I>
2046           <SET BRANCH <TIME:CHECK>>)>
2047    <SET STK .OSTK>
2048    <RET-TMP-AC <GEN .SPOB
2049                     <COND (<==? .W FLUSHED> .W) (ELSE <FUNCTION:VALUE>)>>>
2050    <VAR-STORE>
2051    <LABEL:TAG .BRANCH>
2052    <MOVE:ARG <FUNCTION:VALUE T> .W>>
2053
2054 <DEFINE GET-GEN (N W) <GETGET .N .W T>>
2055
2056 <DEFINE GET2-GEN (N W) <GETGET .N .W <>>>
2057
2058 <GDECL (GETTERS) UVECTOR>
2059
2060 <DEFINE GETGET (N W REV
2061                 "AUX" (K <KIDS .N>) PITEM PINDIC (BR <MAKE:TAG>)
2062                       (INDX <LENGTH <CHTYPE <MEMQ <NODE-SUBR .N> ,GETTERS> UVECTOR>>)
2063                       (LN <LENGTH .K>))
2064         #DECL ((N) NODE (K) <LIST NODE NODE [REST NODE]> (PITEM PINDIC) DATUM
2065                (INDX LN) FIX)
2066         <SET PITEM <GEN <1 .K> <DATUM ,AC-A ,AC-B>>>
2067         <SET PINDIC <GEN <2 .K> <DATUM ,AC-C ,AC-D>>>
2068         <SET PITEM <MOVE:ARG .PITEM <DATUM ,AC-A ,AC-B>>>
2069         <RET-TMP-AC <MOVE:ARG .PINDIC <DATUM ,AC-C ,AC-D>>>
2070         <RET-TMP-AC .PITEM>
2071         <REGSTO T>
2072         <EMIT <INSTRUCTION `PUSHJ
2073                            `P*
2074                            <NTH '![|CIGETP  |CIGTPR  |CIGETL  |CIGET !] .INDX>>>
2075         <COND (<==? .LN 2> <EMIT '<`JFCL >>)
2076               (ELSE
2077                <EMIT '<`SKIPA >>
2078                <BRANCH:TAG .BR>
2079                <COND (.REV
2080                       <RET-TMP-AC <STACK:ARGUMENT <GEN <3 .K> DONT-CARE>>>
2081                       <REGSTO T>
2082                       <SUBR:CALL EVAL 1>)
2083                      (ELSE <RET-TMP-AC <GEN <3 .K> <FUNCTION:VALUE>>>)>
2084                <VAR-STORE>
2085                <LABEL:TAG .BR>)>
2086         <MOVE:ARG <FUNCTION:VALUE T> .W>>
2087
2088
2089 <DEFINE REG? (TYP TRY
2090               "OPTIONAL" (GETIT <>)
2091               "AUX" (FUNNY <MEMQ <TYPEPRIM .TYP> '![STRING BYTES FRAME TUPLE LOCD!]>)
2092                     (TRY1 .TRY))
2093         #DECL ((TYP) ATOM)
2094         <COND (<AND <TYPE? .TRY1 DATUM>
2095                     <REPEAT ()
2096                             <AND <EMPTY? .TRY1> <RETURN <>>>
2097                             <AND <TYPE? <DATVAL .TRY1> AC> <RETURN T>>
2098                             <SET TRY1 <REST .TRY1 2>>>>
2099                <DATUM <COND (.FUNNY <DATTYP .TRY1>) (ELSE .TYP)>
2100                       <DATVAL .TRY1>>)
2101               (.FUNNY
2102                <COND (.GETIT <ANY2ACS>) (ELSE <DATUM ANY-AC ANY-AC>)>)
2103               (ELSE
2104                <DATUM .TYP <COND (.GETIT <GETREG <>>) (ELSE ANY-AC)>>)>>
2105
2106 <SETG GETTERS ![,GET ,GETL ,GETPROP ,GETPL!]>
2107
2108 <COND (<GASSIGNED? ARITH-GEN>
2109 <SETG GENERATORS
2110       <DISPATCH ,DEFAULT-GEN
2111                 (,FORM-CODE ,FORM-GEN)
2112                 (,PROG-CODE ,PROG-REP-GEN)
2113                 (,SUBR-CODE ,SUBR-GEN)
2114                 (,COND-CODE ,COND-GEN)
2115                 (,LVAL-CODE ,LVAL-GEN)
2116                 (,SET-CODE ,SET-GEN)
2117                 (,OR-CODE ,OR-GEN)
2118                 (,AND-CODE ,AND-GEN)
2119                 (,RETURN-CODE ,RETURN-GEN)
2120                 (,COPY-CODE ,COPY-GEN)
2121                 (,AGAIN-CODE ,AGAIN-GEN)
2122                 (,GO-CODE ,GO-GEN)
2123                 (,ARITH-CODE ,ARITH-GEN)
2124                 (,RSUBR-CODE ,RSUBR-GEN)
2125                 (,0-TST-CODE ,0-TEST)
2126                 (,NOT-CODE ,NOT-GEN)
2127                 (,1?-CODE ,1?-GEN)
2128                 (,TEST-CODE ,TEST-GEN)
2129                 (,EQ-CODE ,==-GEN)
2130                 (,TY?-CODE ,TYPE?-GEN)
2131                 (,LNTH-CODE ,LNTH-GEN)
2132                 (,MT-CODE ,MT-GEN)
2133                 (,REST-CODE ,REST-GEN)
2134                 (,NTH-CODE ,NTH-GEN)
2135                 (,PUT-CODE ,PUT-GEN)
2136                 (,PUTR-CODE ,PUTREST-GEN)
2137                 (,FLVAL-CODE ,FLVAL-GEN)
2138                 (,FSET-CODE ,FSET-GEN)
2139                 (,FGVAL-CODE ,FGVAL-GEN)
2140                 (,FSETG-CODE ,FSETG-GEN)
2141                 (,STACKFORM-CODE ,STACKFORM-GEN)
2142                 (,MIN-MAX-CODE ,MIN-MAX)
2143                 (,CHTYPE-CODE ,CHTYPE-GEN)
2144                 (,FIX-CODE ,FIX-GEN)
2145                 (,FLOAT-CODE ,FLOAT-GEN)
2146                 (,ABS-CODE ,ABS-GEN)
2147                 (,MOD-CODE ,MOD-GEN)
2148                 (,ID-CODE ,ID-GEN)
2149                 (,ASSIGNED?-CODE ,ASSIGNED?-GEN)
2150                 (,ISTRUC-CODE ,ISTRUC-GEN)
2151                 (,ISTRUC2-CODE ,ISTRUC-GEN)
2152                 (,BITS-CODE ,BITS-GEN)
2153                 (,GETBITS-CODE ,GETBITS-GEN)
2154                 (,BITL-CODE ,BITLOG-GEN)
2155                 (,PUTBITS-CODE ,PUTBITS-GEN)
2156                 (,ISUBR-CODE ,ISUBR-GEN)
2157                 (,EOF-CODE ,ID-GEN)
2158                 (,READ-EOF2-CODE ,READ2-GEN)
2159                 (,READ-EOF-CODE ,SUBR-GEN)
2160                 (,IPUT-CODE ,IPUT-GEN)
2161                 (,IREMAS-CODE ,IREMAS-GEN)
2162                 (,GET-CODE ,GET-GEN)
2163                 (,GET2-CODE ,GET2-GEN)
2164                 (,IRSUBR-CODE ,IRSUBR-GEN)
2165                 (,MAP-CODE ,MAPFR-GEN)
2166                 (,MARGS-CODE ,MPARGS-GEN)
2167                 (,MAPLEAVE-CODE ,MAPLEAVE-GEN)
2168                 (,MAPRET-STOP-CODE ,MAPRET-STOP-GEN)
2169                 (,UNWIND-CODE ,UNWIND-GEN)
2170                 (,GVAL-CODE ,GVAL-GEN)
2171                 (,SETG-CODE ,SETG-GEN)
2172                 (,TAG-CODE ,TAG-GEN)
2173                 (,PRINT-CODE ,PRINT-GEN)
2174                 (,MEMQ-CODE ,MEMQ-GEN)
2175                 (,LENGTH?-CODE ,LENGTH?-GEN)
2176                 (,FORM-F-CODE ,FORM-F-GEN)
2177                 (,INFO-CODE ,INFO-GEN)
2178                 (,OBLIST?-CODE ,OBLIST?-GEN)
2179                 (,AS-NXT-CODE ,AS-NXT-GEN)
2180                 (,AS-IT-IND-VAL-CODE ,ASSOC-FIELD-GET)
2181                 (,ALL-REST-CODE ,ALL-REST-GEN)
2182                 (,COPY-LIST-CODE ,LIST-BUILD)
2183                 (,PUT-SAME-CODE ,SPEC-PUT-GEN)
2184                 (,BACK-CODE ,BACK-GEN)
2185                 (,TOP-CODE ,TOP-GEN)
2186                 (,SUBSTRUC-CODE ,SUBSTRUC-GEN)
2187                 (,ROT-CODE ,ROT-GEN)
2188                 (,LSH-CODE ,LSH-GEN)
2189                 (,BIT-TEST-CODE ,BIT-TEST-GEN)>>
2190 \f)>
2191
2192 <ENDPACKAGE>