--- /dev/null
+<PACKAGE "NEWREP">
+
+<ENTRY PROG-REP-GEN RETURN-GEN AGAIN-GEN TAG-GEN GO-GEN CLEANUP-STATE
+ AGAIN-UP RETURN-UP PROG-START-AC>
+
+<USE "CODGEN" "COMCOD" "CACS" "CHKDCL" "COMPDEC" "CUP">
+
+" Generate code for a poor innocent PROG or REPEAT."
+
+
+"\f"
+
+<DEFINE PROG-REP-GEN (PNOD PWHERE
+ "AUX" (BSTB .BSTB) (NTSLOTS .NTSLOTS) XX (SPECD <>)
+ START:TAG (STB .STK) (STK (0 !.STK))
+ (NTMPS
+ <COND (.PRE .TMPS)
+ (<STACK:L .STK .BSTB>)
+ (ELSE (0))>) (TMPS .TMPS) BTP (BASEF .BASEF)
+ EXIT EXIT:OFF AGAIN (FRMS .FRMS) (OPRE .PRE) DEST
+ (CD <>) (AC-HACK .AC-HACK) (K <KIDS .PNOD>)
+ (SPEC-LIST .SPEC-LIST) TEM (ONS .NTSLOTS)
+ (ORPNOD <AND <ASSIGNED? RPNOD> .RPNOD>) RPNOD
+ SACS)
+ #DECL ((NTSLOTS STB) <SPECIAL LIST> (BASEF PNOD RPNOD) <SPECIAL NODE>
+ (PWHERE DEST) <OR ATOM DATUM> (SPECD PRE) <SPECIAL ANY>
+ (STK FRMS) <SPECIAL LIST> (BTP NSTB) LIST
+ (AC-HACK) <SPECIAL <PRIMTYPE LIST>> (TMPS) <SPECIAL LIST>
+ (START:TAG) <SPECIAL ATOM> (K) <LIST [REST NODE]>
+ (SPEC-LIST) <SPECIAL LIST>)
+ <REGSTO <> <>>
+ <COND (<N==? <NODE-SUBR .PNOD> ,BIND> <SET RPNOD .PNOD>)
+ (.ORPNOD <SET RPNOD .ORPNOD>)>
+ <PUT .PNOD ,SPECS-START <- <SPECS-START .PNOD> .TOT-SPEC>>
+ <SET TMPS .NTMPS>
+ <BEGIN-FRAME <TMPLS .PNOD> <ACTIVATED .PNOD> <PRE-ALLOC .PNOD>>
+ <SET DEST
+ <COND (<==? .PWHERE FLUSHED> FLUSHED)
+ (ELSE <GOODACS .PNOD .PWHERE>)>>
+ <PROG ((PRE .PRE) (TOT-SPEC .TOT-SPEC))
+ #DECL ((PRE) <SPECIAL ANY> (TOT-SPEC) <SPECIAL FIX>)
+ <OR .PRE
+ <EMIT-PRE <NOT <OR <ACTIVATED .PNOD> <0? <SSLOTS .BASEF>>>>>>
+ <COND (<ACTIVATED .PNOD>
+ <REGSTO T>
+ <SET TOT-SPEC 0>
+ <SET SPEC-LIST ()>
+ <ADD:STACK ,FRAMLN>
+ <SET FRMID <+ .FRMID 1>>
+ <PUT .FRMS 5 .NTSLOTS>
+ <SET FRMS
+ (.FRMID
+ <SET STK (0 !.STK)>
+ .PNOD
+ <COND (.PRE FUZZ)
+ (<STACK:L .STK <2 .FRMS>>)
+ (ELSE FUZZ)>
+ (<FORM GVAL <TMPLS .PNOD>>)
+ !.FRMS)>
+ <SET PRE <>>
+ <SET AC-HACK <>>
+ <SET BASEF .PNOD>
+ <SET NTSLOTS (<FORM GVAL <TMPLS .PNOD>>)>
+ <COND (<NOT <==? .PWHERE FLUSHED>>
+ <SET DEST <FUNCTION:VALUE>>)>
+ <BUILD:FRAME <SET EXIT:OFF <MAKE:TAG "EXIT">>>
+ <SET TMPS (2)>
+ <SET BSTB .STK>)>
+ <SET EXIT <MAKE:TAG "EXIT">>
+ <PUT .PNOD ,STK-B .STB>
+ <COND (<AND <NOT .PRE> <NOT <ACTIVATED .PNOD>>>
+ <SET NTSLOTS (<FORM GVAL <TMPLS .PNOD>> !.NTSLOTS)>)>
+ <BIND-CODE .PNOD>
+ <SET SPEC-LIST (.PNOD .SPECD <SPECS-START .PNOD> !.SPEC-LIST)>
+ <SET BTP .STK>
+ <OR .OPRE <SET BASEF .PNOD>>
+ <SET STK (0 !.STK)>
+ <COND (<OR <AGND .PNOD> <==? <NODE-SUBR .PNOD> ,REPEAT>>
+ <PROG-START-AC .PNOD>)
+ (ELSE <SET SACS <SAVE:RES>> <REGSTO <>>)>
+ <LABEL:TAG <SET AGAIN <MAKE:TAG "AGAIN">>>
+ <COND (<OR <AGND .PNOD> <==? <NODE-SUBR .PNOD> ,REPEAT>>
+ <CALL-INTERRUPT>)>
+ <PUT .PNOD ,BTP-B .BTP>
+ <PUT .PNOD ,DST .DEST>
+ <PUT .PNOD ,SPCS-X .SPECD>
+ <PUT .PNOD ,ATAG .AGAIN>
+ <PUT .PNOD ,RTAG .EXIT>
+ <PUT .PNOD ,PRE-ALLOC .PRE>
+ <COND (<OR <==? <NODE-SUBR .PNOD> ,REPEAT> <AGND .PNOD>>
+ <COND (<OR <==? <NODE-SUBR .PNOD> ,REPEAT>
+ <==? .DEST FLUSHED>>
+ <RET-TMP-AC <SET TEM <SEQ-GEN .K FLUSHED T T>>>)
+ (ELSE
+ <SET TEM <SET CD <SEQ-GEN .K .DEST T T>>>
+ <COND (<==? .TEM ,NO-DATUM>
+ <COND (<EMPTY? <CDST .PNOD>>
+ <SET CD ,NO-DATUM>)
+ (ELSE <SET CD <CDST .PNOD>>)>)>)>)
+ (ELSE
+ <COND (<==? .DEST FLUSHED>
+ <RET-TMP-AC <SET TEM <SEQ-GEN .K .DEST T>>>
+ <COND (<NOT <==? .TEM ,NO-DATUM>>)>)
+ (ELSE
+ <SET TEM <SET CD <SEQ-GEN .K .DEST T>>>
+ <COND (<==? .TEM ,NO-DATUM>
+ <COND (<EMPTY? <CDST .PNOD>>
+ <SET CD ,NO-DATUM>)
+ (ELSE <SET CD <CDST .PNOD>>)>)>)>)>
+ <OR <ASSIGNED? NPRUNE> <PUT .PNOD ,KIDS ()>>
+ <AND .CD <TYPE? .CD DATUM> <PROG ()
+ <ACFIX .DEST .CD>>>
+ <COND (<AND <N==? <NODE-SUBR .PNOD> ,REPEAT>
+ <N==? .TEM ,NO-DATUM>>
+ <COND (<ACTIVATED .PNOD> <PROG:END>)
+ (.OPRE
+ <POP:LOCS .STK .STB>
+ <UNBIND:FUNNY <SPECS-START .PNOD> !.NTSLOTS>)
+ (ELSE <UNBIND:LOCS .STK .STB>)>)
+ (<==? <NODE-SUBR .PNOD> ,REPEAT>
+ <AGAIN-UP .PNOD>
+ <BRANCH:TAG .AGAIN>)>
+ <COND (<AND <N==? <NODE-SUBR .PNOD> ,REPEAT> <AGND .PNOD>>
+ <RETURN-UP .PNOD>)>
+ <COND (<AND <N==? <NODE-SUBR .PNOD> ,REPEAT> <NOT <AGND .PNOD>>>
+ <NON-LOOP-CLEANUP .PNOD>
+ <PROG ((STK .STB) (NTSLOTS .ONS))
+ #DECL ((NTSLOTS STK) <SPECIAL LIST>)
+ <VAR-STORE>>)>
+ <COND (<OR <AGND .PNOD> <==? <NODE-SUBR .PNOD> ,REPEAT>>
+ <CLEANUP-STATE .PNOD>)
+ (ELSE <CHECK:VARS .SACS T>)>
+ <COND (<AND <==? <NODE-SUBR .PNOD> ,REPEAT>
+ <NOT <==? .DEST FLUSHED>>>
+ <MOVE:ARG .DEST .DEST>)>
+ <COND (<AND <TYPE? .DEST DATUM>
+ <ISTYPE? <DATTYP .DEST>>
+ .CD
+ <TYPE? <DATTYP .CD> AC>>
+ <RET-TMP-AC <DATTYP .CD> .CD>)>
+ <LABEL:TAG .EXIT>
+ <COND (<ACTIVATED .PNOD> <LABEL:OFF .EXIT:OFF>)
+ (ELSE <SET TEM .TOT-SPEC>)>>
+ <OR <ACTIVATED .PNOD> <SET TOT-SPEC .TEM>>
+ <SET STK .STB>
+ <COND (.CD
+ <AND <TYPE? <DATTYP .DEST> AC>
+ <FIX-ACLINK <DATTYP .DEST> .DEST .CD>>
+ <AND <TYPE? <DATVAL .DEST> AC>
+ <FIX-ACLINK <DATVAL .DEST> .DEST .CD>>)>
+ <SET XX <MOVE:ARG .DEST .PWHERE>>
+ <END-FRAME>
+ .XX>
+
+"\f"
+
+" Generate code for a RETURN."
+
+<DEFINE RETURN-GEN (NOD WHERE
+ "AUX" (SPECD .SPECD) N NN (CD1 <>) DEST (NF 0)
+ NOT-HANDLED-PROG (NT .NTSLOTS))
+ #DECL ((NOD N RPNOD) NODE (WHERE) <OR ATOM DATUM> (CD1) <OR DATUM
+ FALSE>
+ (SPECD) <SPECIAL ANY> (NF) FIX)
+ <PROG ()
+ <COND (<1? <LENGTH <KIDS .NOD>>> <SET N .RPNOD>)
+ (<SET NN <RET-AGAIN-ONLY <NODE-NAME <2 <KIDS .NOD>>>>>
+ <SET N .NN>)
+ (ELSE <RETURN <SUBR-GEN .NOD .WHERE>>)>
+ <SET NOT-HANDLED-PROG
+ <NOT <OR <==? <NODE-SUBR .N> ,REPEAT>
+ <AND <==? <NODE-SUBR .N> ,PROG> <AGND .N>>>>>
+ <COND (<==? <SET DEST <DST .N>> FLUSHED>
+ <RET-TMP-AC <GEN <1 <KIDS .NOD>> FLUSHED>>)
+ (ELSE
+ <PUT .N
+ ,CDST
+ <SET CD1 <GEN <1 <KIDS .NOD>> <DATUM !.DEST>>>>
+ <RET-TMP-AC .CD1>
+ <ACFIX <DST .N> .CD1>)>
+ <AND .NOT-HANDLED-PROG <VAR-STORE>>
+ <COND (<ACTIVATED .N>
+ <REPEAT ((L .FRMS))
+ #DECL ((L) LIST)
+ <COND (<==? <3 .L> .N> <RETURN>)>
+ <AND <EMPTY? <SET L <REST .L 5>>> <RETURN>>
+ <SET NT <5 .L>>
+ <SET NF <+ .NF 1>>>
+ <GO:BACK:FRAMES .NF>
+ <OR .NOT-HANDLED-PROG <RETURN-UP .N>>
+ <PROG:END>)
+ (ELSE
+ <REPEAT ((LL .SPEC-LIST))
+ #DECL ((LL) LIST)
+ <AND <2 .LL> <RETURN <SET SPECD T>>>
+ <AND <==? <1 .LL> .N> <RETURN>>
+ <SET LL <REST .LL 3>>>
+ <COND (<TYPE? .CD1 DATUM>
+ <COND (<TYPE? <DATTYP .CD1> AC>
+ <PUT <DATTYP .CD1> ,ACPROT T>)>
+ <COND (<TYPE? <DATVAL .CD1> AC>
+ <PUT <DATVAL .CD1> ,ACPROT T>)>)>
+ <COND (<PRE-ALLOC .N>
+ <POP:LOCS .STK <STK-B .N>>
+ <UNBIND:FUNNY <SPECS-START .N> !.NT>)
+ (ESLE <UNBIND:LOCS .STK <STK-B .N>>)>
+ <COND (<TYPE? .CD1 DATUM>
+ <COND (<TYPE? <DATTYP .CD1> AC>
+ <PUT <DATTYP .CD1> ,ACPROT <>>)>
+ <COND (<TYPE? <DATVAL .CD1> AC>
+ <PUT <DATVAL .CD1> ,ACPROT <>>)>)>
+ <OR .NOT-HANDLED-PROG
+ <PROG ((STB <STK-B .N>))
+ #DECL ((STB) <SPECIAL LIST>)
+ <RETURN-UP .N>>>
+ <BRANCH:TAG <RTAG .N>>)>
+ ,NO-DATUM>>
+
+<DEFINE GO:BACK:FRAMES (NF)
+ #DECL ((NF) FIX)
+ <OR <0? .NF>
+ <REPEAT ()
+ <EMIT '<`MOVE `TB* |OTBSAV `(TB) >>
+ <COND (<0? <SET NF <- .NF 1>>> <RETURN>)>>>>
+
+"\f"
+
+" Generate code for an AGAIN."
+
+<DEFINE AGAIN-GEN (NOD WHERE
+ "AUX" N NN (SPECD .SPECD) (PRE <>) NOT-HANDLED-PROG)
+ #DECL ((NOD N RPNOD) NODE (SPECD) <SPECIAL ANY>)
+ <PROG ()
+ <COND (<EMPTY? <KIDS .NOD>> <SET N .RPNOD>)
+ (<SET NN <RET-AGAIN-ONLY <NODE-NAME <1 <KIDS .NOD>>>>>
+ <SET N .NN>)
+ (ELSE <VAR-STORE <>> <RETURN <SUBR-GEN .NOD .WHERE>>)>
+ <COND (<SET NOT-HANDLED-PROG
+ <NOT <OR <==? <NODE-SUBR .N> ,PROG>
+ <==? <NODE-SUBR .N> ,REPEAT>
+ <==? <NODE-SUBR .N> ,BIND>>>>
+ <VAR-STORE>)>
+ <COND (<N==? .N <1 .SPEC-LIST>>
+ <REPEAT ((L1 ()) (LL .SPEC-LIST))
+ #DECL ((LL L1) LIST)
+ <AND <EMPTY? <SET L1 <REST .LL 3>>> <RETURN>>
+ <AND <2 .LL> <SET SPECD <3 .LL>>>
+ <COND (<==? <4 .LL> .N>
+ <RETURN <SET PRE <PRE-ALLOC <1 .LL>>>>)
+ (ELSE <SET LL .L1>)>>)>
+ <COND (.PRE <POP:LOCS .STK <BTP-B .N>> <UNBIND:FUNNY .SPECD !.NTSLOTS>)
+ (ELSE <UNBIND:LOCS .STK <BTP-B .N>>)>
+ <OR .NOT-HANDLED-PROG <PROG ((STK <BTP-B .N>)) #DECL ((STK) <SPECIAL LIST>)
+ <AGAIN-UP .N>>>
+ <BRANCH:TAG <ATAG .N>>
+ ,NO-DATUM>>
+
+" Generate code for a GO in a PROG/REPEAT."
+
+<DEFINE GO-GEN (NOD WHERE "AUX" (N <1 <KIDS .NOD>>) (RT <RESULT-TYPE .N>))
+ #DECL ((NOD N) NODE (WHERE) <OR ATOM DATUM>)
+ <VAR-STORE>
+ <COND (<==? .RT ATOM>
+ <POP:LOCS .STK <BTP-B .RPNOD>>
+ <REGSTO T>
+ <BRANCH:TAG <UNIQUE:TAG <NODE-NAME <1 <KIDS .NOD>>> <>>>)
+ (ELSE
+ <RET-TMP-AC <STACK:ARGUMENT <GEN .N DONT-CARE>>>
+ <REGSTO T>
+ <EMIT '<MCALL!-OP!-PACKAGE 1 GO>>)>
+ ,NO-DATUM>
+
+<DEFINE TAG-GEN (NOD WHERE
+ "AUX" (ATM <UNIQUE:TAG <NODE-NAME <1 <KIDS .NOD>>> <>>))
+ #DECL ((NOD) NODE)
+ <EMIT <INSTRUCTION `MOVEI `O .ATM>>
+ <EMIT '<`SUBI `O `(M) >>
+ <EMIT '<`PUSH `TP* <TYPE-WORD!-OP!-PACKAGE FIX>>>
+ <EMIT '<`PUSH `TP* 0>>
+ <REGSTO T>
+ <EMIT '<`PUSHJ `P* |MAKACT >>
+ <EMIT '<`PUSH `TP* `A >>
+ <EMIT '<`PUSH `TP* `B >>
+ <EMIT '<MCALL!-OP!-PACKAGE 2 TAG>>
+ <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>
+
+
+" Generate code to flush stack for leaving a PROG etc."
+
+<DEFINE PROG:UNBIND ()
+ #DECL ((STK STB) LIST (PNOD) NODE)
+ <COND (.PRE
+ <POP:LOCS .STK .STB>
+ <UNBIND:FUNNY <SPECS-START .PNOD> !.NTSLOTS>)
+ (ELSE <UNBIND:LOCS .STK .STB>)>>
+
+"\f"
+
+"ROUTINES TO ALLOW KEEPING VARIABLES IN AC'S THRU LOOPS. THE OUTINES KEEP INFORMATION
+ IN THE PROG NODE TELLING INFORMATION AT VARIOUS POINTS (I.E. AGAIN AND RETURN POINTS).
+ VARIABLES KEPT IN ACS WILL CONTAIN POINTERS TO THE PROG NODES INVOLVED AND THE DECISION
+ WILL BE MADE TO KEEP THEM IN AC'S WHEN THEY ARE FIRST REFERENCED. AGAINS AND RETURNS
+ WILL EMIT NULL MACROS AND A FIXUP ROUTINE WILL BE USED AT THE END TO COERCE THE STATES
+ CORRECTLY."
+
+"ROUTINE TO INITIALIZE STATE INFORMATION ON ENTERING LOOPS. IT TAKES A PROG/REPEAT NODE
+ AND WILL UPDATE INFORMATION CONTAING SLOTS AS WELL AS PUTTING THE NODE INTO PROG-AC
+ SLOTS OF APPROPRIATE SYMTABS. THE SLOTS MAY CONTAIN MULTIPLE PROG NODES BUT THE ONE
+ CURRENTLY BEING HACKED WILL BE FIRST. IF FLUSHING A VAR THE ENTIRE SLOT WILL BE
+ FLUSHED."
+
+<DEFINE PROG-START-AC (PNOD "AUX" (PVARS ()) ONSYMT OPROG-AC OPOTLV)
+ #DECL ((PNOD) NODE)
+ <MAPF <>
+ <FUNCTION (AC "AUX" SYMT)
+ #DECL ((AC) AC)
+ <COND (<SET SYMT <CLEAN-AC .AC>>
+ <COND (<NOT <MEMQ .PNOD <PROG-AC .SYMT>>>
+ <SET ONSYMT <NUM-SYM .SYMT>>
+ <SMASH-NUM-SYM .SYMT>
+ <SET OPROG-AC <PROG-AC .SYMT>>
+ <SET OPOTLV <POTLV .SYMT>>
+ <PUT .SYMT ,POTLV <>>
+ <PUT .SYMT
+ ,PROG-AC
+ (.PNOD
+ TMP
+ <STORED .SYMT>
+ <DATUM <DATTYP <INACS .SYMT>>
+ <DATVAL <INACS .SYMT>>>)>
+ <SET PVARS
+ (.SYMT
+ .ONSYMT
+ .OPROG-AC
+ .OPOTLV
+ !.PVARS)>)>)>>
+ ,ALLACS>
+ <PUT .PNOD ,LOOP-VARS ()>
+ <PUT .PNOD ,AGAIN-STATES ()>
+ <PUT .PNOD ,RETURN-STATES ()>
+ <PUT .PNOD ,PROG-VARS .PVARS>
+ <VAR-STORE <>>
+ <REPEAT ((PTR .PVARS) SYMT)
+ <COND (<EMPTY? .PTR> <RETURN>)>
+ <SET SYMT <SYM-SLOT .PTR>>
+ <OR <STORED-SLOT <PROG-AC .SYMT>>
+ <PUT <PROG-AC .SYMT> ,NUM-SYM-SLOT <2 <NUM-SYM .SYMT>>>>
+ <SET PTR <REST .PTR ,LENGTH-PROG-VARS>>>>
+
+<DEFINE CLEAN-AC (AC "AUX" ACRES INAC OAC)
+ #DECL ((AC) AC (INAC) DATUM)
+ <COND
+ (<SET ACRES <ACRESIDUE .AC>>
+ <PUT .AC ,ACRESIDUE <>>
+ <MAPF <>
+ <FUNCTION (SYM)
+ <COND
+ (<TYPE? .SYM SYMTAB>
+ <MAPF <>
+ <FUNCTION (SYMT)
+ <COND (<N==? .SYMT .SYM>
+ <COND (<OR <NOT <TYPE? .SYMT SYMTAB>>
+ <STORED .SYMT>>
+ <SMASH-INACS .SYMT <>>)
+ (ELSE <STOREV .SYMT T>)>)>>
+ .ACRES>
+ <COND
+ (<AND <SET INAC <INACS .SYM>>
+ <OR <AND <==? <DATTYP .INAC> .AC>
+ <TYPE? <SET OAC <DATVAL .INAC>> AC>>
+ <AND <==? <DATVAL .INAC> .AC>
+ <TYPE? <SET OAC <DATTYP .INAC>> AC>>>>
+ <MAPF <>
+ <FUNCTION (SYMT)
+ <COND (<N==? .SYMT .SYM>
+ <COND (<OR <NOT <TYPE? .SYMT SYMTAB>>
+ <STORED .SYMT>>
+ <SMASH-INACS .SYMT <>>)
+ (ELSE <STOREV .SYMT T>)>)>>
+ <ACRESIDUE .OAC>>
+ <PUT .OAC ,ACRESIDUE (.SYM)>)>
+ <PUT .AC ,ACRESIDUE (.SYM)>
+ <MAPLEAVE <1 <ACRESIDUE .AC>>>)
+ (ELSE <SMASH-INACS .SYM <>> <>)>>
+ .ACRES>)>>
+
+<DEFINE AGAIN-UP (PNOD "OPTIONAL" (RET <>) "AUX" CSTATE)
+ #DECL ((PNOD) NODE (RET) <OR ATOM FALSE>)
+ <SET CSTATE <CURRENT-AC-STATE>>
+ <PUT .PNOD
+ ,AGAIN-STATES
+ (.CSTATE .CODE:PTR <STACK:INFO> .RET !<AGAIN-STATES .PNOD>)>>
+
+<DEFINE RETURN-UP (PNOD "OPTIONAL" (STK .STB) "AUX" CSTATE)
+ #DECL ((PNOD) NODE (STK) <SPECIAL LIST>)
+ <COND (<NOT <AND <OR <==? <NODE-SUBR .PNOD> ,PROG>
+ <==? <NODE-SUBR .PNOD> ,BIND>>
+ <NOT <AGND .PNOD>>>>
+ <SET CSTATE <CURRENT-AC-STATE .PNOD>>
+ <PUT .PNOD
+ ,RETURN-STATES
+ (.CSTATE
+ .CODE:PTR
+ <STACK:INFO>
+ T
+ !<RETURN-STATES .PNOD>)>)>>
+
+<DEFINE STACK:INFO ()
+ (.FRMS .BSTB .NTSLOTS .STK)>
+"\f"
+
+"OK FOLKS HERE IT IS. THIS IS THE ROUTINE THAT MERGES ALL THE STATES IN LOOPS
+ AND DOES THE RIGHT THING IN ALL CASES (MAYBE?). IT TAKES A PROG AND MAKES SURE
+ THAT STATES ARE CONSISTENT AT AGAIN AND RETURN POINTS. FOR AGAIN POINTS IT
+ MAKES SURE THAT ALL LOOP VARIABLES IN THE RIGHT ACS."
+
+<DEFINE CLEANUP-STATE (PNOD
+ "AUX" (LOOPVARS <LOOP-VARS .PNOD>)
+ (AGAIN-ST <AGAIN-STATES .PNOD>)
+ (RETURN-ST <RETURN-STATES .PNOD>))
+ #DECL ((PNOD) NODE (RETURN-ST) <SPECIAL LIST>)
+ <FIXUP-STORES .AGAIN-ST>
+ <FIXUP-STORES .RETURN-ST>
+ <CLEANUP-VARS <PROG-VARS .PNOD>>
+ <LOOP-REPEAT .LOOPVARS .AGAIN-ST>
+ <LOOP-RETURN .RETURN-ST>>
+
+<DEFINE LOOP-REPEAT (LOOPVARS AGAIN-ST)
+ <REPEAT ((APTR .AGAIN-ST) REST-CODE-PTR)
+ #DECL ((APTR)
+ <LIST [REST REP-STATE <PRIMTYPE LIST> LIST <OR ATOM FALSE>]>
+ (REST-CODE-PTR)
+ LIST)
+ <COND (<EMPTY? .APTR> <RETURN>)>
+ <SET REST-CODE-PTR <REST <SAVED-CODE:PTR .APTR>>>
+ <LOOP-RESTORE <LIST !.LOOPVARS>
+ <SAVED-CODE:PTR .APTR>
+ <SAVED-AC-STATE .APTR>
+ <SAVED-STACK-STATE .APTR>
+ <SAVED-RET-FLAG .APTR>>
+ <COND
+ (<SAVED-RET-FLAG .APTR>
+ <SET RETURN-ST
+ (<SAVED-AC-STATE .APTR>
+ <MAPR <>
+ <FUNCTION (CP "AUX" (RCP <REST .CP>))
+ #DECL ((CP) <LIST ANY> (RCP) LIST)
+ <COND (<==? .RCP .REST-CODE-PTR>
+ <MAPLEAVE .CP>)>>
+ <SAVED-CODE:PTR .APTR>>
+ <SAVED-STACK-STATE .APTR>
+ T
+ !.RETURN-ST)>)>
+ <SET APTR <REST .APTR ,LENGTH-CONTROL-STATE>>>>
+
+<DEFINE LOOP-RESTORE (LPV INST ACS STACK-INFO RET)
+ #DECL ((LPV INST STACK-INFO) <PRIMTYPE LIST> (ACS) REP-STATE
+ (RET) <OR ATOM FALSE>)
+ <PROG ((SCODE:PTR .INST) (BSTB <SAVED-BSTB .STACK-INFO>)
+ (FRMS <SAVED-FRMS .STACK-INFO>)
+ (NTSLOTS <SAVED-NTSLOTS .STACK-INFO>)
+ (STK <SAVED-STK .STACK-INFO>))
+ #DECL ((NTSLOTS BSTB FRMS STK SCODE:PTR) <SPECIAL LIST>)
+ <STORE-SAVED-ACS .LPV .ACS>
+ <MOVE-AROUND-ACS .LPV .ACS .RET>
+ <GET-ACS-FROM-STACK .LPV .ACS>>>
+
+<DEFINE MOVE-AROUND-ACS (LPV ACS RET)
+ #DECL ((LPV) LIST (ACS) REP-STATE (RET) <OR ATOM FALSE>)
+ <REPEAT ((LPVP .LPV) CSYMT CINACS INAC)
+ #DECL ((SYMT) SYMTAB (CINACS) DATUM)
+ <COND (<EMPTY? .LPVP> <RETURN>)>
+ <SET CSYMT <LSYM-SLOT .LPVP>>
+ <SET CINACS <LINACS-SLOT .LPVP>>
+ <COND (<SET INAC <AC? .CSYMT .ACS>>
+ <PUT .LPVP ,LSYM-SLOT <>>
+ <COND (<OR <=? .INAC .CINACS>
+ <AND <TYPE? <DATTYP .CINACS> ATOM>
+ <==? <DATVAL .CINACS> <DATVAL .INAC>>>>)
+ (<TYPE? <DATTYP .CINACS> ATOM>
+ <ONE-EXCH-AC .CINACS
+ .INAC
+ .ACS
+ .CSYMT
+ .RET
+ .LPV>)
+ (<TWO-AC-EXCH .CINACS
+ .INAC
+ .ACS
+ .CSYMT
+ .RET
+ .LPV>)>)>
+ <SET LPVP <REST .LPVP ,LOOPVARS-LENGTH>>>>
+
+<DEFINE ONE-EXCH-AC (DEST-INAC CURR-INAC ACS CSYMT RET LPV
+ "AUX" (DEST-AC <DATVAL .DEST-INAC>)
+ (NOEXCH
+ <AND <NOT <AND .RET <ACLINK .DEST-AC>>>
+ <EMPTY? <NTH .ACS <ACNUM .DEST-AC>>>>))
+ #DECL ((DEST-INAC CURR-INAC) <DATUM ANY AC> (ACS) REP-STATE
+ (DEST-AC) AC)
+ <SEMIT <INSTRUCTION <COND (.NOEXCH `MOVE ) (ELSE `EXCH )>
+ <ACSYM <DATVAL .DEST-INAC>>
+ <ADDRSYM <DATVAL .CURR-INAC>>>>
+ <SWAP-INAC <DATVAL .CURR-INAC>
+ <DATVAL .DEST-INAC>
+ .ACS
+ .CSYMT
+ .RET
+ .NOEXCH
+ .LPV>>
+
+<DEFINE TWO-AC-EXCH (DEST-INAC CURR-INAC ACS CSYMT RET LPV
+ "AUX" (DTAC <DATTYP .DEST-INAC>)
+ (DVAC <DATVAL .DEST-INAC>)
+ (TDONTEXCH
+ <AND <NOT <AND .RET <ACLINK .DTAC>>>
+ <NTH .ACS <ACNUM .DTAC>>>)
+ (VDONTEXCH
+ <AND <NOT <AND .RET <ACLINK .DVAC>>>
+ <NTH .ACS <ACNUM .DVAC>>>))
+ #DECL ((DEST-INAC CURR-INAC) DATUM)
+ <COND
+ (<TYPE? <DATTYP .CURR-INAC> AC>
+ <COND
+ (<==? <DATTYP .CURR-INAC> .DTAC>
+ <ONE-EXCH-AC .DEST-INAC .CURR-INAC .ACS .CSYMT .RET .LPV>)
+ (<==? .DTAC <DATVAL .CURR-INAC>>
+ <SEMIT <INSTRUCTION <COND (.TDONTEXCH `MOVE ) (ELSE `EXCH )>
+ <ACSYM .DTAC>
+ <ADDRSYM <DATTYP .CURR-INAC>>>>
+ <SWAP-INAC <DATTYP .CURR-INAC>
+ <DATTYP .DEST-INAC>
+ .ACS
+ .CSYMT
+ .RET
+ .TDONTEXCH
+ .LPV>
+ <COND (<==? .DVAC <DATVAL .CURR-INAC>>)
+ (ELSE
+ <SEMIT <INSTRUCTION <COND (.VDONTEXCH `MOVE ) (ELSE `EXCH )>
+ <ACSYM .DVAC>
+ <ADDRSYM <DATVAL .CURR-INAC>>>>
+ <SWAP-INAC <DATVAL .CURR-INAC>
+ <DATVAL .DEST-INAC>
+ .ACS
+ .CSYMT
+ .RET
+ .VDONTEXCH
+ .LPV>)>)
+ (ELSE
+ <SEMIT <INSTRUCTION <COND (.TDONTEXCH `MOVE ) (ELSE `EXCH )>
+ <ACSYM .DTAC>
+ <ADDRSYM <DATTYP .CURR-INAC>>>>
+ <SWAP-INAC <DATTYP .CURR-INAC>
+ <DATTYP .DEST-INAC>
+ .ACS
+ .CSYMT
+ .RET
+ .TDONTEXCH
+ .LPV>
+ <COND (<==? <DATVAL .DEST-INAC> <DATVAL .CURR-INAC>>)
+ (ELSE
+ <SEMIT <INSTRUCTION <COND (.VDONTEXCH `MOVE ) (ELSE `EXCH )>
+ <ACSYM .DVAC>
+ <ADDRSYM <DATVAL .CURR-INAC>>>>
+ <SWAP-INAC <DATVAL .CURR-INAC>
+ <DATVAL .DEST-INAC>
+ .ACS
+ .CSYMT
+ .RET
+ .VDONTEXCH
+ .LPV>)>)>)
+ (<COND (<==? <DATVAL .CURR-INAC> .DVAC>)
+ (ELSE
+ <SEMIT <INSTRUCTION <COND (.VDONTEXCH `MOVE ) (ELSE `EXCH )>
+ <ACSYM .DVAC>
+ <ADDRSYM <DATVAL .CURR-INAC>>>>
+ <SWAP-INAC <DATVAL .CURR-INAC>
+ <DATVAL .DEST-INAC>
+ .ACS
+ .CSYMT
+ .RET
+ .VDONTEXCH
+ .LPV>)>
+ <SEMIT <INSTRUCTION `MOVE <ACSYM .DTAC> !<ADDR:TYPE .CURR-INAC>>>)>>
+
+"\f"
+
+<DEFINE CURRENT-AC-STATE ("OPTIONAL" (RETPNOD <>) "AUX" (BST ()) PAC)
+ #DECL ((VALUE) REP-STATE)
+ <COND (.RETPNOD <SET BST <BINDING-STRUCTURE .RETPNOD>>)>
+ <MAPF ,LIST
+ <FUNCTION (AC "AUX" (ACR <ACRESIDUE .AC>) (SACR ()))
+ <MAPF <>
+ <FUNCTION (SYMT)
+ <COND
+ (<AND <TYPE? .SYMT SYMTAB> <NOT <MEMQ .SYMT .BST>>>
+ <SET SACR
+ (.SYMT
+ <SINACS .SYMT>
+ <COND (<STORED .SYMT>
+ <OR <NOT <TYPE? <NUM-SYM .SYMT> LIST>>
+ <NOT <1 <NUM-SYM .SYMT>>>
+ <L? <LENGTH <NUM-SYM .SYMT>> 2>
+ <2 <NUM-SYM .SYMT>>>)>
+ <AND <SET PAC <PROG-AC .SYMT>>
+ <NOT <MEMQ .SYMT <LOOP-VARS <PROG-SLOT .PAC>>>>>
+ !.SACR)>)>>
+ .ACR>
+ .SACR>
+ ,ALLACS>>
+
+
+<DEFINE LVAL-UP (SYMT "OPTIONAL" (PSLOT <PROG-AC .SYMT>) "AUX" PNAC)
+ #DECL ((SYMT) SYMTAB)
+ <COND
+ (<AND .PSLOT
+ <SET PNAC <PROG-SLOT .PSLOT>>
+ <NOT <MEMQ .SYMT <LOOP-VARS .PNAC>>>>
+ <COND (<INACS .SYMT>
+ <PUT .PNAC
+ ,LOOP-VARS
+ (.SYMT <INACS-SLOT .PSLOT> !<LOOP-VARS .PNAC>)>
+ <COND (<STORED-SLOT .PSLOT>) (<KILL-STORE <NUM-SYM-SLOT .PSLOT>>)>
+ <COND (<NOT <POTLV .SYMT>> <PUT .SYMT ,STORED <>>)>
+ <REPEAT ((PTR <PROG-VARS .PNAC>))
+ #DECL ((PTR) LIST)
+ <COND (<EMPTY? .PTR> <RETURN>)>
+ <COND (<==? .SYMT <SYM-SLOT .PTR>>
+ <LVAL-UP .SYMT <SAVED-PROG-AC-SLOT .PTR>>
+ <RETURN>)>
+ <SET PTR <REST .PTR ,LENGTH-PROG-VARS>>>)
+ (ELSE <KILL-LOOP-AC .SYMT>)>)>>
+
+"\f"
+
+<DEFINE STORE-SAVED-ACS (LPV ACS "AUX" CINAC)
+ #DECL ((LPV) LIST (ACS) REP-STATE)
+ <MAPF <>
+ <FUNCTION (ONE-ACS AC)
+ #DECL ((ONE-ACS) LIST)
+ <REPEAT ((PTR .ONE-ACS) SYMT)
+ #DECL ((PTR) LIST (SYMT) SYMBOL)
+ <COND (<EMPTY? .PTR> <RETURN>)
+ (<AND <NOT <MEMQ <SET SYMT <CSYMT-SLOT .PTR>> .LPV>>
+ <NOT <AND <TYPE? <DATTYP <SET CINAC <CINACS-SLOT .PTR>>>
+ AC>
+ <==? .AC <DATTYP .CINAC>>
+ <TYPE? <DATVAL .CINAC> AC>>>>
+ <SPEC-STOREV .SYMT .CINAC <CSTORED-SLOT .PTR>>
+ <PUT .PTR ,CSTORED-SLOT T>)>
+ <SET PTR <REST .PTR ,LENGTH-CSTATE>>>>
+ .ACS
+ ,ALLACS>>
+
+<DEFINE AC? (SYMT ACS)
+ #DECL ((SYMT) SYMTAB (ACS) LIST)
+ <MAPF <>
+ <FUNCTION (AC)
+ #DECL ((AC) LIST)
+ <REPEAT ((PTR .AC))
+ #DECL ((PTR) LIST)
+ <COND (<EMPTY? .PTR> <RETURN <>>)>
+ <COND (<==? <CSYMT-SLOT .PTR> .SYMT>
+ <MAPLEAVE <CINACS-SLOT .PTR>>)>
+ <SET PTR <REST .PTR ,LENGTH-CSTATE>>>>
+ .ACS>>
+
+"THIS ROUTINE SWAPS PORTIONS OF DATUMS. IT TAKES TWO ACS AND THE ACS LIST AND SWAPS THE
+ INFORMATION IN THE ACS LIST. AC2 IS THE GOAL AC AND ENDS UP CONTAINING ONLY ONE DATUM."
+
+<DEFINE SWAP-INAC (AC1 AC2 ACS SYMT RET NOEXCH LPV
+ "AUX" (NUM1 <ACNUM .AC1>) (NUM2 <ACNUM .AC2>) SWDAT1 SWDAT2
+ (ACL1 <ACLINK .AC1>) (ACL2 <ACLINK .AC2>) (PUTR ()))
+ #DECL ((AC1 AC2) AC (NUM1 NUM2) FIX (ACS) REP-STATE (RET) <OR ATOM FALSE>
+ (LPV) LIST)
+ <COND (<AND .RET <NOT .NOEXCH>>
+ <SWAP-DATUMS .ACL1 .AC1 .AC2>
+ <SWAP-DATUMS .ACL2 .AC2 .AC1>
+ <PUT .AC2 ,ACLINK .ACL1>
+ <PUT .AC1 ,ACLINK .ACL2>)>
+ <SET SWDAT1 <NTH .ACS .NUM1>>
+ <SET SWDAT2 <NTH .ACS .NUM2>>
+ <REPEAT ((PTR .SWDAT1) SUB-PTR)
+ #DECL ((PTR) LIST)
+ <COND (<EMPTY? .PTR> <RETURN>)>
+ <COND
+ (<AND
+ <SET SUB-PTR <MEMQ .AC1 <CINACS-SLOT .PTR>>>
+ <OR
+ <NOT .NOEXCH>
+ <==? .SYMT <CSYMT-SLOT .PTR>>
+ <REPEAT ((S <CSYMT-SLOT .PTR>) (LP .LPV)
+ (DV <==? .AC1 <DATVAL <CINACS-SLOT .PTR>>>))
+ #DECL ((LP) LIST)
+ <COND (<EMPTY? .LP> <RETURN>)>
+ <COND (<==? <LSYM-SLOT .LP> .S>
+ <COND (.DV <RETURN <==? <DATVAL <LINACS-SLOT .LP>> .AC2>>)
+ (ELSE
+ <RETURN <==? <DATTYP <LINACS-SLOT .LP>> .AC2>>)>)>
+ <SET LP <REST .LP ,LOOPVARS-LENGTH>>>>>
+ <SET PUTR (.SUB-PTR .AC2 !.PUTR)>)>
+ <SET PTR <REST .PTR ,LENGTH-CSTATE>>>
+ <COND (<NOT .NOEXCH>
+ <REPEAT ((PTR .SWDAT2) SUB-PTR)
+ #DECL ((PTR) LIST)
+ <COND (<EMPTY? .PTR> <RETURN>)>
+ <COND (<SET SUB-PTR <MEMQ .AC2 <CINACS-SLOT .PTR>>>
+ <SET PUTR (.SUB-PTR .AC1 !.PUTR)>)>
+ <SET PTR <REST .PTR ,LENGTH-CSTATE>>>)>
+ <REPEAT ()
+ <COND (<EMPTY? .PUTR> <RETURN>)>
+ <PUT <1 .PUTR> 1 <2 .PUTR>>
+ <SET PUTR <REST .PUTR 2>>>
+ <COND (<NOT .NOEXCH> <PUT .ACS .NUM1 .SWDAT2>)>
+ <PUT .ACS .NUM2 .SWDAT1>>
+
+<DEFINE SWAP-DATUMS (ACL ACOLD ACNEW)
+ #DECL ((ACL) <OR FALSE <LIST [REST DATUM]>>)
+ <MAPF <>
+ <FUNCTION (DAT "AUX" ACLTEM)
+ #DECL ((DAT) DATUM)
+ <COND (<SET ACLTEM <MEMQ .ACOLD .DAT>>
+ <PUT .ACLTEM 1 .ACNEW>)
+ (ELSE <MESSAGE INCONSISTENCY "BAD ACLINK">)>>
+ .ACL>>
+
+<DEFINE GET-ACS-FROM-STACK (LPV ACS)
+ #DECL ((LPV) LIST (ACS) REP-STATE)
+ <REPEAT ((LPVP .LPV) DAT DAT2)
+ #DECL ((LPVP) LIST (DAT) DATUM)
+ <COND (<EMPTY? .LPVP> <RETURN>)>
+ <COND (<LSYM-SLOT .LPVP>
+ <PUT <LSYM-SLOT .LPVP> ,INACS <>>
+ <SET DAT2 <LADDR <LSYM-SLOT .LPVP> <> <>>>
+ <SET DAT <LINACS-SLOT .LPVP>>
+ <COND (<TYPE? <DATTYP .DAT> AC>
+ <SEMIT <INSTRUCTION
+ `MOVE
+ <ACSYM <DATTYP .DAT>>
+ !<ADDR:TYPE .DAT2>>>)>
+ <SEMIT <INSTRUCTION `MOVE
+ <ACSYM <DATVAL .DAT>>
+ !<ADDR:VALUE .DAT2>>>)>
+ <SET LPVP <REST .LPVP ,LOOPVARS-LENGTH>>>>
+
+"\f"
+
+<DEFINE NON-LOOP-CLEANUP (N "AUX" (B <BINDING-STRUCTURE .N>))
+ #DECL ((N) NODE (B) <LIST [REST SYMTAB]>)
+ <MAPF <>
+ <FUNCTION (S "AUX" (INA <INACS .S>))
+ #DECL ((S) SYMTAB)
+ <COND (.INA
+ <COND (<TYPE? <DATTYP .INA> AC>
+ <FLUSH-RESIDUE <DATTYP .INA> .S>)>
+ <COND (<TYPE? <DATVAL .INA> AC>
+ <FLUSH-RESIDUE <DATVAL .INA> .S>)>)>
+ <PUT .S ,INACS <>>
+ <PUT .S ,STORED T>>
+ .B>>
+
+"ROUTINES TO HANDLE LOOP-RETURNS."
+
+<DEFINE LOOP-RETURN (RETINFO "AUX" LST)
+ #DECL ((LST RETINFO) LIST)
+ <MAPF <>
+ <FUNCTION (AC "AUX" ACR)
+ #DECL ((AC) AC)
+ <PUT .AC ,ACLINK <>>
+ <COND (<SET ACR <ACRESIDUE .AC>>
+ <MAPF <>
+ <FUNCTION (IT) <SMASH-INACS .IT <> <>>>
+ .ACR>)>
+ <PUT .AC ,ACRESIDUE <>>>
+ ,ALLACS>
+ <COND (<NOT <EMPTY? .RETINFO>>
+ <SET LST <MERGE-RETURNS .RETINFO>>
+ <REPEAT ((PTR .RETINFO))
+ #DECL ((PTR) LIST)
+ <COND (<EMPTY? .PTR> <RETURN>)>
+ <MERGE-SINGLE-RETURN
+ <SAVED-AC-STATE .PTR>
+ <SAVED-CODE:PTR .PTR>
+ .LST
+ <SAVED-STACK-STATE .PTR>>
+ <SET PTR <REST .PTR ,LENGTH-CONTROL-STATE>>>)>>
+
+"ROUTINE TO FIGURE OUT A MERGE BETWEEN DIFFERENT RETURN POINTS. IN THE END A LIST OF
+ THINGS TO REMAIN IN AC'S ARE PRODUCED."
+
+<DEFINE MERGE-RETURNS (RETINFO "AUX" (ACKEEP ()))
+ #DECL ((ACKEEP) LIST
+ (RETINFO) <LIST [REST
+ REP-STATE
+ <PRIMTYPE LIST>
+ LIST
+ <OR ATOM FALSE>]>)
+ <REPEAT ((CNT 1) MERGER)
+ #DECL ((CNT) FIX)
+ <SET MERGER <LIST !<NTH <SAVED-AC-STATE .RETINFO> .CNT>>>
+ <COND (<NOT <EMPTY? .MERGER>>
+ <REPEAT ((PTR <REST .RETINFO ,LENGTH-CONTROL-STATE>))
+ <COND (<EMPTY? .PTR> <RETURN>)>
+ <SET MERGER
+ <MERG-IT .MERGER
+ <NTH <SAVED-AC-STATE .PTR> .CNT>>>
+ <COND (<EMPTY? .MERGER> <RETURN>)>
+ <SET PTR <REST .PTR ,LENGTH-CONTROL-STATE>>>)>
+ <COND (<NOT <EMPTY? .MERGER>> <SET ACKEEP (!.MERGER !.ACKEEP)>)>
+ <COND (<G? <SET CNT <+ .CNT 1>> 5> <RETURN>)>>
+ .ACKEEP>
+
+"ROUTINE TO FIGURE OUT IF THINGS MERGE"
+
+<DEFINE MERG-IT (CURR-STATE NEW-STATE
+ "AUX" (OLD-STATE .CURR-STATE) SPTR INAC1 INAC2)
+ #DECL ((CURR-STATE NEW-STATE) LIST)
+ <COND (<AND <SET SPTR <MEMQ <CSYMT-SLOT .CURR-STATE> .NEW-STATE>>
+ <OR <=? <SET INAC1 <CINACS-SLOT .CURR-STATE>>
+ <SET INAC2 <CINACS-SLOT .SPTR>>>
+ <AND <==? <DATVAL .INAC1> <DATVAL .INAC2>>
+ <OR <AND <ISTYPE? <DATTYP .INAC1>>
+ <PUT .SPTR ,CINACS-SLOT .INAC1>>
+ <AND <ISTYPE? <DATTYP .INAC2>>
+ <PUT .CURR-STATE
+ ,CINACS-SLOT
+ .INAC2>>>>>>
+ <COND (<AND <CSTORED-SLOT .CURR-STATE> <CSTORED-SLOT .SPTR>>)
+ (<PUT .CURR-STATE ,CSTORED-SLOT <>>
+ <PUT .SPTR ,CSTORED-SLOT <>>)>)
+ (<SET CURR-STATE <REST .CURR-STATE ,LENGTH-CSTATE>>)>
+ <REPEAT ((PTR .CURR-STATE))
+ #DECL ((PTR) LIST)
+ <COND (<EMPTY? .PTR> <RETURN>)>
+ <COND (<AND <SET SPTR <MEMQ <CSYMT-SLOT .PTR> .NEW-STATE>>
+ <=? <CINACS-SLOT .SPTR> <CINACS-SLOT .CURR-STATE>>>
+ <COND (<AND <CSTORED-SLOT .CURR-STATE>
+ <CSTORED-SLOT .SPTR>>)
+ (<PUT .CURR-STATE ,CSTORED-SLOT <>>
+ <PUT .SPTR ,CSTORED-SLOT <>>)>)
+ (ELSE ;"THIS ELSE USED TO B <CSTORED-STATE .CURR-STATE>"
+ <COND (<==? .PTR .CURR-STATE>
+ <SET OLD-STATE .CURR-STATE>
+ <SET CURR-STATE
+ <REST .CURR-STATE ,LENGTH-CSTATE>>)
+ (ELSE
+ <PUTREST <REST .OLD-STATE <- ,LENGTH-CSTATE 1>>
+ <REST .PTR ,LENGTH-CSTATE>>
+ <SET PTR .OLD-STATE>)>)>
+ <SET OLD-STATE .PTR>
+ <SET PTR <REST .PTR ,LENGTH-CSTATE>>>
+ .CURR-STATE>
+
+<DEFINE MERGE-SINGLE-RETURN (THISRETURN INS MERGEDRETURN STACK-INFO
+ "AUX" SYMT (MS ()))
+ #DECL ((INS THISRETURN MERGEDRETURN STACK-INFO) LIST
+ (MS) <LIST [REST SYMTAB]>)
+ <PROG ((SCODE:PTR .INS) (FRMS <SAVED-FRMS .STACK-INFO>)
+ (BSTB <SAVED-BSTB .STACK-INFO>) (NTSLOTS <SAVED-NTSLOTS .STACK-INFO>)
+ (STK <SAVED-STK .STACK-INFO>))
+ #DECL ((FRMS BSTB NTSLOTS STK SCODE:PTR) <SPECIAL LIST>)
+ <MAPF <>
+ <FUNCTION (CP AC)
+ #DECL ((AC) AC)
+ <REPEAT ()
+ <COND (<EMPTY? .CP> <RETURN>)>
+ <COND (<AND <NOT <MEMQ <SET SYMT <CSYMT-SLOT .CP>>
+ .MERGEDRETURN>>
+ <OR <==? .AC <DATVAL <CINACS-SLOT .CP>>>
+ <NOT <TYPE? <DATVAL <CINACS-SLOT .CP>> AC>>>>
+ <SPEC-STOREV .SYMT <CINACS-SLOT .CP> <CSTORED-SLOT .CP>>
+ <FLUSH-RESIDUE .AC .SYMT>
+ <SET MS (.SYMT !.MS)>)
+ (<MEMQ .SYMT .MS> <FLUSH-RESIDUE .AC .SYMT>)
+ (ELSE
+ <PUT .SYMT ,STORED <CSTORED-SLOT .CP>>
+ <SMASH-INACS .SYMT <CINACS-SLOT .CP>>
+ <SMASH-ITEM-INTO-DATUM .SYMT <CINACS-SLOT .CP>>)>
+ <SET CP <REST .CP ,LENGTH-CSTATE>>>>
+ .THISRETURN
+ ,ALLACS>>>
+
+<DEFINE SPEC-STOREV (SYMT INAC STORED)
+ <SMASH-INACS .SYMT .INAC>
+ <SMASH-ITEM-INTO-DATUM .SYMT .INAC>
+ <FLUSH-SYMTAB-FROM-AC .SYMT>
+ <COND (<TYPE? .SYMT SYMTAB>
+ <AND <NOT .STORED>
+ <MAPF <>
+ ,SEMIT
+ <PROG ((CODE:TOP (())) (CODE:PTR .CODE:TOP))
+ #DECL ((CODE:TOP CODE:PTR) <SPECIAL LIST>)
+ <PUT .SYMT ,STORED <>>
+ <STOREV .SYMT>
+ <REST .CODE:TOP>>>>
+ <PUT .SYMT ,STORED T>)>
+ <SMASH-INACS .SYMT <>>>
+
+<DEFINE CLEANUP-SYMT (SYM)
+ #DECL ((SYM) SYMTAB)
+ <PUT .SYM ,PROG-AC <>>
+ <PUT .SYM ,NUM-SYM T>>
+
+<DEFINE SEMIT (FRM)
+ #DECL ((SCODE:PTR CODE:PTR) LIST)
+ <PUTREST .SCODE:PTR (.FRM !<REST .SCODE:PTR>)>
+ <COND (<==? .CODE:PTR .SCODE:PTR> <SET CODE:PTR <REST .CODE:PTR>>)>
+ <SET SCODE:PTR <REST .SCODE:PTR>>>
+
+"\f"
+
+<DEFINE FLUSH-SYMTAB-FROM-AC (SYMT "AUX" (INAC <SINACS .SYMT>) AC)
+ <COND (<TYPE? <SET AC <DATTYP .INAC>> AC>
+ <FLUSH-RESIDUE .AC .SYMT>)>
+ <COND (<TYPE? <SET AC <DATVAL .INAC>> AC>
+ <FLUSH-RESIDUE .AC .SYMT>)>>
+
+<DEFINE SMASH-ITEM-INTO-DATUM (SYM DAT "AUX" AC)
+ #DECL ((SYM) SYMBOL (DAT) DATUM)
+ <COND (<TYPE? <SET AC <DATTYP .DAT>> AC>
+ <OR <MEMQ .SYM <ACRESIDUE .AC>>
+ <PUT .AC ,ACRESIDUE (.SYM !<ACRESIDUE .AC>)>>)>
+ <COND (<TYPE? <SET AC <DATVAL .DAT>> AC>
+ <OR <MEMQ .SYM <ACRESIDUE .AC>>
+ <PUT .AC ,ACRESIDUE (.SYM !<ACRESIDUE .AC>)>>)>>
+
+
+<DEFINE CLEANUP-VARS (VARLST)
+ #DECL ((VARLST) LIST)
+ <REPEAT ((PTR .VARLST) VAR)
+ <COND (<EMPTY? .PTR> <RETURN>)>
+ <PUT <SET VAR <SYM-SLOT .PTR>>
+ ,NUM-SYM
+ <SAVED-NUM-SYM-SLOT .PTR>>
+ <PUT .VAR ,PROG-AC <SAVED-PROG-AC-SLOT .PTR>>
+ <PUT .VAR ,POTLV <SAVED-POTLV-SLOT .PTR>>
+ <SET PTR <REST .PTR ,LENGTH-PROG-VARS>>>>
+
+<DEFINE FIXUP-STORES (STATE)
+ #DECL ((STATE) <LIST [REST REP-STATE <PRIMTYPE LIST> LIST <OR ATOM FALSE>]>)
+ <REPEAT ((PTR .STATE))
+ #DECL ((PTR) <LIST [REST REP-STATE <PRIMTYPE LIST> LIST <OR ATOM FALSE>]>)
+ <COND (<EMPTY? .PTR> <RETURN>)>
+ <MAPR <>
+ <FUNCTION (STATE-ITEMS "AUX" SYMT PAC (STATE-ITEM <1 .STATE-ITEMS>))
+ #DECL ((STATE-ITEMS) REP-STATE
+ (STATE-ITEM)
+ <LIST [REST SYMTAB DATUM <OR FALSE ATOM> <OR ATOM FALSE>]>
+ (PAC) <OR FALSE LIST> (SYMT) SYMTAB)
+ <REPEAT ()
+ <COND (<EMPTY? .STATE-ITEM> <RETURN>)>
+ <SET SYMT <CSYMT-SLOT .STATE-ITEM>>
+ <COND (<OR <CPOTLV-SLOT .STATE-ITEM>
+ <N==? <CSTORED-SLOT .STATE-ITEM> T>>
+ <COND (<OR <AND <N==? <CSTORED-SLOT .STATE-ITEM> T>
+ <MEMQ <CSTORED-SLOT .STATE-ITEM> .KILL-LIST>>
+ <AND <CPOTLV-SLOT .STATE-ITEM>
+ <CSTORED-SLOT .STATE-ITEM>
+ <SET PAC <PROG-AC .SYMT>>
+ <MEMQ .SYMT <LOOP-VARS <PROG-SLOT .PAC>>>
+ <NOT <STORED-SLOT .PAC>>>>
+ <PUT .STATE-ITEM ,CSTORED-SLOT <>>)>)>
+ <COND (<AND <CPOTLV-SLOT .STATE-ITEM>
+ <OR <NOT <SET PAC <PROG-AC .SYMT>>>
+ <NOT <MEMQ .SYMT <LOOP-VARS <PROG-SLOT .PAC>>>>>>
+ <SET STATE-ITEM <REST .STATE-ITEM ,LENGTH-CSTATE>>)
+ (<RETURN>)>>
+ <COND
+ (<NOT <EMPTY? .STATE-ITEM>>
+ <REPEAT ((START-STATE .STATE-ITEM)
+ (STATE-ITEM <REST .STATE-ITEM ,LENGTH-CSTATE>))
+ <COND (<EMPTY? .STATE-ITEM> <RETURN>)>
+ <SET SYMT <CSYMT-SLOT .STATE-ITEM>>
+ <COND
+ (<OR <CPOTLV-SLOT .STATE-ITEM>
+ <N==? <CSTORED-SLOT .STATE-ITEM> T>>
+ <COND (<OR <AND <N==? <CSTORED-SLOT .STATE-ITEM> T>
+ <MEMQ <CSTORED-SLOT .STATE-ITEM> .KILL-LIST>>
+ <AND <CPOTLV-SLOT .STATE-ITEM>
+ <CSTORED-SLOT .STATE-ITEM>
+ <SET PAC <PROG-AC .SYMT>>
+ <MEMQ .SYMT <LOOP-VARS <PROG-SLOT .PAC>>>
+ <NOT <STORED-SLOT .PAC>>>>
+ <PUT .STATE-ITEM ,CSTORED-SLOT <>>)>)>
+ <COND (<AND <CPOTLV-SLOT .STATE-ITEM>
+ <OR <NOT <SET PAC <PROG-AC .SYMT>>>
+ <NOT <MEMQ .SYMT <LOOP-VARS <PROG-SLOT .PAC>>>>>>
+ <PUTREST .START-STATE <REST .STATE-ITEM ,LENGTH-CSTATE>>)>
+ <SET STATE-ITEM <REST .STATE-ITEM ,LENGTH-CSTATE>>
+ <SET START-STATE <REST .START-STATE ,LENGTH-CSTATE>>>)>
+ <PUT .STATE-ITEMS 1 .STATE-ITEM>>
+ <SAVED-AC-STATE .PTR>>
+ <SET PTR <REST .PTR ,LENGTH-CONTROL-STATE>>>>
+
+<ENDPACKAGE>
+\f
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff