--- /dev/null
+<PACKAGE "CUP">
+
+<ENTRY CUP STORE:VAR STORE:TVAR CREATE-TMP KILL:STORE EMIT-PRE END-FRAME PRE
+ STORE-TMP BEGIN-FRAME CDUP EXP-MAC ZTMPLST PRIN-SET>
+
+<USE "COMPDEC" "COMCOD">
+
+<FLOAD "PUREQ.NBIN">
+
+"AN SCL IS A TEMPORARY. IT IS REPLACED BY A FIX WHICH IS A OFFSET OFF THE BASE OF THE
+ TEMPORARIES IN THE CODE UPDATE PASS"
+
+<NEWTYPE SCL WORD>
+
+"A PFRAME IS A PSEUDO-FRAME GENERATED BY A PROG/REPEAT/MAPF/MAPR/FUNCTION. IT CONTAINS
+ INFORMATION FOR CUP'S USE."
+
+<NEWTYPE PFRAME
+ VECTOR
+ '<<PRIMTYPE VECTOR> ATOM
+ <OR ATOM FALSE>
+ <OR ATOM FALSE>
+ LIST
+ LIST
+ FIX
+ LIST>>
+
+<MANIFEST NAME-PF ACT-PF PRE-PF TEMPS-PF KIDS-PF NTEMPS-PF TMP-STR-PF>
+
+<SETG NAME-PF 1>
+
+<SETG ACT-PF 2>
+
+<SETG PRE-PF 3>
+
+<SETG TEMPS-PF 4>
+
+<SETG KIDS-PF 5>
+
+<SETG NTEMPS-PF 6>
+
+<SETG TMP-STR-PF 7>
+
+"A TEMPB DESCRIBES A TEMPORARY"
+
+<NEWTYPE TEMPB
+ VECTOR
+ '<<PRIMTYPE VECTOR> SCL LIST FIX FIX FIX <OR ATOM FALSE> LIST>>
+
+<MANIFEST ID-TMP REF-TMP LOC-TMP HI-TMP LO-TMP TYP-TMP STORE-TEMP>
+
+<SETG ID-TMP 1>
+
+<SETG REF-TMP 2>
+
+<SETG LOC-TMP 5>
+
+<SETG HI-TMP 3>
+
+<SETG LO-TMP 4>
+
+<SETG TYP-TMP 6>
+
+<SETG STORE-TEMP 7>
+
+
+<MANIFEST BEGIN:FRAME
+ END:FRAME
+ CREATE:TEMP
+ EMIT:PRE
+ STORE:TMP
+ STORE:VAR
+ STORE:TVAR
+ KILL:STORE>
+
+<SETG BEGIN:FRAME 1>
+
+<SETG END:FRAME 2>
+
+<SETG CREATE:TEMP 3>
+
+<SETG EMIT:PRE 5>
+
+<SETG STORE:VAR 4>
+
+<SETG STORE:TVAR 8>
+
+<SETG KILL:STORE 7>
+
+<SETG STORE:TMP 6>
+
+"BEGIN-FRAME STARTS A FRAME. IT TAKES 3 ARGUMENTS:
+ 1) ATOM LATER SETG'd TO LENGTH OF TEMPORARY BLOCK
+ 2) FLAG INDICATING WHETHER THE FRAME IS ACTIVATED
+ 3) FLAG INDICATING WHETHER PRE-ALLOCATION IS TO BEGIN"
+
+<DEFINE BEGIN-FRAME (NM ACT PRE)
+ <EMIT <CHTYPE [,BEGIN:FRAME .NM .ACT .PRE] TOKEN>>>
+
+"END-FRAME ENDS A FRAME."
+
+<DEFINE END-FRAME () <EMIT <CHTYPE [,END:FRAME] TOKEN>>>
+
+"CREATE-TMP CREATES A TEMPORARY AND RETURNS THE ID OF IT"
+
+<DEFINE CREATE-TMP (TYP)
+ <EMIT <CHTYPE [,CREATE:TEMP <CHTYPE <SET IDT <+ .IDT 1>> SCL> .TYP]
+ TOKEN>>
+ <CHTYPE .IDT SCL>>
+
+<DEFINE EMIT-PRE (PRE) <EMIT <CHTYPE [,EMIT:PRE .PRE] TOKEN>>>
+
+<DEFINE STORE-TMP (TYP VAL ADR)
+ <EMIT <CHTYPE [,STORE:TMP .ADR T .TYP .VAL] TOKEN>>>
+
+\\f
+
+<DEFINE CDUP (COD "AUX" (CPTR .COD) (MODEL (())) (REMOVES (())) (SNO 0))
+ #DECL ((COD) LIST (MODEL REMOVES CPTR) <SPECIAL LIST>
+ (SNO) <SPECIAL FIX>)
+ <PASS:1 .MODEL <> ()>
+ <PASS:2 .MODEL>
+ <PASS:3 .COD .MODEL>>
+
+"PASS:1 SETS UP THE INITIAL MODEL FOR CUP. IT ALSO DETERMINES WHICH VARIABLES ARE TO BE
+ KEPT BY USING A MARK-BIT IN THE TEMPORARY DESCRIPTORS."
+
+<DEFINE PASS:1 (MODEL PCFRAM VARLST "AUX" FD (CFRAM <>))
+ #DECL ((VALUE) PFRAME (CPTR COD) LIST (CFRAM) <OR FALSE PFRAME>)
+ <REPEAT RETPNT (INST TOKCOD FD)
+ #DECL ((SNO) FIX (TOKCOD) FIX)
+ <SET INST <1 .CPTR>>
+ <SET SNO <+ .SNO 1>>
+ <COND (<TYPE? .INST ATOM>)
+ (<TYPE? .INST TOKEN>
+ <COND (<NOT <OR <==? <SET TOKCOD <1 .INST>> ,STORE:TMP>
+ <==? .TOKCOD ,STORE:VAR>
+ <==? .TOKCOD ,STORE:TVAR>>>
+ <SET REMOVES <ADDON (.CPTR) .REMOVES>>)>
+ <CASE ,==?
+ .TOKCOD
+ (,BEGIN:FRAME
+ <COND (.CFRAM <PASS:1 .MODEL .CFRAM .VARLST>)
+ (ELSE
+ <SET CFRAM
+ <CHTYPE [<2 .INST>
+ <3 .INST>
+ <4 .INST>
+ (())
+ ()
+ 0
+ ()]
+ PFRAME>>
+ <COND (.PCFRAM
+ <PUT .PCFRAM
+ ,KIDS-PF
+ (.CFRAM !<KIDS-PF .PCFRAM>)>)
+ (<PUT .MODEL 1 .CFRAM>)>)>)
+ (,END:FRAME <RETURN .CFRAM .RETPNT>)
+ (,STORE:VAR <SET VARLST (<2 .INST> .CPTR !.VARLST)>)
+ (,KILL:STORE <NULLIFY .VARLST <2 .INST>>)
+ (,CREATE:TEMP
+ <PUT .CFRAM
+ ,TEMPS-PF
+ <ADDON (<CHTYPE [<2 .INST> () 0 .SNO 0 <3 .INST> ()]
+ TEMPB>)
+ <TEMPS-PF .CFRAM>>>)
+ (,EMIT:PRE <PUT .CFRAM ,PRE-PF <2 .INST>>)
+ (,STORE:TMP
+ <PUT <SET FD
+ <COND (<FIND-TMP <FX <2 .INST>> <1 .MODEL>>)
+ (<MESSAGE INCONSISTENCY "LOST TEMPORARY">)>>
+ ,STORE-TEMP
+ (.CPTR .SNO !<STORE-TEMP .FD>)>)
+ (,STORE:TVAR
+ <COND (<SET FD <FIND-TMP <FX <3 .INST>> <1 .MODEL>>>
+ <COND (<EMPTY? <REF-TMP .FD>> <PUT .FD ,HI-TMP .SNO>)
+ (<PUT .FD ,HI-TMP <CHTYPE <MIN> FIX>>)>
+ <PUT .FD
+ ,STORE-TEMP
+ (.CPTR .SNO !<STORE-TEMP .FD>)>)
+ (ELSE <MESSAGE INCONSISTENCY "LOST VARIABLE">)>
+ <SET VARLST (<2 .INST> .CPTR !.VARLST)>)
+ DEFAULT
+ (<MESSAGE INCONSISTENCY "BAD TOKEN TO CUP">)>)
+ (<SET FD <FX .INST>>
+ <COND (<SET FD <FIND-TMP .FD <1 .MODEL>>>
+ <PUT .FD ,REF-TMP (.CPTR !<REF-TMP .FD>)>
+ <COND (<L? .SNO <HI-TMP .FD>>) (<PUT .FD ,HI-TMP .SNO>)>)
+ (<MESSAGE INCONSISTENCY "VARIABLE NOT FOUND">)>)>
+ <COND (<EMPTY? <SET CPTR <REST .CPTR>>>
+ <MESSAGE INCONSISTENCY "UNBALENCED STACK MODEL">)>>
+ <FIXUP-VARLST .VARLST>
+ .CFRAM>
+
+<DEFINE FIXUP-VARLST (VARLST)
+ #DECL ((VARLST) LIST)
+ <REPEAT ((VP .VARLST) VAR)
+ <COND (<EMPTY? .VP> <RETURN>)
+ (<AND <TYPE? <SET VAR <1 <2 .VP>>> TOKEN>
+ <==? <1 .VAR> ,STORE:VAR>>
+ <PUT <2 .VP>
+ 1
+ <INSTRUCTION STORE-MTEMP
+ <3 .VAR>
+ <6 .VAR>
+ <4 .VAR>
+ <5 .VAR>>>)>
+ <SET VP <REST .VP 2>>>>
+
+<DEFINE NULLIFY (MNLST ITEM)
+ #DECL ((MNLST) <OR FALSE LIST>)
+ <COND (<SET MNLST <MEMQ .ITEM .MNLST>>
+ <PUT .MNLST 1 <>>
+ <PUT <2 .MNLST> 1 '<NULL-MACRO>>)>>
+
+<DEFINE FX (SC)
+ <COND (<STRUCTURED? .SC>
+ <MAPF <>
+ <FUNCTION (X "AUX" QD)
+ <COND (<SET QD <FX .X>> <MAPLEAVE .QD>)>>
+ .SC>)
+ (<TYPE? .SC SCL> .SC)>>
+
+"FIND-TMP LOOKS FOR A TEMPORARY. IF IT DOESN'T FIND IT AND ERR IS T IT CAUSES AN ERROR"
+
+<DEFINE FIND-TMP (ID CFRAM "AUX" XD)
+ #DECL ((ID) SCL (CFRAM) PFRAME)
+ <COND (<MAPF <>
+ <FUNCTION (VL)
+ #DECL ((VL) TEMPB)
+ <COND (<EMPTY? .VL>)
+ (<==? <ID-TMP .VL> .ID> <MAPLEAVE .VL>)>>
+ <REST <TEMPS-PF .CFRAM>>>)
+ (<MAPF <>
+ <FUNCTION (FRM "AUX" VAL)
+ #DECL ((FRM) PFRAME)
+ <COND (<SET VAL <FIND-TMP .ID .FRM>>
+ <MAPLEAVE .VAL>)>>
+ <KIDS-PF .CFRAM>>)>>
+
+\\f
+
+"THIS IS PASS2 OF THE VARIABLE ALLOCATION PROCESS. DURING THIS PHASE VARIABLES AND
+ TEMPORARIES ARE ASSIGNED SLOTS ON THE STACK AND THE LENGTH OF THE BTP'S BECOMES
+ KNOWN. NO CODE UPDATE IS DONE DURING THIS PHASE."
+
+<DEFINE PASS:2 (MODEL) #DECL ((MODEL) <LIST PFRAME>) <VAR-ALLOC <1 .MODEL>>>
+
+"THIS ROUTINE ACTUALLY DOES THE ALLOCATION OF VARIBLES. IF IT MUST DO PREALLOCATION
+ IT CALLS PRE-ALLOC-VAR."
+
+<DEFINE VAR-ALLOC (FRM "AUX" SLOTS)
+ #DECL ((FRM) PFRAME (SLOTS) LIST)
+ <COND (<PRE-PF .FRM> <PRE-ALLOC-VAR1 .FRM>)
+ (ELSE
+ <SET SLOTS <SLOTFIX <REST <TEMPS-PF .FRM>>>>
+ <PUT .FRM ,TMP-STR-PF .SLOTS>
+ <PUT .FRM ,NTEMPS-PF <* <LENGTH .SLOTS> 2>>
+ <MAPF <>
+ <FUNCTION (FRM) #DECL ((FRM) PFRAME) <VAR-ALLOC .FRM>>
+ <KIDS-PF .FRM>>)>>
+
+"THIS ROUTINE TAKES A LIST OF TEMPORARIES AND ALLOCATES THERE SPACE ON THE STACK.
+ IT TRIES TO KEEP TEMPORARIES OF THE SAME TYPE TOGETHER THOUGH ITS MAIN GOAL IS
+ TO MINIMIZE THE NUMBER OF TEMPORARIES. IT RETURNS A LIST OF THE TYPES OF THE
+ TEMPORARIES. A FALSE MEANS THAT THE TYPE CANNOT BE PRE-ALLOCATED."
+
+<DEFINE SLOTFIX (VARLST "AUX" (NVRLST ()) (SLOTS 0))
+ #DECL ((VARLST) LIST (SLOTS) FIX (NVRLST) <LIST [REST LIST]>)
+ <MAPF <>
+ <FUNCTION (TMP)
+ #DECL ((TMP) TEMPB)
+ <COND
+ (<NOT <EMPTY? <REF-TMP .TMP>>>
+ <COND (<MAPF <>
+ <FUNCTION (TMPLST)
+ #DECL ((TMPLST) <LIST <OR FALSE ATOM> TEMPB>)
+ <COND (<AND <TYP-TMP .TMP>
+ <==? <TYP-TMP .TMP> <1 .TMPLST>>
+ <FITTMP .TMP <2 .TMPLST>>>
+ <PUT .TMPLST 2 .TMP>
+ <MAPLEAVE T>)>>
+ .NVRLST>)
+ (<MAPF <>
+ <FUNCTION (TMPLST)
+ #DECL ((TMPLST) <LIST <OR FALSE ATOM> TEMPB>)
+ <COND (<FITTMP .TMP <2 .TMPLST>>
+ <PUT .TMPLST 1 <>>
+ <PUT .TMPLST 2 .TMP>
+ <MAPLEAVE T>)>>
+ .NVRLST>)
+ (ELSE
+ <SET NVRLST ((<TYP-TMP .TMP> .TMP) !.NVRLST)>
+ <PUT .TMP ,LOC-TMP .SLOTS>
+ <SET SLOTS <+ .SLOTS 2>>)>)>>
+ .VARLST>
+ <LREVERSE <MAPF ,LIST 1 .NVRLST>>>
+
+<DEFINE FITTMP (VAR CMPVAR "AUX" (SHI <HI-TMP .VAR>) (SLO <LO-TMP .VAR>))
+ #DECL ((SLO) FIX (VAR CMPVAR) TEMPB)
+ <COND (<G? .SLO <HI-TMP .CMPVAR>>
+ <PUT .VAR ,LOC-TMP <LOC-TMP .CMPVAR>>
+ <PUT .VAR ,LO-TMP <LO-TMP .CMPVAR>>)
+ (<L? .SHI <LO-TMP .CMPVAR>>
+ <PUT .VAR ,LOC-TMP <LOC-TMP .CMPVAR>>
+ <PUT .VAR ,HI-TMP <HI-TMP .CMPVAR>>)>>
+
+"THIS ROUTINE DOES PRE-ALLOCATION. THE TOP FRAME GETS THE STRUCTURE AND
+ THE OTHER FRAMES ARE IGNORED (THEIR TEMPS ARE ALLOCATED IN THE FIRST FRAME)."
+
+<DEFINE PRE-ALLOC-VAR1 (FRM "AUX" (SLOTS ()))
+ #DECL ((FRM) PFRAME (SLOTS) LIST)
+ <SET SLOTS <PRE-ALLOC-VAR .FRM .SLOTS T>>
+ <SET SLOTS <SLOTFIX .SLOTS>>
+ <PUT .FRM ,NTEMPS-PF <* <LENGTH .SLOTS> 2>>
+ <PUT .FRM ,TMP-STR-PF .SLOTS>>
+
+<DEFINE PRE-ALLOC-VAR (FRM SLOTS "OPTIONAL" (FIRST? <>))
+ #DECL ((FRM) PFRAME (SLOTS) LIST)
+ <COND (<AND <NOT .FIRST?> <ACT-PF .FRM>> <VAR-ALLOC .FRM> .SLOTS)
+ (<SET SLOTS (!<REST <TEMPS-PF .FRM>> !.SLOTS)>
+ <MAPF <>
+ <FUNCTION (FRM) <SET SLOTS <PRE-ALLOC-VAR .FRM .SLOTS>>>
+ <KIDS-PF .FRM>>
+ .SLOTS)>>
+
+\\f
+
+"PASS:3 OF CUP FIXES UP THE REFERENCES TO TEMPORARIES, FIXES UP THE CODE AND
+ ADDS THE PSEUDO-SETG'S."
+
+<DEFINE PASS:3 (COD MODEL "AUX" (LFRAM <1 .MODEL>) (NPS ()) (PS ()))
+ #DECL ((NPS) <LIST [REST FORM]> (MODEL) <LIST PFRAME> (COD) LIST
+ (PS) <SPECIAL LIST>)
+ <FIXIT .LFRAM <PRE-PF .LFRAM> T>
+ <REPEAT ()
+ <COND (<EMPTY? .PS> <RETURN>)>
+ <SET NPS
+ (<FORM PSEUDO!-OP!-PACKAGE <FORM SETG <1 .PS> <2 .PS>>>
+ !.NPS)>
+ <SET PS <REST .PS 2>>>
+ <ADDON <UPD .REMOVES .COD> .NPS>>
+
+<DEFINE FIXIT (FRM PRE "OPTIONAL" (FIRST? <>) "AUX" LX)
+ #DECL ((LX) LIST (FRM) PFRAME (PS) LIST (ADDS REMOVES) LIST)
+ <COND (<AND <NOT .FIRST?> <ACT-PF .FRM>> <SET PRE <PRE-PF .FRM>>)>
+ <COND (<NOT <AND .PRE <NOT <PRE-PF .FRM>>>>
+ <SET PS <ADDON (<NAME-PF .FRM> <NTEMPS-PF .FRM>) .PS>>
+ <SETG TMPLST
+ <ADDON ,TMPLST (<NAME-PF .FRM> <TMP-STR-PF .FRM>)>>)>
+ <MAPF <>
+ <FUNCTION (VAR
+ "AUX" (NUM <LOC-TMP .VAR>) (SC <ID-TMP .VAR>)
+ (LADJ <REF-TMP .VAR>))
+ #DECL ((SC) SCL (NUM) FIX (LADJ) LIST (VAR) TEMPB)
+ <MAPF <>
+ <FUNCTION (IT)
+ #DECL ((IT) <PRIMTYPE LIST>)
+ <COND (<NOT <EMPTY? .IT>> <ADDIT .SC <1 .IT> .NUM>)>>
+ .LADJ>
+ <REPEAT ((PTR <STORE-TEMP .VAR>) (HT <HI-TMP .VAR>) XX)
+ <COND (<EMPTY? .PTR> <RETURN>)>
+ <COND
+ (<AND <NOT <EMPTY? <REF-TMP .VAR>>> <L=? <2 .PTR> .HT>>
+ <SET XX <1 <1 .PTR>>>
+ <COND (<NOT <=? .XX '<NULL-MACRO>>>
+ <COND (<==? <1 .XX> ,STORE:TMP>
+ <SET XX
+ <INSTRUCTION STORE-MTEMP
+ <2 .XX>
+ <3 .XX>
+ <4 .XX>
+ <5 .XX>>>)
+ (<==? <1 .XX> ,STORE:TVAR>
+ <SET XX
+ <INSTRUCTION STORE-MTEMP
+ <3 .XX>
+ <6 .XX>
+ <4 .XX>
+ <5 .XX>>>)
+ (<MESSAGE INCONSISTENCY "BAD STORE">)>
+ <ADDIT .SC .XX .NUM>
+ <PUT .XX 3 <NTH <2 ,TMPLST> <+ </ <LOC-TMP .VAR> 2> 1>>>
+ <PUT <1 .PTR> 1 .XX>)>)
+ (<PUT <1 .PTR> 1 '<NULL-MACRO>>)>
+ <SET PTR <REST .PTR 2>>>>
+ <REST <TEMPS-PF .FRM>>>
+ <COND (<SET LX <KIDS-PF .FRM>>
+ <MAPF <>
+ <FUNCTION (X) <FIXIT .X <COND (.PRE .PRE) (ELSE <PRE-PF .X>)>>>
+ .LX>)>>
+
+<DEFINE ADDIT (SC FRM NUM)
+ #DECL ((NUM) FIX)
+ <COND
+ (<STRUCTURED? .FRM>
+ <MAPF <>
+ <FUNCTION (X)
+ <COND (<ADDIT .SC .X .NUM>
+ <MAPR <>
+ <FUNCTION (X)
+ <COND (<==? <1 .X> .SC>
+ <PUT .X 1 .NUM>)>>
+ .FRM>)>>
+ .FRM>)
+ (<==? .FRM .SC>)>>
+
+\\f
+
+<DEFINE PRIN-SET ("AUX" (UVEC <IVECTOR ,TOKEN-MAX "#TOKEN <">))
+ <PRINTTYPE SCL ,SCL-PRINT>
+ <PRINTTYPE TOKEN ,TOKEN-PRINT>
+ <REPEAT ((TPS ,TOKENS) CNT ITEM)
+ <SET ITEMS <1 .TPS>>
+ <SET CNT <1 .ITEMS>>
+ <PUT .UVEC .CNT <2 .ITEMS>>
+ <COND (<EMPTY? <SET TPS <REST .TPS>>> <RETURN>)>>
+ <SETG TOKEN-TABLE .UVEC>>
+
+<GDECL (TOKEN-MAX)
+ FIX
+ (TOKENS)
+ <LIST [REST LIST]>
+ (TOKEN-TABLE)
+ <VECTOR [REST STRING]>>
+
+<SETG TOKEN-MAX 10>
+
+<SETG TOKENS
+ ((,EMIT:PRE "EMIT:PRE")
+ (,STORE:VAR "STORE:VAR")
+ (,CREATE:TEMP "CREATE:TEMPORARY")
+ (,KILL:STORE "KILL:STORE")
+ (,STORE:TMP "STORE:TEMPORARY")
+ (,BEGIN:FRAME "BEGIN:FRAME")
+ (,END:FRAME "END:FRAME")
+ (,STORE:TVAR "STORE:TVARIABLE"))>
+
+<DEFINE SCL-PRINT (X)
+ #DECL ((X) SCL)
+ <PRINC "TEMPORARY:">
+ <PRIN1 <CHTYPE .X FIX>>>
+
+<DEFINE MAP-PRINT (X)
+ #DECL ((X) STRUCTURED)
+ <MAPF <> <FUNCTION (X) <PRINC !" > <PRIN1 .X>> .X>>
+
+<DEFINE TOKEN-PRINT (X)
+ #DECL ((X) TOKEN)
+ <COND (<L? <1 .X> ,TOKEN-MAX>
+ <PRINC "<">
+ <PRINC <NTH ,TOKEN-TABLE <1 .X>>>)
+ (ELSE <PRINC "#TOKEN <"> <PRIN1 <1 .X>>)>
+ <MAP-PRINT <REST .X>>
+ <PRINC !">>>
+
+
+
+<DEFINE UPD (REMOVES QCOD)
+ #DECL ((QCOD REMOVES) <PRIMTYPE LIST>)
+ <REPEAT ((TEMP1 .QCOD) (CPTR .QCOD))
+ #DECL ((CD) FIX (CPTR QCOD) LIST)
+ <AND <EMPTY? .CPTR> <RETURN>>
+ <MAPF <>
+ <FUNCTION (REMOVES)
+ <AND <==? .REMOVES .CPTR>
+ <COND (<==? .QCOD .CPTR>
+ <SET QCOD <REST .QCOD>>)
+ (ELSE
+ <PUTREST .TEMP1 <REST .CPTR>>
+ <SET CPTR .TEMP1>)>>>
+ .REMOVES>
+ <SET TEMP1 .CPTR>
+ <SET CPTR <REST .CPTR>>>
+ .QCOD>
+
+<DEFINE LREVERSE (TEM "AUX" LST VAL TMP)
+ #DECL ((LST) LIST)
+ <SET LST .TEM>
+ <SET VAL ()>
+ <REPEAT ()
+ <COND (<EMPTY? .LST> <RETURN .VAL>)>
+ <SET TMP <REST .LST>>
+ <SET VAL <PUTREST .LST .VAL>>
+ <SET LST .TMP>>>
+
+\\f
+
+"THIS ROUTINE CALLED AT ASSEMBLY TIME ALLOCATES SLOTS FOR THE TEMPORARIES."
+
+<DEFINE ALLOCATE:SLOTS (ATM "OPTIONAL" (FXI 0) "AUX" XX (SPL ()))
+ #DECL ((SPL) LIST (ATM) <OR ATOM FIX> (FXI) FIX)
+ <COND
+ (<TYPE? .ATM FIX> <SET SPL <FIXAD .ATM>>)
+ (ELSE
+ <REPEAT ((SLTS <2 <MEMQ .ATM ,TMPLST>>))
+ <COND (<EMPTY? .SLTS>
+ <SET SPL <ADDON <FIXAD .FXI> .SPL>>
+ <SET FXI 0>
+ <RETURN>)
+ (<SET XX <1 .SLTS>>
+ <SET SPL <ADDON <FIXAD .FXI> .SPL>>
+ <SET FXI 0>
+ <SET SPL
+ <ADDON (<INSTRUCTION
+ `PUSH `TP* <FORM TYPE-WORD!-OP!-PACKAGE .XX>>
+ <INSTRUCTION `PUSH `TP* [0]>)
+ .SPL>>)
+ (<SET FXI <+ .FXI 2>>)>
+ <SET SLTS <REST .SLTS>>>)>
+ <CHTYPE .SPL SPLICE>>
+
+<DEFINE FIXAD (NUM)
+ #DECL ((NUM) FIX)
+ <COND (<0? .NUM> ())
+ (<L? .NUM 5> <ILIST .NUM ''<`PUSH `TP* [0]>>)
+ ((<INSTRUCTION `MOVEI `O* .NUM>
+ <INSTRUCTION `PUSHJ `P* |NTPALO>))>>
+
+<DEFINE ZTMPLST () <SETG TMPLST ()>>
+
+<DEFINE STORE-MTEMP (TMPADR TMPPRED TYP VALUE)
+ <CHTYPE
+ (!<COND (.TMPPRED (<INSTRUCTION `MOVEM .VALUE !.TMPADR 1>))
+ (ELSE
+ <COND (<AND <TYPE? .TYP ATOM> <VALID-TYPE? .TYP>>
+ (<INSTRUCTION `MOVE `O <FORM TYPE-WORD!-OP!-PACKAGE .TYP>>
+ <INSTRUCTION `MOVEM `O !.TMPADR>
+ <INSTRUCTION `MOVEM .VALUE !.TMPADR 1>))
+ (<STRUCTURED? .TYP>
+ (<INSTRUCTION `MOVE `O !<ADDR:TYPE1 .TYP>>
+ <INSTRUCTION `MOVEM `O !.TMPADR>
+ <INSTRUCTION `MOVEM .VALUE !.TMPADR 1>))
+ (ELSE
+ (<INSTRUCTION `MOVEM .TYP !.TMPADR>
+ <INSTRUCTION `MOVEM .VALUE !.TMPADR 1>))>)>)
+ SPLICE>>
+
+<DEFINE NULL-MACRO () <CHTYPE () SPLICE>>
+
+<DEFINE DEALLOCATE (LST "AUX" (NUM <+ !.LST>))
+ <COND (<0? .NUM> #SPLICE ())
+ (<CHTYPE (<INSTRUCTION `SUB `TP* <VECTOR <FORM (.NUM) .NUM>>>)
+ SPLICE>)>>
+
+"FUNCTION TO EXPAND THE MACROS IN THE SOURCE GENERATED BY THE COMPILER.
+ SHOULD BE CALLED AFTER CUP."
+
+<DEFINE EXP-MAC (CODE "AUX" (CP <REST .CODE>) (TC .CODE) TC1)
+ #DECL ((CODE CP TC) LIST)
+ <REPEAT (ELE FRST)
+ <COND
+ (<TYPE? <SET ELE <1 .CP>> FORM>
+ <COND
+ (<TYPE? <SET FRST <1 .ELE>> ATOM>
+ <COND
+ (<==? .FRST PSEUDO!-OP!-PACKAGE> <EVAL <2 .ELE>>)
+ (<==? <GET <OBLIST? .FRST> OBLIST> OP!-PACKAGE>)
+ (<==? .FRST TITLE>)
+ (<GASSIGNED? .FRST>
+ <COND
+ (<TYPE? <SET ELE <EVAL .ELE>> SPLICE>
+ <COND
+ (<EMPTY? .ELE> <PUTREST .TC <SET CP <REST .CP>>> <AGAIN>)
+ (ELSE
+ <PUTREST <SET TC1 <CHTYPE <REST .ELE <- <LENGTH .ELE> 1>> LIST>>
+ <REST .CP>>
+ <PUTREST .TC .ELE>
+ <SET CP <CHTYPE .ELE LIST>>
+ <AGAIN>)>)>)>)
+ (<NOT <PUREQ .ELE>>
+ <PROG ((NUM 0))
+ <REPEAT ((PTR .ELE) (RPTR <REST .ELE>) ELE)
+ #DECL ((PTR RPTR) <PRIMTYPE LIST> (NUM) FIX)
+ <COND (<EMPTY? .RPTR> <RETURN>)>
+ <COND (<AND <TYPE? <SET ELE <1 .RPTR>> FORM>
+ <OR <==? <1 .ELE> -> <==? <1 .ELE> GVAL>>>
+ <SET ELE <EVAL .ELE>>)>
+ <COND (<TYPE? .ELE FIX>
+ <SET NUM <+ .NUM .ELE>>
+ <PUTREST .PTR <SET RPTR <REST .RPTR>>>
+ <AGAIN>)>
+ <SET PTR <REST .PTR>>
+ <SET RPTR <REST .RPTR>>>
+ <COND (<NOT <0? .NUM>>
+ <PUTREST <REST .ELE <- <LENGTH .ELE> 1>> (.NUM)>)>>)>)>
+ <COND (<EMPTY? <SET CP <REST .CP>>> <RETURN>)>
+ <SET TC <REST .TC>>>
+ .CODE>
+\f
+<DEFINE ADDON (AD OB)
+ #DECL ((AD OB) <PRIMTYPE LIST>)
+ <COND (<EMPTY? .OB> .AD)
+ (ELSE <PUTREST <REST .OB <- <LENGTH .OB> 1>> .AD> .OB)>>
+
+
+<ENDPACKAGE>
projects / pdp10-muddle.git / blobdiff