<mdl.comp>/cup.mud.57

   1 <PACKAGE "CUP">
   2
   3 <ENTRY CUP STORE:VAR STORE:TVAR CREATE-TMP KILL:STORE EMIT-PRE END-FRAME PRE
   4         STORE-TMP BEGIN-FRAME  CDUP EXP-MAC ZTMPLST PRIN-SET>
   5
   6 <USE "COMPDEC" "COMCOD">
   7
   8 <FLOAD "PUREQ.NBIN">
   9
  10 "AN SCL IS A TEMPORARY.  IT IS REPLACED BY A FIX WHICH IS A OFFSET OFF THE BASE OF THE
  11  TEMPORARIES IN THE CODE UPDATE PASS"
  12
  13 <NEWTYPE SCL WORD>
  14
  15 "A PFRAME IS A PSEUDO-FRAME GENERATED BY A PROG/REPEAT/MAPF/MAPR/FUNCTION.  IT CONTAINS
  16  INFORMATION FOR CUP'S USE."
  17
  18 <NEWTYPE PFRAME
  19          VECTOR
  20          '<<PRIMTYPE VECTOR> ATOM
  21                              <OR ATOM FALSE>
  22                              <OR ATOM FALSE>
  23                              LIST
  24                              LIST
  25                              FIX
  26                              LIST>>
  27
  28 <MANIFEST NAME-PF ACT-PF PRE-PF TEMPS-PF KIDS-PF NTEMPS-PF TMP-STR-PF>
  29
  30 <SETG NAME-PF 1>
  31
  32 <SETG ACT-PF 2>
  33
  34 <SETG PRE-PF 3>
  35
  36 <SETG TEMPS-PF 4>
  37
  38 <SETG KIDS-PF 5>
  39
  40 <SETG NTEMPS-PF 6>
  41
  42 <SETG TMP-STR-PF 7>
  43
  44 "A TEMPB DESCRIBES A TEMPORARY"
  45
  46 <NEWTYPE TEMPB
  47          VECTOR
  48          '<<PRIMTYPE VECTOR> SCL LIST FIX FIX FIX <OR ATOM FALSE> LIST>>
  49
  50 <MANIFEST ID-TMP REF-TMP LOC-TMP HI-TMP LO-TMP TYP-TMP STORE-TEMP>
  51
  52 <SETG ID-TMP 1>
  53
  54 <SETG REF-TMP 2>
  55
  56 <SETG LOC-TMP 5>
  57
  58 <SETG HI-TMP 3>
  59
  60 <SETG LO-TMP 4>
  61
  62 <SETG TYP-TMP 6>
  63
  64 <SETG STORE-TEMP 7>
  65
  66
  67 <MANIFEST BEGIN:FRAME
  68           END:FRAME
  69           CREATE:TEMP
  70           EMIT:PRE
  71           STORE:TMP
  72           STORE:VAR
  73           STORE:TVAR
  74           KILL:STORE>
  75
  76 <SETG BEGIN:FRAME 1>
  77
  78 <SETG END:FRAME 2>
  79
  80 <SETG CREATE:TEMP 3>
  81
  82 <SETG EMIT:PRE 5>
  83
  84 <SETG STORE:VAR 4>
  85
  86 <SETG STORE:TVAR 8>
  87
  88 <SETG KILL:STORE 7>
  89
  90 <SETG STORE:TMP 6>
  91
  92 "BEGIN-FRAME STARTS A FRAME.  IT TAKES 3 ARGUMENTS:
  93         1) ATOM LATER SETG'd TO LENGTH OF TEMPORARY BLOCK
  94         2) FLAG INDICATING WHETHER THE FRAME IS ACTIVATED
  95         3) FLAG INDICATING WHETHER PRE-ALLOCATION IS TO BEGIN"
  96
  97 <DEFINE BEGIN-FRAME (NM ACT PRE)
  98         <EMIT <CHTYPE [,BEGIN:FRAME .NM .ACT .PRE] TOKEN>>>
  99
 100 "END-FRAME ENDS A FRAME."
 101
 102 <DEFINE END-FRAME () <EMIT <CHTYPE [,END:FRAME] TOKEN>>>
 103
 104 "CREATE-TMP CREATES A TEMPORARY AND RETURNS THE ID OF IT"
 105
 106 <DEFINE CREATE-TMP (TYP)
 107         <EMIT <CHTYPE [,CREATE:TEMP <CHTYPE <SET IDT <+ .IDT 1>> SCL> .TYP]
 108                       TOKEN>>
 109         <CHTYPE .IDT SCL>>
 110
 111 <DEFINE EMIT-PRE (PRE) <EMIT <CHTYPE [,EMIT:PRE .PRE] TOKEN>>>
 112
 113 <DEFINE STORE-TMP (TYP VAL ADR)
 114         <EMIT <CHTYPE [,STORE:TMP .ADR T .TYP .VAL] TOKEN>>>
 115
 116 \\f
 117
 118 <DEFINE CDUP (COD "AUX" (CPTR .COD) (MODEL (())) (REMOVES (())) (SNO 0))
 119         #DECL ((COD) LIST (MODEL REMOVES CPTR) <SPECIAL LIST>
 120                (SNO) <SPECIAL FIX>)
 121         <PASS:1 .MODEL <> ()>
 122         <PASS:2 .MODEL>
 123         <PASS:3 .COD .MODEL>>
 124
 125 "PASS:1 SETS UP THE INITIAL MODEL FOR CUP.  IT ALSO DETERMINES WHICH VARIABLES ARE TO BE
 126  KEPT BY USING A MARK-BIT IN THE TEMPORARY DESCRIPTORS."
 127
 128 <DEFINE PASS:1 (MODEL PCFRAM VARLST "AUX" FD (CFRAM <>))
 129    #DECL ((VALUE) PFRAME (CPTR COD) LIST (CFRAM) <OR FALSE PFRAME>)
 130    <REPEAT RETPNT (INST TOKCOD FD)
 131      #DECL ((SNO) FIX (TOKCOD) FIX)
 132      <SET INST <1 .CPTR>>
 133      <SET SNO <+ .SNO 1>>
 134      <COND (<TYPE? .INST ATOM>)
 135            (<TYPE? .INST TOKEN>
 136             <COND (<NOT <OR <==? <SET TOKCOD <1 .INST>> ,STORE:TMP>
 137                             <==? .TOKCOD ,STORE:VAR>
 138                             <==? .TOKCOD ,STORE:TVAR>>>
 139                    <SET REMOVES <ADDON (.CPTR) .REMOVES>>)>
 140             <CASE ,==?
 141                   .TOKCOD
 142                   (,BEGIN:FRAME
 143                    <COND (.CFRAM <PASS:1 .MODEL .CFRAM .VARLST>)
 144                          (ELSE
 145                           <SET CFRAM
 146                                <CHTYPE [<2 .INST>
 147                                         <3 .INST>
 148                                         <4 .INST>
 149                                         (())
 150                                         ()
 151                                         0
 152                                         ()]
 153                                        PFRAME>>
 154                           <COND (.PCFRAM
 155                                  <PUT .PCFRAM
 156                                       ,KIDS-PF
 157                                       (.CFRAM !<KIDS-PF .PCFRAM>)>)
 158                                 (<PUT .MODEL 1 .CFRAM>)>)>)
 159                   (,END:FRAME <RETURN .CFRAM .RETPNT>)
 160                   (,STORE:VAR <SET VARLST (<2 .INST> .CPTR !.VARLST)>)
 161                   (,KILL:STORE <NULLIFY .VARLST <2 .INST>>)
 162                   (,CREATE:TEMP
 163                    <PUT .CFRAM
 164                         ,TEMPS-PF
 165                         <ADDON (<CHTYPE [<2 .INST> () 0 .SNO 0 <3 .INST> ()]
 166                                         TEMPB>)
 167                                <TEMPS-PF .CFRAM>>>)
 168                   (,EMIT:PRE <PUT .CFRAM ,PRE-PF <2 .INST>>)
 169                   (,STORE:TMP
 170                    <PUT <SET FD
 171                              <COND (<FIND-TMP <FX <2 .INST>> <1 .MODEL>>)
 172                                    (<MESSAGE INCONSISTENCY "LOST TEMPORARY">)>>
 173                         ,STORE-TEMP
 174                         (.CPTR .SNO !<STORE-TEMP .FD>)>)
 175                   (,STORE:TVAR
 176                    <COND (<SET FD <FIND-TMP <FX <3 .INST>> <1 .MODEL>>>
 177                           <COND (<EMPTY? <REF-TMP .FD>> <PUT .FD ,HI-TMP .SNO>)
 178                                 (<PUT .FD ,HI-TMP <CHTYPE <MIN> FIX>>)>
 179                           <PUT .FD
 180                                ,STORE-TEMP
 181                                (.CPTR .SNO !<STORE-TEMP .FD>)>)
 182                          (ELSE <MESSAGE INCONSISTENCY "LOST VARIABLE">)>
 183                    <SET VARLST (<2 .INST> .CPTR !.VARLST)>)
 184                   DEFAULT
 185                   (<MESSAGE INCONSISTENCY "BAD TOKEN TO CUP">)>)
 186            (<SET FD <FX .INST>>
 187             <COND (<SET FD <FIND-TMP .FD <1 .MODEL>>>
 188                    <PUT .FD ,REF-TMP (.CPTR !<REF-TMP .FD>)>
 189                    <COND (<L? .SNO <HI-TMP .FD>>) (<PUT .FD ,HI-TMP .SNO>)>)
 190                   (<MESSAGE INCONSISTENCY "VARIABLE NOT FOUND">)>)>
 191      <COND (<EMPTY? <SET CPTR <REST .CPTR>>>
 192             <MESSAGE INCONSISTENCY "UNBALENCED STACK MODEL">)>>
 193    <FIXUP-VARLST .VARLST>
 194    .CFRAM>
 195
 196 <DEFINE FIXUP-VARLST (VARLST)
 197         #DECL ((VARLST) LIST)
 198         <REPEAT ((VP .VARLST) VAR)
 199                 <COND (<EMPTY? .VP> <RETURN>)
 200                       (<AND <TYPE? <SET VAR <1 <2 .VP>>> TOKEN>
 201                             <==? <1 .VAR> ,STORE:VAR>>
 202                        <PUT <2 .VP>
 203                             1
 204                             <INSTRUCTION STORE-MTEMP
 205                                          <3 .VAR>
 206                                          <6 .VAR>
 207                                          <4 .VAR>
 208                                          <5 .VAR>>>)>
 209                 <SET VP <REST .VP 2>>>>
 210
 211 <DEFINE NULLIFY (MNLST ITEM)
 212         #DECL ((MNLST) <OR FALSE LIST>)
 213         <COND (<SET MNLST <MEMQ .ITEM .MNLST>>
 214                <PUT .MNLST 1 <>>
 215                <PUT <2 .MNLST> 1 '<NULL-MACRO>>)>>
 216
 217 <DEFINE FX (SC)
 218         <COND (<STRUCTURED? .SC>
 219                <MAPF <>
 220                      <FUNCTION (X "AUX" QD)
 221                              <COND (<SET QD <FX .X>> <MAPLEAVE .QD>)>>
 222                      .SC>)
 223               (<TYPE? .SC SCL> .SC)>>
 224
 225 "FIND-TMP LOOKS FOR A TEMPORARY.  IF IT DOESN'T FIND IT AND ERR IS T IT CAUSES AN ERROR"
 226
 227 <DEFINE FIND-TMP (ID CFRAM "AUX" XD)
 228         #DECL ((ID) SCL (CFRAM) PFRAME)
 229         <COND (<MAPF <>
 230                      <FUNCTION (VL)
 231                              #DECL ((VL) TEMPB)
 232                              <COND (<EMPTY? .VL>)
 233                                    (<==? <ID-TMP .VL> .ID> <MAPLEAVE .VL>)>>
 234                      <REST <TEMPS-PF .CFRAM>>>)
 235               (<MAPF <>
 236                      <FUNCTION (FRM "AUX" VAL)
 237                              #DECL ((FRM) PFRAME)
 238                              <COND (<SET VAL <FIND-TMP .ID .FRM>>
 239                                     <MAPLEAVE .VAL>)>>
 240                      <KIDS-PF .CFRAM>>)>>
 241
 242 \\f
 243
 244 "THIS IS PASS2 OF THE VARIABLE ALLOCATION PROCESS.  DURING THIS PHASE VARIABLES AND
 245  TEMPORARIES ARE ASSIGNED SLOTS ON THE STACK AND THE LENGTH OF THE BTP'S BECOMES
 246  KNOWN.  NO CODE UPDATE IS DONE DURING THIS PHASE."
 247
 248 <DEFINE PASS:2 (MODEL) #DECL ((MODEL) <LIST PFRAME>) <VAR-ALLOC <1 .MODEL>>>
 249
 250 "THIS ROUTINE ACTUALLY DOES THE ALLOCATION OF VARIBLES.  IF IT MUST DO PREALLOCATION
 251  IT CALLS PRE-ALLOC-VAR."
 252
 253 <DEFINE VAR-ALLOC (FRM "AUX" SLOTS)
 254         #DECL ((FRM) PFRAME (SLOTS) LIST)
 255         <COND (<PRE-PF .FRM> <PRE-ALLOC-VAR1 .FRM>)
 256               (ELSE
 257                <SET SLOTS <SLOTFIX <REST <TEMPS-PF .FRM>>>>
 258                <PUT .FRM ,TMP-STR-PF .SLOTS>
 259                <PUT .FRM ,NTEMPS-PF <* <LENGTH .SLOTS> 2>>
 260                <MAPF <>
 261                      <FUNCTION (FRM) #DECL ((FRM) PFRAME) <VAR-ALLOC .FRM>>
 262                      <KIDS-PF .FRM>>)>>
 263
 264 "THIS ROUTINE TAKES A LIST OF TEMPORARIES AND ALLOCATES THERE SPACE ON THE STACK.
 265  IT TRIES TO KEEP TEMPORARIES OF THE SAME TYPE TOGETHER THOUGH ITS MAIN GOAL IS
 266  TO MINIMIZE THE NUMBER OF TEMPORARIES.  IT RETURNS A LIST OF THE TYPES OF THE
 267  TEMPORARIES. A FALSE MEANS THAT THE TYPE CANNOT BE PRE-ALLOCATED."
 268
 269 <DEFINE SLOTFIX (VARLST "AUX" (NVRLST ()) (SLOTS 0))
 270    #DECL ((VARLST) LIST (SLOTS) FIX (NVRLST) <LIST [REST LIST]>)
 271    <MAPF <>
 272     <FUNCTION (TMP)
 273        #DECL ((TMP) TEMPB)
 274        <COND
 275         (<NOT <EMPTY? <REF-TMP .TMP>>>
 276          <COND (<MAPF <>
 277                       <FUNCTION (TMPLST)
 278                               #DECL ((TMPLST) <LIST <OR FALSE ATOM> TEMPB>)
 279                               <COND (<AND <TYP-TMP .TMP>
 280                                           <==? <TYP-TMP .TMP> <1 .TMPLST>>
 281                                           <FITTMP .TMP <2 .TMPLST>>>
 282                                      <PUT .TMPLST 2 .TMP>
 283                                      <MAPLEAVE T>)>>
 284                       .NVRLST>)
 285                (<MAPF <>
 286                       <FUNCTION (TMPLST)
 287                               #DECL ((TMPLST) <LIST <OR FALSE ATOM> TEMPB>)
 288                               <COND (<FITTMP .TMP <2 .TMPLST>>
 289                                      <PUT .TMPLST 1 <>>
 290                                      <PUT .TMPLST 2 .TMP>
 291                                      <MAPLEAVE T>)>>
 292                       .NVRLST>)
 293                (ELSE
 294                 <SET NVRLST ((<TYP-TMP .TMP> .TMP) !.NVRLST)>
 295                 <PUT .TMP ,LOC-TMP .SLOTS>
 296                 <SET SLOTS <+ .SLOTS 2>>)>)>>
 297     .VARLST>
 298    <LREVERSE <MAPF ,LIST 1 .NVRLST>>>
 299
 300 <DEFINE FITTMP (VAR CMPVAR "AUX" (SHI <HI-TMP .VAR>) (SLO <LO-TMP .VAR>))
 301         #DECL ((SLO) FIX (VAR CMPVAR) TEMPB)
 302         <COND (<G? .SLO <HI-TMP .CMPVAR>>
 303                <PUT .VAR ,LOC-TMP <LOC-TMP .CMPVAR>>
 304                <PUT .VAR ,LO-TMP <LO-TMP .CMPVAR>>)
 305               (<L? .SHI <LO-TMP .CMPVAR>>
 306                <PUT .VAR ,LOC-TMP <LOC-TMP .CMPVAR>>
 307                <PUT .VAR ,HI-TMP <HI-TMP .CMPVAR>>)>>
 308
 309 "THIS ROUTINE DOES PRE-ALLOCATION.  THE TOP FRAME GETS THE STRUCTURE AND
 310  THE OTHER FRAMES ARE IGNORED (THEIR TEMPS ARE ALLOCATED IN THE FIRST FRAME)."
 311
 312 <DEFINE PRE-ALLOC-VAR1 (FRM "AUX" (SLOTS ()))
 313         #DECL ((FRM) PFRAME (SLOTS) LIST)
 314         <SET SLOTS <PRE-ALLOC-VAR .FRM .SLOTS T>>
 315         <SET SLOTS <SLOTFIX .SLOTS>>
 316         <PUT .FRM ,NTEMPS-PF <* <LENGTH .SLOTS> 2>>
 317         <PUT .FRM ,TMP-STR-PF .SLOTS>>
 318
 319 <DEFINE PRE-ALLOC-VAR (FRM SLOTS "OPTIONAL" (FIRST? <>))
 320         #DECL ((FRM) PFRAME (SLOTS) LIST)
 321         <COND (<AND <NOT .FIRST?> <ACT-PF .FRM>> <VAR-ALLOC .FRM> .SLOTS)
 322               (<SET SLOTS (!<REST <TEMPS-PF .FRM>> !.SLOTS)>
 323                <MAPF <>
 324                      <FUNCTION (FRM) <SET SLOTS <PRE-ALLOC-VAR .FRM .SLOTS>>>
 325                      <KIDS-PF .FRM>>
 326                .SLOTS)>>
 327
 328 \\f
 329
 330 "PASS:3 OF CUP FIXES UP THE REFERENCES TO TEMPORARIES, FIXES UP THE CODE AND
 331  ADDS THE PSEUDO-SETG'S."
 332
 333 <DEFINE PASS:3 (COD MODEL "AUX" (LFRAM <1 .MODEL>) (NPS ()) (PS ()))
 334         #DECL ((NPS) <LIST [REST FORM]> (MODEL) <LIST PFRAME> (COD) LIST
 335                (PS) <SPECIAL LIST>)
 336         <FIXIT .LFRAM <PRE-PF .LFRAM> T>
 337         <REPEAT ()
 338                 <COND (<EMPTY? .PS> <RETURN>)>
 339                 <SET NPS
 340                      (<FORM PSEUDO!-OP!-PACKAGE <FORM SETG <1 .PS> <2 .PS>>>
 341                       !.NPS)>
 342                 <SET PS <REST .PS 2>>>
 343         <ADDON <UPD .REMOVES .COD> .NPS>>
 344
 345 <DEFINE FIXIT (FRM PRE "OPTIONAL" (FIRST? <>) "AUX" LX)
 346    #DECL ((LX) LIST (FRM) PFRAME (PS) LIST (ADDS REMOVES) LIST)
 347    <COND (<AND <NOT .FIRST?> <ACT-PF .FRM>> <SET PRE <PRE-PF .FRM>>)>
 348    <COND (<NOT <AND .PRE <NOT <PRE-PF .FRM>>>>
 349           <SET PS <ADDON (<NAME-PF .FRM> <NTEMPS-PF .FRM>) .PS>>
 350           <SETG TMPLST
 351                 <ADDON ,TMPLST (<NAME-PF .FRM> <TMP-STR-PF .FRM>)>>)>
 352    <MAPF <>
 353     <FUNCTION (VAR
 354                "AUX" (NUM <LOC-TMP .VAR>) (SC <ID-TMP .VAR>)
 355                      (LADJ <REF-TMP .VAR>))
 356        #DECL ((SC) SCL (NUM) FIX (LADJ) LIST (VAR) TEMPB)
 357        <MAPF <>
 358              <FUNCTION (IT)
 359                      #DECL ((IT) <PRIMTYPE LIST>)
 360                      <COND (<NOT <EMPTY? .IT>> <ADDIT .SC <1 .IT> .NUM>)>>
 361              .LADJ>
 362        <REPEAT ((PTR <STORE-TEMP .VAR>) (HT <HI-TMP .VAR>) XX)
 363                <COND (<EMPTY? .PTR> <RETURN>)>
 364                <COND
 365                 (<AND <NOT <EMPTY? <REF-TMP .VAR>>> <L=? <2 .PTR> .HT>>
 366                  <SET XX <1 <1 .PTR>>>
 367                  <COND (<NOT <=? .XX '<NULL-MACRO>>>
 368                         <COND (<==? <1 .XX> ,STORE:TMP>
 369                                <SET XX
 370                                     <INSTRUCTION STORE-MTEMP
 371                                                  <2 .XX>
 372                                                  <3 .XX>
 373                                                  <4 .XX>
 374                                                  <5 .XX>>>)
 375                               (<==? <1 .XX> ,STORE:TVAR>
 376                                <SET XX
 377                                     <INSTRUCTION STORE-MTEMP
 378                                                  <3 .XX>
 379                                                  <6 .XX>
 380                                                  <4 .XX>
 381                                                  <5 .XX>>>)
 382                               (<MESSAGE INCONSISTENCY "BAD STORE">)>
 383                         <ADDIT .SC .XX .NUM>
 384                         <PUT .XX 3 <NTH <2 ,TMPLST> <+ </ <LOC-TMP .VAR> 2> 1>>>
 385                         <PUT <1 .PTR> 1 .XX>)>)
 386                 (<PUT <1 .PTR> 1 '<NULL-MACRO>>)>
 387                <SET PTR <REST .PTR 2>>>>
 388     <REST <TEMPS-PF .FRM>>>
 389    <COND (<SET LX <KIDS-PF .FRM>>
 390           <MAPF <>
 391                 <FUNCTION (X) <FIXIT .X <COND (.PRE .PRE) (ELSE <PRE-PF .X>)>>>
 392                 .LX>)>>
 393
 394 <DEFINE ADDIT (SC FRM NUM)
 395    #DECL ((NUM) FIX)
 396    <COND
 397     (<STRUCTURED? .FRM>
 398      <MAPF <>
 399            <FUNCTION (X)
 400                    <COND (<ADDIT .SC .X .NUM>
 401                           <MAPR <>
 402                                 <FUNCTION (X)
 403                                         <COND (<==? <1 .X> .SC>
 404                                                <PUT .X 1 .NUM>)>>
 405                                 .FRM>)>>
 406            .FRM>)
 407     (<==? .FRM .SC>)>>
 408
 409 \\f
 410
 411 <DEFINE PRIN-SET ("AUX" (UVEC <IVECTOR ,TOKEN-MAX "#TOKEN <">))
 412         <PRINTTYPE SCL ,SCL-PRINT>
 413         <PRINTTYPE TOKEN ,TOKEN-PRINT>
 414         <REPEAT ((TPS ,TOKENS) CNT ITEM)
 415                 <SET ITEMS <1 .TPS>>
 416                 <SET CNT <1 .ITEMS>>
 417                 <PUT .UVEC .CNT <2 .ITEMS>>
 418                 <COND (<EMPTY? <SET TPS <REST .TPS>>> <RETURN>)>>
 419         <SETG TOKEN-TABLE .UVEC>>
 420
 421 <GDECL (TOKEN-MAX)
 422        FIX
 423        (TOKENS)
 424        <LIST [REST LIST]>
 425        (TOKEN-TABLE)
 426        <VECTOR [REST STRING]>>
 427
 428 <SETG TOKEN-MAX 10>
 429
 430 <SETG TOKENS
 431       ((,EMIT:PRE "EMIT:PRE")
 432        (,STORE:VAR "STORE:VAR")
 433        (,CREATE:TEMP "CREATE:TEMPORARY")
 434        (,KILL:STORE "KILL:STORE")
 435        (,STORE:TMP "STORE:TEMPORARY")
 436        (,BEGIN:FRAME "BEGIN:FRAME")
 437        (,END:FRAME "END:FRAME")
 438        (,STORE:TVAR "STORE:TVARIABLE"))>
 439
 440 <DEFINE SCL-PRINT (X)
 441         #DECL ((X) SCL)
 442         <PRINC "TEMPORARY:">
 443         <PRIN1 <CHTYPE .X FIX>>>
 444
 445 <DEFINE MAP-PRINT (X)
 446         #DECL ((X) STRUCTURED)
 447         <MAPF <> <FUNCTION (X) <PRINC !" > <PRIN1 .X>> .X>>
 448
 449 <DEFINE TOKEN-PRINT (X)
 450         #DECL ((X) TOKEN)
 451         <COND (<L? <1 .X> ,TOKEN-MAX>
 452                <PRINC "<">
 453                <PRINC <NTH ,TOKEN-TABLE <1 .X>>>)
 454               (ELSE <PRINC "#TOKEN <"> <PRIN1 <1 .X>>)>
 455         <MAP-PRINT <REST .X>>
 456         <PRINC !">>>
 457
 458
 459
 460 <DEFINE UPD (REMOVES QCOD)
 461         #DECL ((QCOD REMOVES) <PRIMTYPE LIST>)
 462         <REPEAT ((TEMP1 .QCOD) (CPTR .QCOD))
 463                 #DECL ((CD) FIX (CPTR QCOD) LIST)
 464                 <AND <EMPTY? .CPTR> <RETURN>>
 465                 <MAPF <>
 466                       <FUNCTION (REMOVES)
 467                               <AND <==? .REMOVES .CPTR>
 468                                    <COND (<==? .QCOD .CPTR>
 469                                           <SET QCOD <REST .QCOD>>)
 470                                          (ELSE
 471                                           <PUTREST .TEMP1 <REST .CPTR>>
 472                                           <SET CPTR .TEMP1>)>>>
 473                       .REMOVES>
 474                 <SET TEMP1 .CPTR>
 475                 <SET CPTR <REST .CPTR>>>
 476         .QCOD>
 477
 478 <DEFINE LREVERSE (TEM "AUX" LST VAL TMP)
 479         #DECL ((LST) LIST)
 480         <SET LST .TEM>
 481         <SET VAL ()>
 482         <REPEAT ()
 483                 <COND (<EMPTY? .LST> <RETURN .VAL>)>
 484                 <SET TMP <REST .LST>>
 485                 <SET VAL <PUTREST .LST .VAL>>
 486                 <SET LST .TMP>>>
 487
 488 \\f
 489
 490 "THIS ROUTINE CALLED AT ASSEMBLY TIME ALLOCATES SLOTS FOR THE TEMPORARIES."
 491
 492 <DEFINE ALLOCATE:SLOTS (ATM "OPTIONAL" (FXI 0) "AUX" XX (SPL ()))
 493  #DECL ((SPL) LIST (ATM) <OR ATOM FIX> (FXI) FIX)
 494    <COND
 495     (<TYPE? .ATM FIX> <SET SPL <FIXAD .ATM>>)
 496     (ELSE
 497      <REPEAT ((SLTS <2 <MEMQ .ATM ,TMPLST>>))
 498        <COND (<EMPTY? .SLTS>
 499               <SET SPL <ADDON <FIXAD .FXI> .SPL>>
 500               <SET FXI 0>
 501               <RETURN>)
 502              (<SET XX <1 .SLTS>>
 503               <SET SPL <ADDON <FIXAD .FXI> .SPL>>
 504               <SET FXI 0>
 505               <SET SPL
 506                    <ADDON (<INSTRUCTION
 507                             `PUSH `TP* <FORM TYPE-WORD!-OP!-PACKAGE .XX>>
 508                            <INSTRUCTION `PUSH `TP* [0]>)
 509                           .SPL>>)
 510              (<SET FXI <+ .FXI 2>>)>
 511        <SET SLTS <REST .SLTS>>>)>
 512    <CHTYPE .SPL SPLICE>>
 513
 514 <DEFINE FIXAD (NUM)
 515         #DECL ((NUM) FIX)
 516         <COND (<0? .NUM> ())
 517               (<L? .NUM 5> <ILIST .NUM ''<`PUSH `TP* [0]>>)
 518               ((<INSTRUCTION `MOVEI `O* .NUM>
 519                 <INSTRUCTION `PUSHJ `P* |NTPALO>))>>
 520
 521 <DEFINE ZTMPLST () <SETG TMPLST ()>>
 522
 523 <DEFINE STORE-MTEMP (TMPADR TMPPRED TYP VALUE)
 524    <CHTYPE
 525     (!<COND (.TMPPRED (<INSTRUCTION `MOVEM  .VALUE !.TMPADR 1>))
 526             (ELSE
 527              <COND (<AND <TYPE? .TYP ATOM> <VALID-TYPE? .TYP>>
 528                     (<INSTRUCTION `MOVE  `O  <FORM TYPE-WORD!-OP!-PACKAGE .TYP>>
 529                      <INSTRUCTION `MOVEM  `O  !.TMPADR>
 530                      <INSTRUCTION `MOVEM  .VALUE !.TMPADR 1>))
 531                    (<STRUCTURED? .TYP>
 532                     (<INSTRUCTION `MOVE  `O  !<ADDR:TYPE1 .TYP>>
 533                      <INSTRUCTION `MOVEM  `O  !.TMPADR>
 534                      <INSTRUCTION `MOVEM  .VALUE !.TMPADR 1>))
 535                    (ELSE
 536                     (<INSTRUCTION `MOVEM  .TYP !.TMPADR>
 537                      <INSTRUCTION `MOVEM  .VALUE !.TMPADR 1>))>)>)
 538     SPLICE>>
 539
 540 <DEFINE NULL-MACRO () <CHTYPE () SPLICE>>
 541
 542 <DEFINE DEALLOCATE (LST "AUX" (NUM <+ !.LST>))
 543         <COND (<0? .NUM> #SPLICE ())
 544               (<CHTYPE (<INSTRUCTION `SUB  `TP*  <VECTOR <FORM (.NUM) .NUM>>>)
 545                        SPLICE>)>>
 546
 547 "FUNCTION TO EXPAND THE MACROS IN THE SOURCE GENERATED BY THE COMPILER.
 548  SHOULD BE CALLED AFTER CUP."
 549
 550 <DEFINE EXP-MAC (CODE "AUX" (CP <REST .CODE>) (TC .CODE) TC1)
 551    #DECL ((CODE CP TC) LIST)
 552    <REPEAT (ELE FRST)
 553      <COND
 554       (<TYPE? <SET ELE <1 .CP>> FORM>
 555        <COND
 556         (<TYPE? <SET FRST <1 .ELE>> ATOM>
 557          <COND
 558           (<==? .FRST PSEUDO!-OP!-PACKAGE> <EVAL <2 .ELE>>)
 559           (<==? <GET <OBLIST? .FRST> OBLIST> OP!-PACKAGE>)
 560           (<==? .FRST TITLE>)
 561           (<GASSIGNED? .FRST>
 562            <COND
 563             (<TYPE? <SET ELE <EVAL .ELE>> SPLICE>
 564              <COND
 565               (<EMPTY? .ELE> <PUTREST .TC <SET CP <REST .CP>>> <AGAIN>)
 566               (ELSE
 567                <PUTREST <SET TC1 <CHTYPE <REST .ELE <- <LENGTH .ELE> 1>> LIST>>
 568                         <REST .CP>>
 569                <PUTREST .TC .ELE>
 570                <SET CP <CHTYPE .ELE LIST>>
 571                <AGAIN>)>)>)>)
 572         (<NOT <PUREQ .ELE>>
 573          <PROG ((NUM 0))
 574                <REPEAT ((PTR .ELE) (RPTR <REST .ELE>) ELE)
 575                        #DECL ((PTR RPTR) <PRIMTYPE LIST> (NUM) FIX)
 576                        <COND (<EMPTY? .RPTR> <RETURN>)>
 577                        <COND (<AND <TYPE? <SET ELE <1 .RPTR>> FORM>
 578                                    <OR <==? <1 .ELE> -> <==? <1 .ELE> GVAL>>>
 579                               <SET ELE <EVAL .ELE>>)>
 580                        <COND (<TYPE? .ELE FIX>
 581                               <SET NUM <+ .NUM .ELE>>
 582                               <PUTREST .PTR <SET RPTR <REST .RPTR>>>
 583                               <AGAIN>)>
 584                        <SET PTR <REST .PTR>>
 585                        <SET RPTR <REST .RPTR>>>
 586                <COND (<NOT <0? .NUM>>
 587                       <PUTREST <REST .ELE <- <LENGTH .ELE> 1>> (.NUM)>)>>)>)>
 588      <COND (<EMPTY? <SET CP <REST .CP>>> <RETURN>)>
 589      <SET TC <REST .TC>>>
 590    .CODE>
 591 \f
 592 <DEFINE ADDON (AD OB)
 593         #DECL ((AD OB) <PRIMTYPE LIST>)
 594         <COND (<EMPTY? .OB> .AD)
 595               (ELSE <PUTREST <REST .OB <- <LENGTH .OB> 1>> .AD> .OB)>>
 596
 597
 598 <ENDPACKAGE>