<mdl.comp>/mapgen.mud.71

   1 <PACKAGE "MAPGEN">
   2
   3 <ENTRY MAPFR-GEN MAPRET-STOP-GEN MAPLEAVE-GEN NOTIMP MBINDERS MPARGS-GEN
   4        MOPTG MOPTG2>
   5
   6 <USE "CODGEN" "CACS" "COMCOD" "COMPDEC" "CHKDCL" "CARGEN" "CUP" "NEWREP" "CARGEN">
   7
   8
   9 " Definitions of offsets into MAPINFO vector used by MAP hackers inferiors."
  10
  11 <SETG MAP-STRS 1>
  12
  13 <SETG MAP-SRC 2>
  14
  15 \\f
  16
  17 <SETG MAP-FR 3>
  18
  19 <SETG MAP-TAG 4>
  20
  21 <SETG MAP-STK 5>
  22
  23 <SETG MAP-STOF 6>
  24
  25 <SETG MAP-OFF 7>
  26
  27 <SETG MAP-TGL 8>
  28
  29 <SETG MAP-STSTR 9>
  30
  31 <SETG MAP-STKFX 10>
  32
  33 <SETG MAP-POFF 11>
  34
  35 <MANIFEST MAP-FR MAP-TAG MAP-STK MAP-STOF MAP-OFF MAP-TGL MAP-STSTR MAP-STKFX MAP-POFF
  36           MAP-SRC MAP-STRS>
  37 \\f
  38
  39 <DEFINE MAPFR-GEN (NOD WHERE "AUX" (K <KIDS .NOD>) (COD <NODE-TYPE <2 .K>>))
  40    #DECL ((NOD) NODE (COD) FIX (K) <LIST [REST NODE]>)
  41    <COND
  42     (<==? .COD ,MFCN-CODE> <REGSTO <> <>> <HMAPFR .NOD .WHERE .K>)
  43     (ELSE
  44      <REGSTO <>>
  45      <PROG ((FAP <1 .K>) MPINFO (INRAP <2 .K>) (W <GOODACS .NOD .WHERE>)
  46             (DTEM <DATUM FIX ANY-AC>) F? FF? (MAYBE-FALSE <>) (ANY? <>)
  47             (NARG <LENGTH <SET K <REST .K 2>>>) (RW .WHERE) (POFF 0)
  48             (R? <==? <NODE-SUBR .NOD> ,MAPR>) (OFFS 0) (STKOFFS <>)
  49             (MAPEND <ILIST .NARG '<MAKE:TAG "MAP">>) (MAPLP <MAKE:TAG "MAP">)
  50             (SUBRC <AP? .FAP>) (STB .STK) STOP (STK (0 !.STK)) TT)
  51        #DECL ((FAP INRAP) NODE (DTEM) DATUM (NARG POFF OFFS) FIX
  52               (STKOFFS) <OR FALSE LIST> (MAPLP) ATOM (MAPEND) <LIST [REST
  53                                                                      ATOM]>
  54               (STK) <SPECIAL LIST> (STOP STB) LIST
  55               (MPINFO) <SPECIAL <VECTOR <LIST [REST NODE]>
  56                                         DATUM
  57                                         <OR FALSE ATOM>
  58                                         <LIST [REST ATOM]>
  59                                         ANY
  60                                         <OR FALSE LIST>
  61                                         FIX
  62                                         LIST
  63                                         LIST
  64                                         <PRIMTYPE LIST>
  65                                         FIX>>)
  66        <SET WHERE
  67             <COND (<==? .WHERE FLUSHED> FLUSHED) (ELSE <GOODACS .NOD .WHERE>)>>
  68        <SET F? <DO-FIRST-SETUP .FAP .WHERE <> <> <> <>>>
  69        <OR .F? <SET FF? <==? <NODE-TYPE .FAP> ,MFIRST-CODE>>>
  70        <SET ANY? <PUSH-STRUCS .K T <> () <>>>
  71        <SET STOP .STK>
  72        <SET STK (0 !.STK)>
  73        <COND (.F? <SET MAYBE-FALSE <DO-FINAL-SETUP .FAP .SUBRC>>)>
  74        <REGSTO <>>
  75        <LABEL:TAG .MAPLP>
  76        <EMIT '<INTGO!-OP!-PACKAGE>>
  77        <COND (<N==? .COD ,MPSBR-CODE>
  78               <RET-TMP-AC <STACK:ARGUMENT <GEN .INRAP DONT-CARE>>>
  79               <ADD:STACK 2>)>
  80        <COND (.F? <SET STKOFFS <FIND-FIRST-STRUC .DTEM .STB <NOT .PRE>>>)>
  81        <SET OFFS <- 1 <* .NARG 2>>>
  82        <SET MPINFO
  83             [.K
  84              .DTEM
  85              .R?
  86              .MAPEND
  87              .F?
  88              .STKOFFS
  89              .OFFS
  90              ()
  91              .STK
  92              '(0)
  93              <SET POFF <COND (.MAYBE-FALSE -2) (.F? -1) (ELSE 0)>>]>
  94        <SET STK (0 !.STK)>
  95        <COND
  96         (<==? .COD ,MPSBR-CODE>
  97          <COND (.F?
  98                 <DO-STACK-ARGS .MAYBE-FALSE <GEN <1 <KIDS .INRAP>> DONT-CARE>>)
  99                (.FF?
 100                 <DO-FUNNY-HACK <GEN <1 <KIDS .INRAP>> DONT-CARE>
 101                                (<- .OFFS 1> ())
 102                                .NOD
 103                                .FAP
 104                                <1 <KIDS .INRAP>>>)
 105                (<N==? .WHERE FLUSHED>
 106                 <MOVE:ARG <GEN <1 <KIDS .INRAP>> .W>
 107                           <DATUM <SET TT <ADDRESS:C <+ -2 .OFFS> '`(TP) >>
 108                                  .TT>>)
 109                (ELSE <GEN <1 <KIDS .INRAP>> FLUSHED>)>)
 110         (ELSE
 111          <REPEAT ((I .NARG))
 112                  #DECL ((I) FIX)
 113                  <RET-TMP-AC <STACK:ARGUMENT <MPARGS-GEN .NOD DONT-CARE>>>
 114                  <AND <0? <SET I <- .I 1>>> <RETURN>>>
 115          <SUBR:CALL APPLY <+ .NARG 1>>
 116          <COND (.F? <DO-STACK-ARGS .MAYBE-FALSE <FUNCTION:VALUE>>)
 117                (.FF?
 118                 <DO-FUNNY-HACK <FUNCTION:VALUE>
 119                                (<- .OFFS 1> ())
 120                                .NOD
 121                                .FAP
 122                                .INRAP>)
 123                (<N==? .WHERE FLUSHED>
 124                 <MOVE:ARG <FUNCTION:VALUE>
 125                           <DATUM <SET TT <ADDRESS:C <+ -2 .OFFS> '`(TP) >>
 126                                  .TT>>)>)>
 127        <COND (<AND .F? <NOT .STKOFFS>> <RET-TMP-AC .DTEM>)>
 128        <COND (.ANY? <EMIT <INSTRUCTION `SETZM  .POFF '`(P) >>)>
 129        <BRANCH:TAG .MAPLP>
 130        <GEN-TAGS <MAP-TGL .MPINFO> <>>
 131        <MAPF <>
 132              <FUNCTION (N)
 133                      #DECL ((N) NODE)
 134                      <COND (<NOT <ISTYPE? <STRUCTYP <RESULT-TYPE .N>>>>
 135                             <EMIT '<`SETZM  |DSTORE >>
 136                             <MAPLEAVE>)>>
 137              .K>
 138        <COND (.F? <SET WHERE <DO-LAST .SUBRC .MAYBE-FALSE .WHERE>>)
 139              (.FF? <SET WHERE <DO-FUNNY-LAST .FAP <- .OFFS 2> .WHERE>>)
 140              (<N==? .WHERE FLUSHED>
 141               <SET WHERE
 142                    <MOVE:ARG <DATUM <SET TT <ADDRESS:C <+ -2 .OFFS> '`(TP) >>
 143                                     .TT>
 144                              .WHERE>>)>
 145        <POP:LOCS .STOP .STB>
 146        <SET STK .STB>
 147        <MOVE:ARG .WHERE .RW>>)>>
 148
 149 \\f
 150
 151 <DEFINE PUSH-STRUCS (K SM ACS BST NONO "AUX" (NL <>) S TEM TT NEW)
 152    #DECL ((K) <LIST [REST NODE]> (BST) <LIST [REST SYMTAB]> (S) SYMTAB)
 153    <MAPF <>
 154     <FUNCTION (N "AUX" (RT <RESULT-TYPE .N>))
 155        #DECL ((N) NODE)
 156        <COND (.ACS
 157               <SET TEM
 158                    <GEN .N
 159                         <COND (<SET TT <ISTYPE-GOOD? .RT>> <DATUM .TT ANY-AC>)
 160                               (ELSE <DATUM ANY-AC ANY-AC>)>>>
 161               <COND (.TT
 162                      <RET-TMP-AC <DATTYP .TEM> .TEM>
 163                      <PUT .TEM ,DATTYP .TT>)>
 164               <COND (<TYPE? .NONO DATUM>
 165                      <COND (<OR <==? <DATVAL .NONO> <DATTYP .TEM>>
 166                                 <==? <DATTYP .NONO> <DATTYP .TEM>>>
 167                             <SET NEW <DATUM <GETREG <>> <DATVAL .TEM>>>
 168                             <PUT <DATTYP .NEW> ,ACPROT T>)>
 169                      <COND (<OR <==? <DATVAL .NONO> <DATVAL .TEM>>
 170                                 <==? <DATTYP .NONO> <DATVAL .TEM>>>
 171                             <COND (<ASSIGNED? NEW>
 172                                    <PUT .NEW ,DATVAL <GETREG <>>>
 173                                    <PUT <DATTYP .NEW> ,ACPROT <>>)
 174                                   (ELSE
 175                                    <SET NEW
 176                                         <DATUM <DATTYP .TEM> <GETREG <>>>>)>)>
 177                      <SET TEM <MOVE:ARG .TEM .NEW>>)>
 178               <MUNG-AC <DATVAL .TEM>>
 179               <SET S <1 .BST>>
 180               <COND (<TYPE? <ADDR-SYM .S> TEMPV>
 181                      <SET TT <CREATE-TMP .TT>>
 182                      <PUT .S
 183                           ,ADDR-SYM
 184                           <CHTYPE (.BSTB
 185                                    .TT
 186                                    <COND (<=? .AC-HACK '(FUNNY-STACK)>
 187                                           <* <TOTARGS .FCN> -2>)
 188                                          (ELSE 0)>
 189                                    !.TMPS)
 190                                   TEMPV>>)>
 191               <PUT .S ,INACS .TEM>
 192               <PUT .S ,STORED <>>
 193               <COND (<TYPE? <SET TT <DATTYP .TEM>> AC>
 194                      <PUT .TT ,ACRESIDUE (.S !<ACRESIDUE .TT>)>)>
 195               <PUT <SET TT <DATVAL .TEM>> ,ACRESIDUE (.S !<ACRESIDUE .TT>)>
 196               <RET-TMP-AC .TEM>
 197               <SET BST <REST .BST>>)
 198              (ELSE
 199               <RET-TMP-AC <STACK:ARGUMENT <GEN .N DONT-CARE>>>
 200               <AND .SM <ADD:STACK 2>>)>
 201        <COND (<AND <SET RT <STRUCTYP .RT>>
 202                    <NOT .ACS>
 203                    <OR <==? .RT LIST> <==? .RT TEMPLATE>>>
 204               <SET NL T>)
 205              (<NOT .RT> <SET NL T>)>>
 206     .K>
 207    <COND (.NL <EMIT '<`PUSH  `P*  [-1]>> <AND .SM <ADD:STACK PSLOT>>)>
 208    .NL>
 209
 210 <DEFINE KEEP-IN-ACS (BST K R? "AUX" D S PTYP)
 211    #DECL ((BST) <LIST [REST SYMTAB]> (K) <LIST [REST NODE]>)
 212    <MAPF <>
 213     <FUNCTION (S N
 214                "AUX" (D <INACS .S>) (PTYP <STRUCTYP <RESULT-TYPE .N>>) A1 A)
 215             #DECL ((S) SYMTAB (D) <OR DATUM FALSE> (N) NODE (A) AC)
 216             <COND (<N==? <NAME-SYM .S> DUMMY-MAPF> <MAPLEAVE>)>
 217             <COND (<AND <NOT .D>
 218                         <OR .R? <AND <N==? .PTYP STRING> <N==? .PTYP BYTES>>>>
 219                    <SET D
 220                         <MOVE:ARG <LADDR .S <> <>>
 221                                   <DATUM <COND (<OR <==? .PTYP STRING>
 222                                                     <==? .PTYP BYTES>>
 223                                                 ANY-AC)
 224                                                (ELSE .PTYP)>
 225                                          ANY-AC>>>
 226                    <PUT .S ,INACS <DATUM <DATTYP .D> <DATVAL .D>>>
 227                    <PUT <SET A <DATVAL .D>> ,ACRESIDUE (.S !<ACRESIDUE .A>)>
 228                    <COND (<TYPE? <SET A1 <DATTYP .D>> AC>
 229                           <PUT .A1 ,ACRESIDUE (.S !<ACRESIDUE .A1>)>)>
 230                    <PUT .S ,STORED <>>
 231                    <RET-TMP-AC .D>)>>
 232     .BST
 233     .K>
 234    T>
 235
 236 <DEFINE REST-STRUCS (BST K LV NR TG R? "AUX" DAT PTYP (CNT 0) TEM ACFLG)
 237    #DECL ((BST) <LIST [REST SYMTAB]> (K) <LIST [REST NODE]> (CNT) FIX
 238           (LV) LIST)
 239    <REPEAT ((BST .BST))
 240      #DECL ((BST) <LIST [REST SYMTAB]>)
 241      <COND (<OR <EMPTY? .BST> <N==? <NAME-SYM <1 .BST>> DUMMY-MAPF>> <RETURN>)>
 242      <SET CNT <+ .CNT 1>>
 243      <SET PTYP <STRUCTYP <RESULT-TYPE <1 .K>>>>
 244      <COND (<SET TEM <MEMQ <1 .BST> .LV>> <SET DAT <2 .TEM>>)
 245            (ELSE <SET DAT <LADDR <1 .BST> <> <>>>)>
 246      <COND (<TYPE? <DATVAL .DAT> AC> <SET ACFLG T>) (ELSE <SET ACFLG <>>)>
 247      <COND
 248       (<==? .PTYP LIST>
 249        <COND (.ACFLG
 250               <EMIT <INSTRUCTION `HRRZ
 251                                  <ACSYM <DATVAL .DAT>>
 252                                  (<ADDRSYM <DATVAL .DAT>>)>>
 253               <COND (<1? .NR>
 254                      <EMIT <INSTRUCTION `JUMPN  <ACSYM <DATVAL .DAT>> .TG>>)>)
 255              (ELSE
 256               <EMIT <INSTRUCTION `HRRZ  `@  !<ADDR:VALUE .DAT>>>
 257               <EMIT <INSTRUCTION `MOVEM  !<ADDR:VALUE .DAT>>>
 258               <COND (<1? .NR> <EMIT <INSTRUCTION `JUMPN  .TG>>)>)>)
 259       (<OR <==? .PTYP VECTOR> <==? .PTYP TUPLE>>
 260        <COND (.ACFLG
 261               <EMIT <INSTRUCTION `ADD  <ACSYM <DATVAL .DAT>> '[<2 (2)>]>>
 262               <COND (<1? .NR>
 263                      <EMIT <INSTRUCTION `JUMPL  <ACSYM <DATVAL .DAT>> .TG>>)>)
 264              (ELSE
 265               <EMIT '<`MOVE  [<2 (2)>]>>
 266               <EMIT <INSTRUCTION `ADDB  !<ADDR:VALUE .DAT>>>
 267               <COND (<1? .NR> <EMIT <INSTRUCTION `JUMPL  .TG>>)>)>)
 268       (<OR <==? .PTYP UVECTOR> <==? .PTYP STORAGE>>
 269        <COND (.ACFLG
 270               <COND (<1? .NR>
 271                      <EMIT <INSTRUCTION `AOBJN  <ACSYM <DATVAL .DAT>> .TG>>)
 272                     (<EMIT <INSTRUCTION `ADD
 273                                         <ACSYM <DATVAL .DAT>>
 274                                         '[<1 (1)>]>>)>)
 275              (ELSE
 276               <EMIT '<`MOVE  [<1 (1)>]>>
 277               <EMIT <INSTRUCTION `ADDB  !<ADDR:VALUE .DAT>>>
 278               <COND (<1? .NR> <EMIT <INSTRUCTION `JUMPL  .TG>>)>)>)
 279       (<OR <==? .PTYP STRING> <==? .PTYP BYTES>>
 280        <COND (.R?
 281               <EMIT <INSTRUCTION `IBP  !<ADDR:VALUE .DAT>>>
 282               <EMIT <INSTRUCTION `SOS  !<ADDR:TYPE .DAT>>>)>
 283        <COND (<1? .NR>
 284               <COND (<TYPE? <DATTYP .DAT> AC>
 285                      <EMIT <INSTRUCTION `TRNE  <ACSYM <DATTYP .DAT>> -1>>
 286                      <BRANCH:TAG .TG>)
 287                     (ELSE
 288                      <EMIT <INSTRUCTION `HRRZ  `O*  !<ADDR:TYPE .DAT>>>
 289                      <EMIT <INSTRUCTION `JUMPN  `O*  .TG>>)>)>)>
 290      <SET BST <REST .BST>>
 291      <SET K <REST .K>>>
 292    <REPEAT ()
 293            <COND (<L? <SET CNT <- .CNT 1>> 0> <RETURN>)>
 294            <PUT <1 .BST> ,STORED T>
 295            <PUT <1 .BST> ,INACS <>>
 296            <SET BST <REST .BST>>>>
 297
 298 <DEFINE FIND-FIRST-STRUC (DTEM STB FL "AUX" DAC (STKOFFS <>))
 299         #DECL ((DTEM) DATUM (DAC) AC (STB) LIST)
 300         <COND (<AND .FL <SET STKOFFS <STACK:L .STB <2 .FRMS>>>>)
 301               (ELSE
 302                <MOVE:ARG <REFERENCE 524290> .DTEM>
 303                <PUT .DTEM ,DATTYP <ADDRESS:PAIR |$TTP >>
 304                <EMIT <INSTRUCTION `IMUL
 305                                   <ACSYM <SET DAC <DATVAL .DTEM>>>
 306                                   '`(P) >>
 307                <EMIT <INSTRUCTION `SUBM  `TP*  <ADDRSYM .DAC>>>)>
 308         .STKOFFS>
 309
 310 <DEFINE DO-FINAL-SETUP (FAP SUBRC "AUX" (MAYBE-FALSE <>))
 311         #DECL ((FAP) NODE)
 312         <COND (<NOT .SUBRC>
 313                <RET-TMP-AC <STACK:ARGUMENT <GEN .FAP DONT-CARE>>>)>
 314         <COND (<AND <NOT .SUBRC>
 315                     <OR <NOT .REASONABLE> <N==? <NODE-TYPE .FAP> ,GVAL-CODE>>
 316                     <SET MAYBE-FALSE <TYPE-OK? <RESULT-TYPE .FAP> FALSE>>>
 317                <EMIT '<`PUSH  `P*  [0]>>
 318                <ADD:STACK PSLOT>
 319                <PCOUNTER 1>
 320                <EMIT '<GETYP!-OP!-PACKAGE `O*  -1 `(TP) >>
 321                <EMIT '<`CAIN  `O*  <TYPE-CODE!-OP!-PACKAGE FALSE>>>
 322                <EMIT '<`SETOM  -1 `(P) >>)
 323               (ELSE <PCOUNTER <COND (.SUBRC 0) (ELSE 1)>>)>
 324         <ADD:STACK PSTACK>
 325         .MAYBE-FALSE>
 326
 327 <DEFINE DO-STACK-ARGS (MAYBE-FALSE DAT "AUX" TT (T1 <MAKE:TAG>) (T2
 328                                                                  <MAKE:TAG>))
 329    #DECL ((DAT) DATUM (T1 T2) ATOM)
 330    <COND
 331     (<N==? .DAT ,NO-DATUM>
 332      <COND (.MAYBE-FALSE
 333             <SET DAT <MOVE:ARG .DAT <DATUM ANY-AC ANY-AC>>>
 334             <EMIT '<`SKIPGE  -1 `(P) >>
 335             <BRANCH:TAG .T1>
 336             <STACK:ARGUMENT .DAT>
 337             <COUNTP>
 338             <BRANCH:TAG .T2>
 339             <LABEL:TAG .T1>
 340             <RET-TMP-AC <MOVE:ARG .DAT
 341                                   <DATUM <SET TT <ADDRESS:C -1 '`(TP) >> .TT>>>
 342             <LABEL:TAG .T2>)
 343            (<RET-TMP-AC <STACK:ARGUMENT .DAT>> <COUNTP>)>)>>
 344
 345 \\f
 346
 347 <DEFINE DO-FUNNY-LAST (N OFFS W "AUX" TT TYP)
 348         #DECL ((N) NODE (OFFS) FIX)
 349         <COND (<==? <NODE-SUBR .N> 5> <SET OFFS <- .OFFS 2>>)>
 350         <SET TYP <ISTYPE-GOOD? <RESULT-TYPE <PARENT .N>>>>
 351         <SET TT <ADDRESS:C .OFFS '`(TP) >>
 352         <MOVE:ARG <DATUM <COND (.TYP .TYP) (ELSE .TT)> .TT> .W>>
 353
 354 <SETG MINS
 355       '![![`CAMGE  `CAMLE  `IMULM  `ADDM !]
 356          ![`CAMGE  `CAMLE  `FMPRM  `FADRM !]!]>
 357
 358 <DEFINE DO-FUNNY-HACK (DAT OFFS N FAP NN
 359                        "AUX" (COD <NODE-SUBR .FAP>) (LMOD <RESULT-TYPE .NN>)
 360                              (MOD <RESULT-TYPE .N>) ACSY)
 361         #DECL ((OFFS) <LIST FIX LIST> (DAT) DATUM (COD) FIX (N FAP NN) NODE)
 362         <COND (<==? .COD 5>
 363                <RET-TMP-AC <MOVE:ARG .DAT <DATUM ,AC-C ,AC-D>>>
 364                <REGSTO T>
 365                <EMIT '<`MOVEI  `E*  0>>
 366                <EMIT '<`PUSHJ  `P*  |CICONS >>
 367                <EMIT <INSTRUCTION `SKIPE  <1 .OFFS> !<2 .OFFS> '`(TP) >>
 368                <EMIT <INSTRUCTION `HRRM
 369                                   `@
 370                                   `B*
 371                                   <1 .OFFS>
 372                                   !<2 .OFFS>
 373                                   '`(TP) >>
 374                <EMIT <INSTRUCTION `MOVEM  `B*  <1 .OFFS> !<2 .OFFS> '`(TP) >>
 375                <SET OFFS <STFIXIT .OFFS '(-2)>>
 376                <EMIT <INSTRUCTION `SKIPN  <1 .OFFS> !<2 .OFFS> '`(TP) >>
 377                <EMIT <INSTRUCTION `MOVEM  `B*  <1 .OFFS> !<2 .OFFS> '`(TP) >>)
 378               (ELSE
 379                <SET DAT <MOVE:ARG .DAT <DATUM .LMOD ANY-AC>>>
 380                <SET MOD <OR <AND <==? .MOD FIX> 1> 2>>
 381                <AND <==? .MOD 2> <==? .LMOD FIX> <SET DAT <GEN-FLOAT .DAT>>>
 382                <SET ACSY <ACSYM <DATVAL .DAT>>>
 383                <RET-TMP-AC .DAT>
 384                <EMIT <INSTRUCTION <NTH <NTH ,MINS .MOD> .COD>
 385                                   .ACSY
 386                                   <1 .OFFS>
 387                                   !<2 .OFFS>
 388                                   '`(TP) >>
 389                <COND (<L? .COD 3>
 390                       <EMIT <INSTRUCTION `MOVEM
 391                                          .ACSY
 392                                          <1 .OFFS>
 393                                          !<2 .OFFS>
 394                                          '`(TP) >>)>)>
 395         T>
 396
 397 <DEFINE DO-LAST (SUBRC MAYBE-FALSE WHERE "AUX" TG TG2)
 398         <REGSTO T>
 399         <COND (.MAYBE-FALSE
 400                <EMIT '<`POP  `P*  `A >>
 401                <EMIT '<`POP  `P*  0>>
 402                <EMIT <INSTRUCTION `JUMPL  `O  <SET TG <MAKE:TAG>>>>
 403                <COND (.SUBRC <GOOD-CALL .SUBRC>)
 404                      (ELSE <EMIT '<ACALL!-OP!-PACKAGE `A*  APPLY>>)>
 405                <BRANCH:TAG <SET TG2 <MAKE:TAG>>>
 406                <LABEL:TAG .TG>
 407                <EMIT '<`POP  `TP*  `B >>
 408                <EMIT '<`POP  `TP*  `A >>
 409                <LABEL:TAG .TG2>
 410                <SET WHERE <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>)
 411               (ELSE
 412                <EMIT '<`POP  `P*  `A >>
 413                <COND (.SUBRC <GOOD-CALL .SUBRC>)
 414                      (ELSE <EMIT '<ACALL!-OP!-PACKAGE `A*  APPLY>>)>
 415                <SET WHERE <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>)>>
 416
 417 <DEFINE GOOD-CALL (SBR "AUX" TP SB)
 418         #DECL ((TP) LIST)
 419         <COND (<AND <GASSIGNED? .SBR>
 420                     <TYPE? <SET SB ,.SBR> SUBR>
 421                     <SET TP <GET-TMPS .SB>>
 422                     <G=? <LENGTH .TP> 4>
 423                     <==? <4 .TP> STACK>>
 424                <EMIT <INSTRUCTION `PUSHJ  `P*  <6 .TP>>>)
 425               (ELSE <EMIT <INSTRUCTION ACALL!-OP!-PACKAGE `A*  .SBR>>)>>
 426
 427 <SETG SLOT-FIRST [<CHTYPE <MIN> FIX> <CHTYPE <MAX> FIX> 1 0]>
 428
 429 <SETG FSLOT-FIRST [<MIN> <MAX> 1.0 0.0000000]>
 430
 431 \\f
 432
 433 <DEFINE DO-FIRST-SETUP (FAP W ACS CHF ONES FLS
 434                         "AUX" (COD 0)
 435                               (TYP <ISTYPE? <RESULT-TYPE <PARENT .FAP>>>) DAT
 436                               TEM TT T1)
 437    #DECL ((FAP) NODE (COD) FIX)
 438    <COND
 439     (<==? <NODE-TYPE .FAP> ,MFIRST-CODE>
 440      <SET COD <NODE-SUBR .FAP>>
 441      <COND (<==? .COD 5>
 442             <STACK:ARGUMENT <REFERENCE <COND (.TYP <CHTYPE () .TYP>)
 443                                              (ELSE ())>>>
 444             <STACK:ARGUMENT <REFERENCE ()>>
 445             <ADD:STACK 4>
 446             <>)
 447            (<NOT .ACS>
 448             <STACK:ARGUMENT
 449              <REFERENCE <COND (<==? .TYP FLOAT> <NTH ,FSLOT-FIRST .COD>)
 450                               (ELSE <NTH ,SLOT-FIRST .COD>)>>>
 451             <ADD:STACK 2>
 452             <>)>)
 453     (<NODE-NAME .FAP> T)
 454     (<NOT .ACS>
 455      <RET-TMP-AC <STACK:ARGUMENT <REFERENCE <>>>>
 456      <ADD:STACK 2>
 457      <>)>>
 458
 459 \\f
 460
 461 <DEFINE DO-FIRST-SETUP-2 (FAP W ACS CHF ONES FLS
 462                           "AUX" (COD 0)
 463                                 (TYP <ISTYPE? <RESULT-TYPE <PARENT .FAP>>>) DAT
 464                                 TEM TT T1)
 465    #DECL ((FAP) NODE (COD) FIX (ACS) <OR FALSE SYMTAB>)
 466    <COND
 467     (<AND <NOT <NODE-NAME .FAP>> .FLS> <SET TEM <SET ACS <>>>)
 468     (<==? <NODE-TYPE .FAP> ,MFIRST-CODE>
 469      <SET COD <NODE-SUBR .FAP>>
 470      <COND (<==? .COD 5> <SET TEM #FALSE (1)>)
 471            (.ACS
 472             <SET T1
 473                  <MOVE:ARG <REFERENCE <COND (<==? .TYP FLOAT>
 474                                              <NTH ,FSLOT-FIRST .COD>)
 475                                             (ELSE <NTH ,SLOT-FIRST .COD>)>>
 476                            <GOODACS <PARENT .FAP> .W>>>
 477             <SET TEM <>>)
 478            (ELSE <SET TEM <>>)>)
 479     (<NODE-NAME .FAP> <SET TEM T>)
 480     (<AND .ACS <NOT .CHF>>
 481      <SET DAT <GOODACS <PARENT .FAP> .W>>
 482      <COND (<NOT .ONES>
 483             <COND (<==? <SET TEM <DATTYP .DAT>> ANY-AC>
 484                    <PUT .DAT ,DATTYP <GETREG .DAT>>)
 485                   (<TYPE? .TEM AC> <SGETREG .TEM .DAT>)>
 486             <COND (<==? <SET TEM <DATVAL .DAT>> ANY-AC>
 487                    <PUT .DAT ,DATVAL <GETREG .DAT>>)
 488                   (<TYPE? .TEM AC> <SGETREG .TEM .DAT>)>)>
 489      <SET T1 .DAT>
 490      <SET TEM <>>)
 491     (.ACS
 492      <SET T1 <MOVE:ARG <REFERENCE <>> <GOODACS <PARENT .FAP> .W>>>
 493      <SET TEM <>>)
 494     (ELSE <SET TEM <>>)>
 495    <COND (<AND .ACS <NOT .TEM> <EMPTY? .TEM>>
 496           <SET TT <CREATE-TMP .TYP>>
 497           <PUT .ACS
 498                ,ADDR-SYM
 499                <CHTYPE (.BSTB
 500                         .TT
 501                         <COND (<=? .AC-HACK '(FUNNY-STACK)>
 502                                <* <TOTARGS .FCN> -2>)
 503                               (ELSE 0)>
 504                         !.TMPS)
 505                        TEMPV>>
 506           <COND (<OR .CHF <NOT .ONES>>
 507                  <PUT .ACS ,INACS .T1>
 508                  <PUT .ACS ,STORED <>>
 509                  <PUT <SET TT <DATVAL .T1>>
 510                       ,ACRESIDUE
 511                       (.ACS !<ACRESIDUE .TT>)>
 512                  <COND (<AND <NOT .TYP> <TYPE? <DATTYP .T1> AC>>
 513                         <PUT <SET TT <DATTYP .T1>>
 514                              ,ACRESIDUE
 515                              (.ACS !<ACRESIDUE .TT>)>)>)>
 516           <RET-TMP-AC .T1>
 517           <>)
 518          (ELSE .TEM)>>
 519
 520 \\f
 521
 522 <DEFINE MPARGS-GEN (N W
 523                     "AUX" (MP .MPINFO) DAT TT ETAG
 524                           (STKD <STACK:L .STK <MAP-STSTR .MP>>)
 525                           (OFFS <FORM - <MAP-OFF .MP> !.STKD>))
 526         #DECL ((MP)
 527                <VECTOR <LIST [REST NODE]>
 528                        DATUM
 529                        <OR FALSE ATOM>
 530                        <LIST [REST ATOM]>
 531                        ANY
 532                        <OR LIST FALSE>
 533                        FIX
 534                        LIST
 535                        LIST
 536                        LIST>
 537                (STKD OFFS)
 538                <PRIMTYPE LIST>
 539                (DAT)
 540                DATUM
 541                (ETAG)
 542                ATOM)
 543         <COND (<NOT <MAP-STK .MP>>
 544                <SET DAT <DATUM <SET TT <ADDRESS:C .OFFS '`(TP) >> .TT>>
 545                <PUT .MP ,MAP-OFF <+ <MAP-OFF .MP> 2>>)
 546               (<NOT <MAP-STOF .MP>>
 547                <SET OFFS
 548                     <FORM + <MAP-OFF .MP> !<STACK:L .STK <MAP-STSTR .MP>>>>
 549                <SET DAT
 550                     <DATUM <SET TT <SPEC-OFFPTR 0 <MAP-SRC .MP> VECTOR (.OFFS)>>
 551                            .TT>>
 552                <PUT .MP ,MAP-OFF <+ <MAP-OFF .MP> 2>>)
 553               (ELSE
 554                <SET DAT
 555                     <DATUM <SET TT
 556                                 <ADDRESS:C !<MAP-STOF .MP>
 557                                            <COND (.AC-HACK `(FRM) ) (`(TB) )>
 558                                            <COND (.AC-HACK <+ <* <TOTARGS .FCN> -2> 1>)
 559                                                  (0)>>>
 560                            .TT>>)>
 561         <COND (<AND <MAP-STK .MP> <MAP-STOF .MP>>
 562                <PUT .MP ,MAP-STOF (2 !<MAP-STOF .MP>)>)>
 563         <SET W
 564              <MOVE:ARG <STACKM <1 <MAP-STRS .MP>>
 565                                .DAT
 566                                <MAP-FR .MP>
 567                                <SET ETAG <1 <MAP-TAG .MP>>>
 568                                <MAP-POFF .MP>>
 569                        .W>>
 570         <PUT .MP ,MAP-STRS <REST <MAP-STRS .MP>>>
 571         <AND <EMPTY? <MAP-STRS .MP>> <RET-TMP-AC <MAP-SRC .MP>>>
 572         <PUT .MP
 573              ,MAP-TGL
 574              ((.ETAG (<FORM - !<MAP-STKFX .MP>> !.STKD))
 575               !<MAP-TGL .MP>)>
 576         <PUT .MP ,MAP-STKFX .STKD>
 577         <PUT .MP ,MAP-TAG <REST <MAP-TAG .MP>>>
 578         .W>
 579
 580 \\f
 581
 582 <DEFINE STACKM (N SRC R? LBL POFF
 583                 "AUX" (STY <STRUCTYP <RESULT-TYPE .N>>) (COD 0) TT
 584                       (ETY <GET-ELE-TYPE <RESULT-TYPE .N> ALL>) SAC TEM)
 585    #DECL ((N) NODE (SRC TEM) DATUM (SAC) AC (COD POFF) FIX)
 586    <SET ETY <ISTYPE-GOOD? .ETY>>
 587    <COND
 588     (<OR <==? .STY TUPLE> <==? .STY VECTOR>>
 589      <SET SAC
 590           <DATVAL <SET TEM <MOVE:ARG .SRC <DATUM .STY ANY-AC> T>>>>
 591      <EMIT <INSTRUCTION `JUMPGE  <ACSYM .SAC> .LBL>>
 592      <EMIT <INSTRUCTION `MOVE  `O  '[<2 (2)>]>>
 593      <EMIT <INSTRUCTION `ADDM  `O  !<ADDR:VALUE .SRC>>>
 594      <COND (.R?
 595             <COND (<==? .STY TUPLE> <PUT .TEM ,DATTYP <DATTYP .SRC>>)
 596                   (ELSE .TEM)>)
 597            (ELSE
 598             <SET TT <OFFPTR 0 .TEM .STY>>
 599             <COND (.ETY <DATUM .ETY .TT>) (ELSE <DATUM .TT .TT>)>)>)
 600     (<==? .STY LIST>
 601      <SET SAC
 602           <DATVAL <SET TEM <MOVE:ARG .SRC <DATUM LIST ANY-AC> T>>>>
 603      <EMIT <INSTRUCTION `SKIPL  .POFF `(P) >>
 604      <EMIT <INSTRUCTION `HRRZ  <ACSYM .SAC> (<ADDRSYM .SAC>)>>
 605      <EMIT <INSTRUCTION `JUMPE  <ACSYM .SAC> .LBL>>
 606      <EMIT <INSTRUCTION `MOVEM  <ACSYM .SAC> !<ADDR:VALUE .SRC>>>
 607      <MUNG-AC .SAC .TEM>
 608      <COND (.R? .TEM)
 609            (ELSE
 610             <COND (<1? <SET COD <DEFERN <GET-ELE-TYPE <RESULT-TYPE .N> ALL>>>>
 611                    <EMIT <INSTRUCTION `MOVE  <ACSYM .SAC> 1 (<ADDRSYM .SAC>)>>)
 612                   (<NOT <0? .COD>>
 613                    <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O  (<ADDRSYM .SAC>)>>
 614                    <EMIT <INSTRUCTION `CAIN  `O  TDEFER!-OP!-PACKAGE>>
 615                    <EMIT <INSTRUCTION `MOVE  <ACSYM .SAC> 1 (<ADDRSYM .SAC>)>>)>
 616             <SET TT <OFFPTR 0 .TEM LIST>>
 617             <DATUM <COND (.ETY .ETY) (ELSE .TT)> .TT>)>)
 618     (<OR <==? .STY UVECTOR> <==? .STY STORAGE>>
 619      <SET SAC
 620           <DATVAL <SET TEM <MOVE:ARG .SRC <DATUM UVECTOR ANY-AC> T>>>>
 621      <EMIT <INSTRUCTION `JUMPGE  <ACSYM .SAC> .LBL>>
 622      <EMIT <INSTRUCTION `MOVE  `O  '[<1 (1)>]>>
 623      <EMIT <INSTRUCTION `ADDM  `O  !<ADDR:VALUE .SRC>>>
 624      <COND (.R? .TEM)
 625            (ELSE
 626             <SET TT <OFFPTR -1 .TEM UVECTOR>>
 627             <DATUM <COND (.ETY .ETY) (ELSE .TT)> .TT>)>)
 628     (<OR <==? .STY STRING> <==? .STY BYTES>>
 629      <EMIT <INSTRUCTION `HRRZ  `O  !<ADDR:TYPE .SRC>>>
 630      <EMIT <INSTRUCTION `SOJL  `O  .LBL>>
 631      <COND (.R?
 632             <SET TEM <MOVE:ARG .SRC <DATUM ANY-AC ANY-AC> T>>
 633             <EMIT <INSTRUCTION `HRRM  `O  !<ADDR:TYPE .SRC>>>
 634             <EMIT <INSTRUCTION `IBP  !<ADDR:VALUE .SRC>>>
 635             .TEM)
 636            (ELSE
 637             <EMIT <INSTRUCTION `HRRM  `O  !<ADDR:TYPE .SRC>>>
 638             <SET TEM <DATUM <COND (<==? .STY STRING> CHARACTER)
 639                                   (ELSE FIX)> ANY-AC>>
 640             <PUT .TEM ,DATVAL <GETREG .TEM>>
 641             <EMIT <INSTRUCTION `ILDB
 642                                <ACSYM <DATVAL .TEM>>
 643                                !<ADDR:VALUE .SRC>>>
 644             .TEM)>)
 645     (ELSE                       ;"Don't know type of structure, much more hair."
 646      <RET-TMP-AC <MOVE:ARG .SRC <FUNCTION:VALUE> T>>
 647      <REGSTO T>
 648      <SET TEM <FUNCTION:VALUE T>>
 649      <PUT ,AC-D ,ACPROT T>
 650      <EMIT '<`PUSHJ  `P*  |TYPSEG >>
 651      <EMIT <INSTRUCTION `SKIPL  .POFF '`(P) >>
 652      <EMIT '<`XCT  |INCR1  `(C) >>
 653      <EMIT '<`XCT  |TESTR  `(C) >>
 654      <BRANCH:TAG .LBL>
 655      <COND (.R?
 656             <EMIT '<`MOVE  `A*  |DSTORE>>
 657             <EMIT '<`MOVE  `B*  `D >>)
 658            (ELSE
 659             <EMIT '<`XCT  |TYPG  `(C) >>
 660             <EMIT '<`XCT  |VALG  `(C) >>
 661             <EMIT '<`JSP  `E*  |CHKAB >>)>
 662      <EMIT '<`MOVE  `O  |DSTORE>>
 663      <EMIT <INSTRUCTION `MOVEM  `O  !<ADDR:TYPE .SRC>>>
 664      <EMIT <INSTRUCTION `MOVEM  `D*  !<ADDR:VALUE .SRC>>>
 665      <EMIT '<`SETZM  |DSTORE>>
 666      <PUT ,AC-D ,ACPROT <>>
 667      .TEM)>>
 668
 669 <DEFINE ISET (TYP S1 S2 R? TG CHF NRG TG2
 670               "AUX" (PTYP <STRUCTYP .TYP>) D1 A1 A2 COD D2
 671                     (ETYP
 672                      <TYPE-AND <1 <DECL-SYM .S2>> <GET-ELE-TYPE .TYP ALL .R?>>)
 673                     TEM (TT <ISTYPE-GOOD? <1 <DECL-SYM .S2>>>) ET (BIND <>))
 674    #DECL ((S1 S2) SYMTAB (D1) <OR DATUM FALSE> (A1) AC (COD NR) FIX
 675           (FSYM) <OR FALSE SYMTAB>)
 676    <LVAL-UP .S1>
 677    <SET D1 <INACS .S1>>
 678    <COND (<AND <NOT .D1> <OR .R? <AND <N==? .PTYP STRING> <N==? .PTYP BYTES>>>>
 679           <SET D1
 680                <MOVE:ARG <LADDR .S1 <> <>>
 681                          <DATUM <COND (<OR <==? .PTYP STRING> <==? .PTYP BYTES>>
 682                                        ANY-AC)
 683                                       (ELSE .PTYP)>
 684                                 ANY-AC>>>
 685           <PUT .S1 ,INACS <DATUM <DATTYP .D1> <DATVAL .D1>>>
 686           <PUT <SET A1 <DATVAL .D1>> ,ACRESIDUE (.S1 !<ACRESIDUE .A1>)>
 687           <RET-TMP-AC .D1>)
 688          (<NOT .D1> <SET D1 <LADDR .S1 <> <>>>)
 689          (ELSE <SET A1 <DATVAL .D1>>)>
 690    <COND (<INACS .S1> <PUT .S1 ,STORED <>>)>
 691    <COND (<OR .CHF <NOT <1? .NRG>>>
 692           <RETURN-UP .INRAP .STK>
 693           <COND (<==? .PTYP LIST> <EMIT <INSTRUCTION `JUMPE  <ACSYM .A1> .TG>>)
 694                 (<OR <==? .PTYP VECTOR>
 695                      <==? .PTYP UVECTOR>
 696                      <==? .PTYP TUPLE>
 697                      <==? .PTYP STORAGE>>
 698                  <EMIT <INSTRUCTION `JUMPGE  <ACSYM .A1> .TG>>)
 699                 (<TYPE? <SET A2 <DATTYP .D1>> AC>
 700                  <EMIT <INSTRUCTION `TRNN  <ACSYM .A2> -1>>
 701                  <BRANCH:TAG .TG>)
 702                 (ELSE
 703                  <EMIT <INSTRUCTION `HRRZ  `O*  !<ADDR:TYPE .D1>>>
 704                  <EMIT <INSTRUCTION `JUMPE  `O*  .TG>>)>)>
 705    <COND (<1? .NRG>
 706           <LABEL:TAG .TG2>
 707           <OR .PRE
 708               <PROG ()
 709                     <SALLOC:SLOTS <TMPLS .INRAP>>
 710                     <ADD:STACK <TMPLS .INRAP>>
 711                     <SET NTSLOTS (<FORM GVAL <TMPLS .INRAP>> !.NTSLOTS)>
 712                     <SET GSTK .STK>
 713                     <SET STK (0 !.STK)>>>
 714           <AND .PRE <SET GSTK .STK> <SET STK (0 !.STK)>>)>
 715    <COND (<TYPE? <ADDR-SYM .S2> TEMPV>
 716           <SET TT <CREATE-TMP .TT>>
 717           <PUT .S2
 718                ,ADDR-SYM
 719                <CHTYPE (.BSTB
 720                         .TT
 721                         <COND (<=? .AC-HACK '(FUNNY-STACK)>
 722                                <* <TOTARGS .FCN> -2>)
 723                               (ELSE 0)>
 724                         !.TMPS)
 725                        TEMPV>>)
 726          (ELSE <SET BIND T>)>
 727    <COND
 728     (.R?
 729      <COND (.BIND <BINDUP .S2 <DATUM !.D1>>)
 730            (ELSE <PUT .S2 ,INACS <SET D2 <DATUM !.D1>>>)>)
 731     (ELSE
 732      <COND (<NOT .BIND>
 733             <COND (<TYPE? <DATTYP .D1> AC> <PUT <DATTYP .D1> ,ACPROT T>)>
 734             <COND (<TYPE? <DATVAL .D1> AC> <PUT <DATVAL .D1> ,ACPROT T>)>
 735             <COND (<SET ET <ISTYPE-GOOD? .ETYP>>
 736                    <PUT <SET D2 <DATUM .ET ANY-AC>> ,DATVAL <GETREG .D2>>)
 737                   (ELSE
 738                    <PUT <SET D2 <DATUM ANY-AC ANY-AC>>
 739                         ,DATTYP
 740                         <SET TEM <GETREG .D2>>>
 741                    <PUT .TEM ,ACPROT T>
 742                    <PUT .D2 ,DATVAL <GETREG .D2>>
 743                    <PUT .TEM ,ACPROT <>>)>
 744             <COND (<TYPE? <DATVAL .D1> AC> <PUT <DATVAL .D1> ,ACPROT <>>)>
 745             <COND (<TYPE? <DATTYP .D1> AC> <PUT <DATTYP .D1> ,ACPROT <>>)>
 746             <PUT .S2 ,INACS .D2>)
 747            (ELSE <SET ET <ISTYPE-GOOD? .ETYP>>)>
 748      <COND
 749       (<==? .PTYP LIST>
 750        <COND (.BIND
 751               <COND (<TYPE? <DATVAL .D1> AC> <PUT <DATVAL .D1> ,ACPROT T>)>
 752               <SET TEM <GETREG <>>>
 753               <COND (<TYPE? <DATVAL .D1> AC> <PUT <DATVAL .D1> ,ACPROT <>>)>)
 754              (ELSE <SET TEM <DATVAL .D2>>)>
 755        <COND (<NOT <0? <SET COD <DEFERN .ETYP>>>>
 756               <COND (<1? .COD>
 757                      <EMIT <INSTRUCTION `MOVE  <ACSYM .TEM> 1 (<ADDRSYM .A1>)>>)
 758                     (ELSE
 759                      <EMIT <INSTRUCTION `MOVE  <ACSYM .TEM> <ADDRSYM .A1>>>
 760                      <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE
 761                                         `O*
 762                                         (<ADDRSYM .A1>)>>
 763                      <EMIT '<`CAIN  `O*  TDEFER!-OP!-PACKAGE>>
 764                      <EMIT <INSTRUCTION `MOVE
 765                                         <ACSYM .TEM>
 766                                         1
 767                                         (<ADDRSYM .TEM>)>>)>
 768               <SET A1 .TEM>)>
 769        <COND (<NOT .BIND>
 770               <COND (<NOT .ET>
 771                      <EMIT <INSTRUCTION `MOVE
 772                                         <ACSYM <DATTYP .D2>>
 773                                         (<ADDRSYM .A1>)>>)>
 774               <EMIT <INSTRUCTION `MOVE
 775                                  <ACSYM <DATVAL .D2>>
 776                                  1
 777                                  (<ADDRSYM .A1>)>>)
 778              (ELSE
 779               <SET TEM <OFFPTR 0 <DATUM LIST .A1> LIST>>
 780               <BINDUP .S2 <DATUM .TEM .TEM>>)>)
 781       (<OR <==? .PTYP VECTOR> <==? .PTYP TUPLE>>
 782        <COND (.BIND
 783               <SET TEM <OFFPTR 0 .D1 VECTOR>>
 784               <BINDUP .S2 <DATUM .TEM .TEM>>)
 785              (ELSE
 786               <COND (<NOT .ET>
 787                      <EMIT <INSTRUCTION `MOVE
 788                                         <ACSYM <DATTYP .D2>>
 789                                         (<ADDRSYM .A1>)>>)>
 790               <EMIT <INSTRUCTION `MOVE
 791                                  <ACSYM <DATVAL .D2>>
 792                                  1
 793                                  (<ADDRSYM .A1>)>>)>)
 794       (<OR <==? .PTYP UVECTOR> <==? .PTYP STORAGE>>
 795        <COND (.BIND
 796               <SET TEM <OFFPTR -1 .D1 .PTYP>>
 797               <BINDUP .S2
 798                       <COND (.ET <DATUM .ET .TEM>) (ELSE <DATUM .TEM .TEM>)>>)
 799              (ELSE
 800               <COND (<NOT .ET>
 801                      <EMIT <INSTRUCTION `HLRE
 802                                         <ACSYM <DATTYP .D2>>
 803                                         <ADDRSYM .A1>>>
 804                      <EMIT <INSTRUCTION `SUBM
 805                                         <ACSYM .A1>
 806                                         <ADDRSYM <DATTYP .D2>>>>
 807                      <EMIT <INSTRUCTION `MOVE
 808                                         <ACSYM <DATTYP .D2>>
 809                                         (<ADDRSYM <DATTYP .D2>>)>>)>
 810               <EMIT <INSTRUCTION `MOVE
 811                                  <ACSYM <DATVAL .D2>>
 812                                  (<ADDRSYM .A1>)>>)>)
 813       (<OR <==? .PTYP STRING> <==? .PTYP BYTES>>
 814        <COND (.BIND
 815               <COND (<TYPE? <DATTYP .D1> AC> <PUT <DATTYP .D1> ,ACPROT T>)>
 816               <COND (<TYPE? <DATVAL .D1> AC> <PUT <DATVAL .D1> ,ACPROT T>)>
 817               <SET A1 <GETREG <>>>
 818               <EMIT <INSTRUCTION `ILDB  <ACSYM .A1> !<ADDR:VALUE .D1>>>
 819               <EMIT <INSTRUCTION `SOS  !<ADDR:TYPE .D1>>>
 820               <BINDUP .S2 <SET D2 <DATUM <COND (<==? .PTYP STRING> CHARACTER)
 821                                                (ELSE FIX)> .A1>>>
 822               <SET BIND <>>
 823               <PUT .S2 ,INACS .D2>
 824               <COND (<TYPE? <DATTYP .D1> AC> <PUT <DATTYP .D1> ,ACPROT <>>)>
 825               <COND (<TYPE? <DATVAL .D1> AC> <PUT <DATVAL .D1> ,ACPROT <>>)>)
 826              (ELSE
 827               <EMIT <INSTRUCTION `ILDB
 828                                  <ACSYM <DATVAL .D2>>
 829                                  !<ADDR:VALUE .D1>>>
 830               <EMIT <INSTRUCTION `SOS  !<ADDR:TYPE .D1>>>)>)>)>
 831    <COND (<NOT .BIND>
 832           <COND (<TYPE? <DATTYP .D2> AC>
 833                  <PUT <SET A1 <DATTYP .D2>>
 834                       ,ACRESIDUE
 835                       (.S2 !<ACRESIDUE .A1>)>)>
 836           <COND (<TYPE? <DATVAL .D2> AC>
 837                  <PUT <SET A1 <DATVAL .D2>>
 838                       ,ACRESIDUE
 839                       (.S2 !<ACRESIDUE .A1>)>)>
 840           <PUT .S2 ,STORED <>>
 841           <RET-TMP-AC .D2>)>>
 842
 843 <DEFINE IISET (TYP SYM DAT R?
 844                "AUX" (TT <ISTYPE-GOOD? <1 <DECL-SYM .SYM>>>)
 845                      (ETYP
 846                       <TYPE-AND <1 <DECL-SYM .SYM>>
 847                                 <GET-ELE-TYPE .TYP ALL .R?>>) AC)
 848         #DECL ((SYM) SYMTAB (DAT) DATUM)
 849         <COND (<TYPE? <ADDR-SYM .SYM> TEMPV>
 850                <SET TT <CREATE-TMP .TT>>
 851                <PUT .SYM
 852                     ,ADDR-SYM
 853                     <CHTYPE (.BSTB
 854                              .TT
 855                              <COND (<=? .AC-HACK '(FUNNY-STACK)>
 856                                     <* <TOTARGS .FCN> -2>)
 857                                    (ELSE 0)>
 858                              !.TMPS)
 859                             TEMPV>>)>
 860         <PUT .SYM
 861              ,INACS
 862              <SET DAT
 863                   <MOVE:ARG .DAT
 864                             <DATUM <COND (<ISTYPE-GOOD? .ETYP>) (ELSE ANY-AC)>
 865                                    ANY-AC>>>>
 866         <COND (<TYPE? <SET AC <DATTYP .DAT>> AC>
 867                <PUT .AC ,ACRESIDUE (.SYM !<ACRESIDUE .AC>)>)>
 868         <PUT <SET AC <DATVAL .DAT>> ,ACRESIDUE (.SYM !<ACRESIDUE .AC>)>
 869         <PUT .SYM ,STORED <>>
 870         <RET-TMP-AC .DAT>>
 871
 872 <DEFINE DO-EVEN-FUNNIER-HACK (D1 S N FAP NN LV
 873                               "AUX" (COD <NODE-SUBR .FAP>)
 874                                     (LMOD <RESULT-TYPE .NN>)
 875                                     (MOD <RESULT-TYPE .N>) ACSY
 876                                     (D2 <LADDR .S <> <>>))
 877         #DECL ((D1 D2 D3) DATUM (N FAP NN) NODE (COD) FIX)
 878         <SET MOD <OR <AND <==? .MOD FIX> 1> 2>>
 879         <AND <==? .MOD 2> <==? .LMOD FIX> <SET D1 <GENFLOAT .D1>>>
 880         <SET ACSY <ACSYM <DATVAL .D1>>>
 881         <RET-TMP-AC .D1>
 882         <EMIT <INSTRUCTION <NTH <NTH ,MINS .MOD> .COD>
 883                            .ACSY
 884                            !<ADDR:VALUE .D2>>>
 885         <COND (<L? .COD 3>
 886                <COND (<TYPE? <DATVAL .D2> AC>
 887                       <EMIT <INSTRUCTION `MOVE
 888                                          <ACSYM <DATVAL .D2>>
 889                                          <ADDRSYM <DATVAL .D1>>>>)
 890                      (ELSE
 891                       <EMIT <INSTRUCTION `MOVEM  .ACSY !<ADDR:VALUE
 892                                                          .D2>>>)>)>>
 893
 894 \\f
 895
 896 <DEFINE HMAPFR (MNOD WHERE K
 897                 "AUX" XX (NTSLOTS .NTSLOTS)
 898                       (NTMPS
 899                        <COND (.PRE .TMPS) (<STACK:L .STK .BSTB>) (ELSE (0))>)
 900                       TEM (NSLOTS 0) (SPECD <>) STB (DTEM <DATUM FIX ANY-AC>)
 901                       (STKOFFS <>) (FAP <1 .K>) (INRAP <2 .K>) F? (POFF 0)
 902                       (ANY? <>) (NARG <LENGTH <SET K <REST .K 2>>>) START:TAG
 903                       (R? <==? <NODE-SUBR .MNOD> ,MAPR>) STRV (FF? <>)
 904                       (MAPEND <ILIST .NARG '<MAKE:TAG "MAP">>) (OSTK .STK)
 905                       (MAPLP <MAKE:TAG "MAP">) (MAPL2 <MAKE:TAG "MAP">) MAP:OFF
 906                       (SUBRC <AP? .FAP>) STOP (STK (0 !.STK)) (TMPS .TMPS) BTP
 907                       (BASEF .BASEF) (FRMS .FRMS) (MAYBE-FALSE <>) (OPRE .PRE)
 908                       (OTAG ()) DEST CD (AC-HACK .AC-HACK)
 909                       (EXIT <MAKE:TAG "MAPEX">) (APPLTAG <MAKE:TAG "MAPAP">) TT
 910                       GMF (OUTD .WHERE) OUTSAV CHF (FLS <==? .WHERE FLUSHED>)
 911                       (RTAG <MAKE:TAG "MAP">) (NEED-INT T) FSYM OS NS (DOIT T)
 912                       RV GSTK)
 913    #DECL ((NTSLOTS) <SPECIAL LIST> (DTEM) DATUM
 914           (SPECD) <SPECIAL <OR FALSE ATOM>> (TEM) <OR ATOM DATUM> (OFFS) FIX
 915           (TMPS) <SPECIAL LIST> (POFF NSLOTS NARG) <SPECIAL FIX> (FAP) NODE
 916           (BASEF MNOD INRAP) <SPECIAL NODE> (K) <LIST [REST NODE]>
 917           (MAPEND) <LIST [REST ATOM]> (MAP:OFF) ATOM
 918           (EXIT MAPLP RTAG APPLTAG) <SPECIAL ATOM> (OSTK) LIST
 919           (DEST CD) <SPECIAL <OR ATOM DATUM>> (FRMS) <SPECIAL LIST>
 920           (STOP STRV STB BTP STK GSTK) <SPECIAL LIST>
 921           (AC-HACK START:TAG) <SPECIAL ANY>
 922           (GMF MAYBE-FALSE ANY?) <SPECIAL ANY> (FSYM) SYMTAB)
 923    <PUT .INRAP ,SPECS-START <- <SPECS-START .INRAP> .TOT-SPEC>>
 924    <PROG ((PRE .PRE))
 925      #DECL ((PRE) <SPECIAL ANY>)
 926      <COND (<AND <NOT <EMPTY? .K>>
 927                  <MAPF <>
 928                        <FUNCTION (Z)
 929                                <AND <TYPE-OK? <RESULT-TYPE .Z>
 930                                               '<PRIMTYPE LIST>>
 931                                     <MAPLEAVE <>>>
 932                                T>
 933                        .K>>
 934             <SET NEED-INT <>>)>
 935      <COND (<AND <NOT <AND <EMPTY? .K> <NODE-NAME .FAP>>>
 936                  <OR <==? <NODE-NAME .FAP> <>>
 937                      <AND <==? <NODE-TYPE .FAP> ,MFIRST-CODE>
 938                           <N==? <NODE-SUBR .FAP> 5>>
 939                      .SUBRC>
 940                  <OR <EMPTY? .K>
 941                      <==? <NAME-SYM <1 <BINDING-STRUCTURE .INRAP>>>
 942                           DUMMY-MAPF>>>
 943             <SET GMF T>)
 944            (ELSE <SET GMF <>>)>
 945      <COND (<AND <NOT <EMPTY? .K>>
 946                  <L=? <MAPF ,MIN
 947                             <FUNCTION (N)
 948                                     #DECL ((N) NODE)
 949                                     <MINL <RESULT-TYPE .N>>>
 950                             .K>
 951                       0>>
 952             <SET CHF T>)
 953            (ELSE <SET CHF <>>)>
 954      <SET DEST <SET OUTD <COND (.FLS FLUSHED) (ELSE <GOODACS .MNOD .WHERE>)>>>
 955      <OR .PRE <EMIT-PRE <NOT <OR <ACTIVATED .INRAP> <0? <SSLOTS .BASEF>>>>>>
 956      <SET STOP .STK>
 957      <SET STK (0 !.STK)>
 958      <SET F?
 959       <DO-FIRST-SETUP
 960        .FAP
 961        .DEST
 962        <COND (.GMF
 963               <SET FSYM <1 <BINDING-STRUCTURE .INRAP>>>
 964               <PUT .INRAP ,BINDING-STRUCTURE <REST <BINDING-STRUCTURE .INRAP>>>
 965               .FSYM)>
 966        .CHF
 967        <1? .NARG>
 968        .FLS>>
 969      <AND .GMF <NOT .FLS> <INACS .FSYM> <SET OUTD <INACS .FSYM>>>
 970      <OR .F? <SET FF? <==? <NODE-TYPE .FAP> ,MFIRST-CODE>>>
 971      <COND (<AND .GMF .CHF <NOT .FLS>> <PREFER-DATUM .WHERE>)>
 972      <SET ANY? <PUSH-STRUCS .K T .GMF <BINDING-STRUCTURE .INRAP> .WHERE>>
 973      <COND (.GMF <KEEP-IN-ACS <BINDING-STRUCTURE .INRAP> .K .R?>)>
 974      <COND (<AND .GMF .CHF <NOT .FLS>> <UNPREFER>)>
 975      <DO-FIRST-SETUP-2 .FAP .DEST <COND (.GMF .FSYM)> .CHF <1? .NARG> .FLS>
 976      <BEGIN-FRAME <TMPLS .INRAP> <ACTIVATED .INRAP> <PRE-ALLOC .INRAP>>
 977      <SET TMPS <COND (.PRE .NTMPS) (ELSE <STACK:L .STK <2 .FRMS>>)>>
 978      <SET STK (0 !.STK)>
 979      <SET STB .STK>
 980      <SET STK (0 !.STK)>
 981      <COND (.F? <SET MAYBE-FALSE <DO-FINAL-SETUP .FAP .SUBRC>>)>
 982      <PROG-START-AC .INRAP>
 983      <LABEL:TAG .MAPLP>
 984      <COND (<AND .F? <NOT .GMF>>
 985             <SET STKOFFS
 986                  <FIND-FIRST-STRUC
 987                   .DTEM .STB <AND <NOT .PRE> <NOT <ACTIVATED .INRAP>>>>>)>
 988      <AND <ACTIVATED .INRAP> <ACT:INITIAL> <ADD:STACK 2>>
 989      <SET STK (0 !.STK)>
 990      <SET STRV .STK>
 991      <OR .PRE
 992          <AND .GMF <1? .NARG>>
 993          <PROG ()
 994                <SALLOC:SLOTS <TMPLS .INRAP>>
 995                <ADD:STACK <TMPLS .INRAP>>
 996                <COND (<NOT .PRE>
 997                       <SET NTSLOTS (<FORM GVAL <TMPLS .INRAP>> !.NTSLOTS)>)>
 998                <COND (.GMF <SET GSTK .STK> <SET STK (0 !.STK)>)>>>
 999      <AND .PRE .GMF <NOT <1? .NARG>> <SET GSTK .STK> <SET STK (0 !.STK)>>
1000      <SET POFF <COND (.MAYBE-FALSE -2) (.F? -1) (ELSE 0)>>
1001      <COND (<AND .GMF <OR .CHF <NOT <1? .NARG>>> <NOT .FLS>> <LVAL-UP .FSYM>)>
1002      <REPEAT ((KK .K) (BS <BINDING-STRUCTURE .INRAP>)
1003               (BST
1004                <COND
1005                 (<EMPTY? .BS> ())
1006                 (ELSE
1007                  <MAPR <>
1008                        <FUNCTION (S)
1009                                #DECL ((S) <LIST SYMTAB>)
1010                                <COND (<N==? <NAME-SYM <1 .S>> DUMMY-MAPF>
1011                                       <MAPLEAVE .S>)
1012                                      (ELSE ())>>
1013                        .BS>)>) (OFFSET (<- 1 <* .NARG 2>> ())) TEM
1014               (TOFF (0 ())) (GOFF '(0)))
1015        #DECL ((BST) <LIST [REST SYMTAB]> (TOFF OFFSET) <LIST FIX LIST>
1016               (KK) <LIST [REST NODE]>)
1017        <COND
1018         (<EMPTY? .KK>
1019          <AND .GMF <NOT <1? .NARG>> <NOT .FF?> <NOT .FLS> <RET-TMP-AC .OUTD>>
1020          <COND (<AND .F? <NOT .STKOFFS>> <RET-TMP-AC .DTEM>)>
1021          <MAPF <>
1022                <FUNCTION (SYM)
1023                        #DECL ((SYM) SYMTAB)
1024                        <APPLY <NTH ,MBINDERS <CODE-SYM .SYM>> .SYM>>
1025                .BST>
1026          <RETURN>)
1027         (ELSE
1028          <SET RV <TYPE? <ADDR-SYM <1 .BST>> TEMPV>>
1029          <COND (.GMF)
1030                (.F?
1031                 <COND (.STKOFFS
1032                        <SET TEM
1033                             <ADDRESS:C .STKOFFS
1034                                        <COND (.AC-HACK `(FRM) ) (`(TB) )>
1035                                        <COND (.AC-HACK 1) (ELSE 0)>>>
1036                        <OR .RV <SET STKOFFS <+ .STKOFFS 2>>>)
1037                       (ELSE
1038                        <SET TEM
1039                             <SPEC-OFFPTR <1 .OFFSET>
1040                                          .DTEM
1041                                          VECTOR
1042                                          (!<2 .OFFSET>
1043                                           !<STACK:L .STK .STRV>)>>
1044                        <SET OFFSET
1045                             <STFIXIT .OFFSET
1046                                      (2
1047                                       <- <1 .TOFF>>
1048                                       <FORM - 0 !<2 .TOFF>>)>>)>)
1049                (ELSE
1050                 <SET TEM
1051                      <ADDRESS:C <FORM - <1 .OFFSET> !<STACK:L .STK .STRV>>
1052                                 '`(TP)
1053                                 !<2 .OFFSET>>>
1054                 <SET OFFSET <STFIXIT .OFFSET (2)>>)>
1055          <IF <==? <CODE-SYM <1 .BST>> 4>
1056              <MESSAGE ERROR "NOT IMPLEMENTED MAPF/R TUPLES ">>
1057          <SET OTAG
1058               ((<1 .MAPEND>
1059                 <COND (.GMF (<FORM + !.GOFF>))
1060                       ((<FORM - 0 <1 .TOFF> !<2 .TOFF>>
1061                         <1 <SET TOFF <STFIXIT (0 ()) <STACK:L .STK .STRV>>>>
1062                         !<2 .TOFF>))>)
1063                !.OTAG)>
1064          <COND (.GMF
1065                 <ISET <RESULT-TYPE <1 .KK>>
1066                       <1 .BS>
1067                       <1 .BST>
1068                       .R?
1069                       <1 .MAPEND>
1070                       .CHF
1071                       .NARG
1072                       .MAPL2>
1073                 <SET BS <REST .BS>>
1074                 <SET GOFF <STACK:L .STK .GSTK>>)
1075                (.RV
1076                 <RETURN-UP .INRAP .STK>
1077                 <IISET <RESULT-TYPE <1 .KK>>
1078                        <1 .BST>
1079                        <STACKM <1 .KK> <DATUM .TEM .TEM> .R? <1 .MAPEND> .POFF>
1080                        .R?>)
1081                (ELSE
1082                 <BINDUP <1 .BST>
1083                         <STACKM <1 .KK>
1084                                 <DATUM .TEM .TEM>
1085                                 .R?
1086                                 <1 .MAPEND>
1087                                 .POFF>>)>
1088          <SET MAPEND <REST .MAPEND>>
1089          <SET KK <REST .KK>>
1090          <SET BST <REST .BST>>)>>
1091      <COND
1092       (<AND .GMF <OR .CHF <NOT <1? .NARG>>> <NOT .FLS> <NOT .FF?>>
1093        <PROG ((S .FSYM))
1094              <PUT .S ,STORED T>
1095              <COND (<INACS .S>
1096                     <COND (<TYPE? <DATTYP <INACS .S>> AC>
1097                            <FLUSH-RESIDUE <DATTYP <INACS .S>> .S>)>
1098                     <COND (<TYPE? <DATVAL <INACS .S>> AC>
1099                            <FLUSH-RESIDUE <DATVAL <INACS .S>> .S>)>
1100                     <PUT .S ,INACS <>>)>>)>
1101      <COND (<AND .GMF <NOT .CHF> <1? .NARG> <NOT .FLS>> <LVAL-UP .FSYM>)>
1102      <OR .PRE
1103          <0? <SET NSLOTS <SSLOTS .INRAP>>>
1104          <PROG ()
1105                <SALLOC:SLOTS .NSLOTS>
1106                <ADD:STACK .NSLOTS>
1107                <EMIT-PRE <SET PRE T>>>>
1108      <AND <ACTIVATED .INRAP> <ACT:FINAL>>
1109      <SET BTP .STK>
1110      <OR .OPRE <SET BASEF .INRAP>>
1111      <SET STK (0 !.STK)>
1112      <AND .NEED-INT <CALL-INTERRUPT>>
1113      <COND
1114       (<AND .R?
1115             <NOT .F?>
1116             <NOT .FF?>
1117             .FLS
1118             <1? .NARG>
1119             <BLT-HACK <KIDS .INRAP>
1120                       <BINDING-STRUCTURE .INRAP>
1121                       <MINL <RESULT-TYPE <1 .K>>>>>
1122        <SET DOIT <>>)
1123       (<OR .F? .FF?>
1124        <SET TEM <SEQ-GEN <KIDS .INRAP> <GOODACS .INRAP DONT-CARE> T>>)
1125       (<NOT .FLS>
1126        <SET TEM
1127         <SEQ-GEN
1128          <KIDS .INRAP>
1129          <COND (.GMF .OUTD)
1130                (ELSE
1131                 <DATUM <SET TT
1132                             <ADDRESS:C <FORM -
1133                                              -1
1134                                              <* 2 .NARG>
1135                                              !<STACK:L .STK .STRV>>
1136                                        '`(TP) >>
1137                        .TT>)>
1138          T>>
1139        <SET OUTD .TEM>)
1140       (ELSE <RET-TMP-AC <SET TEM <SEQ-GEN <KIDS .INRAP> FLUSHED T>>>)>
1141      <COND
1142       (<AND .DOIT <N==? .TEM ,NO-DATUM>>
1143        <COND (<ACTIVATED .INRAP> <PROG:END> <LABEL:OFF .MAP:OFF>)
1144              (<OR .OPRE .F?>
1145               <AND .SPECD
1146                    <OR .OPRE <SET TEM <MOVE:ARG .TEM <DATUM ,AC-A ,AC-B>>>>>
1147               <POP:LOCS .STK .STRV>
1148               <UNBIND:FUNNY <SPECS-START .INRAP> !.NTSLOTS>)
1149              (ELSE <UNBIND:LOCS .STK .STB>)>
1150        <COND
1151         (.F? <DO-STACK-ARGS .MAYBE-FALSE .TEM>)
1152         (<AND .GMF .FF?>
1153          <OR .PRE
1154              <PROG ()
1155                    <SET NTSLOTS <REST <SET NS .NTSLOTS>>>
1156                    <SET OS .STK>
1157                    <SET STK .STB>>>
1158          <DO-EVEN-FUNNIER-HACK .TEM
1159                                .FSYM
1160                                .MNOD
1161                                .FAP
1162                                .INRAP
1163                                <LOOP-VARS .INRAP>>)
1164         (<AND .GMF <NOT .FLS>>
1165          <OR .PRE
1166              <PROG ()
1167                    <SET NTSLOTS <REST <SET NS .NTSLOTS>>>
1168                    <SET STK .STB>>>
1169          <RET-TMP-AC .TEM>
1170          <PUT .FSYM ,INACS .TEM>
1171          <PUT .FSYM ,STORED <>>
1172          <COND (<TYPE? <DATTYP .TEM> AC>
1173                 <PUT <DATTYP .TEM>
1174                      ,ACRESIDUE
1175                      (.FSYM !<ACRESIDUE <DATTYP .TEM>>)>)>
1176          <PUT <DATVAL .TEM> ,ACRESIDUE (.FSYM !<ACRESIDUE <DATVAL .TEM>>)>
1177          <PUT .FSYM ,STORED <>>
1178          <COND
1179           (<NOT <MEMQ .FSYM <LOOP-VARS .INRAP>>>
1180            <REPEAT ((L <LOOP-VARS .INRAP>) LL)
1181                    #DECL ((L) LIST (LL) DATUM)
1182                    <COND (<EMPTY? .L> <RETURN>)>
1183                    <COND (<TYPE? <DATVAL <SET LL <LINACS-SLOT .L>>> AC>
1184                           <PUT <DATVAL .LL> ,ACPROT T>)>
1185                    <COND (<TYPE? <DATTYP .LL> AC>
1186                           <PUT <DATTYP .LL> ,ACPROT T>)>
1187                    <SET L <REST .L ,LOOPVARS-LENGTH>>>
1188            <PUT
1189             .INRAP
1190             ,LOOP-VARS
1191             (.FSYM
1192              <PROG (R R2 D)
1193                    <SET D
1194                         <DATUM
1195                          <COND (<ISTYPE-GOOD? <RESULT-TYPE .MNOD>>)
1196                                (<AND <TYPE? .WHERE DATUM>
1197                                      <TYPE? <SET R <DATTYP .WHERE>> AC>
1198                                      <NOT <ACPROT .R>>>
1199                                 <PUT <COND (<==? .R <DATVAL .TEM>> .R)
1200                                            (ELSE <SGETREG .R <>>)>
1201                                      ,ACPROT
1202                                      T>)
1203                                (ELSE <PUT <SET R <GETREG <>>> ,ACPROT T>)>
1204                          <COND (<AND <TYPE? .WHERE DATUM>
1205                                      <TYPE? <SET R2 <DATVAL .WHERE>> AC>
1206                                      <NOT <ACPROT .R2>>>
1207                                 <COND (<==? .R2 <DATVAL .TEM>> .R2)
1208                                       (ELSE <SGETREG .R2 <>>)>)
1209                                (ELSE <SET R2 <GETREG <>>>)>>>
1210                    <COND (<AND <ASSIGNED? R>>
1211                           <TYPE? .R AC>
1212                           <PUT .R ,ACPROT <>>)>
1213                    .D>
1214              !<LOOP-VARS .INRAP>)>
1215            <REPEAT ((L <LOOP-VARS .INRAP>) LL)
1216                    #DECL ((L) LIST (LL) DATUM)
1217                    <COND (<EMPTY? .L> <RETURN>)>
1218                    <COND (<TYPE? <DATVAL <SET LL <LINACS-SLOT .L>>> AC>
1219                           <PUT <DATVAL .LL> ,ACPROT <>>)>
1220                    <COND (<TYPE? <DATTYP .LL> AC>
1221                           <PUT <DATTYP .LL> ,ACPROT <>>)>
1222                    <SET L <REST .L ,LOOPVARS-LENGTH>>>)>)
1223         (.FF? <DO-FUNNY-HACK .TEM (<* .NARG -2> ()) .MNOD .FAP .INRAP>)>
1224        <COND (.ANY? <EMIT <INSTRUCTION `SETZM  .POFF '`(P) >>)>
1225        <OR .PRE
1226            <AND .GMF <NOT .FLS>>
1227            <AND .GMF .FF?>
1228            <PROG ()
1229                  <SET NTSLOTS <REST <SET NS .NTSLOTS>>>
1230                  <SET STK .STB>>>)>
1231      <COND
1232       (.DOIT
1233        <AGAIN-UP .INRAP <AND .GMF <1? .NARG>>>
1234        <LABEL:TAG .RTAG>
1235        <COND (.GMF
1236               <REST-STRUCS <BINDING-STRUCTURE .INRAP>
1237                            .K
1238                            <LOOP-VARS .INRAP>
1239                            .NARG
1240                            .MAPL2
1241                            .R?>)>
1242        <COND (<NOT <AND .GMF <1? .NARG>>> <BRANCH:TAG .MAPLP>)>
1243        <GEN-TAGS .OTAG .SPECD>
1244        <COND (<AND .GMF <NOT .PRE>> <SET STK .GSTK> <SET NTSLOTS .NS>)>
1245        <COND (<AND .GMF <NOT <1? .NARG>>>
1246               <COND (<OR .OPRE .F?>
1247                      <POP:LOCS .STK .STRV>
1248                      <UNBIND:FUNNY <SPECS-START .INRAP> !.NTSLOTS>)
1249                     (ELSE <UNBIND:LOCS .STK .STB>)>)>
1250        <MAPF <>
1251         <FUNCTION (N)
1252                 #DECL ((N) NODE)
1253                 <COND (<NOT <ISTYPE? <STRUCTYP <RESULT-TYPE .N>>>>
1254                        <EMIT '<`SETZM  |DSTORE >>
1255                        <MAPLEAVE>)>>
1256         .K>)
1257       (ELSE <GEN-TAGS .OTAG .SPECD>)>
1258      <CLEANUP-STATE .INRAP>
1259      <LABEL:TAG .APPLTAG>
1260      <COND
1261       (<TYPE? .DEST DATUM>
1262        <SET CD
1263             <COND (.F? <DO-LAST .SUBRC .MAYBE-FALSE <DATUM !.DEST>>)
1264                   (<AND .FF? .GMF>
1265                    <MOVE:ARG <LADDR .FSYM <> <>> <DATUM !.DEST>>)
1266                   (.FF? <DO-FUNNY-LAST .FAP <- -1 <* 2 .NARG>> <DATUM !.DEST>>)
1267                   (.GMF <MOVE:ARG .OUTD <DATUM !.DEST>>)
1268                   (ELSE
1269                    <MOVE:ARG
1270                     <DATUM <SET TT <ADDRESS:C <- -1 <* 2 .NARG>> '`(TP) >> .TT>
1271                     <DATUM !.DEST>>)>>
1272        <ACFIX .DEST .CD>
1273        <AND <ISTYPE? <DATTYP .DEST>>
1274             <TYPE? <DATTYP .CD> AC>
1275             <RET-TMP-AC <DATTYP .CD> .CD>>)
1276       (.F? <DO-LAST .SUBRC .MAYBE-FALSE <FUNCTION:VALUE>>)
1277       (<AND .FF? .GMF> <MOVE:ARG .OUTD <FUNCTION:VALUE>>)
1278       (<AND .GMF .FF?> <MOVE:ARG .OUTD <FUNCTION:VALUE>>)
1279       (.FF? <DO-FUNNY-LAST .FAP <- -1 <* 2 .NARG>> <FUNCTION:VALUE>>)>
1280      <POP:LOCS .STB .STOP>
1281      <LABEL:TAG .EXIT>>
1282    <COND (<ASSIGNED? CD>
1283           <AND <TYPE? <DATTYP .DEST> AC> <FIX-ACLINK <DATTYP .DEST> .DEST .CD>>
1284           <AND <TYPE? <DATVAL .DEST> AC>
1285                <FIX-ACLINK <DATVAL .DEST> .DEST .CD>>)>
1286    <SET STK .OSTK>
1287    <SET XX <MOVE:ARG .DEST .WHERE>>
1288    <END-FRAME>
1289    .XX>
1290
1291 <DEFINE BLT-HACK (K B LN "AUX" N N1 AC EA D1 D2 TY TT (TG <MAKE:TAG>))
1292         <COND (<AND <==? <LENGTH .K> 1>
1293                     <==? <NODE-TYPE <SET N <1 .K>>> ,PUT-CODE>
1294                     <==? <LENGTH <SET K <KIDS .N>>> 3>
1295                     <==? <NODE-TYPE <SET N1 <2 .K>>> ,QUOTE-CODE>
1296                     <==? <NODE-NAME .N1> 1>
1297                     <==? <NODE-TYPE <SET N1 <1 .K>>> ,LVAL-CODE>
1298                     <MEMQ <NODE-NAME .N1> .B>
1299                     <OR <==? <SET TT <STRUCTYP <RESULT-TYPE .N>>> UVECTOR>
1300                         <==? .TT VECTOR>>
1301                     <SET TY
1302                          <COND (<==? .TT VECTOR>
1303                                 <SET TT T>
1304                                 <OR <ISTYPE? <RESULT-TYPE <3 .K>>> ANY>)
1305                                (ELSE
1306                                 <SET TT <>>
1307                                 <ISTYPE? <RESULT-TYPE <3 .K>>>)>>
1308                     <OR <==? <NODE-TYPE <3 .K>> ,QUOTE-CODE>
1309                         <==? <NODE-TYPE <3 .K>> ,GVAL-CODE>
1310                         <AND <G=? <LENGTH <3 .K>> <INDEX ,SIDE-EFFECTS>>
1311                              <NOT <SIDE-EFFECTS <3 .K>>>
1312                              <NO-INTERFERE <3 .K> .B>>>>
1313                <SET D1
1314                     <GEN .N1
1315                          <DATUM <COND (<ISTYPE? <RESULT-TYPE .N1>>)
1316                                       (ELSE ANY-AC)>
1317                                 ANY-AC>>>
1318                <SET D2 <GEN <3 .K> DONT-CARE>>
1319                <MOVE:ARG .D2
1320                          <DATUM <COND (<AND .TT
1321                                             <ISTYPE-GOOD?
1322                                                 <GET-ELE-TYPE
1323                                                   <RESULT-TYPE .N1> ALL>>>)
1324                                       (.TT <OFFPTR 0 .D1 VECTOR>)
1325                                       (ELSE .TY)>
1326                                 <OFFPTR <COND (.TT 0) (ELSE -1)>
1327                                         .D1
1328                                         <COND (.TT VECTOR) (ELSE UVECTOR)>>>>
1329                <RET-TMP-AC .D2>
1330                <DATTYP-FLUSH .D1>
1331                <PUT .D1 ,DATTYP <COND (.TT VECTOR) (ELSE UVECTOR)>>
1332                <TOACV .D1>
1333                <PUT <SET AC <DATVAL .D1>> ,ACPROT T>
1334                <MUNG-AC .AC .D1>
1335                <SET EA <GETREG <>>>
1336                <PUT .AC ,ACPROT <>>
1337                <EMIT <INSTRUCTION `HLRE  <ACSYM .EA> !<ADDR:VALUE .D1>>>
1338                <EMIT <INSTRUCTION `SUBM  <ACSYM .AC> <ADDRSYM .EA>>>
1339                <COND (<G? .LN 1>
1340                       <EMIT <INSTRUCTION `HRLI  <ACSYM .AC> (<ADDRSYM .AC>)>>
1341                       <EMIT <INSTRUCTION `ADDI
1342                                          <ACSYM .AC>
1343                                          <COND (.TT 2) (ELSE 1)>>>)
1344                      (.TT
1345                       <EMIT <INSTRUCTION `ADD  <ACSYM .AC> '[<2 (2)>]>>
1346                       <EMIT <INSTRUCTION `JUMPGE  <ACSYM .AC> .TG>>
1347                       <EMIT <INSTRUCTION `HRLI
1348                                          <ACSYM .AC>
1349                                          -2
1350                                          (<ADDRSYM .AC>)>>)
1351                      (ELSE
1352                       <EMIT <INSTRUCTION `AOBJP  <ACSYM .AC> .TG>>
1353                       <EMIT <INSTRUCTION `HRLI
1354                                          <ACSYM .AC>
1355                                          -1
1356                                          (<ADDRSYM .AC>)>>)>
1357                <EMIT <INSTRUCTION `BLT  <ACSYM .AC> -1 (<ADDRSYM .EA>)>>
1358                <LABEL:TAG .TG>
1359                <RET-TMP-AC .D1>
1360                T)>>
1361
1362 <DEFINE NO-INTERFERE (N B) #DECL ((N) NODE (B) <LIST [REST SYMTAB]>)
1363         <COND (<AND <==? <NODE-TYPE .N> ,LVAL-CODE>
1364                     <MEMQ <NODE-NAME .N> .B>>
1365                 <>)
1366               (<MEMQ <NODE-TYPE .N> ,SNODES> T)
1367               (<AND <==? <NODE-TYPE .N> ,COND-CODE>
1368                     <NOT <NO-INTERFERE <PREDIC .N> .B>>> <>)
1369               (ELSE
1370                <MAPF <>
1371                      <FUNCTION (N) #DECL ((N) NODE)
1372                         <COND (<NO-INTERFERE .N .B> T)
1373                               (ELSE <MAPLEAVE <>>)>> <KIDS .N>>)>>
1374
1375 \\f
1376
1377 <DEFINE GEN-TAGS (TGS SPECD)
1378    #DECL ((TGS) LIST (MNOD) NODE)
1379    <MAPR <>
1380     <FUNCTION (LL "AUX" (L <1 .LL>) (TG <1 .L>) (OFF <2 .L>))
1381        #DECL ((LL) <LIST LIST> (L) LIST (TG) ATOM (OFF) LIST)
1382        <LABEL:TAG .TG>
1383        <EMIT <INSTRUCTION DEALLOCATE .OFF>>
1384        <COND
1385         (<EMPTY? <REST .LL>>
1386          <COND
1387           (.SPECD
1388            <COND (.PRE <UNBIND:FUNNY <SPECS-START <2 <KIDS .MNOD>>> !.NTSLOTS>)
1389                  (ELSE <EMIT '<`PUSHJ  `P*  |SSPECS >>)>)>)>>
1390     .TGS>>
1391
1392 <DEFINE MOPTG (SYM) #DECL ((SYM) SYMTAB) <BINDUP .SYM <INIT-SYM .SYM>>>
1393
1394 <DEFINE MOPTG2 (SYM) #DECL ((SYM) SYMTAB) <BINDUP .SYM <REFERENCE:UNBOUND>>>
1395
1396 <DEFINE NOTIMP (ARG) <MESSAGE ERROR "NOT IMPLEMENTED MAPF/R TUPLES">>
1397
1398 <DEFINE MAPLEAVE-GEN (N W)
1399         #DECL ((N) NODE (CD) DATUM (DEST) <OR DATUM ATOM>)
1400         <COND (<ACTIVATED <2 <KIDS .MNOD>>>
1401                <RET-TMP-AC <GEN <1 <KIDS .N>> .DEST>>
1402                <VAR-STORE>
1403                <PROG:END>)
1404               (ELSE
1405                <COND (<==? .DEST FLUSHED>
1406                       <RET-TMP-AC <GEN <1 <KIDS .N>> FLUSHED>>
1407                       <MAP:UNBIND .STOP .STOP>
1408                       <RETURN-UP .INRAP>)
1409                      (ELSE
1410                       <SET CD <GEN <1 <KIDS .N>> <DATUM !.DEST>>>
1411                       <MAP:UNBIND .STOP .STOP>
1412                       <RETURN-UP .INRAP>
1413                       <RET-TMP-AC .CD>
1414                       <ACFIX .DEST .CD>)>
1415                <BRANCH:TAG .EXIT>)>
1416         ,NO-DATUM>
1417
1418 <DEFINE MAP:UNBIND (STOP STOP1)
1419         #DECL ((MNOD) NODE)
1420         <COND (.PRE
1421                <POP:LOCS .STK .STOP1>
1422                <UNBIND:FUNNY <SPECS-START <2 <KIDS .MNOD>>> !.NTSLOTS>)
1423               (ELSE <UNBIND:LOCS .STK .STOP1>)>>
1424
1425 \\f
1426
1427 <DEFINE MAPRET-STOP-GEN (N W
1428                          "AUX" (STA <STACKS .N>) (SG <SEGS .N>) (DWN '(0))
1429                                (K <KIDS .N>) (LN <LENGTH .K>) (UNK <>) TEM DAT
1430                                (FAP <1 <KIDS .MNOD>>) FTG
1431                                (FF? <==? <NODE-TYPE .FAP> ,MFIRST-CODE>)
1432                                (LEAVE <==? <NODE-SUBR .N> ,MAPSTOP>) (OS .STK)
1433                                (FUZZY <* -2 .NARG>) (STK (0 !.STK)) AC-SY
1434                                (OOS .STK) (NS .NTSLOTS))
1435    #DECL ((N) NODE (K) <LIST [REST NODE]> (LN FUZZY STA) FIX (DWN) LIST
1436           (DAT) DATUM (STK) <SPECIAL LIST> (OS) LIST)
1437    <COND
1438     (<AND <NOT .SG> <L? .LN 2>>
1439      <OR <0? .LN> <SET DAT <GEN <1 .K> <GOODACS <1 .K> DONT-CARE>>>>
1440      <MAP:UNBIND .STB .STRV>
1441      <COND
1442       (<NOT <0? .LN>>
1443        <COND (<AND .GMF .FF?>
1444               <SET NTSLOTS <REST .NTSLOTS>>
1445               <SET STK .STB>
1446               <DO-EVEN-FUNNIER-HACK
1447                .DAT
1448                <1 <BINDING-STRUCTURE .INRAP>>
1449                .MNOD
1450                .FAP
1451                .INRAP
1452                <LOOP-VARS .INRAP>>)
1453              (.FF? <DO-FUNNY-HACK .DAT (.FUZZY ()) .MNOD .FAP <1 .K>>)
1454              (ELSE <DO-STACK-ARGS .MAYBE-FALSE .DAT>)>)>)
1455     (.FF? <DO-FUNNY-MAPRET .N .FUZZY .K .FAP>)
1456     (ELSE
1457      <MAPF <>
1458       <FUNCTION (NOD "AUX" TG)
1459               #DECL ((NOD) NODE)
1460               <COND (<==? <NODE-TYPE .NOD> ,SEGMENT-CODE>
1461                      <RET-TMP-AC <GEN <1 <KIDS .NOD>> <FUNCTION:VALUE>>>
1462                      <REGSTO T>
1463                      <COND (.MAYBE-FALSE
1464                             <SET TG <MAKE:TAG>>
1465                             <EMIT '<`SKIPGE  -1 `(P) >>
1466                             <BRANCH:TAG .TG>)>
1467                      <SEGMENT:STACK </ .STA 2> .UNK>
1468                      <COND (<NOT .UNK>
1469                             <ADD:STACK <- .STA>>
1470                             <ADD:STACK PSTACK>
1471                             <SET UNK T>)>
1472                      <AND .MAYBE-FALSE <LABEL:TAG .TG>>)
1473                     (ELSE
1474                      <COND (.MAYBE-FALSE
1475                             <SET TG <MAKE:TAG>>
1476                             <EMIT '<`SKIPGE  -1 `(P) >>
1477                             <BRANCH:TAG .TG>)>
1478                      <RET-TMP-AC <STACK:ARGUMENT <GEN .NOD DONT-CARE>>>
1479                      <ADD:STACK 2>
1480                      <AND .MAYBE-FALSE <LABEL:TAG .TG>>)>>
1481       .K>
1482      <COND (<OR <ACTIVATED <2 <KIDS .MNOD>>>
1483                 <NOT <SET TEM <STACK:L .OS .STRV>>>>
1484             <MESSAGE ERROR " NOT IMLEMENTED HAIRY MAPRET/STOP " .N>)
1485            (ELSE
1486             <COND (.SPECD <UNBIND:FUNNY <SPECS-START <2 <KIDS .MNOD>>>>)>
1487             <COND (.MAYBE-FALSE
1488                    <SET FTG <MAKE:TAG>>
1489                    <EMIT '<`SKIPGE  -1 `(P) >>
1490                    <BRANCH:TAG .FTG>)>
1491             <SET AC-SY <GETREG <>>>
1492             <COND (.UNK <EMIT <INSTRUCTION `POP  `P*  <ADDRSYM .AC-SY>>>)
1493                   (ELSE <EMIT <INSTRUCTION `MOVEI  <ACSYM .AC-SY> </ .STA 2>>>)>
1494             <EMIT <INSTRUCTION `ADDM  <ACSYM .AC-SY> `(P) >>
1495             <COND (<NOT <=? <SET DWN .TEM> '(0)>>
1496                    <EMIT <INSTRUCTION `ASH  <ACSYM .AC-SY> 1>>
1497                    <EMIT <INSTRUCTION `HRLI  <ACSYM .AC-SY> (<ADDRSYM .AC-SY>)>>
1498                    <EMIT <INSTRUCTION `SUBM  `TP*  <ADDRSYM .AC-SY>>>
1499                    <EMIT <INSTRUCTION `HRLI
1500                                       <ACSYM .AC-SY>
1501                                       <FORM - !.DWN>
1502                                       '`(A) >>
1503                    <EMIT <INSTRUCTION `BLT
1504                                       <ACSYM .AC-SY>
1505                                       <FORM - !.DWN>
1506                                       '`(TP) >>
1507                    <EMIT <INSTRUCTION `SUB  `TP*  [<FORM !.DWN .DWN>]>>)>)>
1508      <AND .MAYBE-FALSE <LABEL:TAG .FTG>>)>
1509    <OR .PRE <AND .GMF .FF?> <PROG () <SET NTSLOTS <REST .NTSLOTS>> <SET STK .STB>>>
1510    <COND (.ANY? <EMIT <INSTRUCTION `SETZM  .POFF '`(P) >>)>
1511    <COND (.LEAVE <RETURN-UP .INRAP>) (<AGAIN-UP .INRAP>)>
1512    <SET STK .OOS>
1513    <SET NTSLOTS .NS>
1514    <BRANCH:TAG <COND (.LEAVE .APPLTAG) (.GMF .RTAG) (ELSE .MAPLP)>>
1515    ,NO-DATUM>
1516
1517 \\f
1518
1519 <DEFINE DO-FUNNY-MAPRET (N OFFS K FAP "AUX" (NOFFS (.OFFS ())))
1520    #DECL ((N FAP) NODE (K) <LIST [REST NODE]> (OFFS) FIX)
1521    <SET NOFFS
1522         <STFIXIT .NOFFS (<FORM - 0 !<STACK:L .STK .STB>>)>>
1523    <MAPF <>
1524     <FUNCTION (NN "AUX" TG1 TG2 TT DAT (ANY? <>))
1525             #DECL ((NN) NODE (TG1 TG2) ATOM (DAT) DATUM (TT) ADDRESS:C)
1526             <COND (<==? <NODE-TYPE .NN> ,SEG-CODE>
1527                    <SET ANY? <PUSH-STRUCS <KIDS .NN> <> <> () <>>>
1528                    <LABEL:TAG <SET TG1 <MAKE:TAG>>>
1529                    <SET DAT
1530                         <STACKM <1 <KIDS .NN>>
1531                                 <DATUM <SET TT <ADDRESS:C -1 '`(TP) >> .TT>
1532                                 <>
1533                                 <SET TG2 <MAKE:TAG>>
1534                                 0>>
1535                    <DO-FUNNY-HACK .DAT <STFIXIT .NOFFS '(-2)> .MNOD .FAP .N>
1536                    <AND .ANY? <EMIT '<`SETZM  `(P) >>>
1537                    <BRANCH:TAG .TG1>
1538                    <LABEL:TAG .TG2>
1539                    <AND .ANY? <EMIT '<`SUB  `P*  [<1 (1)>]>>>
1540                    <COND (<NOT <STRUCTYP <RESULT-TYPE <1 <KIDS .NN>>>>>
1541                           <EMIT '<`SETZM  |DSTORE>>)>
1542                    <EMIT '<`SUB  `TP*  [<(2) 2>]>>)
1543                   (ELSE
1544                    <SET DAT <GEN .NN DONT-CARE>>
1545                    <VAR-STORE>
1546                    <DO-FUNNY-HACK .DAT .NOFFS .MNOD .FAP .NN>)>>
1547     .K>
1548    <MAP:UNBIND .STB .STRV>>
1549
1550
1551 \f
1552 <DEFINE AP? (N "AUX" AT)
1553         #DECL ((N) NODE)
1554         <AND <==? <NODE-TYPE .N> ,GVAL-CODE>
1555              <==? <NODE-TYPE <SET N <1 <KIDS .N>>>> ,QUOTE-CODE>
1556              <SET AT <NODE-NAME .N>>
1557              <OR .REASONABLE
1558                  <AND <GASSIGNED? .AT> <TYPE? ,.AT SUBR RSUBR RSUBR-ENTRY>>
1559                  <AND <GASSIGNED? .AT>
1560                       <TYPE? ,.AT FUNCTION>
1561                       <OR <==? .AT .FCNS>
1562                           <AND <TYPE? .FCNS LIST> <MEMQ .AT .FCNS>>>>>
1563              .AT>>
1564
1565 <ENDPACKAGE>