<mdl.comp>/strgen.mud.33

   1 <PACKAGE "STRGEN">
   2
   3 <ENTRY NTH-GEN REST-GEN PUT-GEN LNTH-GEN MT-GEN PUTREST-GEN IPUT-GEN
   4         IREMAS-GEN FLUSH-COMMON-SYMT COMMUTE-STRUC DEFER-IT PUT-COMMON-DAT
   5         LIST-LNT-SPEC RCHK>
   6
   7 <USE "CODGEN" "CACS" "COMCOD" "CHKDCL" "COMPDEC" "SPCGEN" "COMTEM" "CARGEN">
   8
   9 <GDECL (PATTRNS)
  10        <UVECTOR [REST <LIST [REST <OR ATOM LIST>]>]>
  11        (RESTERS NTHERS PUTTERS)
  12        VECTOR
  13        (STYPES)
  14        <UVECTOR [REST ATOM]>>
  15
  16 <DEFINE PREG? (TYP TRY "AUX" (FTYP <ISTYPE? .TYP>))
  17         <COND (.FTYP <REG? .FTYP .TRY>) (ELSE <REG? TUPLE .TRY>
  18                                                 ;"Fool REG? into not losing.")>>
  19
  20
  21 <DEFINE LIST-LNT-SPEC (N W NF BR DI NUM
  22                        "AUX" (K <KIDS .N>) REG RAC (FLS <==? .W FLUSHED>)
  23                              (B2 <COND (<AND .BR .FLS> .BR) (ELSE <MAKE:TAG>)>)
  24                              (SDIR .DI) (B3 <>) B4 F1 F2 F3
  25                              (SBR <NODE-NAME .N>) TT)
  26         #DECL ((N) NODE (NUM) FIX (RAC) AC (K) <LIST [REST NODE]>)
  27         <SET REG
  28              <GEN <SET TT <1 <KIDS <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE> <2 .K>)
  29                                          (ELSE <1 .K>)>>>>
  30                   <COND (<SET TT <ISTYPE? <RESULT-TYPE .TT>>> <DATUM .TT ANY-AC>)
  31                         (ELSE DONT-CARE)>>>
  32         <SET RAC <DATVAL <SET REG <TOACV .REG>>>>
  33         <DATTYP-FLUSH .REG>
  34         <AND .NF <SET DI <NOT .DI>>>
  35         <SET DI <COND (<AND .BR <NOT .FLS>> <NOT .DI>) (ELSE .DI)>>
  36         <AND .DI <SET SBR <FLIP .SBR>>>
  37         <VAR-STORE <>>
  38         <SET F1 <MEMQ .SBR '![==? G? G=? 1? 0?!]>>
  39         <SET F2 <MEMQ .SBR '![G? G=?!]>>
  40         <SET F3 <MEMQ .SBR '![L? L=?!]>>
  41         <COND (<OR <==? .SBR L=?> <==? .SBR G?>> <SET NUM <- .NUM 1>>)>
  42         <COND (<L=? .NUM 2>
  43                <REPEAT ((FLG T) (RAC1 .RAC))
  44                        <EMIT <INSTRUCTION
  45                               <COND (<OR <NOT <0? .NUM>> <NOT .F1>> `JUMPE )
  46                                     (ELSE `JUMPN )>
  47                               <ACSYM .RAC>
  48                               <COND (<0? .NUM> .B2)
  49                                     (.F3 .B2)
  50                                     (<OR .F2 <NOT .F1>>
  51                                      <OR .B3 <SET B3 <MAKE:TAG>>>)
  52                                     (ELSE .B2)>>>
  53                        <COND (<L? <SET NUM <- .NUM 1>> 0>
  54                               <AND .B3 <LABEL:TAG .B3>>
  55                               <RETURN>)>
  56                        <COND (<AND .FLG <ACRESIDUE .RAC>
  57                                    <G? <CHTYPE <FREE-ACS T> FIX> 0>>
  58                               <SET RAC <GETREG <>>>)
  59                              (.FLG <MUNG-AC .RAC .REG>)
  60                              (ELSE <SET RAC1 .RAC>)>
  61                        <SET FLG <>>
  62                        <EMIT <INSTRUCTION `HRRZ
  63                                           <ACSYM .RAC>
  64                                           (<ADDRSYM .RAC1>)>>>)
  65               (ELSE
  66                <MUNG-AC .RAC .REG>
  67                <EMIT <INSTRUCTION `MOVEI
  68                                   `O
  69                                   <COND (<OR .F2 .F3> <+ .NUM 1>) (ELSE .NUM)>>>
  70                <LABEL:TAG <SET B4 <MAKE:TAG>>>
  71                <EMIT <INSTRUCTION `JUMPE
  72                                   <ACSYM .RAC>
  73                                   <COND (<AND <NOT .F3> <OR .F2 <NOT .F1>>>
  74                                          <OR .B3 <SET B3 <MAKE:TAG>>>)
  75                                         (ELSE .B2)>>>
  76                <EMIT <INSTRUCTION `HRRZ  <ACSYM .RAC> (<ADDRSYM .RAC>)>>
  77                <EMIT <INSTRUCTION `SOJG  `O  .B4>>
  78                <COND (<OR .F3 .F2> <AND .B3 <BRANCH:TAG .B2>>)
  79                      (ELSE
  80                       <EMIT <INSTRUCTION <COND (.F1 `JUMPN ) (ELSE `JUMPE )>
  81                                          <ACSYM .RAC>
  82                                          .B2>>)>
  83                <COND (.B3 <LABEL:TAG .B3>)>)>
  84         <PUT .RAC ,ACPROT <>>
  85         <RET-TMP-AC .REG>
  86         <COND (<NOT .BR> <TRUE-FALSE .N .B2 .W>)
  87               (<NOT .FLS>
  88                <SET W <MOVE:ARG <REFERENCE .SDIR> .W>>
  89                <BRANCH:TAG .BR>
  90                <LABEL:TAG .B2>
  91                .W)>>
  92
  93 <DEFINE LNTH-GEN (NOD WHERE
  94                   "AUX" (STRN <1 <KIDS .NOD>>) T1 T2 STR
  95                         (ITYP <RESULT-TYPE .STRN>) (TYP <STRUCTYP .ITYP>) RAC
  96                         REG (NEGOK <>) (*2OK <>) (HWOK <>) (SWOK <>) TR TRIN
  97                         TROUT (MUNG <>))
  98    #DECL ((STRN NOD) NODE (K) <LIST [REST NODE]> (STR REG) DATUM (RAC) AC
  99           (T1 T2) ATOM (TRIN TROUT) <UVECTOR [7 FIX]> (TRANSFORM) TRANS)
 100    <COND (<AND <ASSIGNED? TRANSFORM>
 101                <==? <PARENT .NOD> <1 <SET TR .TRANSFORM>>>>
 102           <SET TROUT <3 .TR>>
 103           <SET NEGOK <NOT <0? <1 <SET TRIN <2 .TR>>>>>>
 104           <SET *2OK
 105                <AND <OR <==? .TYP VECTOR> <==? .TYP TUPLE>>
 106                     <OR <1? <4 .TRIN>>
 107                         <AND <==? 2 <4 .TRIN>> <==? 2 <5 .TRIN>>>
 108                         <AND <NOT .NEGOK>
 109                              <==? 2 <4 .TRIN>>
 110                              <==? <5 .TRIN> -2>
 111                              <SET NEGOK T>>>>>
 112           <SET HWOK <==? 2 <6 .TRIN>>>
 113           <SET SWOK <NOT <0? <7 .TRIN>>>>)>
 114    <SET STR <GEN .STRN DONT-CARE>>
 115    <RET-TMP-AC <SET RAC <DATVAL <SET REG <REG? FIX .WHERE T>>>>
 116                .REG>
 117    <MUNG-AC .RAC .REG>
 118    <COND
 119     (<==? .TYP LIST>
 120      <MOVE:ARG .STR .REG>
 121      <RET-TMP-AC <DATTYP .REG> .REG>
 122      <PUT .REG ,DATTYP FIX>
 123      <EMIT '<`MOVSI 0 *400000*>>
 124      <LABEL:TAG <SET T1 <MAKE:TAG>>>
 125      <EMIT <INSTRUCTION `JUMPE <ACSYM .RAC> <SET T2 <MAKE:TAG>>>>
 126      <EMIT <INSTRUCTION `HRRZ  <ACSYM .RAC> (<ADDRSYM .RAC>)>>
 127      <EMIT <INSTRUCTION `AOBJN 0 .T1>>
 128      <LABEL:TAG .T2>
 129      <EMIT <INSTRUCTION `HRRZ <ACSYM .RAC> 0>>)
 130     (<==? <TYPEPRIM .TYP> TEMPLATE>
 131      <SGETREG .RAC .REG>
 132      <PUT .RAC ,ACPROT T>
 133      <GET:TEMPLATE:LENGTH <ISTYPE? .ITYP> .STR .RAC>
 134      <RET-TMP-AC .STR>)
 135     (<MEMQ .TYP '![UVECTOR VECTOR TUPLE STORAGE!]>
 136      <SGETREG .RAC .REG>
 137      <PUT .RAC ,ACPROT T>
 138      <COND (.SWOK <PUT .TROUT 7 1> <PUT .TROUT 6 1>)
 139            (.HWOK
 140             <PUT .TROUT 6 1>
 141             <SET MUNG T>
 142             <EMIT <INSTRUCTION `HLRZ  <ACSYM .RAC> !<ADDR:VALUE .STR>>>)
 143            (ELSE
 144             <EMIT <INSTRUCTION `HLRE  <ACSYM .RAC> !<ADDR:VALUE .STR>>>
 145             <SET MUNG T>)>
 146      <COND (.NEGOK <COND (<N==? <5 .TRIN> -2> <PUT .TROUT 1 1>)>)
 147            (ELSE
 148             <COND (.MUNG <EMIT <INSTRUCTION `MOVNS  <ADDRSYM .RAC>>>)
 149                   (ELSE
 150                    <EMIT <INSTRUCTION `MOVN
 151                                       <ACSYM .RAC>
 152                                       !<ADDR:VALUE .STR>>>)>
 153             <SET MUNG T>)>
 154      <OR <==? .TYP UVECTOR>
 155          <==? .TYP STORAGE>
 156          <COND (.*2OK
 157                 <PUT .TROUT 4 2>
 158                 <PUT .TROUT 5 <COND (<1? <4 .TRIN>> 2) (ELSE <5 .TRIN>)>>)
 159                (ELSE
 160                 <COND (<NOT .MUNG>
 161                        <EMIT <INSTRUCTION `MOVE
 162                                           <ACSYM .RAC>
 163                                           !<ADDR:VALUE .STR>>>)>
 164                 <EMIT <INSTRUCTION `ASH  <ACSYM .RAC> -1>>
 165                 <SET MUNG T>)>>
 166      <COND (<NOT .MUNG>
 167             <RET-TMP-AC .REG>
 168             <DATTYP-FLUSH .STR>
 169             <PUT .STR ,DATTYP FIX>
 170             <SET REG .STR>)
 171            (ELSE <RET-TMP-AC .STR>)>)
 172     (ELSE
 173      <SGETREG .RAC .REG>
 174      <PUT .RAC ,ACPROT T>
 175      <EMIT <INSTRUCTION `HRRZ  <ACSYM .RAC> !<ADDR:TYPE .STR>>>
 176      <RET-TMP-AC .STR>)>
 177    <PUT .RAC ,ACPROT <>>
 178    <MOVE:ARG .REG .WHERE>>
 179
 180
 181 <DEFINE MT-GEN (NOD WHERE
 182                 "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
 183                 "AUX" (STRN <1 <KIDS .NOD>>) RAC STR (ITYP <RESULT-TYPE .STRN>)
 184                       (SDIR .DIR) (TYP <STRUCTYP .ITYP>)
 185                       (FLS <==? .WHERE FLUSHED>)
 186                       (B2 <COND (<AND .BRANCH .FLS> .BRANCH) (ELSE <MAKE:TAG>)>)
 187                       (TEMP? <==? <TYPEPRIM .TYP> TEMPLATE>))
 188         #DECL ((STR) DATUM (STRN NOD) NODE (RAC) AC (B2) ATOM
 189                (BRANCH) <OR ATOM FALSE>)
 190         <COND (.TEMP?
 191                <SET STR <GEN .STRN DONT-CARE>>
 192                <TOACV .STR>
 193                <PUT <CHTYPE <DATVAL .STR> AC> ,ACPROT T>
 194                <GET:TEMPLATE:LENGTH <ISTYPE? .ITYP>
 195                                     .STR
 196                                     <SET RAC <GETREG <>>>>
 197                <PUT <CHTYPE <DATVAL .STR> AC> ,ACPROT <>>
 198                <RET-TMP-AC .STR>
 199                <SET STR <DATUM FIX .RAC>>
 200                <PUT .RAC ,ACLINK (.STR !<ACLINK .RAC>)>)
 201               (<AND <SET ITYP  <ISTYPE-GOOD? .ITYP>> <G? <CHTYPE <FREE-ACS T> FIX> 0>>
 202                <SET STR <GEN .STRN <DATUM .ITYP ANY-AC>>>)
 203               (ELSE <SET STR <GEN .STRN DONT-CARE>>)>
 204         <AND .NOTF <SET DIR <NOT .DIR>>>
 205         <SET DIR
 206              <COND (<AND .BRANCH <NOT .FLS>> <NOT .DIR>) (ELSE .DIR)>>
 207         <VAR-STORE <>>
 208         <COND (<AND <TYPE? <DATVAL .STR> AC> <N==? .TYP STRING> <N==? .TYP BYTES>>
 209                <SET RAC <DATVAL .STR>>
 210                <COND (<OR <==? .TYP LIST> .TEMP?>
 211                       <EMIT <INSTRUCTION <COND (.DIR `JUMPE ) (ELSE `JUMPN )>
 212                                          <ACSYM .RAC>
 213                                          .B2>>)
 214                      (ELSE
 215                       <EMIT <INSTRUCTION <COND (.DIR `JUMPGE ) (ELSE `JUMPL )>
 216                                          <ACSYM .RAC>
 217                                          .B2>>)>)
 218               (<AND <TYPE? <DATTYP .STR> AC> <OR <==? .TYP STRING> <==? .TYP BYTES>>>
 219                <SET RAC <DATTYP .STR>>
 220                <EMIT <INSTRUCTION <COND (.DIR `TRNN ) (ELSE `TRNE )>
 221                                   <ACSYM .RAC>
 222                                   -1>>
 223                <BRANCH:TAG .B2>)
 224               (ELSE
 225                <COND (<==? .TYP LIST>
 226                       <EMIT <INSTRUCTION <COND (.DIR `SKIPN ) (ELSE `SKIPE )>
 227                                          !<ADDR:VALUE .STR>>>
 228                       <BRANCH:TAG .B2>)
 229                      (<OR <==? .TYP STRING> <==? .TYP BYTES>>
 230                       <EMIT <INSTRUCTION `HRRZ  !<ADDR:TYPE .STR>>>
 231                       <EMIT <INSTRUCTION <COND (.DIR `JUMPE ) (ELSE `JUMPN )>
 232                                          .B2>>)
 233                      (ELSE
 234                       <EMIT <INSTRUCTION <COND (.DIR `SKIPL ) (ELSE `SKIPGE )>
 235                                          !<ADDR:VALUE .STR>>>
 236                       <BRANCH:TAG .B2>)>)>
 237         <RET-TMP-AC .STR>
 238         <COND (<NOT .BRANCH> <TRUE-FALSE .NOD .B2 .WHERE>)
 239               (<NOT .FLS>
 240                <SET WHERE <MOVE:ARG <REFERENCE .SDIR> .WHERE>>
 241                <BRANCH:TAG .BRANCH>
 242                <LABEL:TAG .B2>
 243                .WHERE)>>
 244
 245
 246 <DEFINE REST-GEN (NOD WHERE
 247                   "AUX" (K <KIDS .NOD>) (TYP <RESULT-TYPE <1 .K>>)
 248                         (TPS <STRUCTYP .TYP>) (2ARG <2 .K>) (1ARG <1 .K>)
 249                         (NRP <NTH-REST-PUT? .1ARG>)
 250                         (NUMKN <==? <NODE-TYPE .2ARG> ,QUOTE-CODE>)
 251                         (NUM <COND (.NUMKN <NODE-NAME .2ARG>) (ELSE 0)>)
 252                         (NR <GET-RANGE <RESULT-TYPE .2ARG>>) W TEM)
 253         #DECL ((NOD) NODE (K) <LIST NODE NODE> (TPS) ATOM (NUM) FIX)
 254         <COND (<SET TEM <FIND-COMMON .NOD>>
 255                <SET W <MOVE:ARG <GET-COMMON-DATUM .TEM> .WHERE>>)
 256               (<PROG ((COMMON-SUB <>))
 257                      #DECL ((COMMON-SUB) <SPECIAL <OR FALSE COMMON>>)
 258                      <SET W
 259                           <APPLY <NTH ,RESTERS
 260                                       <LENGTH <CHTYPE <MEMQ .TPS ,STYPES> UVECTOR>>>
 261                                  .NOD
 262                                  .WHERE
 263                                  .TYP
 264                                  .TPS
 265                                  .NUMKN
 266                                  .NUM
 267                                  <1 .K>
 268                                  .2ARG
 269                                  T
 270                                  <>
 271                                  .NR>>
 272                      <SET TEM .COMMON-SUB>>)>
 273         <HACK-COMMON REST
 274                      .1ARG
 275                      .TEM
 276                      .WHERE
 277                      .W
 278                      .NUMKN
 279                      .NUM
 280                      .TPS
 281                      .NRP>
 282         .W>
 283
 284 <DEFINE VEC-REST (NOD WHERE TYP TPS NUMKN NUM STRNOD NUMNOD R? RV NR
 285                   "AUX" (ML <MINL .TYP>) N SAC STR (MP <MPCNT .TPS>) NUMN
 286                         (ONO .NO-KILL) (NO-KILL .ONO) (LCAREFUL .CAREFUL)
 287                         (W2
 288                          <COND (.R? DONT-CARE)
 289                                (ELSE
 290                                 <REG? <COND (<SET TYP <ISTYPE? .TYP>>)
 291                                             (ELSE .TPS)>
 292                                       .WHERE>)>))
 293         #DECL ((NOD NUMNOD STRNOD) NODE (STR NUMN) DATUM (ML N MP NUM) FIX
 294                (SAC) AC (NUMNK R? RV) <OR ATOM FALSE>
 295                (NR) <OR FALSE <LIST FIX FIX>> (WHERE W2) <OR ATOM DATUM>
 296                (NO-KILL) <SPECIAL LIST>)
 297         <SET RV <COMMUTE-STRUC .RV .STRNOD .NUMNOD>>
 298         <COND (.NUMKN
 299                <COND (<L? .NUM 0>
 300                       <MESSAGE ERROR "ARG OUT OF RANGE " <NODE-NAME .NOD>>)
 301                      (<0? .NUM>
 302                       <SET STR <GEN .STRNOD .W2>>
 303                       <COND (<AND .LCAREFUL <NOT .R?> <0? .ML>>
 304                              <TOACV .STR>
 305                              <RCHK <DATVAL .STR> .R?>)>
 306                       <COND (<NOT <AND .TYP <NOT .R?>>>
 307                              <TOACV .STR>
 308                              <MUNG-AC <DATVAL .STR> .STR>)>)
 309                      (ELSE
 310                       <TOACV <SET STR <GEN .STRNOD .W2>>>
 311                       <MUNG-AC <SET SAC <DATVAL .STR>> .STR>
 312                       <EMIT <INSTRUCTION `ADD
 313                                          <ACSYM .SAC>
 314                                          [<FORM (<SET N <* .NUM .MP>>) .N>]>>
 315                       <AND .LCAREFUL
 316                            <COND (.R? <G? .NUM .ML>) (ELSE <G=? .NUM .ML>)>
 317                            <RCHK .SAC .R?>>)>)
 318               (ELSE
 319                <COND (.RV
 320                       <SET NUMN <GEN .NUMNOD <REG? FIX .WHERE>>>
 321                       <SET STR <GEN .STRNOD DONT-CARE>>)
 322                      (ELSE
 323                       <SET STR <GEN .STRNOD DONT-CARE>>
 324                       <SET NUMN <GEN .NUMNOD <REG? FIX .WHERE>>>)>
 325                <DELAY-KILL .NO-KILL .ONO>
 326                <TOACV .NUMN>
 327                <PUT <SET SAC <DATVAL .NUMN>> ,ACPROT T>
 328                <MUNG-AC .SAC .NUMN>
 329                <PUT .SAC ,ACPROT T>
 330                <TOACV .STR>
 331                <AND .LCAREFUL
 332                     <NOT <AND .NR
 333                               <COND (.R? <G=? <1 .NR> 0>)
 334                                     (ELSE <G? <1 .NR> 0>)>>>
 335                     <EMIT <INSTRUCTION <COND (.R? `JUMPL ) (ELSE `JUMPLE )>
 336                                        <ACSYM .SAC>
 337                                        |CERR1 >>>
 338                <OR <1? .MP> <EMIT <INSTRUCTION `ASH  <ACSYM .SAC> 1>>>
 339                <EMIT <INSTRUCTION `HRLI  <ACSYM .SAC> (<ADDRSYM .SAC>)>>
 340                <EMIT <INSTRUCTION `ADD  <ACSYM .SAC> !<ADDR:VALUE .STR>>>
 341                <RET-TMP-AC <DATTYP .NUMN> .NUMN>
 342                <PUT .NUMN ,DATTYP <DATTYP .STR>>
 343                <COND (<TYPE? <DATTYP .STR> AC>
 344                       <PUT <DATTYP .STR>
 345                            ,ACLINK
 346                            (.NUMN !<ACLINK <DATTYP .STR>>)>)>
 347                <RET-TMP-AC .STR>
 348                <PUT .SAC ,ACPROT <>>
 349                <SET STR .NUMN>
 350                <AND .LCAREFUL
 351                     <NOT <AND .NR <L=? <2 .NR> .ML>>>
 352                     <RCHK .SAC T>>)>
 353         <COND (<NOT <==? .TPS TUPLE>>
 354                <COND (<OR .R? .TYP>
 355                       <RET-TMP-AC <DATTYP .STR> .STR>
 356                       <PUT .STR ,DATTYP <COND (.R? .TPS) (ELSE .TYP)>>)>)>
 357         <MOVE:ARG .STR .WHERE>>
 358
 359 <DEFINE LIST-REST (NOD WHERE TYP TPS NUMKN NUM STRNOD NUMNOD R? RV NR
 360                    "OPTIONAL" (PAC <>) PN (SAME? <>)
 361                    "AUX" (ONO .NO-KILL) (NO-KILL .ONO)
 362                          (RR
 363                           <AND .PAC <NOT .SAME?>
 364                                <COMMUTE-STRUC <> .PN .NUMNOD>
 365                                <COMMUTE-STRUC <> .PN .STRNOD>>) VN
 366                          (NNUMKN .NUMKN) (NUMK <>) (NCAREFUL .CAREFUL) (FLAC <>)
 367                          STR SAC SAC1 (TYP1 <COND (<ISTYPE? .TYP>) (ELSE LIST)>)
 368                          NUMN NAC (T1 <MAKE:TAG>) (T2 <MAKE:TAG>) NTHCASE TEM
 369                          (ONE-OR-TWO-HRRZS <>) (PSTR <>) HI LO (REDEF <>))
 370    #DECL ((PN NOD STRNOD NUMNOD) NODE (STR NUMN VN) DATUM (T1 T2 TYP1 TPS) ATOM
 371           (SAC SAC1 NAC) AC (NUM NTHCASE) FIX (NO-KILL) <SPECIAL LIST>
 372           (R? RR RV NUMK NUMKN NNUMKN) <OR ATOM FALSE> (WHERE) <OR ATOM DATUM>
 373           (PAC) <OR ATOM FALSE AC> (PSTR) <OR DATUM FALSE> (HI LO) FIX
 374           (NR) <OR FALSE <LIST FIX FIX>>)
 375    <COND (.PAC
 376           <COND (<1? <CHTYPE <DEFERN <RESULT-TYPE .PN>> FIX>> <SET REDEF T>)
 377                 (<AND .NUMKN <1? <CHTYPE <DEFERN <GET-ELE-TYPE .TYP <+ .NUM 1>>> FIX>>>
 378                  <SET REDEF T>)
 379                 (<1? <CHTYPE <DEFERN <GET-ELE-TYPE .TYP ALL>> FIX>> <SET REDEF T>)>)>
 380    <SET RV <AND <NOT .SAME?>  <COMMUTE-STRUC .RV .NUMNOD .STRNOD>>>
 381    <COND (.NR
 382           <COND (<==? <SET LO <1 .NR>> <SET HI <2 .NR>>> <SET NUMKN T>)
 383                 (ELSE <SET NNUMKN T>)>
 384           <SET NUM .HI>
 385           <AND <NOT .NUMKN>
 386                <L=? .NUM <MINL .TYP>>
 387                <COND (.R? <G=? .LO 0>) (ELSE <G? .LO 0>)>
 388                <SET NUMK T>>
 389           <COND (<AND <G=? .LO 0> <L=? .NUM <MINL .TYP>>>
 390                  <SET NCAREFUL <>>)>)>
 391    <SET NTHCASE
 392         <+ <COND (.R? 0) (ELSE 12)>
 393            <COND (<AND .NR <G? .LO 0> <G? .HI <MINL .TYP>>> 2)
 394                  (ELSE 0)>
 395            <COND (<AND .NR
 396                        <OR <COND (.R? <G=? .LO 0>) (ELSE <G? .LO 0>)>
 397                            <L=? .NUM <MINL .TYP>>>>
 398                   1)
 399                  (ELSE 0)>
 400            <COND (<AND .NR
 401                        <L=? .NUM <MINL .TYP>>
 402                        <COND (.R? <L? .LO 0>) (ELSE <L=? .LO 0>)>>
 403                   1)
 404                  (ELSE 0)>
 405            <COND (<OR <AND <NOT .NUMK> <NOT .NUMKN>>
 406                       <AND .NCAREFUL
 407                            <G? <COND (.R? .NUM) (ELSE <+ .NUM 1>)>
 408                                <MINL .TYP>>>>
 409                   0)
 410                  (ELSE 1)>
 411            <COND (<NOT .NUMKN> 8)
 412                  (<AND <NOT .NUMK> <SET FLAC <0? .NUM>>> 0)
 413                  (<AND <NOT .NUMK> <SET FLAC <1? .NUM>>> 2)
 414                  (<AND <NOT .NUMK> <SET FLAC <==? .NUM 2>>> 4)
 415                  (ELSE 6)>>>
 416    <COND (<OR <AND <G? .NTHCASE 1> <L? .NTHCASE 6>>
 417               <AND <G? .NTHCASE 13> <L? .NTHCASE 18>>>
 418           <SET ONE-OR-TWO-HRRZS T>)>
 419    <COND
 420     (.RR
 421      <PREFER-DATUM .WHERE>
 422      <SET VN
 423       <GEN
 424        .PN
 425        <COND
 426         (<SET TEM
 427           <AND
 428            <NOT .REDEF>
 429            <OR <ISTYPE? <RESULT-TYPE .PN>>
 430                <ISTYPE?
 431                 <TYPE-MERGE <GET-ELE-TYPE <RESULT-TYPE .STRNOD>
 432                                           <COND (.NUMKN <+ .NUM 1>) (ELSE ALL)>>
 433                             <GET-ELE-TYPE <RESULT-TYPE .NOD>
 434                                           <COND (.NUMKN <+ .NUM 1>)
 435                                                 (ELSE ALL)>>>>>>>
 436          <DATUM .TEM ANY-AC>)
 437         (ELSE <DATUM ANY-AC ANY-AC>)>>>
 438      <SET PUT-COMMON-DAT .VN>)>
 439    <COND (.RV
 440           <OR .NUMKN
 441               .FLAC
 442               <SET NUMN <GEN .NUMNOD <DATUM FIX ANY-AC>>>>
 443           <SET STR
 444                <GEN .STRNOD
 445                     <COND (.PAC <PREG? .TYP .WHERE>)
 446                           (ELSE <REG? .TYP1 .WHERE>)>>>)
 447          (ELSE
 448           <SET STR
 449                <GEN .STRNOD
 450                     <COND (.PAC <PREG? .TYP .WHERE>)
 451                           (ELSE <REG? .TYP1 .WHERE>)>>>
 452           <OR .FLAC
 453               .NUMKN
 454               <SET NUMN <GEN .NUMNOD <DATUM FIX ANY-AC>>>>)>
 455    <COND (<OR .RR <NOT .PAC>> <DELAY-KILL .NO-KILL .ONO>)>
 456    <TOACV .STR>
 457    <COND (<AND .PAC
 458                <SET PAC <CHTYPE <DATVAL .STR> AC>>
 459                <PUT .PAC ,ACPROT T>
 460                <NOT <==? .WHERE FLUSHED>>
 461                <OR <G? .NTHCASE 13> .REDEF>>
 462           <PUT <SET SAC <GETREG <SET PSTR <DATUM .TYP1 LIST>>>>
 463                ,ACPROT
 464                T>
 465           <PUT .PSTR ,DATVAL .SAC>
 466           <OR .ONE-OR-TWO-HRRZS
 467               <EMIT <INSTRUCTION `MOVEI  <ACSYM .SAC> (<ADDRSYM .PAC>)>>>)
 468          (ELSE <SET SAC <DATVAL .STR>>)>
 469    <PUT .SAC ,ACPROT T>
 470    <COND (<AND .NUMKN <NOT .FLAC>>
 471           <SET NAC
 472                <DATVAL <SET NUMN
 473                             <MOVE:ARG <REFERENCE .NUM> <DATUM FIX ANY-AC>>>>>)
 474          (<NOT .FLAC> <TOACV .NUMN> <SET NAC <DATVAL .NUMN>>)>
 475    <COND (<AND <NOT .PSTR>
 476                <ISTYPE? .TYP>
 477                <ACRESIDUE .SAC>
 478                .ONE-OR-TWO-HRRZS
 479                <NOT <AND <TYPE? .WHERE DATUM> <==? <DATVAL .WHERE> .SAC>>>
 480                <G? <CHTYPE <FREE-ACS T> FIX> 0>>
 481           <SET SAC1 <GETREG <>>>
 482           <AND .PAC <SET PAC .SAC1>>)
 483          (<AND .PSTR .ONE-OR-TWO-HRRZS>
 484           <SET SAC1 .SAC>
 485           <SET SAC .PAC>)
 486          (ELSE <SET SAC1 .SAC>)>
 487    <PUT .SAC ,ACPROT <>>
 488    <AND .PAC <PUT <CHTYPE .PAC AC> ,ACPROT <>>>
 489    <AND <==? .SAC .SAC1>
 490         <NOT <L=? .NTHCASE 1>>
 491         <N==? .NTHCASE 12>
 492         <N==? .NTHCASE 13>
 493         <MUNG-AC .SAC <COND (.PSTR .PSTR) (ELSE .STR)>>>
 494    <AND <ASSIGNED? NAC> <MUNG-AC .NAC .NUMN>>
 495    <MAPF <>
 496     <FUNCTION (APAT)
 497             #DECL ((APAT) <OR ATOM LIST>)
 498             <COND (<TYPE? .APAT ATOM>
 499                    <LABEL:TAG <COND (<==? .APAT T1> .T1) (ELSE .T2)>>)
 500                   (<EMPTY? .APAT> T)
 501                   (ELSE
 502                    <EMIT <MAPF ,INSTRUCTION
 503                                <FUNCTION (ITM)
 504                                        <COND (<==? .ITM A11> <ACSYM .SAC>)
 505                                              (<==? .ITM IA11> (<ADDRSYM .SAC>))
 506                                              (<==? .ITM A1> <ACSYM .SAC1>)
 507                                              (<==? .ITM A2> <ACSYM .NAC>)
 508                                              (<==? .ITM IA1> (<ADDRSYM .SAC1>))
 509                                              (<==? .ITM IA2> (<ADDRSYM .NAC>))
 510                                              (<==? .ITM T1> .T1)
 511                                              (<==? .ITM T2> .T2)
 512                                              (ELSE .ITM)>>
 513                                .APAT>>)>>
 514     <NTH ,PATTRNS <+ .NTHCASE 1>>>
 515    <OR .FLAC <RET-TMP-AC .NUMN>>
 516    <COND (<AND <NOT .PSTR> <N==? .SAC .SAC1>>
 517           <RET-TMP-AC .STR>
 518           <SET STR <DATUM .TYP1 .SAC1>>
 519           <PUT .SAC1 ,ACLINK (.STR)>)>
 520    <COND
 521     (<AND .SAME? .PAC> <SPEC-GEN .PN <OR .PSTR .STR> LIST 0>)
 522     (.PAC
 523      <COND
 524       (<NOT .RR>
 525        <SET VN
 526         <GEN
 527          .PN
 528          <COND
 529           (<SET TEM
 530             <AND
 531              <NOT .REDEF>
 532              <OR
 533               <ISTYPE? <RESULT-TYPE .PN>>
 534               <ISTYPE?
 535                <TYPE-MERGE <GET-ELE-TYPE <RESULT-TYPE .STRNOD>
 536                                          <COND (.NUMKN <+ .NUM 1>) (ELSE ALL)>>
 537                            <GET-ELE-TYPE <RESULT-TYPE .NOD>
 538                                          <COND (.NUMKN <+ .NUM 1>)
 539                                                (ELSE ALL)>>>>>>>
 540            <DATUM .TEM ANY-AC>)
 541           (ELSE <DATUM ANY-AC ANY-AC>)>>>
 542        <SET PUT-COMMON-DAT .VN>)>
 543      <DELAY-KILL .NO-KILL .ONO>
 544      <COND (.PSTR <TOACV .PSTR> <SET SAC <DATVAL .PSTR>>)
 545            (ELSE <TOACV .STR> <SET SAC <DATVAL .STR>>)>
 546      <COND (.REDEF
 547             <MUNG-AC .SAC>
 548             <EMIT <INSTRUCTION `MOVE  <ACSYM .SAC> 1 (<ADDRSYM .SAC>)>>
 549             <TOACT .VN>
 550             <SET PUT-COMMON-DAT .VN>
 551             <EMIT <INSTRUCTION `MOVEM  <ACSYM <CHTYPE <DATTYP .VN> AC>>
 552                                (<ADDRSYM .SAC>)>>)
 553            (<OR <NOT .TEM>
 554                 <NOT <==? .TEM
 555                           <ISTYPE?
 556                            <GET-ELE-TYPE <RESULT-TYPE .STRNOD>
 557                                          <COND (.NUMKN <+ .NUM 1>)
 558                                                (ELSE ALL)>>>>>>
 559             <TOACT .VN>
 560             <SET PUT-COMMON-DAT .VN>
 561             <EMIT <INSTRUCTION `HLLM  <ACSYM <CHTYPE <DATTYP .VN> AC>>
 562                                (<ADDRSYM .SAC>)>>)>
 563      <TOACV .VN>
 564      <SET PUT-COMMON-DAT .VN>
 565      <EMIT <INSTRUCTION `MOVEM
 566                         <ACSYM <CHTYPE <DATVAL .VN> AC>>
 567                         1
 568                         (<ADDRSYM .SAC>)>>
 569      <RET-TMP-AC .VN>
 570      <RET-TMP-AC .PSTR>
 571      <PUT <CHTYPE .PAC AC> ,ACPROT <>>)
 572     (<AND .R? <N==? <ISTYPE? .TYP> LIST>>
 573      <DATTYP-FLUSH .STR>
 574      <PUT .STR ,DATTYP LIST>)>
 575    <MOVE:ARG .STR .WHERE>>
 576
 577 <SETG PATTRNS
 578       '![()
 579          ()
 580          ((`JUMPE  A11 |CERR2 ) (`HRRZ  A1 IA11))
 581          ((`HRRZ  A1 IA11))
 582          ((`JUMPE  A11 |CERR2 )
 583           (`HRRZ  A1 IA11)
 584           (`JUMPE  A1 |CERR2 )
 585           (`HRRZ  A1 IA1))
 586          ((`HRRZ  A1 IA11) (`HRRZ  A1 IA1))
 587          (T1
 588           (`JUMPE  A1 |CERR2 )
 589           (`HRRZ  A1 IA1)
 590           (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1))
 591          (T1 (`HRRZ  A1 IA1) (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1))
 592          ((`JUMPL  A2 |CERR1 )
 593           (`JUMPE  A2 T2)
 594           T1
 595           (`JUMPE  A1 |CERR2 )
 596           (`HRRZ  A1 IA1)
 597           (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
 598           T2)
 599          ((`JUMPE  A2 T2)
 600           T1
 601           (`HRRZ  A1 IA1)
 602           (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
 603           T2)
 604          ((`JUMPE  A2 T2)
 605           T1
 606           (`JUMPE  A1 |CERR2 )
 607           (`HRRZ  A1 IA1)
 608           (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
 609           T2)
 610          (T1
 611           (`JUMPE  A1 |CERR2 )
 612           (`HRRZ  A1 IA1)
 613           (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1))
 614          ((`JUMPE  A1 |CERR2 ))
 615          ()
 616          ((`JUMPE  A11 |CERR2 ) (`HRRZ  A1 IA11) (`JUMPE  A1 |CERR2 ))
 617          ((`HRRZ  A1 IA11))
 618          ((`JUMPE  A11 |CERR2 )
 619           (`HRRZ  A1 IA11)
 620           (`JUMPE  A1 |CERR2 )
 621           (`HRRZ  A1 IA1)
 622           (`JUMPE  A1 |CERR2 ))
 623          ((`HRRZ  A1 IA11) (`HRRZ  A1 IA1))
 624          (T1
 625           (`JUMPE  A1 |CERR2 )
 626           (`HRRZ  A1 IA1)
 627           (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
 628           (`JUMPE  A1 |CERR2 ))
 629          (T1 (`HRRZ  A1 IA1) (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1))
 630          ((`JUMPLE  A2 |CERR2 )
 631           (`SOJE  A2 T2)
 632           T1
 633           (`JUMPE  A1 |CERR2 )
 634           (`HRRZ  A1 IA1)
 635           (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
 636           T2
 637           (`JUMPE  A1 |CERR2 ))
 638          ((`SOJE  A2 T2)
 639           T1
 640           (`HRRZ  A1 IA1)
 641           (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
 642           T2)
 643          ((`JUMPLE  A2 |CERR1 )
 644           (`SOJE  A2 T2)
 645           T1
 646           (`HRRZ  A1 IA1)
 647           (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
 648           T2)
 649          ((`SOJE  A2 T2)
 650           T1
 651           (`JUMPE  A1 |CERR2 )
 652           (`HRRZ  A1 IA1)
 653           (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
 654           T2
 655           (`JUMPE  A1 |CERR2 ))!]>
 656
 657 <DEFINE RCHK (AC RORN)
 658         #DECL ((AC) AC (RORN) <OR FALSE ATOM>)
 659         <COND (.RORN
 660                <EMIT <INSTRUCTION `CAILE  <ACSYM .AC> -1>>
 661                <BRANCH:TAG |CERR2 >)
 662               (ELSE <EMIT <INSTRUCTION `JUMPGE  <ACSYM .AC> |CERR2 >>)>>
 663
 664 <DEFINE NTH-GEN (NOD WHERE
 665                  "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
 666                  "AUX" (K <KIDS .NOD>) W2 B2 (SDIR .DIR)
 667                        (TYP <RESULT-TYPE <1 .K>>) (TPS <STRUCTYP .TYP>) W
 668                        (2ARG <2 .K>) (NUMKN <==? <NODE-TYPE .2ARG> ,QUOTE-CODE>)
 669                        (NUM <COND (.NUMKN <COND (<TYPE? <NODE-NAME .2ARG>
 670                                                         OFFSET>
 671                                                  <INDEX <NODE-NAME .2ARG>>)
 672                                                 (ELSE <NODE-NAME .2ARG>)>) (ELSE 1)>)
 673                        (COD <LENGTH <CHTYPE <MEMQ .TPS ,STYPES> UVECTOR>>) FLS
 674                        (NR <GET-RANGE <RESULT-TYPE .2ARG>>) (TEM <>)
 675                        (1ARG <1 .K>) (NRP <NTH-REST-PUT? .1ARG>) NDAT
 676                        (DONE <>))
 677         #DECL ((NOD) NODE (K) <LIST NODE NODE> (TPS) ATOM (NUM COD) FIX
 678                (NDAT) DATUM)
 679         <COND (.NUMKN <PUT .2ARG ,NODE-NAME .NUM>)>
 680         <COND (<AND .BRANCH <NOT <NTH-PRED .COD>>>
 681                <SET W <UPDATE-WHERE .NOD .WHERE>>)
 682               (ELSE <SET W .WHERE>)>
 683         <COND (<SET TEM <FIND-COMMON .NOD>>
 684                <SET W <MOVE:ARG <GET-COMMON-DATUM .TEM> .W>>
 685                <SET DONE T>)
 686               (<AND <SET TEM <FIND-COMMON-REST-NODE .NOD>>
 687                     <SET W <LOC-COMMON .TEM .NOD .TPS .1ARG .2ARG .W>>>
 688                <SET DONE T>)>
 689         <PROG ((COMMON-SUB <>))
 690               #DECL ((COMMON-SUB)
 691                      <SPECIAL <OR FALSE COMMON <LIST [REST COMMON]>>>)
 692               <SET W
 693                    <COND (<AND <NOT .DONE> <NTH-PRED .COD>>
 694                           <APPLY <NTH ,NTHERS .COD>
 695                                  .NOD
 696                                  .WHERE
 697                                  .TYP
 698                                  .TPS
 699                                  .NUMKN
 700                                  .NUM
 701                                  <1 .K>
 702                                  .2ARG
 703                                  .NOTF
 704                                  .BRANCH
 705                                  .DIR
 706                                  .NR>)
 707                          (.BRANCH
 708                           <AND .NOTF <SET DIR <NOT .DIR>>>
 709                           <COND (<NOT .DONE>
 710                                  <SET W
 711                                       <APPLY <NTH ,NTHERS .COD>
 712                                              .NOD
 713                                              .W
 714                                              .TYP
 715                                              .TPS
 716                                              .NUMKN
 717                                              .NUM
 718                                              <1 .K>
 719                                              .2ARG
 720                                              .NR>>)>
 721                           <VAR-STORE <>>
 722                           <OR <SET FLS
 723                                    <OR <==? .WHERE FLUSHED>
 724                                        <AND <NOT .NOTF>
 725                                             <OR <==? .WHERE DONT-CARE>
 726                                                 <=? .W .WHERE>>>>>
 727                               <SET DIR <NOT .DIR>>>
 728                           <D:B:TAG <COND (.FLS .BRANCH)
 729                                          (ELSE <SET B2 <MAKE:TAG>>)>
 730                                    .W
 731                                    .DIR
 732                                    <RESULT-TYPE .NOD>>
 733                           <SET W2
 734                                <MOVE:ARG <COND (.NOTF
 735                                                 <RET-TMP-AC .W>
 736                                                 <REFERENCE .SDIR>)
 737                                                (ELSE .W)>
 738                                          .WHERE>>
 739                           <COND (<NOT .FLS>
 740                                  <BRANCH:TAG .BRANCH>
 741                                  <LABEL:TAG .B2>)>
 742                           .W2)
 743                          (<NOT .DONE>
 744                           <APPLY <NTH ,NTHERS .COD>
 745                                  .NOD
 746                                  .WHERE
 747                                  .TYP
 748                                  .TPS
 749                                  .NUMKN
 750                                  .NUM
 751                                  <1 .K>
 752                                  .2ARG
 753                                  .NR>)
 754                          (ELSE .W)>>
 755               <SET TEM .COMMON-SUB>>
 756         <COND (<NOT .DONE>
 757                <HACK-COMMON NTH .1ARG .TEM .WHERE .W .NUMKN .NUM .TPS .NRP>)>
 758         .W>
 759
 760 <DEFINE VEC-NTH (NOD WHERE TYP TPS NUMKN NUM STRNOD NUMNOD NR
 761                  "AUX" STRN (MP <MPCNT .TPS>) (RV <==? <NODE-NAME .NOD> INTH>)
 762                        STR (TYPR <ISTYPE-GOOD? <RESULT-TYPE .NOD>>))
 763         #DECL ((NOD STRNOD NUMNOD) NODE (NUM MP) FIX (STR) DATUM
 764                (WHERE) <OR ATOM DATUM> (TYPR RV NUMKN) <OR FALSE ATOM>)
 765         <COND (<NOT <G? .NUM 0>> <MESSAGE ERROR "ARG OUT OF RANGE " NTH>)
 766               (<AND .NUMKN
 767                     <OR <NOT .CAREFUL> <NOT <G? .NUM <MINL .TYP>>>>>
 768                <SET STR
 769                     <VEC-REST .NOD
 770                               DONT-CARE
 771                               .TYP
 772                               .TPS
 773                               T
 774                               0
 775                               .STRNOD
 776                               .NUMNOD
 777                               <>
 778                               .RV
 779                               .NR>>
 780                <SET STRN <OFFPTR <+ <* <- .NUM 1> .MP> -2 .MP> .STR .TPS>>)
 781               (ELSE
 782                <SET STR
 783                     <VEC-REST .NOD
 784                               DONT-CARE
 785                               .TYP
 786                               .TPS
 787                               .NUMKN
 788                               <- .NUM 1>
 789                               .STRNOD
 790                               .NUMNOD
 791                               <>
 792                               .RV
 793                               .NR>>
 794                <SET STRN
 795                     <OFFPTR <- <COND (.NUMKN .MP) (ELSE 0)> 2> .STR .TPS>>)>
 796         <MOVE:ARG <DATUM <COND (.TYPR .TYPR) (ELSE .STRN)> .STRN>
 797                   .WHERE>>
 798
 799 <DEFINE LIST-NTH (NOD WHERE TYP TPS NUMKN NUM STRNOD NUMNOD NR
 800                   "AUX" STRN STR (ITYP <ISTYPE-GOOD? <RESULT-TYPE .NOD>>))
 801         #DECL ((NOD STRNOD NUMNOD) NODE (NUM COD) FIX (STR) DATUM (SAC) AC
 802                (WHERE) <OR DATUM ATOM> (ITYP) <OR ATOM FALSE>)
 803         <SET STR
 804              <LIST-REST .NOD
 805                         DONT-CARE
 806                         .TYP
 807                         .TPS
 808                         .NUMKN
 809                         <- .NUM 1>
 810                         .STRNOD
 811                         .NUMNOD
 812                         <>
 813                         <==? <NODE-NAME .NOD> INTH>
 814                         .NR>>
 815         <SET STR <DEFER-IT .NOD .STR>>
 816         <SET STRN <OFFPTR 0 .STR LIST>>
 817         <MOVE:ARG <DATUM <COND (.ITYP .ITYP) (ELSE .STRN)> .STRN>
 818                   .WHERE>>
 819
 820 <DEFINE STRING-REST (N W TYP TPS NK NUM STRN NUMN R? RV NR
 821                      "OPTIONAL" (VN <>)
 822                      "AUX" STRD VD ND SACT SSAC SAC (ML <MINL .TYP>)
 823                            (BSYZ <GETBSYZ .TYP>) NWDS NCHRS (ONO .NO-KILL)
 824                            (NO-KILL .ONO) TEM (LCAREFUL .CAREFUL)
 825                            (OT <COND (<==? .TPS STRING> CHARACTER) (ELSE FIX)>)
 826                            (RR
 827                             <AND .VN
 828                                  <COMMUTE-STRUC <> .VN .NUMN>
 829                                  <COMMUTE-STRUC <> .VN .STRN>>)
 830                            (STAY-MEM
 831                             <AND .R?
 832                                  <==? <NODE-TYPE .STRN> ,LVAL-CODE>
 833                                  <NOT <EMPTY? <SET TEM <PARENT .N>>>>
 834                                  <==? <NODE-TYPE <CHTYPE .TEM NODE>> ,SET-CODE>
 835                                  <==? <NODE-NAME .STRN> <NODE-NAME <CHTYPE .TEM NODE>>>>)
 836                            (W2
 837                             <COND (<AND .R? <NOT .STAY-MEM>> <REG? .TPS .W>)
 838                                   (<AND .VN <NOT .RR>> <DATUM ANY-AC ANY-AC>)
 839                                   (ELSE DONT-CARE)>) (FLS <==? .W FLUSHED>)
 840                            SSTRD)
 841    #DECL ((N NUMN STRN) NODE (STRD SSTRD ND VD) DATUM (NUM ML NWDS NCHRS) FIX
 842           (SACT SSAC SAC) AC (NO-KILL) <SPECIAL LIST>
 843           (NR) <OR FALSE <LIST FIX FIX>> (VN) <OR NODE FALSE>
 844           (BSYZ) <OR FIX FALSE>)
 845    <COND (.RR <SET VD <GEN .VN <DATUM .OT ANY-AC>>> <SET PUT-COMMON-DAT .VD>)>
 846    <COND
 847     (.NK
 848      <COND
 849       (<L? .NUM 0> <MESSAGE ERROR " ARG OUT OF RANGE " <NODE-NAME .N> .N>)
 850       (<0? .NUM>
 851        <SET STRD <GEN .STRN .W2>>
 852        <COND (<AND .LCAREFUL <NOT .R?> <0? .ML>>
 853               <EMIT <INSTRUCTION `HRRZ  !<ADDR:TYPE .STRD>>>
 854               <EMIT <INSTRUCTION `JUMPE  |CERR2 >>)>
 855        <COND (<NOT <AND .TYP <NOT .R?>>>
 856               <TOACV .STRD>
 857               <MUNG-AC <DATVAL .STRD> .STRD>)>
 858        <COND (.VN
 859               <COND (<NOT .RR>
 860                      <SET PUT-COMMON-DAT
 861                           <SET VD <GEN .VN <DATUM .OT ANY-AC>>>>)>
 862               <COND (<AND .FLS <TYPE? <DATVAL .STRD> AC>>
 863                      <TOACV .STRD>
 864                      <MUNG-AC <SET SAC <DATVAL .STRD>> .STRD>
 865                      <TOACV .VD>
 866                      <EMIT <INSTRUCTION `IDPB
 867                                         <ACSYM <CHTYPE <DATVAL .VD> AC>>
 868                                         !<ADDR:VALUE .STRD>>>)
 869                     (ELSE
 870                      <EMIT <INSTRUCTION `MOVE  `O  !<ADDR:VALUE .STRD>>>
 871                      <EMIT <INSTRUCTION `IDPB  <ACSYM <CHTYPE <DATVAL .VD> AC>> `O>>)>)>)
 872       (ELSE
 873        <SET STRD <GEN .STRN .W2>>
 874        <COND (<OR <TYPE? <DATTYP .STRD> AC> <TYPE? <DATVAL .STRD> AC>>
 875               <SET STAY-MEM <>>)>
 876        <COND (<AND .VN <NOT .RR>>
 877               <SET VD <GEN .VN <DATUM .OT ANY-AC>>>
 878               <SET PUT-COMMON-DAT .VD>)>
 879        <DELAY-KILL .NO-KILL .ONO>
 880        <COND
 881         (<AND .LCAREFUL <COND (.R? <G? .NUM .ML>) (ELSE <G=? .NUM .ML>)>>
 882          <COND (<AND .R? <NOT .STAY-MEM>>
 883                 <TOACT .STRD>
 884                 <MUNG-AC <SET SACT <DATTYP .STRD>>>)>
 885          <COND (<TYPE? <DATTYP .STRD> AC>
 886                 <EMIT <INSTRUCTION `MOVEI  `O  (<ADDRSYM <DATTYP .STRD>>)>>)
 887                (ELSE <EMIT <INSTRUCTION `HRRZ  `O  !<ADDR:TYPE .STRD>>>)>
 888          <COND (<1? .NUM>
 889                 <EMIT <INSTRUCTION <COND (.R? `SOJL ) (ELSE `SOJLE )> |CERR2 >>)
 890                (ELSE
 891                 <EMIT <INSTRUCTION `SUBI  `O  .NUM>>
 892                 <EMIT <INSTRUCTION <COND (.R? `JUMPL ) (ELSE `JUMPLE )>
 893                                    `O
 894                                    |CERR2 >>)>
 895          <COND (.R?
 896                 <COND (<TYPE? <DATTYP .STRD> AC>
 897                        <EMIT <INSTRUCTION `HRR  <ACSYM <DATTYP .STRD>> `O >>)
 898                       (ELSE
 899                        <EMIT <INSTRUCTION `HRRM  `O  !<ADDR:TYPE .STRD>>>)>)>)
 900         (<AND <1? .NUM> .R?>
 901          <COND (<NOT .STAY-MEM>
 902                 <TOACT .STRD>
 903                 <MUNG-AC <SET SACT <DATTYP .STRD>> .STRD>)>
 904          <EMIT <INSTRUCTION #OPCODE!-OP!-PACKAGE 33285996544
 905                             !<ADDR:TYPE .STRD>>>)
 906         (<AND .R? <NOT .STAY-MEM>>
 907          <TOACT .STRD>
 908          <MUNG-AC <SET SACT <DATTYP .STRD>> .STRD>
 909          <EMIT <INSTRUCTION `SUBI  <ACSYM .SACT> .NUM>>)
 910         (.R?
 911          <EMIT <INSTRUCTION `MOVNI  `O  .NUM>>
 912          <EMIT <INSTRUCTION `ADDM  `O  !<ADDR:TYPE .STRD>>>)>
 913        <COND (<OR <NOT .R?> <NOT .STAY-MEM>>
 914               <TOACV .STRD>
 915               <SET SAC <DATVAL .STRD>>)
 916              (<TYPE? <DATVAL .STRD> AC> <SET SAC <DATVAL .STRD>>)>
 917        <COND (<AND <NOT .FLS> .VN>
 918               <SET SSAC <PUT .SAC ,ACPROT T>>
 919               <SET SAC <GETREG <>>>
 920               <EMIT <INSTRUCTION `MOVE  <ACSYM .SAC> <ADDRSYM .SSAC>>>
 921               <SET SSTRD <DATUM <DATTYP .STRD> .SAC>>
 922               <PUT .SSAC ,ACPROT <>>)
 923              (ELSE <SET SSTRD .STRD>)>
 924        <COND
 925         (.BSYZ
 926          <SET NWDS </ 36 .BSYZ>>
 927          <SET NCHRS <MOD .NUM .NWDS>>
 928          <SET NWDS </ .NUM .NWDS>>
 929          <COND (<AND <ASSIGNED? SAC> <NOT .FLS>> <MUNG-AC .SAC .SSTRD>)>
 930          <COND (<NOT <0? .NWDS>>
 931                 <COND (<ASSIGNED? SAC>
 932                        <EMIT <INSTRUCTION `ADDI  <ACSYM .SAC> .NWDS>>)
 933                       (ELSE
 934                        <EMIT <INSTRUCTION `MOVEI  `O  .NWDS>>
 935                        <EMIT <INSTRUCTION `ADDM  `O  !<ADDR:VALUE
 936                                                        .SSTRD>>>)>)>
 937          <REPEAT ()
 938                  <COND (<L? <SET NCHRS <- .NCHRS 1>> 0> <RETURN>)>
 939                  <EMIT <INSTRUCTION `IBP  `O  !<ADDR:VALUE .SSTRD>>>>)
 940         (ELSE
 941          <SET TEM <STRINGER .NUM .STRD .SSTRD>>
 942          <COND (.TEM <SET SSTRD <RSTRING .SSTRD .TEM .STAY-MEM>>)
 943                (<1? .NUM>
 944                 <COND (<TYPE? <DATVAL .SSTRD> AC>
 945                        <MUNG-AC <DATVAL .SSTRD> .SSTRD>)>
 946                 <EMIT <INSTRUCTION `IBP  !<ADDR:VALUE .SSTRD>>>)
 947                (ELSE
 948                 <COND (<TYPE? <DATVAL .SSTRD> AC>
 949                        <MUNG-AC <DATVAL .SSTRD> .SSTRD>)>
 950                 <REPEAT ()
 951                         <COND (<L? <SET NUM <- .NUM 1>> 0> <RETURN>)>
 952                         <EMIT <INSTRUCTION `IBP  !<ADDR:VALUE .SSTRD>>>>)>)>
 953        <COND (.VN
 954               <PUT .SAC ,ACPROT T>
 955               <TOACV .VD>
 956               <PUT .SAC ,ACPROT <>>
 957               <EMIT <INSTRUCTION `IDPB  <ACSYM <CHTYPE <DATVAL .VD> AC>>
 958                                  <ADDRSYM .SAC>>>)
 959              (ELSE <SET STRD .SSTRD>)>)>)
 960     (ELSE
 961      <SET RV <COMMUTE-STRUC .RV .NUMN .STRN>>
 962      <COND (.RV
 963             <SET ND <GEN .NUMN <REG? FIX .W>>>
 964             <SET STRD <GEN .STRN DONT-CARE>>)
 965            (<NOT <SIDE-EFFECTS .N>>
 966             <SET STRD <GEN .STRN DONT-CARE>>
 967             <SET ND <GEN .NUMN <REG? FIX .W>>>)
 968            (ELSE
 969             <SET STRD <GEN .STRN <DATUM ANY-AC ANY-AC>>>
 970             <SET ND <GEN .NUMN <DATUM FIX ANY-AC>>>)>
 971      <COND (<OR <TYPE? <DATVAL .STRD> AC> <TYPE? <DATTYP .STRD> AC>>
 972             <SET STAY-MEM <>>)>
 973      <COND (<AND .VN <NOT .RR>>
 974             <SET VD <GEN .VN <DATUM .OT ANY-AC>>>
 975             <SET PUT-COMMON-DAT .VD>)>
 976      <DELAY-KILL .NO-KILL .ONO>
 977      <TOACV .ND>
 978      <COND (<AND .LCAREFUL
 979                  <OR <NOT .NR>
 980                      <COND (.R? <L? <1 .NR> 0>) (ELSE <L=? <1 .NR> 0>)>>>
 981             <EMIT <INSTRUCTION <COND (.R? `JUMPL ) (ELSE `JUMPLE )>
 982                                <ACSYM <CHTYPE <DATVAL .ND> AC>>
 983                                |CERR1 >>)>
 984      <COND (<OR .R? <AND .LCAREFUL <OR <NOT .NR> <G? <2 .NR> .ML>>>>
 985             <EMIT <INSTRUCTION `HRRZ  `O  !<ADDR:TYPE .STRD>>>
 986             <COND (<TYPE? <DATVAL .ND> AC>
 987                    <EMIT <INSTRUCTION `SUBI  `O  (<ADDRSYM <DATVAL .ND>>)>>)
 988                   (ELSE <EMIT <INSTRUCTION `SUB  `O  !<ADDR:VALUE .ND>>>)>
 989             <COND (<AND .LCAREFUL <OR <NOT .NR> <G? <2 .NR> .ML>>>
 990                    <EMIT <INSTRUCTION `JUMPL  `O  |CERR2 >>)>
 991             <COND (<AND .STAY-MEM <NOT <TYPE? <DATTYP .STRD> AC>>>
 992                    <EMIT <INSTRUCTION `HRRM  `O  !<ADDR:TYPE .STRD>>>)
 993                   (.R?
 994                    <TOACT .STRD>
 995                    <MUNG-AC <DATTYP .STRD> .STRD>
 996                    <EMIT <INSTRUCTION `HRR  <ACSYM <CHTYPE <DATTYP .STRD> AC>> `O >>)>)>
 997      <COND (.BSYZ
 998             <SET BSYZ </ 36 .BSYZ>>
 999             <TOACV .ND>
1000             <PUT <SET SAC <DATVAL .ND>> ,ACPROT T>
1001             <MUNG-AC .SAC .ND>
1002             <COND (<==? .SAC ,LAST-AC>
1003                    <SGETREG <SET SAC ,LAST-AC-1> <>>
1004                    <PUT <SET SACT ,LAST-AC> ,ACPROT <>>
1005                    <EMIT <INSTRUCTION `MOVE
1006                                       <ACSYM ,LAST-AC-1>
1007                                       <ADDRSYM ,LAST-AC>>>)
1008                   (ELSE
1009                    <SGETREG <SET SACT <NTH ,ALLACS <+ <ACNUM .SAC> 1>>> <>>
1010                    <PUT .SAC ,ACPROT <>>)>
1011             <EMIT <INSTRUCTION `IDIVI  <ACSYM .SAC> .BSYZ>>)
1012            (ELSE <SET SAC <STRINGER <> .ND .STRD>>)>
1013      <RET-TMP-AC .ND>
1014      <COND (<AND .VN <NOT .FLS>>
1015             <PUT <SET SACT <NTH ,ALLACS <+ <ACNUM <PUT .SAC ,ACPROT T>> 1>>>
1016                  ,ACPROT
1017                  T>
1018             <SET SSAC <GETREG <>>>
1019             <EMIT <INSTRUCTION `MOVE  <ACSYM .SSAC> !<ADDR:VALUE .STRD>>>
1020             <PUT .SAC ,ACPROT <>>
1021             <PUT .SACT ,ACPROT <>>
1022             <RSTRING <DATUM <DATTYP .STRD> .SSAC> .SAC .STAY-MEM>)
1023            (ELSE <SET STRD <RSTRING .STRD .SAC .STAY-MEM>>)>
1024      <COND (.VN
1025             <COND (.FLS
1026                    <TOACV .VD>
1027                    <EMIT <INSTRUCTION `DPB
1028                                       <ACSYM <CHTYPE <DATVAL .VD> AC>>
1029                                       !<ADDR:VALUE .STRD>>>)
1030                   (ELSE
1031                    <PUT .SSAC ,ACPROT T>
1032                    <TOACV .VD>
1033                    <PUT .SSAC ,ACPROT <>>
1034                    <EMIT <INSTRUCTION `DPB
1035                                       <ACSYM <CHTYPE <DATVAL .VD> AC>>
1036                                       <ADDRSYM .SSAC>>>)>)>)>
1037    <COND (.VN <RET-TMP-AC .VD>)>
1038    <COND (.STAY-MEM <SET STORE-SET T> .STRD) (ELSE <MOVE:ARG .STRD .W>)>>
1039
1040 <DEFINE STRING-NTH (N W TYP TPS NK NUM STRN NUMN NR "AUX" STRD RES)
1041         #DECL ((N STRN) NODE (STRD) DATUM (RES) <DATUM ATOM AC>)
1042         <PREFER-DATUM .W>
1043         <SET STRD
1044              <STRING-REST .N
1045                           DONT-CARE
1046                           .TYP
1047                           .TPS
1048                           .NK
1049                           <- .NUM 1>
1050                           .STRN
1051                           .NUMN
1052                           <>
1053                           <==? <NODE-NAME .N> INTH>
1054                           .NR>>
1055         <SET RES
1056              <DATUM <COND (<==? .TPS STRING> CHARACTER)
1057                           (ELSE FIX)>
1058                     <COND (<AND <TYPE? .W DATUM> <TYPE? <DATVAL .W> AC>>
1059                            <SGETREG <DATVAL .W> <>>)
1060                           (ELSE <GETREG <>>)>>>
1061         <PUT <DATVAL .RES> ,ACLINK (.RES !<ACLINK <DATVAL .RES>>)>
1062         <COND (.NK <TOACV .STRD> <MUNG-AC <DATVAL .STRD> .STRD>)>
1063         <RET-TMP-AC .STRD>
1064         <EMIT <INSTRUCTION <COND (.NK `ILDB ) (ELSE `LDB )>
1065                            <ACSYM <DATVAL .RES>>
1066                            !<ADDR:VALUE .STRD>>>
1067         <MOVE:ARG .RES .W>>
1068
1069 <DEFINE STRING-PUT (N W TYP TPS NK NUM STRN NUMN VN NR SAME?
1070                     "AUX" STRD RES (ONO .NO-KILL) (NO-KILL .ONO))
1071         #DECL ((NO-KILL) <SPECIAL LIST> (NR) <OR FALSE <LIST FIX FIX>>)
1072         <STRING-REST .N
1073                      .W
1074                      .TYP
1075                      .TPS
1076                      .NK
1077                      <- .NUM 1>
1078                      .STRN
1079                      .NUMN
1080                      <>
1081                      <>
1082                      .NR
1083                      .VN>>
1084
1085 <DEFINE STRINGER (NUM ND STRD "AUX" SAC SACT)
1086         #DECL ((STRD ND) DATUM (NUM) <OR FALSE FIX> (SAC SACT) AC)
1087         <COND (<AND .NUM <L? .NUM 5>> <>)
1088               (ELSE
1089                <PUT <SET SAC
1090                          <COND (<AND <NOT .NUM> <TYPE? <DATVAL .ND> AC>>
1091                                 <MUNG-AC <DATVAL .ND> .ND>
1092                                 <DATVAL .ND>)
1093                                (ELSE <GETREG <>>)>>
1094                     ,ACPROT
1095                     T>
1096                <COND (<==? .SAC ,LAST-AC>
1097                       <SET SAC <SGETREG ,LAST-AC-1 <>>>
1098                       <PUT <SET SACT ,LAST-AC> ,ACPROT <>>
1099                       <SGETREG ,LAST-AC <>>)
1100                      (ELSE
1101                       <SET SACT <SGETREG <NTH ,ALLACS <+ <ACNUM .SAC> 1>> <>>>)>
1102                <PUT .SAC ,ACPROT <>>
1103                <EMIT <INSTRUCTION `LDB
1104                                   <ACSYM .SACT>
1105                                   [<FORM (98688) !<ADDR:VALUE .STRD>>]>>
1106                <EMIT '<`MOVEI  `O  36>>
1107                <EMIT <INSTRUCTION `IDIVM  `O  <ADDRSYM .SACT>>>
1108                <COND (.NUM <EMIT <INSTRUCTION `MOVEI  <ACSYM .SAC> .NUM>>)
1109                      (<==? .SAC <DATVAL .ND>>)
1110                      (ELSE
1111                       <PUT .SAC ,ACPROT T>
1112                       <EMIT <INSTRUCTION `MOVE
1113                                          <ACSYM .SAC>
1114                                          !<ADDR:VALUE .ND>>>
1115                       <PUT .SAC ,ACPROT <>>)>
1116                <EMIT <INSTRUCTION `IDIV  <ACSYM .SAC> <ADDRSYM .SACT>>>
1117                .SAC)>>
1118
1119 <DEFINE RSTRING (ST SAC STAY-MEM "AUX" (SAC1 <NTH ,ALLACS <+ <ACNUM .SAC> 1>>))
1120         #DECL ((SAC SAC1) AC (ST) DATUM)
1121         <COND (<AND <TYPE? <DATVAL .ST> AC> <NOT <ACRESIDUE <DATVAL .ST>>>>
1122                <MUNG-AC <DATVAL .ST> .ST>
1123                <EMIT <INSTRUCTION `ADD  <ACSYM <CHTYPE <DATVAL .ST> AC>> <ADDRSYM .SAC>>>
1124                <SET SAC <DATVAL .ST>>)
1125               (.STAY-MEM
1126                <EMIT <INSTRUCTION `ADDM  <ACSYM .SAC> !<ADDR:VALUE .ST>>>)
1127               (ELSE
1128                <EMIT <INSTRUCTION `ADD  <ACSYM .SAC> !<ADDR:VALUE .ST>>>
1129                <RET-TMP-AC <DATVAL .ST> .ST>
1130                <PUT .ST ,DATVAL .SAC>
1131                <PUT .SAC ,ACLINK (.ST !<ACLINK .SAC>)>)>
1132         <EMIT <INSTRUCTION `JUMPE  <ACSYM .SAC1> '.HERE!-OP!-PACKAGE 3>>
1133         <EMIT <INSTRUCTION `IBP  !<ADDR:VALUE .ST>>>
1134         <EMIT <INSTRUCTION `SOJG  <ACSYM .SAC1> '.HERE!-OP!-PACKAGE -1>>
1135         .ST>
1136
1137 <SETG RESTERS
1138       [,STRING-REST
1139        ,STRING-REST
1140        ,STRING-REST
1141        ,VEC-REST
1142        ,VEC-REST
1143        ,VEC-REST
1144        ,VEC-REST
1145        ,LIST-REST]>
1146
1147 <SETG STYPES ![LIST TUPLE VECTOR UVECTOR STORAGE STRING BYTES TEMPLATE!]>
1148
1149 <DEFINE NTH-PRED (C) #DECL ((C) FIX) <==? .C 1>>
1150
1151 <SETG NTHERS
1152       [<AND <GASSIGNED? TEMPLATE-NTH> ,TEMPLATE-NTH>
1153        ,STRING-NTH
1154        ,STRING-NTH
1155        ,VEC-NTH
1156        ,VEC-NTH
1157        ,VEC-NTH
1158        ,VEC-NTH
1159        ,LIST-NTH]>
1160
1161 <DEFINE PUT-GEN (NOD WHERE "OPTIONAL" (SAME? <>)
1162                  "AUX" (K <KIDS .NOD>) (TYP <RESULT-TYPE <1 .K>>)
1163                        (TPS <STRUCTYP .TYP>) (2ARG <2 .K>)
1164                        (NUMKN <==? <NODE-TYPE .2ARG> ,QUOTE-CODE>)
1165                        (NUM <COND (.NUMKN <COND (<TYPE? <NODE-NAME .2ARG>
1166                                                       OFFSET>
1167                                                  <INDEX <NODE-NAME .2ARG>>)
1168                                                 (ELSE <NODE-NAME .2ARG>)>) (ELSE 1)>)
1169                        (NR <GET-RANGE <RESULT-TYPE .2ARG>>) TEM W (1ARG <1 .K>)
1170                        (NRP <NTH-REST-PUT? <1 .K>>) PUT-COMMON-DAT)
1171         #DECL ((NOD) NODE (K) <LIST NODE NODE NODE> (NUM) FIX
1172                (PUT-COMMON-DAT) <SPECIAL DATUM> (W) DATUM)
1173         <COND (.NUMKN <PUT .2ARG ,NODE-NAME .NUM>)>
1174         <COND (<AND <==? .WHERE FLUSHED>
1175                     <SET TEM <FIND-COMMON-REST-NODE .NOD>>
1176                     <OR <NOT .CAREFUL> <NOT <MEMQ .TPS '[UVECTOR STORAGE]>>>>
1177                <SET W
1178                     <COMMON-CLOBBER .TEM
1179                                     .NOD
1180                                     <3 .K>
1181                                     <NODE-NAME .2ARG>
1182                                     .1ARG
1183                                     .TPS
1184                                     .SAME?>>
1185                <SET TEM <>>
1186                <KILL-COMMON .TPS>)
1187               (ELSE
1188                <KILL-COMMON .TPS>
1189                <PROG ((COMMON-SUB <>))
1190                      #DECL ((COMMON-SUB) <SPECIAL <OR FALSE COMMON>>)
1191                      <SET W
1192                           <APPLY <NTH ,PUTTERS <LENGTH <CHTYPE <MEMQ .TPS ,STYPES>
1193                                                                UVECTOR>>>
1194                                  .NOD
1195                                  .WHERE
1196                                  .TYP
1197                                  .TPS
1198                                  .NUMKN
1199                                  .NUM
1200                                  <1 .K>
1201                                  .2ARG
1202                                  <3 .K>
1203                                  .NR
1204                                  .SAME?>>
1205                      <SET TEM .COMMON-SUB>>
1206                <OR <==? <TYPEPRIM .TPS> TEMPLATE>
1207                    <AND <TYPE? <DATTYP .W> AC>
1208                         <MEMQ <DATTYP .W> .PUT-COMMON-DAT>>
1209                    <AND <TYPE? <DATVAL .W> AC>
1210                         <MEMQ <DATVAL .W> .PUT-COMMON-DAT>>
1211                    <HACK-COMMON NTH
1212                                 .1ARG
1213                                 .TEM
1214                                 .PUT-COMMON-DAT
1215                                 .PUT-COMMON-DAT
1216                                 .NUMKN
1217                                 .NUM
1218                                 .TPS
1219                                 .NRP>
1220                    <HACK-COMMON NTH
1221                                 .1ARG
1222                                 .TEM
1223                                 .PUT-COMMON-DAT
1224                                 .PUT-COMMON-DAT
1225                                 .NUMKN
1226                                 .NUM
1227                                 .TPS
1228                                 .NRP>>)>
1229         <COND (.TEM
1230                <OR <==? <TYPEPRIM .TPS> TEMPLATE>
1231                    <AND <TYPE? <DATTYP .W> AC>
1232                         <MEMQ <DATTYP .W> .PUT-COMMON-DAT>>
1233                    <AND <TYPE? <DATVAL .W> AC>
1234                         <MEMQ <DATVAL .W> .PUT-COMMON-DAT>>
1235                    <HACK-COMMON NTH
1236                                 .1ARG
1237                                 .TEM
1238                                 .PUT-COMMON-DAT
1239                                 .PUT-COMMON-DAT
1240                                 .NUMKN
1241                                 .NUM
1242                                 .TPS
1243                                 .NRP>
1244                    <HACK-COMMON NTH
1245                                 .1ARG
1246                                 .TEM
1247                                 .PUT-COMMON-DAT
1248                                 .PUT-COMMON-DAT
1249                                 .NUMKN
1250                                 .NUM
1251                                 .TPS
1252                                 .NRP>>)>
1253         .W>
1254
1255 <DEFINE VEC-PUT (N W TYP TPS NK NUM SNOD NNOD VNOD NR SAME?
1256                  "AUX" VN (ONO .NO-KILL) (NO-KILL .ONO)
1257                        (RV <AND <NOT .SAME?> <COMMUTE-STRUC <> .NNOD .SNOD>>)
1258                        (RR
1259                         <AND <NOT .SAME?>
1260                              <COMMUTE-STRUC <> .VNOD .SNOD>
1261                              <COMMUTE-STRUC <> .VNOD .NNOD>>) (MP <MPCNT .TPS>)
1262                        (NN 0) NAC SAC STR NUMN TEM (CFLG 0))
1263    #DECL ((N SNOD NNOD VNOD) NODE (NUM NN MP CFLG) FIX (SAC NAC) AC
1264           (NUMN STR VN) DATUM (NO-KILL) <SPECIAL LIST>
1265           (NR) <OR FALSE <LIST FIX FIX>>)
1266    <COND (.NK
1267           <COND (<NOT <G? .NUM 0>> <MESSAGE ERROR "ARG OUT OF RANGE " PUT>)
1268                 (<OR <NOT .CAREFUL> <L=? .NUM <MINL .TYP>> <1? <SET CFLG .NUM>>>
1269                  <COND (.RR
1270                         <SET VN <GEN .VNOD DONT-CARE>>
1271                         <SET PUT-COMMON-DAT .VN>
1272                         <SET STR <GEN .SNOD <PREG? .TYP .W>>>
1273                         <AND <1? .CFLG> <RCHK <DATVAL .STR> <>>>)
1274                        (ELSE
1275                         <SET STR <GEN .SNOD <PREG? .TYP .W>>>
1276                         <AND <1? .CFLG> <RCHK <DATVAL .STR> <>>>
1277                         <OR .SAME?
1278                             <SET PUT-COMMON-DAT
1279                                  <SET VN <GEN .VNOD DONT-CARE>>>>)>
1280                  <DELAY-KILL .NO-KILL .ONO>
1281                  <COND (.SAME? <SPEC-GEN .VNOD .STR .TPS .NUM>)
1282                        (ELSE <DATCLOB .VNOD .VN .NUM .MP .STR .TYP T>)>
1283                  <MOVE:ARG .STR .W>)
1284                 (ELSE
1285                  <COND (.RR
1286                         <SET VN <GEN .VNOD DONT-CARE>>
1287                         <SET PUT-COMMON-DAT .VN>
1288                         <SET SAC <DATVAL <SET STR <GEN .SNOD <PREG? .TYP .W>>>>>
1289                         <MUNG-AC .SAC .STR>)
1290                        (ELSE
1291                         <SET STR <GEN .SNOD <PREG? .TYP .W>>>
1292                         <OR .SAME?
1293                             <SET PUT-COMMON-DAT <SET VN <GEN .VNOD DONT-CARE>>>>
1294                         <SET SAC <DATVAL <SET STR <TOACV .STR>>>>
1295                         <MUNG-AC .SAC .STR>)>
1296                  <DELAY-KILL .NO-KILL .ONO>
1297                  <EMIT <INSTRUCTION `ADD
1298                                     <ACSYM .SAC>
1299                                     [<FORM <SET NN <* <- .NUM 1> .MP>> (.NN)>]>>
1300                  <RCHK .SAC <>>
1301                  <COND (.SAME? <SPEC-GEN .VNOD .STR .TPS 1>)
1302                        (ELSE <DATCLOB .VNOD .VN 1 .MP .STR .TYP T .NUM>)>
1303                  <SET SAC <DATVAL <TOACV .STR>>>
1304                  <OR <==? .W FLUSHED>
1305                          <EMIT <INSTRUCTION `SUB
1306                                             <ACSYM .SAC>
1307                                             [<FORM .NN (.NN)>]>>>
1308                  <MOVE:ARG .STR .W>)>)
1309          (ELSE
1310           <COND (.RR <SET VN <GEN .VNOD DONT-CARE>> <SET PUT-COMMON-DAT .VN>)>
1311           <COND (.RV
1312                  <PREFER-DATUM <SET STR <PREG? .TYP .W>>>
1313                  <SET NUMN <GEN .NNOD <DATUM FIX ANY-AC>>>
1314                  <SET STR <GEN .SNOD .STR>>
1315                  <TOACV .NUMN>
1316                  <SET NAC <DATVAL .NUMN>>)
1317                 (ELSE
1318                  <SET STR <GEN .SNOD <PREG? .TYP .W>>>
1319                  <SET NAC <DATVAL <SET NUMN <GEN .NNOD <DATUM FIX ANY-AC>>>>>)>
1320           <COND (.RR <DELAY-KILL .NO-KILL .ONO>)>
1321           <TOACV .STR>
1322           <SET SAC <DATVAL .STR>>
1323           <MUNG-AC .NAC .NUMN>
1324           <AND .CAREFUL
1325               <NOT <AND .NR <G? <1 .NR> 0>>>
1326               <EMIT <INSTRUCTION `JUMPLE  <ACSYM .NAC> |CERR1 >>>
1327           <OR <1? .MP> <EMIT <INSTRUCTION `ASH  <ACSYM .NAC> 1>>>
1328           <EMIT <INSTRUCTION `HRLI  <ACSYM .NAC> (<ADDRSYM .NAC>)>>
1329           <EMIT <INSTRUCTION `ADD  <ACSYM .NAC> <ADDRSYM .SAC>>>
1330           <AND .CAREFUL <NOT <AND .NR <L=? <2 .NR> <MINL .TYP>>>> <RCHK .NAC T>>
1331           <RET-TMP-AC <DATTYP .NUMN> .NUMN>
1332           <COND (<==? .TPS TUPLE>
1333                  <PUT .NUMN ,DATTYP <DATTYP .STR>>
1334                  <COND (<TYPE? <DATTYP .STR> AC>
1335                         <PUT <SET SAC <DATTYP .STR>>
1336                              ,ACLINK
1337                              (.NUMN !<ACLINK .SAC>)>)>)
1338                 (ELSE <PUT .NUMN ,DATTYP .TPS>)>
1339           <COND (<NOT .RR>
1340                  <DELAY-KILL .NO-KILL .ONO>
1341                  <OR .SAME?
1342                      <SET PUT-COMMON-DAT <SET VN <GEN .VNOD DONT-CARE>>>>)>
1343           <COND (.SAME? <SPEC-GEN .VNOD .NUMN .TPS 0>)
1344                 (ELSE <DATCLOB .VNOD .VN 0 .MP .NUMN .TYP <>>)>
1345           <RET-TMP-AC .NUMN>
1346           <MOVE:ARG .STR .W>)>>
1347
1348 <DEFINE LIST-PUT (N W TYP TPS NK NUM SNOD NNOD VNOD NR SAME?)
1349         #DECL ((N SNOD NNOD NOD) NODE (NUM) FIX)
1350         <LIST-REST .N
1351                    .W
1352                    .TYP
1353                    .TPS
1354                    .NK
1355                    <- .NUM 1>
1356                    .SNOD
1357                    .NNOD
1358                    <>
1359                    <>
1360                    .NR
1361                    T
1362                    .VNOD .SAME?>>
1363
1364 <SETG PUTTERS
1365       [<AND <GASSIGNED? TEMPLATE-PUT> ,TEMPLATE-PUT>
1366        ,STRING-PUT
1367        ,STRING-PUT
1368        ,VEC-PUT
1369        ,VEC-PUT
1370        ,VEC-PUT
1371        ,VEC-PUT
1372        ,LIST-PUT]>
1373
1374 <DEFINE DATCLOB (VNOD N O TY N2 TP NK
1375                  "OPTIONAL" (RN .O)
1376                  "AUX" (ETYP <GET-ELE-TYPE .TP <COND (.NK .RN) (ELSE ALL)>>)
1377                        (VTYP <RESULT-TYPE .VNOD>) TT TEM)
1378    #DECL ((N) DATUM (O RN TY) FIX (N2) DATUM (VNOD) NODE)
1379    <SET O <+ <* <- .O 1> .TY> -2 .TY>>
1380    <COND
1381     (<1? .TY>
1382      <COND
1383       (<AND .CAREFUL <NOT <TYPESAME .ETYP .VTYP>>>
1384        <COND (<SET TT <ISTYPE? .ETYP>>
1385               <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O  !<ADDR:TYPE .N>>>
1386               <EMIT <INSTRUCTION `CAIE  `O  <FORM TYPE-CODE!-OP!-PACKAGE .TT>>>
1387               <BRANCH:TAG |CERR3 >)
1388              (<SET TT <ISTYPE? .VTYP>>
1389               <TOACV .N2>
1390               <GETUVT <DATVAL .N2> ,ACO T>
1391               <EMIT <INSTRUCTION `CAIE  `O  <FORM TYPE-CODE!-OP!-PACKAGE .TT>>>
1392               <BRANCH:TAG |CERR3 >)
1393              (ELSE
1394               <PUT <SET TT <GETREG <>>> ,ACPROT T>
1395               <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE
1396                                  <ACSYM .TT>
1397                                  !<ADDR:TYPE .N>>>
1398               <TOACV .N2>
1399               <GETUVT <DATVAL .N2> ,ACO T>
1400               <EMIT <INSTRUCTION `CAIE  `O  (<ADDRSYM .TT>)>>
1401               <BRANCH:TAG |CERR3 >
1402               <PUT .TT ,ACPROT <>>)>
1403        <MOVE:ARG .N <DATUM DONT-CARE <OFFPTR .O .N2 UVECTOR>>>)
1404       (ELSE
1405        <MOVE:ARG .N <DATUM DONT-CARE <OFFPTR .O .N2 UVECTOR>>>)>)
1406     (ELSE
1407      <MOVE:ARG .N
1408                <COND (<AND <SET ETYP <ISTYPE-GOOD? .ETYP>>
1409                            <TYPESAME .ETYP .VTYP>>
1410                       <DATUM .ETYP <OFFPTR .O .N2 VECTOR>>)
1411                      (ELSE <DATUM <SET TEM <OFFPTR .O .N2 VECTOR>> .TEM>)>>)>>
1412
1413 <DEFINE MPCNT (TY)
1414         #DECL ((TY) ATOM)
1415         <COND (<OR <==? .TY UVECTOR> <==? .TY STORAGE>> 1)
1416               (ELSE 2)>>
1417
1418 <DEFINE IPUT-GEN (NOD WHERE
1419                   "AUX" (OS .STK) (STK (0 !.STK)) PINDIC (K <KIDS .NOD>) PITEM)
1420         #DECL ((NOD) NODE (K) <LIST NODE NODE NODE> (PITEM PINDIC) DATUM
1421                (STK) <SPECIAL LIST>)
1422         <SET PITEM <GEN <1 .K> <DATUM ,AC-A ,AC-B>>>
1423         <SET PINDIC <GEN <2 .K> <DATUM ,AC-C ,AC-D>>>
1424         <RET-TMP-AC <STACK:ARGUMENT <GEN <3 .K> DONT-CARE>>>
1425         <ADD:STACK 2>
1426         <SET PITEM <MOVE:ARG .PITEM <DATUM ,AC-A ,AC-B>>>
1427         <RET-TMP-AC <MOVE:ARG .PINDIC <DATUM ,AC-C ,AC-D>>>
1428         <RET-TMP-AC .PITEM>
1429         <REGSTO T>
1430         <EMIT <INSTRUCTION `PUSHJ  `P* <COND (<==? <NODE-SUBR .NOD> ,PUT> |CIPUT)
1431                                              (ELSE |CIPUTP)>>>
1432         <SET STK .OS>
1433         <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>
1434
1435 <DEFINE IREMAS-GEN (NOD WHERE "AUX" (K <KIDS .NOD>) PINDIC PITEM)
1436         #DECL ((NOD) NODE (K) <LIST NODE NODE> (PINDIC PITEM) DATUM)
1437         <SET PITEM <GEN <1 .K> <DATUM ,AC-A ,AC-B>>>
1438         <SET PINDIC <GEN <2 .K> <DATUM ,AC-C ,AC-D>>>
1439         <SET PITEM <MOVE:ARG .PITEM <DATUM ,AC-A ,AC-B>>>
1440         <RET-TMP-AC <MOVE:ARG .PINDIC <DATUM ,AC-C ,AC-D>>>
1441         <RET-TMP-AC .PITEM>
1442         <REGSTO T>
1443         <EMIT <INSTRUCTION `PUSHJ  `P*  |CIREMA >>
1444         <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>
1445
1446 <DEFINE PUTREST-GEN (NOD WHERE
1447                      "AUX" ST1 ST2 (K <KIDS .NOD>) (FLG T) N CD (ONO .NO-KILL)
1448                            (NO-KILL .ONO) (2RET <>))
1449         #DECL ((NOD N) NODE (K) <LIST NODE NODE> (ST1 ST2) DATUM
1450                (NO-KILL) <SPECIAL LIST> (ONO) LIST)
1451         <COND (<==? <NODE-SUBR .NOD> ,REST>
1452                <SET NOD <1 .K>>
1453                <SET K <KIDS .NOD>>
1454                <SET 2RET T>)>                      ;"Really <REST <PUTREST ...."
1455         <COND (<AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
1456                     <==? <NODE-NAME <2 .K>> ()>>
1457                <SET ST1 <GEN <1 .K> <UPDATE-WHERE .NOD .WHERE>>>)
1458               (<AND <NOT <SIDE-EFFECTS? <1 .K>>>
1459                     <NOT <SIDE-EFFECTS? <2 .K>>>
1460                     <MEMQ <NODE-TYPE <1 .K>> ,SNODES>>
1461                <AND <==? <NODE-TYPE <SET N <1 .K>>> ,LVAL-CODE>
1462                     <COND (<==? <LENGTH <SET CD <TYPE-INFO .N>>> 2> <2 .CD>)
1463                           (ELSE T)>
1464                     <SET CD <NODE-NAME .N>>
1465                     <NOT <MAPF <>
1466                                <FUNCTION (LL)
1467                                        #DECL ((LL) <LIST SYMTAB ANY>)
1468                                        <AND <==? .CD <1 .LL>> <MAPLEAVE>>>
1469                                .NO-KILL>>
1470                     <SET NO-KILL ((.CD <>) !.NO-KILL)>>
1471                <SET ST2
1472                     <GEN <2 .K>
1473                          <COND (.2RET <GOODACS <2 .K> .WHERE>)
1474                                (ELSE <DATUM LIST ANY-AC>)>>>
1475                <SET ST1
1476                     <GEN <1 .K>
1477                          <COND (.2RET DONT-CARE)
1478                                (ELSE <UPDATE-WHERE .NOD .WHERE>)>>>
1479                <DELAY-KILL .NO-KILL .ONO>)
1480               (ELSE
1481                <SET ST1
1482                     <GEN <1 .K>
1483                          <GOODACS .NOD
1484                                   <COND (<OR <==? .WHERE FLUSHED> .2RET>
1485                                          DONT-CARE)
1486                                         (ELSE .WHERE)>>>>
1487                <SET ST2 <GEN <2 .K> <DATUM LIST ANY-AC>>>)>
1488         <KILL-COMMON LIST>
1489         <AND .CAREFUL
1490              <G? 1 <MINL <RESULT-TYPE <1 .K>>>>
1491              <COND (<TYPE? <DATVAL .ST1> AC>
1492                     <EMIT <INSTRUCTION `JUMPE  <ACSYM <DATVAL .ST1>> |CERR2 >>)
1493                    (ELSE
1494                     <EMIT <INSTRUCTION `SKIPN  !<ADDR:VALUE .ST1>>>
1495                     <BRANCH:TAG |CERR2 >)>>
1496         <AND <ASSIGNED? ST2> <TOACV .ST2>>
1497         <OR <TYPE? <DATVAL .ST1> AC> <SET FLG <>>>
1498         <COND (<ASSIGNED? ST2>
1499                <COND (.FLG
1500                       <EMIT <INSTRUCTION `HRRM
1501                                          <ACSYM <CHTYPE <DATVAL .ST2> AC>>
1502                                          (<ADDRSYM <CHTYPE <DATVAL .ST1> AC>>)>>)
1503                      (ELSE
1504                       <EMIT <INSTRUCTION `HRRM
1505                                          <ACSYM <CHTYPE <DATVAL .ST2> AC>>
1506                                          `@
1507                                          !<ADDR:VALUE .ST1>>>)>
1508                <RET-TMP-AC <COND (.2RET .ST1) (ELSE .ST2)>>)
1509               (ELSE
1510                <COND (.FLG
1511                       <EMIT <INSTRUCTION `HLLZS  (<ADDRSYM <CHTYPE <DATVAL .ST1> AC>>)>>)
1512                      (ELSE
1513                       <EMIT <INSTRUCTION `HLLZS  `@  !<ADDR:VALUE .ST1>>>)>)>
1514         <MOVE:ARG <COND (.2RET .ST2) (ELSE .ST1)> .WHERE>>
1515
1516 <DEFINE SIDE-EFFECTS? (N)
1517         #DECL ((N) NODE)
1518         <AND <N==? <NODE-TYPE .N> ,QUOTE-CODE> <SIDE-EFFECTS .N>>>
1519
1520 <DEFINE COMMUTE-STRUC (RV NUMNOD STRNOD "AUX" N (L .NO-KILL) CD (FLG T))
1521         #DECL ((NO-KILL) LIST (NUMNOD STRNOD) NODE (L) LIST)
1522         <COND
1523          (<OR <AND <NOT .RV>
1524                    <OR <AND <==? <NODE-TYPE .NUMNOD> ,QUOTE-CODE>
1525                             <NOT <SET FLG <>>>>
1526                        <NOT <SIDE-EFFECTS .NUMNOD>>>
1527                    <MEMQ <SET CD <NODE-TYPE <SET N .STRNOD>>> ,SNODES>>
1528               <AND .RV
1529                    <OR <AND <==? <NODE-TYPE .STRNOD> ,QUOTE-CODE>
1530                             <NOT <SET FLG <>>>>
1531                        <NOT <SIDE-EFFECTS .STRNOD>>>
1532                    <NOT <MEMQ <SET CD <NODE-TYPE <SET N .NUMNOD>>> ,SNODES>>>>
1533           <COND (<AND .FLG
1534                       <==? .CD ,LVAL-CODE>
1535                       <COND (<==? <LENGTH <SET CD <TYPE-INFO .N>>> 2> <2 .CD>)
1536                             (ELSE T)>
1537                       <SET CD <NODE-NAME .N>>
1538                       <NOT <MAPF <>
1539                                  <FUNCTION (LL)
1540                                          #DECL ((LL) <LIST SYMTAB ANY>)
1541                                          <AND <==? .CD <1 .LL>> <MAPLEAVE>>>
1542                                  .L>>>
1543                  <SET NO-KILL ((.CD <>) !.L)>)>
1544           <NOT .RV>)
1545          (ELSE .RV)>>
1546
1547
1548 <DEFINE DEFER-IT (NOD STR "AUX" SAC SAC1 STR1 COD)
1549    #DECL ((STR STR1) DATUM (NOD) NODE (SAC SAC1) AC (COD) FIX)
1550    <COND
1551     (<1? <SET COD <DEFERN <RESULT-TYPE .NOD>>>>
1552      <COND (<AND <ACRESIDUE
1553                   <SET SAC
1554                        <DATVAL <SET STR <MOVE:ARG .STR <REG? LIST .STR>>>>>>
1555                  <NOT <0? <CHTYPE <FREE-ACS T> FIX>>>>
1556             <SET SAC1 <GETREG <SET STR1 <DATUM LIST ANY-AC>>>>
1557             <PUT .STR1 ,DATVAL .SAC1>
1558             <EMIT <INSTRUCTION `MOVE  <ACSYM .SAC1> 1 (<ADDRSYM .SAC>)>>
1559             <RET-TMP-AC .STR>
1560             <SET STR .STR1>)
1561            (ELSE
1562             <MUNG-AC .SAC .STR>
1563             <EMIT <INSTRUCTION `MOVE  <ACSYM .SAC> 1 (<ADDRSYM .SAC>)>>)>)
1564     (<AND <NOT <0? .COD>>
1565           <G? <CHTYPE <FREE-ACS T> FIX> 0>
1566           <ACRESIDUE <SET SAC <DATVAL .STR>>>
1567           <MAPF <>
1568                 <FUNCTION (ITEM)
1569                         #DECL ((ITEM) SYMBOL)
1570                         <COND (<AND <TYPE? .ITEM SYMTAB> <NOT <STORED .ITEM>>>
1571                                <MAPLEAVE T>)>>
1572                 <ACRESIDUE .SAC>>>
1573      <SET SAC
1574           <DATVAL <SET STR <MOVE:ARG .STR <REG? LIST .STR>>>>>
1575      <SET SAC1 <GETREG <SET STR1 <DATUM LIST ANY-AC>>>>
1576      <PUT .STR1 ,DATVAL .SAC1>
1577      <EMIT <INSTRUCTION `MOVEI  <ACSYM .SAC1> (<ADDRSYM .SAC>)>>
1578      <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O  (<ADDRSYM .SAC>)>>
1579      <EMIT <INSTRUCTION `CAIN  `O  TDEFER!-OP!-PACKAGE>>
1580      <EMIT <INSTRUCTION `MOVE  <ACSYM .SAC1> 1 (<ADDRSYM .SAC1>)>>
1581      <RET-TMP-AC .STR>
1582      <SET STR .STR1>)
1583     (<NOT <0? .COD>>
1584      <SET SAC
1585           <DATVAL <SET STR <MOVE:ARG .STR <REG? LIST .STR>>>>>
1586      <MUNG-AC .SAC .STR>
1587      <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O  (<ADDRSYM .SAC>)>>
1588      <EMIT <INSTRUCTION `CAIN  `O  TDEFER!-OP!-PACKAGE>>
1589      <EMIT <INSTRUCTION `MOVE  <ACSYM .SAC> 1 (<ADDRSYM .SAC>)>>)>
1590    .STR>
1591
1592 \\f
1593
1594 "ROUTINES TO DO COMMON SUBEXPRESSION HACKING IN SIMPLE CASES
1595  (CURRENTLY NTH REST)."
1596
1597 "ROUTINE TO CREATE A COMMON"
1598
1599 <DEFINE COMMON (CODE SYMT OBJ PTYP DAT)
1600         #DECL ((CODE) ATOM (SYMT) <OR SYMTAB COMMON> (OBJ) FIX)
1601         <CHTYPE [.CODE .SYMT .OBJ .PTYP .DAT] COMMON>>
1602
1603 "THIS ROUTINE BUILDS A CANONACAILZED COMMON.  THIS ROUTINE CAN RETURN
1604  EITHER A COMMON OR A LIST OF COMMONS."
1605
1606 <DEFINE BUILD-COMMON (CODE COMSYMT ITEM PTYP DAT "AUX" INAC COMM COMT CUR-COM)
1607         #DECL ((CODE) ATOM (COMSYMT) <OR SYMTAB COMMON LIST> (ITEM) FIX
1608                (CUR-COM) <OR COMMON <LIST [REST COMMON]>>)
1609         <COND (<TYPE? .COMSYMT LIST>
1610                <REPEAT ((PTR .COMSYMT) (CLIST ()))
1611                        <COND (<EMPTY? .PTR>
1612                               <RETURN <COND (<1? <LENGTH .CLIST>> <1 .CLIST>)
1613                                             (.CLIST)>>)>
1614                        <SET CUR-COM <BUILD-COMMON .CODE <1 .PTR> .ITEM .PTYP .DAT>>
1615                        <COND (<TYPE? .CUR-COM COMMON>
1616                               <SET CLIST (.CUR-COM !.CLIST)>)
1617                              (<PUTREST <REST .CUR-COM <- <LENGTH .CUR-COM> 1>>
1618                                        .CLIST>)>
1619                        <SET PTR <REST .PTR>>>)
1620               (<TYPE? .COMSYMT SYMTAB>
1621                <COND (<AND <SET INAC <INACS .COMSYMT>>
1622                            <SET COMM <FIND-COMMON-AC <DATVAL .INAC>>>>
1623                       <SET COMT <BUILD-COMMON .CODE .COMM .ITEM .PTYP .DAT>>
1624                       <COND (<TYPE? .COMT LIST>
1625                              (<COMMON .CODE .COMSYMT .ITEM .PTYP .DAT> !.COMT))
1626                             (ELSE
1627                              (<COMMON .CODE .COMSYMT .ITEM .PTYP .DAT> .COMT))>)
1628                      (<COMMON .CODE .COMSYMT .ITEM .PTYP .DAT>)>)
1629               (ELSE
1630                <COND (<==? <COMMON-TYPE .COMSYMT> REST>
1631                       (<COMMON .CODE .COMSYMT .ITEM .PTYP .DAT>
1632                        <COMMON .CODE
1633                                <COMMON-SYMT .COMSYMT>
1634                                <+ .ITEM <COMMON-ITEM .COMSYMT>>
1635                                .PTYP
1636                                .DAT>))
1637                      (<COMMON .CODE .COMSYMT .ITEM .PTYP .DAT>)>)>>
1638
1639 "ROUTINE TO FIND A COMMON GIVEN A NODE"
1640
1641 <DEFINE FIND-COMMON (NOD "OPTIONAL" (NAME <>) (NUM <>))
1642    #DECL ((NOD) NODE)
1643    <PROG RTPNT ()
1644      <MAPF <>
1645       <FUNCTION (AC "AUX" ACR)
1646          #DECL ((AC) AC)
1647          <COND
1648           (<SET ACR <ACRESIDUE .AC>>
1649            <MAPF <>
1650             <FUNCTION (ITEM)
1651                     <COND (<AND <TYPE? .ITEM COMMON>
1652                                 <COND (.NAME
1653                                        <SPEC-COMMON-EQUAL
1654                                         .NAME .NOD .NUM .ITEM>)
1655                                       (<COMMON-EQUAL .NOD .ITEM>)>>
1656                            <RETURN .ITEM .RTPNT>)>>
1657             .ACR>)>>
1658       ,ALLACS>>>
1659
1660 "ROUTINE TO SEE IF A COMMON AND A NODE ARE EQUAL"
1661
1662 <DEFINE COMMON-EQUAL (NODE COM)
1663         #DECL ((NODE) <OR NODE SYMTAB> (COM) <OR SYMTAB COMMON>)
1664         <COND (<==? .NODE .COM>)
1665               (<NOT <OR <TYPE? .NODE SYMTAB> <TYPE? .COM SYMTAB>>>
1666                <AND <EQCODE .NODE .COM>
1667                     <EQNUM .NODE .COM>
1668                     <EQKIDS .NODE .COM>>)>>
1669
1670 "ROUTINE TO SEE IF THE CODES OF THE COMMONS ARE EQUAL"
1671
1672 <DEFINE EQCODE (NODE COM "OPTIONAL" (NT <NODE-TYPE .NODE>))
1673         #DECL ((NODE) NODE (COM) COMMON)
1674         <OR <AND <==? .NT ,NTH-CODE> <==? <COMMON-TYPE .COM> NTH>>
1675             <AND <==? .NT ,REST-CODE> <==? <COMMON-TYPE .COM> REST>>>>
1676
1677 "ROUTINE TO SEE IF THE NUMBERS OF A COMMON AND A NODE ARE EQUAL"
1678
1679 <DEFINE EQNUM (NODE COM "OPTIONAL" (NUM <NODE-NAME <2 <KIDS .NODE>>>))
1680         #DECL ((NODE) NODE (COM) COMMON)
1681         <==? <COMMON-ITEM .COM> .NUM>>
1682
1683 "ROUTINE TO SEE IF THE KIDS OF A COMMON AND A NODE ARE EQUAL"
1684
1685 <DEFINE EQKIDS (NODE COM "OPTIONAL" (KID <1 <KIDS .NODE>>))
1686         #DECL ((NODE) NODE (COM) COMMON)
1687         <COMMON-EQUAL <COND (<SYMTAB? .KID T>) (.KID)>
1688                       <COMMON-SYMT .COM>>>
1689
1690 "ROUTINE TO FLUSH COMMONS IF PUTS OR PUTRESTS COME ALONG
1691  IF TYP IS FALSE THEN KILL ALL COMMONS.
1692  OTHERWISE KILL THOSE COMMONS WHICH ARE TYE SAME TYPE AS TYP OR UNKNOWN."
1693
1694 <DEFINE KILL-COMMON (PTYP)
1695         #DECL ((TYP) <OR FALSE ATOM>)
1696         <MAPF <>
1697               <FUNCTION (AC "AUX" ACR)
1698                       #DECL ((AC) AC)
1699                       <COND (<SET ACR <ACRESIDUE .AC>>
1700                              <PUT .AC ,ACRESIDUE <FLUSH-COMMONS .ACR .PTYP>>)>>
1701               ,ALLACS>>
1702
1703 "FLUSH-COMMONS IS USED TO FLUSH ALL THE COMMONS FROM AN AC"
1704
1705 <DEFINE FLUSH-COMMONS FC (ACR PTYP)
1706         #DECL ((TYP) <OR ATOM FALSE> (ACR) LIST)
1707         <REPEAT ()
1708                 <COND (<FLUSH? <1 .ACR> .PTYP>
1709                        <COND (<EMPTY? <SET ACR <REST .ACR>>> <RETURN <> .FC>)>)
1710                       (<RETURN .ACR>)>>
1711         <REPEAT ((PTR <REST .ACR>) (TOPACR .ACR))
1712                 <COND (<EMPTY? .PTR> <RETURN .TOPACR>)>
1713                 <COND (<FLUSH? <1 .PTR> .PTYP> <PUTREST .ACR <REST .PTR>>)>
1714                 <SET ACR <REST .ACR>>
1715                 <SET PTR <REST .PTR>>>>
1716
1717 "FLUSH? SEES IF A COMMON SHOULD BE FLUSHED"
1718
1719 <DEFINE FLUSH? (COM PTYP)
1720         <OR <NOT .PTYP>
1721             <AND <TYPE? .COM COMMON>
1722                  <==? <COMMON-PRIMTYPE .COM> .PTYP>>>>
1723
1724 "FLUSH-COMMON-SYMT IS USED TO FLUSH THE COMMONS ASSOCATED WITH A GIVEN SYMTAB"
1725
1726 <DEFINE FLUSH-COMMON-SYMT (SYMT)
1727    #DECL ((SYMT) SYMTAB)
1728    <MAPF <>
1729     <FUNCTION (AC "AUX" ACR)
1730             #DECL ((AC) AC)
1731             <SET ACR
1732                  <COND (<SET ACR <ACRESIDUE .AC>>
1733                         <COND (<EQSYMT <1 .ACR> .SYMT> <REST .ACR>)
1734                               (<REPEAT ((PTR <REST .ACR>) (SACR .ACR))
1735                                        <COND (<EMPTY? .PTR> <RETURN .SACR>)>
1736                                        <COND (<EQSYMT <1 .PTR> .SYMT>
1737                                               <PUTREST .ACR <REST .PTR>>
1738                                               <RETURN .SACR>)>
1739                                        <SET PTR <REST .PTR>>
1740                                        <SET ACR <REST .ACR>>>)>)>>
1741             <PUT .AC ,ACRESIDUE <COND (<EMPTY? .ACR> <>) (ELSE .ACR)>>>
1742     ,ALLACS>>
1743
1744 <DEFINE EQSYMT (ITEM SYMT "AUX" COM)
1745         <COND (<TYPE? .ITEM COMMON>
1746                <OR <==? <SET COM <COMMON-SYMT .ITEM>> .SYMT>
1747                    <EQSYMT .COM .SYMT>>)>>
1748
1749 "SEE IF NODE CONTAINS SYMTABS"
1750
1751 <DEFINE SYMTAB? (NOD "OPTIONAL" (SRCHCOM <>))
1752         #DECL ((NOD) NODE)
1753         <COND (<OR <==? <NODE-TYPE .NOD> ,LVAL-CODE>
1754                    <AND <NOT .SRCHCOM> <==? <NODE-TYPE .NOD> ,SET-CODE>>>
1755                <NODE-NAME .NOD>)>>
1756
1757 "SEE IF THIS IS A NTH OR REST OR PUT CODE"
1758
1759 <DEFINE NTH-REST-PUT? (NOD "AUX" (COD <NODE-TYPE .NOD>))
1760         #DECL ((NOD) NODE)
1761         <OR <==? .COD ,PUT-CODE>
1762             <==? .COD ,REST-CODE>
1763             <==? .COD ,NTH-CODE>>>
1764
1765 "SMASH A COMMON INTO AN DATUM"
1766
1767 <DEFINE SMASH-COMMON (COM DAT "AUX" AC)
1768         #DECL ((DAT) DATUM (COM) COMMON)
1769         <COND (<TYPE? <SET AC <DATTYP .DAT>> AC>
1770                <OR <MEMQ .COM <ACRESIDUE .AC>>
1771                    <PUT .AC ,ACRESIDUE (.COM !<ACRESIDUE .AC>)>>)>
1772         <COND (<TYPE? <SET AC <DATVAL .DAT>> AC>
1773                <OR <MEMQ .COM <ACRESIDUE .AC>>
1774                    <PUT .AC ,ACRESIDUE (.COM !<ACRESIDUE .AC>)>>)>
1775         <PUT .COM ,COMMON-DATUM <DATUM !.DAT>>>
1776
1777 <DEFINE HACK-COMMON (COD 2NARGNOD TEM WHERE W NUMKN NUM PTYP NRP
1778                      "AUX" (COM-ITEM <>) COM)
1779         #DECL ((W) DATUM)
1780         <COND (<AND <N==? .WHERE FLUSHED> <TYPE? <DATVAL .W> AC> .NUMKN>
1781                <COND (<SET COM-ITEM <SYMTAB? .2NARGNOD>>)
1782                      (.NRP <SET COM-ITEM .TEM>)>
1783                <COND (.COM-ITEM
1784                       <SET COM <BUILD-COMMON .COD .COM-ITEM .NUM .PTYP .W>>
1785                       <COND (<TYPE? .COM LIST>
1786                              <MAPF <> <FUNCTION (X) <SMASH-COMMON .X .W>> .COM>)
1787                             (<SMASH-COMMON .COM .W>)>
1788                       <SET COMMON-SUB .COM>)>)>>
1789
1790 <DEFINE FIND-COMMON-AC (AC)
1791         <COND (<TYPE? .AC AC>
1792                <MAPF <>
1793                      <FUNCTION (ITEM)
1794                              <COND (<TYPE? .ITEM COMMON> <MAPLEAVE .ITEM>)>>
1795                      <ACRESIDUE .AC>>)>>
1796
1797 <DEFINE FIND-COMMON-REST-NODE (NOD "AUX" (K <KIDS .NOD>))
1798         #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
1799         <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
1800              <FIND-COMMON <1 .K>
1801                      REST
1802                      <- <CHTYPE <NODE-NAME <2 .K>> FIX> 1>>>>
1803
1804 <DEFINE SPEC-COMMON-EQUAL (NAME KID NUM COM)
1805         #DECL ((NAME) ATOM (NUM) FIX (KID) NODE (COM) COMMON)
1806         <AND <==? <COMMON-TYPE .COM> .NAME>
1807              <EQNUM .KID .COM .NUM>
1808              <EQKIDS .KID .COM .KID>>>
1809
1810 <DEFINE COMMON-CLOBBER (TEM NOD VAL NUM OBJ TPS SAME?
1811                         "AUX" TSM (NDAT <COMMON-DATUM .TEM>)
1812                               (ETYP <GET-ELE-TYPE .OBJ .NUM>)
1813                               (VTYP <RESULT-TYPE .VAL>) ODAT VDAT AC)
1814         #DECL ((VDAT ODAT NDAT) DATUM (TEM) COMMON (NOD) NODE (NUM) FIX
1815                (VAL OBJ) NODE)
1816         <SET TSM
1817              <OR <TYPESAME .ETYP .VTYP>
1818                  <MEMQ .TPS '![STORAGE UVECTOR STRING!]>>>
1819         <SET ODAT <DATUM .TPS <DATVAL .NDAT>>>
1820         <COND (<AND <NOT .TSM> <TYPE? <SET AC <DATTYP .NDAT>> AC>> <SGETREG .AC .ODAT>)>
1821         <COND (<TYPE? <SET AC <DATVAL .NDAT>> AC> <SGETREG .AC .ODAT>)>
1822         <OR .SAME?
1823             <SET VDAT
1824              <GEN .VAL
1825                   <DATUM <COND (<NOT .TSM> ANY-AC) (FLUSHED)> ANY-AC>>>>
1826         <COND (.SAME? <SPEC-GEN .VAL .ODAT .TPS 0>)
1827               (ELSE
1828                <PUT <CHTYPE <DATVAL .VDAT> AC> ,ACPROT T>
1829                <COND (<NOT .TSM> <PUT <CHTYPE <DATTYP .VDAT> AC> ,ACPROT T>)>
1830                <COND (<NOT <TYPE? <DATVAL .ODAT> AC>> <TOACV .ODAT>)>
1831                <PUT <CHTYPE <DATVAL .VDAT> AC> ,ACPROT <>>
1832                <COND (<NOT .TSM> <PUT <CHTYPE <DATTYP .VDAT> AC> ,ACPROT <>>)>
1833                <COND (<NOT .TSM>
1834                       <EMIT <INSTRUCTION <COND (<=? .TPS LIST> `HLLM ) (ELSE `MOVEM )>
1835                                           <ACSYM <CHTYPE <DATTYP .VDAT> AC>>
1836                                           (<ADDRSYM <CHTYPE <DATVAL .ODAT> AC>>)>>)>
1837                <COND (<==? .TPS STRING>
1838                       <EMIT <INSTRUCTION `IDPB
1839                                           <ACSYM <CHTYPE <DATVAL .VDAT> AC>>
1840                                           <ADDRSYM <CHTYPE <DATVAL .ODAT> AC>>>>)
1841                      (<EMIT <INSTRUCTION `MOVEM
1842                                           <ACSYM <CHTYPE <DATVAL .VDAT> AC>>
1843                                           1
1844                                           (<ADDRSYM <CHTYPE <DATVAL .ODAT> AC>>)>>)>)>
1845         <RET-TMP-AC .VDAT>
1846         <RET-TMP-AC .ODAT>
1847         ,NO-DATUM>
1848
1849 <DEFINE LOC-COMMON (TEM NOD TPS 1ARG 2ARG WHERE "AUX" W NDAT)
1850    #DECL ((TEM) COMMON (NOD 1ARG 2ARG) NODE (WHERE W) <OR ATOM DATUM>
1851           (NDAT) DATUM)
1852    <COND (<AND <N==? .WHERE FLUSHED> <N==? .TPS STRING>>
1853           <MOVE:ARG
1854            <DATUM <OFFPTR 0 <SET NDAT <GET-COMMON-DATUM .TEM>> .TPS>
1855                   <OFFPTR 0 .NDAT .TPS>>
1856            .WHERE>)>>
1857
1858
1859 <DEFINE GET-COMMON-DATUM (COM "AUX" TEM DAT)
1860         #DECL ((COM) COMMON (DAT) DATUM)
1861         <SET DAT <DATUM !<COMMON-DATUM .COM>>>
1862         <COND (<TYPE? <SET TEM <DATTYP .DAT>> AC>
1863                <PUT .TEM ,ACLINK (.DAT !<ACLINK .TEM>)>)>
1864         <PUT <SET TEM <CHTYPE <DATVAL .DAT> AC>> ,ACLINK (.DAT !<ACLINK .TEM>)>
1865         .DAT>
1866 \f
1867 <ENDPACKAGE>