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>
6 <USE "COMPDEC" "COMCOD">
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"
15 "A PFRAME IS A PSEUDO-FRAME GENERATED BY A PROG/REPEAT/MAPF/MAPR/FUNCTION. IT CONTAINS
16 INFORMATION FOR CUP'S USE."
20 '<<PRIMTYPE VECTOR> ATOM
28 <MANIFEST NAME-PF ACT-PF PRE-PF TEMPS-PF KIDS-PF NTEMPS-PF TMP-STR-PF>
44 "A TEMPB DESCRIBES A TEMPORARY"
48 '<<PRIMTYPE VECTOR> SCL LIST FIX FIX FIX <OR ATOM FALSE> LIST>>
50 <MANIFEST ID-TMP REF-TMP LOC-TMP HI-TMP LO-TMP TYP-TMP STORE-TEMP>
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"
97 <DEFINE BEGIN-FRAME (NM ACT PRE)
98 <EMIT <CHTYPE [,BEGIN:FRAME .NM .ACT .PRE] TOKEN>>>
100 "END-FRAME ENDS A FRAME."
102 <DEFINE END-FRAME () <EMIT <CHTYPE [,END:FRAME] TOKEN>>>
104 "CREATE-TMP CREATES A TEMPORARY AND RETURNS THE ID OF IT"
106 <DEFINE CREATE-TMP (TYP)
107 <EMIT <CHTYPE [,CREATE:TEMP <CHTYPE <SET IDT <+ .IDT 1>> SCL> .TYP]
111 <DEFINE EMIT-PRE (PRE) <EMIT <CHTYPE [,EMIT:PRE .PRE] TOKEN>>>
113 <DEFINE STORE-TMP (TYP VAL ADR)
114 <EMIT <CHTYPE [,STORE:TMP .ADR T .TYP .VAL] TOKEN>>>
118 <DEFINE CDUP (COD "AUX" (CPTR .COD) (MODEL (())) (REMOVES (())) (SNO 0))
119 #DECL ((COD) LIST (MODEL REMOVES CPTR) <SPECIAL LIST>
121 <PASS:1 .MODEL <> ()>
123 <PASS:3 .COD .MODEL>>
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."
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)
134 <COND (<TYPE? .INST ATOM>)
136 <COND (<NOT <OR <==? <SET TOKCOD <1 .INST>> ,STORE:TMP>
137 <==? .TOKCOD ,STORE:VAR>
138 <==? .TOKCOD ,STORE:TVAR>>>
139 <SET REMOVES <ADDON (.CPTR) .REMOVES>>)>
143 <COND (.CFRAM <PASS:1 .MODEL .CFRAM .VARLST>)
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>>)
165 <ADDON (<CHTYPE [<2 .INST> () 0 .SNO 0 <3 .INST> ()]
168 (,EMIT:PRE <PUT .CFRAM ,PRE-PF <2 .INST>>)
171 <COND (<FIND-TMP <FX <2 .INST>> <1 .MODEL>>)
172 (<MESSAGE INCONSISTENCY "LOST TEMPORARY">)>>
174 (.CPTR .SNO !<STORE-TEMP .FD>)>)
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>>)>
181 (.CPTR .SNO !<STORE-TEMP .FD>)>)
182 (ELSE <MESSAGE INCONSISTENCY "LOST VARIABLE">)>
183 <SET VARLST (<2 .INST> .CPTR !.VARLST)>)
185 (<MESSAGE INCONSISTENCY "BAD TOKEN TO CUP">)>)
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>
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>>
204 <INSTRUCTION STORE-MTEMP
209 <SET VP <REST .VP 2>>>>
211 <DEFINE NULLIFY (MNLST ITEM)
212 #DECL ((MNLST) <OR FALSE LIST>)
213 <COND (<SET MNLST <MEMQ .ITEM .MNLST>>
215 <PUT <2 .MNLST> 1 '<NULL-MACRO>>)>>
218 <COND (<STRUCTURED? .SC>
220 <FUNCTION (X "AUX" QD)
221 <COND (<SET QD <FX .X>> <MAPLEAVE .QD>)>>
223 (<TYPE? .SC SCL> .SC)>>
225 "FIND-TMP LOOKS FOR A TEMPORARY. IF IT DOESN'T FIND IT AND ERR IS T IT CAUSES AN ERROR"
227 <DEFINE FIND-TMP (ID CFRAM "AUX" XD)
228 #DECL ((ID) SCL (CFRAM) PFRAME)
233 (<==? <ID-TMP .VL> .ID> <MAPLEAVE .VL>)>>
234 <REST <TEMPS-PF .CFRAM>>>)
236 <FUNCTION (FRM "AUX" VAL)
238 <COND (<SET VAL <FIND-TMP .ID .FRM>>
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."
248 <DEFINE PASS:2 (MODEL) #DECL ((MODEL) <LIST PFRAME>) <VAR-ALLOC <1 .MODEL>>>
250 "THIS ROUTINE ACTUALLY DOES THE ALLOCATION OF VARIBLES. IF IT MUST DO PREALLOCATION
251 IT CALLS PRE-ALLOC-VAR."
253 <DEFINE VAR-ALLOC (FRM "AUX" SLOTS)
254 #DECL ((FRM) PFRAME (SLOTS) LIST)
255 <COND (<PRE-PF .FRM> <PRE-ALLOC-VAR1 .FRM>)
257 <SET SLOTS <SLOTFIX <REST <TEMPS-PF .FRM>>>>
258 <PUT .FRM ,TMP-STR-PF .SLOTS>
259 <PUT .FRM ,NTEMPS-PF <* <LENGTH .SLOTS> 2>>
261 <FUNCTION (FRM) #DECL ((FRM) PFRAME) <VAR-ALLOC .FRM>>
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."
269 <DEFINE SLOTFIX (VARLST "AUX" (NVRLST ()) (SLOTS 0))
270 #DECL ((VARLST) LIST (SLOTS) FIX (NVRLST) <LIST [REST LIST]>)
275 (<NOT <EMPTY? <REF-TMP .TMP>>>
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>>>
287 #DECL ((TMPLST) <LIST <OR FALSE ATOM> TEMPB>)
288 <COND (<FITTMP .TMP <2 .TMPLST>>
294 <SET NVRLST ((<TYP-TMP .TMP> .TMP) !.NVRLST)>
295 <PUT .TMP ,LOC-TMP .SLOTS>
296 <SET SLOTS <+ .SLOTS 2>>)>)>>
298 <LREVERSE <MAPF ,LIST 1 .NVRLST>>>
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>>)>>
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)."
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>>
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)>
324 <FUNCTION (FRM) <SET SLOTS <PRE-ALLOC-VAR .FRM .SLOTS>>>
330 "PASS:3 OF CUP FIXES UP THE REFERENCES TO TEMPORARIES, FIXES UP THE CODE AND
331 ADDS THE PSEUDO-SETG'S."
333 <DEFINE PASS:3 (COD MODEL "AUX" (LFRAM <1 .MODEL>) (NPS ()) (PS ()))
334 #DECL ((NPS) <LIST [REST FORM]> (MODEL) <LIST PFRAME> (COD) LIST
336 <FIXIT .LFRAM <PRE-PF .LFRAM> T>
338 <COND (<EMPTY? .PS> <RETURN>)>
340 (<FORM PSEUDO!-OP!-PACKAGE <FORM SETG <1 .PS> <2 .PS>>>
342 <SET PS <REST .PS 2>>>
343 <ADDON <UPD .REMOVES .COD> .NPS>>
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>>
351 <ADDON ,TMPLST (<NAME-PF .FRM> <TMP-STR-PF .FRM>)>>)>
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)
359 #DECL ((IT) <PRIMTYPE LIST>)
360 <COND (<NOT <EMPTY? .IT>> <ADDIT .SC <1 .IT> .NUM>)>>
362 <REPEAT ((PTR <STORE-TEMP .VAR>) (HT <HI-TMP .VAR>) XX)
363 <COND (<EMPTY? .PTR> <RETURN>)>
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>
370 <INSTRUCTION STORE-MTEMP
375 (<==? <1 .XX> ,STORE:TVAR>
377 <INSTRUCTION STORE-MTEMP
382 (<MESSAGE INCONSISTENCY "BAD STORE">)>
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>>
391 <FUNCTION (X) <FIXIT .X <COND (.PRE .PRE) (ELSE <PRE-PF .X>)>>>
394 <DEFINE ADDIT (SC FRM NUM)
400 <COND (<ADDIT .SC .X .NUM>
403 <COND (<==? <1 .X> .SC>
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)
417 <PUT .UVEC .CNT <2 .ITEMS>>
418 <COND (<EMPTY? <SET TPS <REST .TPS>>> <RETURN>)>>
419 <SETG TOKEN-TABLE .UVEC>>
426 <VECTOR [REST STRING]>>
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"))>
440 <DEFINE SCL-PRINT (X)
443 <PRIN1 <CHTYPE .X FIX>>>
445 <DEFINE MAP-PRINT (X)
446 #DECL ((X) STRUCTURED)
447 <MAPF <> <FUNCTION (X) <PRINC !" > <PRIN1 .X>> .X>>
449 <DEFINE TOKEN-PRINT (X)
451 <COND (<L? <1 .X> ,TOKEN-MAX>
453 <PRINC <NTH ,TOKEN-TABLE <1 .X>>>)
454 (ELSE <PRINC "#TOKEN <"> <PRIN1 <1 .X>>)>
455 <MAP-PRINT <REST .X>>
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>>
467 <AND <==? .REMOVES .CPTR>
468 <COND (<==? .QCOD .CPTR>
469 <SET QCOD <REST .QCOD>>)
471 <PUTREST .TEMP1 <REST .CPTR>>
472 <SET CPTR .TEMP1>)>>>
475 <SET CPTR <REST .CPTR>>>
478 <DEFINE LREVERSE (TEM "AUX" LST VAL TMP)
483 <COND (<EMPTY? .LST> <RETURN .VAL>)>
484 <SET TMP <REST .LST>>
485 <SET VAL <PUTREST .LST .VAL>>
490 "THIS ROUTINE CALLED AT ASSEMBLY TIME ALLOCATES SLOTS FOR THE TEMPORARIES."
492 <DEFINE ALLOCATE:SLOTS (ATM "OPTIONAL" (FXI 0) "AUX" XX (SPL ()))
493 #DECL ((SPL) LIST (ATM) <OR ATOM FIX> (FXI) FIX)
495 (<TYPE? .ATM FIX> <SET SPL <FIXAD .ATM>>)
497 <REPEAT ((SLTS <2 <MEMQ .ATM ,TMPLST>>))
498 <COND (<EMPTY? .SLTS>
499 <SET SPL <ADDON <FIXAD .FXI> .SPL>>
503 <SET SPL <ADDON <FIXAD .FXI> .SPL>>
507 `PUSH `TP* <FORM TYPE-WORD!-OP!-PACKAGE .XX>>
508 <INSTRUCTION `PUSH `TP* [0]>)
510 (<SET FXI <+ .FXI 2>>)>
511 <SET SLTS <REST .SLTS>>>)>
512 <CHTYPE .SPL SPLICE>>
517 (<L? .NUM 5> <ILIST .NUM ''<`PUSH `TP* [0]>>)
518 ((<INSTRUCTION `MOVEI `O* .NUM>
519 <INSTRUCTION `PUSHJ `P* |NTPALO>))>>
521 <DEFINE ZTMPLST () <SETG TMPLST ()>>
523 <DEFINE STORE-MTEMP (TMPADR TMPPRED TYP VALUE)
525 (!<COND (.TMPPRED (<INSTRUCTION `MOVEM .VALUE !.TMPADR 1>))
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>))
532 (<INSTRUCTION `MOVE `O !<ADDR:TYPE1 .TYP>>
533 <INSTRUCTION `MOVEM `O !.TMPADR>
534 <INSTRUCTION `MOVEM .VALUE !.TMPADR 1>))
536 (<INSTRUCTION `MOVEM .TYP !.TMPADR>
537 <INSTRUCTION `MOVEM .VALUE !.TMPADR 1>))>)>)
540 <DEFINE NULL-MACRO () <CHTYPE () SPLICE>>
542 <DEFINE DEALLOCATE (LST "AUX" (NUM <+ !.LST>))
543 <COND (<0? .NUM> #SPLICE ())
544 (<CHTYPE (<INSTRUCTION `SUB `TP* <VECTOR <FORM (.NUM) .NUM>>>)
547 "FUNCTION TO EXPAND THE MACROS IN THE SOURCE GENERATED BY THE COMPILER.
548 SHOULD BE CALLED AFTER CUP."
550 <DEFINE EXP-MAC (CODE "AUX" (CP <REST .CODE>) (TC .CODE) TC1)
551 #DECL ((CODE CP TC) LIST)
554 (<TYPE? <SET ELE <1 .CP>> FORM>
556 (<TYPE? <SET FRST <1 .ELE>> ATOM>
558 (<==? .FRST PSEUDO!-OP!-PACKAGE> <EVAL <2 .ELE>>)
559 (<==? <GET <OBLIST? .FRST> OBLIST> OP!-PACKAGE>)
563 (<TYPE? <SET ELE <EVAL .ELE>> SPLICE>
565 (<EMPTY? .ELE> <PUTREST .TC <SET CP <REST .CP>>> <AGAIN>)
567 <PUTREST <SET TC1 <CHTYPE <REST .ELE <- <LENGTH .ELE> 1>> LIST>>
570 <SET CP <CHTYPE .ELE LIST>>
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>>>
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>)>
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)>>