--- /dev/null
+;"need to fload <ac.mud>init.mud in order to compile this"
+
+<DEFINE GENERATE_PROCESSING_ORDERS (TR ;"transaction description"
+ PS ;"partial sequence"
+ "AUX" (NN <NTH .TR ,nnodes_t>)
+ ;"no. of nodes"
+ TEMP)
+ #DECL ((TR) transaction_type_desc (PS) <LIST [REST FIX]>
+ (TEMP) <OR <LIST [REST FIX]> FALSE> (NN) FIX)
+ <COND
+ (<==? <LENGTH .PS> .NN> .PS)
+ (<MAPF <>
+ <FUNCTION (X)
+ #DECL ((X) FIX)
+ <SET TEMP
+ <MAPF ,LIST
+ <FUNCTION (Y)
+ #DECL ((Y) FIX)
+ <COND (<NOT <MEMBER .Y .PS>>
+ <MAPRET !<GENERATE_PROCESSING_ORDERS .TR (.Y !.PS)>>)
+ (ELSE <MAPRET>)>>
+ <NTH <NTH <NTH .TR ,conns_t> .X> ,rcn_c>>>
+ <COND (<NOT <EMPTY? .TEMP>> <MAPLEAVE .TEMP>)>>
+ .PS>)
+ (<MAPF <>
+ <FUNCTION (X "AUX" (Y <NTH <NTH <NTH .TR ,conns_t> .X> ,pn_c>))
+ #DECL ((X) FIX (Y) <OR FIX FALSE>)
+ <COND
+ (<AND .Y <NOT <MEMBER .Y .PS>>>
+ <MAPLEAVE <GENERATE_PROCESSING_ORDERS .TR (.Y !.PS)>>)>>
+ .PS>)
+ (ELSE ;"look for unrestricted children nodes"
+ <MAPF <>
+ <FUNCTION (X)
+ #DECL ((X) FIX)
+ <SET TEMP
+ <MAPF <>
+ <FUNCTION (Y)
+ #DECL ((Y) FIX)
+ <COND
+ (<NOT <MEMBER .Y .PS>>
+ <MAPLEAVE <GENERATE_PROCESSING_ORDERS .TR (.Y !.PS)>>)>>
+ <NTH <NTH <NTH .TR ,conns_t> .X> ,ucn_c>>>
+ <COND (.TEMP <MAPLEAVE .TEMP>)>>
+ <LREVERSE <LIST !.PS>>>)>>
+
--- /dev/null
+<PACKAGE "ADVMESS">
+
+<ENTRY VMESS ANA-MESS ADDVMESS>
+
+<USE "NPRINT" "COMPDEC">
+
+<DEFINE VMESS ("TUPLE" MSG)
+ #DECL ((MSG) TUPLE)
+ <PRINC "===== ">
+ <MAPF <>
+ <FUNCTION (O)
+ <COND (<TYPE? .O STRING> <PRINC .O>) (ELSE <PRIN1 .O>)>>
+ .MSG>
+ <CRLF>>
+
+<DEFINE ANA-MESS (L)
+ #DECL ((L) <LIST ANY [REST NODE LIST]>)
+ <REPEAT ((LL <REST .L>))
+ #DECL ((LL) <LIST [REST NODE LIST]>)
+ <COND (<EMPTY? .LL> <RETURN>)>
+ <PRINC "===== ">
+ <MAPF <>
+ <FUNCTION (O)
+ <COND (<TYPE? .O NODE> <NODE-COMPLAIN .O>)
+ (<TYPE? .O STRING> <PRINC .O>)
+ (ELSE <PRIN1 .O>)>>
+ <2 .LL>>
+ <CRLF>
+ <NODE-COMPLAIN <1 .LL>>
+ <SET LL <REST .LL 2>>>>
+
+<DEFINE ADDVMESS (N L "AUX" LL)
+ #DECL ((N) NODE (L) LIST (VERBOSE) <LIST [REST NODE LIST]>)
+ <COND (<SET LL <MEMQ .N .VERBOSE>>
+ <PUTREST <REST <SET LL <2 .LL>> <- <LENGTH .LL> -1>> .L>)
+ (ELSE
+ <SET VERBOSE <REST <PUTREST .VERBOSE (.N .L)> 2>>)>>
+
+<ENDPACKAGE>
+\ 3\ 3\ 3
\ No newline at end of file
--- /dev/null
+<PACKAGE "ALLR">
+
+<ENTRY ALL-REST-GEN>
+
+<USE "CACS" "CODGEN" "COMCOD" "COMPDEC" "CHKDCL" "STRGEN">
+
+<DEFINE ALL-REST-GEN (N W
+ "AUX" (R? <==? <NODE-SUBR .N> ,REST>) SAC NAC TEM STR NUM
+ (K <KIDS .N>) (SS <TYPE-INFO .N>) T1 T2 CAC)
+ #DECL ((N) NODE (K) <LIST NODE NODE> (SAC CAC NAC) AC (STR NUM) DATUM
+ (SS) <LIST LIST LIST LIST>)
+ <SET STR
+ <GEN <1 .K>
+ <COND (.R? <GOODACS .N .W>) (ELSE <DATUM LIST ANY-AC>)>>>
+ <COND (.CAREFUL
+ <EMIT <INSTRUCTION `JUMPE
+ <ACSYM <CHTYPE <DATVAL .STR> AC>>
+ |COMPERR>>)>
+ <COND (<OR <NOT <EMPTY? <1 .SS>>> <NOT <EMPTY? <2 .SS>>>>
+ <SET NUM <DATUM FIX ANY-AC>>)>
+ <TOACV .STR>
+ <SET SAC <DATVAL .STR>>
+ <MUNG-VALS .STR .SAC <3 .SS>>
+ <COND (<ASSIGNED? NUM>
+ <MOVE:ARG <REFERENCE <COND (<EMPTY? <2 .SS>> 1) (ELSE 0)>>
+ .NUM>
+ <TOACV .NUM>
+ <PUT <SET NAC <DATVAL .NUM>> ,ACPROT T>
+ <TOACV .STR>
+ <SET SAC <DATVAL .STR>>
+ <PUT .NAC ,ACPROT <>>)>
+ <COND (.CAREFUL <EMIT '<`MOVEI `O* -1>>)>
+ <SET CAC <COND (.CAREFUL <GETREG <>>) (ELSE ,ACO)>>
+ <LABEL:TAG <SET T1 <MAKE:TAG>>>
+ <EMIT <INSTRUCTION `HRRZ <ACSYM .CAC> (<ADDRSYM .SAC>)>>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM .CAC> <SET T2 <MAKE:TAG>>>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .SAC> <ADDRSYM .CAC>>>
+ <COND (.CAREFUL <EMIT '<`SOJE `O |COMPERR>>)>
+ <COND (<ASSIGNED? NUM>
+ <EMIT <INSTRUCTION `AOJA <ACSYM .NAC> .T1>>)
+ (ELSE <BRANCH:TAG .T1>)>
+ <LABEL:TAG .T2>
+ <COND (<ASSIGNED? NUM>
+ <MUNG-VALS .NUM .NAC <1 .SS>>
+ <COND (<AND <NOT <EMPTY? <2 .SS>>> <NOT <EMPTY? <1 .SS>>>>
+ <MUNG-AC .NAC .NUM>
+ <EMIT <INSTRUCTION `ADDI <ACSYM .NAC> 1>>)>
+ <MUNG-VALS .NUM .NAC <2 .SS>>
+ <RET-TMP-AC .NUM>)>
+ <COND
+ (.R? <MOVE:ARG .STR .W>)
+ (ELSE
+ <SET STR <DEFER-IT .N .STR>>
+ <SET TEM <OFFPTR 0 .STR LIST>>
+ <MOVE:ARG <DATUM <COND (<ISTYPE-GOOD? <RESULT-TYPE .N>>) (ELSE .TEM)>
+ .TEM>
+ .W>)>>
+
+<DEFINE MUNG-VALS (D A L "AUX" (D1 .D))
+ #DECL ((D D1) DATUM (A) AC (L) <LIST [REST NODE]>)
+ <MAPF <>
+ <FUNCTION (N
+ "AUX" (S <NODE-NAME .N>)
+ (TY
+ <OR
+ <ISTYPE-GOOD? <1 <TYPE-INFO .N>>>
+ <AND <OR <ARG? .S> <INIT-SYM .S>>
+ <ISTYPE-GOOD? <1 <DECL-SYM .S>>>>>))
+ #DECL ((S) SYMTAB)
+ <COND (<AND <NOT .TY> <==? .D .D1>>
+ <SET D1 <MOVE:ARG .D <DATUM ANY-AC <DATVAL .D>>>>)>
+ <PUT .S ,STORED <>>
+ <PUT .S ,INACS <DATUM !<COND (.TY .D) (ELSE .D1)>>>
+ <PUT .A ,ACRESIDUE (.S !<ACRESIDUE .A>)>>
+ .L>
+ <COND (<N==? .D .D1> <MOVE:ARG .D1 .D>)>
+ <MUNG-AC .A .D>>
+\f
+<ENDPACKAGE>\ 3
\ No newline at end of file
--- /dev/null
+
+
+ <TITLE ATOSQ>
+
+ <DECLARE ("VALUE" ANY <PRIMTYPE WORD>)>
+ <DPUSH TP* (AB)>
+ <PUSHJ P* IATOSQ>
+ <JRST FINIS>
+
+ <INTERNAL-ENTRY IATOSQ 1>
+ <SUBM M* (P)>
+ <MOVE E* (TP)>
+ <PUSHJ P* ATOSQ>
+ <JRST FALS>
+ <MOVE B* E>
+ <MOVSI A* <TYPE-CODE FIX>>
+FOO <SUB TP* [<(2) 2>]>
+ <JRST MPOPJ>
+
+
+FALS <MOVEI B* 0>
+ <MOVSI A* <TYPE-CODE FALSE>>
+ <JRST FOO>
+\f\ 3\ 3\ 3\ 3
\ No newline at end of file
--- /dev/null
+<PACKAGE "BACKAN">
+
+<ENTRY BACK-ANA TOP-ANA SUBSTRUC-ANA>
+
+<USE "CHKDCL" "COMPDEC" "SYMANA">
+
+<DEFINE BACK-ANA (NOD RTYP "AUX" TF TS (K <KIDS .NOD>) (LN <LENGTH .K>) TPS)
+ #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX)
+ <COND
+ (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <COND (<1? .LN>
+ <PUT .NOD
+ ,KIDS
+ <SET K (<1 .K> <NODE1 ,QUOTE-CODE .NOD FIX 1 ()>)>>)
+ (ELSE <ARGCHK .LN 2 BACK>)>
+ <SET TS <EANA <1 .K> STRUCTURED BACK>>
+ <SET TF <EANA <2 .K> FIX BACK>>
+ <COND (<NOT <OR <NOT <SET TPS <STRUCTYP .TS>>>
+ <==? .TPS TUPLE>
+ <==? .TPS VECTOR>
+ <==? .TPS STRING>
+ <==? .TPS TEMPLATE>
+ <==? .TPS UVECTOR>>>
+ <MESSAGE ERROR "BAD 1ST ARG TO BACK" .NOD>)>
+ <TYPE-OK?
+ <COND (<OR <NOT .TPS> <==? .TPS STRING> <==? .TPS TEMPLATE>>
+ <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>
+ .TPS)
+ (ELSE
+ <PUT .NOD ,NODE-TYPE ,BACK-CODE>
+ <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <TYPE-AND <REST-DECL .TS <NODE-NAME <2 .K>>> .TPS>)
+ (ELSE .TPS)>)>
+ .RTYP>)>>
+
+<PUT ,BACK ANALYSIS ,BACK-ANA>
+
+<DEFINE TOP-ANA (N R "AUX" (K <KIDS .N>) TS TPS) #DECL ((N) NODE (K) <LIST [REST NODE]>)
+ <COND (<SEGFLUSH .N .R>)
+ (ELSE
+ <ARGCHK <LENGTH .K> 1 TOP>
+ <SET TS <EANA <1 .K> STRUCTURED TOP>>
+ <COND (<AND <SET TPS <STRUCTYP .TS>>
+ <MEMQ .TPS '![VECTOR UVECTOR TUPLE]>>
+ <PUT .N ,NODE-TYPE ,TOP-CODE>
+ <TYPE-OK? .R .TPS>)
+ (<==? .TPS LIST>
+ <MESSAGE ERROR " BAD ARG TO TOP ">)
+ (ELSE
+ <PUT .N ,NODE-TYPE ,ISUBR-CODE>
+ <TYPE-OK? .R <COND (.TPS)(ELSE STRUCTURED)>>)>)>>
+
+<PUT ,TOP ANALYSIS ,TOP-ANA>
+
+"ROUTINE TO ANALYZE SUBSTRUCS"
+
+<DEFINE SUBSTRUC-ANA (NOD RTYP
+ "AUX" RNODE K FRST-ARG TS TF TYP LN FD TPS NUM NN SN
+ (ALRDY <==? <NODE-TYPE .NOD> ,SUBSTRUC-CODE>) TEM)
+ #DECL ((FRST-ARG RNODE NOD) NODE (K) <LIST [REST NODE]>
+ (FLG) <OR ATOM FALSE> (NUM) FIX)
+ <COND
+ (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <SET K <KIDS .NOD>>
+ <COND (<0? <SET LN <LENGTH .K>>>
+ <MESSAGE ERROR "TOO FEW ARGS TO SUBSTRUC">)>
+ <SET FD <EANA <SET FRST-ARG <1 .K>> STRUCTURED SUBSTRUC>>
+ <COND (<AND .ALRDY <G? .LN 1> <==? <NODE-TYPE <1 .K>> ,REST-CODE>>
+ <SET SN <1 <KIDS <1 .K>>>>
+ <SET NN <2 <KIDS <1 .K>>>>
+ <PUT .NN ,PARENT .NOD>
+ <PUT .SN ,PARENT .NOD>
+ <SET LN <+ .LN 1>>
+ <PUT .NOD ,KIDS <SET K (.SN .NN !<REST .K>)>>)>
+ <AND <G? .LN 1> <EANA <2 .K> FIX SUBSTRUC>>
+ <AND <G? .LN 2> <EANA <3 .K> FIX SUBSTRUC>>
+ <AND <G? .LN 3> <EANA <4 .K> STRUCTURED SUBSTRUC>>
+ <COND
+ (<OR <==? <SET TPS <STRUCTYP .FD>> VECTOR>
+ <==? .TPS UVECTOR>
+ <==? .TPS TUPLE>>
+ <SET TF
+ <COND
+ (<1? .LN> <PUT .NOD ,NODE-TYPE ,SUBSTRUC-CODE> <GET-ELE-TYPE .FD 0 T>)
+ (<G? .LN 4> <MESSAGE ERROR "TOO MANY ARGS TO SUBSTRUC">)
+ (<OR <L? .LN 4>
+ <COND (<OR <SUB-CASE-1 .FRST-ARG <4 .K>>
+ <SUB-CASE-2 .FRST-ARG <4 .K>>>)>>
+ <PUT .NOD ,NODE-TYPE ,SUBSTRUC-CODE>
+ <SET RNODE <BUILD-REST-NODE <1 .K> <2 .K> .NOD>>
+ <SPLICE-IN-SUB .K .RNODE>
+ <SET TF <EANA .RNODE .TPS SUBSTRUC>>
+ <COND (<==? .LN 4> <SET TS <RESULT-TYPE <3 .K>>>) (<SET TS .TF>)>
+ <SET TF
+ <COND (<AND <N=? .LN 2> <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
+ <SET NUM <NODE-NAME <2 .K>>>
+ <TYPE-OK? .TF <FORM STRUCTURED [.NUM ANY]>>)
+ (ELSE .TS)>>
+ <COND
+ (<N==? .LN 2>
+ <COND
+ (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <SET TF
+ <CHTYPE
+ (.TPS
+ !<MAPF ,LIST
+ <FUNCTION ("AUX" X)
+ <COND (<0? .NUM> <MAPSTOP>)
+ (ELSE
+ <SET X <GET-ELE-TYPE .TF .NUM>>
+ <SET NUM <- .NUM 1>>
+ .X)>>>)
+ SEGMENT>>)
+ (ELSE <SET TF .TPS>)>)>)
+ (ELSE <PUT .NOD ,NODE-TYPE ,ISUBR-CODE> .TPS)>>
+ <COND
+ (<L? .LN 4>
+ <AND <==? .TPS TUPLE> <SET TPS VECTOR>>
+ <SET TF
+ <COND
+ (<AND <TYPE? .TF FORM SEGMENT> <ISTYPE? .TF>>
+ <COND
+ (<==? <1 .TF> OR>
+ <CHTYPE
+ (OR
+ !<MAPF ,LIST
+ <FUNCTION (D)
+ <COND (<TYPE? .D FORM>
+ <CHTYPE (.TPS !<REST .D>) FORM>)
+ (<TYPE? .D SEGMENT>
+ <CHTYPE (.TPS !<REST .D>) SEGMENT>)
+ (ELSE .TPS)>>
+ <REST .TF>>)
+ FORM>)
+ (<TYPE? .TF FORM> <CHTYPE (.TPS !<REST .TF>) FORM>)
+ (ELSE <CHTYPE (.TPS !<REST .TF>) SEGMENT>)>)
+ (ELSE .TPS)>>)>
+ <TYPE-OK? .TF .RTYP>)
+ (ELSE <PUT .NOD ,NODE-TYPE ,ISUBR-CODE> <TYPE-OK? STRUCTURED .RTYP>)>)>>
+
+<PUT ,SUBSTRUC ANALYSIS ,SUBSTRUC-ANA>
+
+"BUILD A REST NODE"
+
+<DEFINE BUILD-REST-NODE (NODE NUM PAR)
+ <NODEFM ,SUBR-CODE .PAR ANY REST (.NODE .NUM) ,REST>>
+
+"SPICE IN A REST NODE"
+
+<DEFINE SPLICE-IN-SUB (K NNODE)
+ #DECL ((K) <LIST [REST NODE]> (NNODE) NODE)
+ <PUT .K 1 .NNODE>
+ <PUTREST .K <REST .K 2>>>
+
+
+"SUB-CASE-1 LOOKS FOR <SUBSTRUC <REST .X> .N1 .N2 .X> AND SIMILAR CASES WHERE
+ BLTS ARE ALWAYS POSSIBLE.
+ STRNOD== NODE OF STRUCTURE
+ CPYNOD== NODE OF STRUCTURE TO COPY INTO"
+
+<DEFINE SUB-CASE-1 (STRNOD CPYNOD
+ "AUX" (DATA <GET-SUB-DATA .STRNOD>)
+ (DATAC <GET-SUB-DATA .CPYNOD>))
+ #DECL ((STRNOD CPYNOD) NODE (DATAC DATA) <OR FALSE LIST>)
+ <AND .DATA
+ .DATAC
+ <==? <1 .DATA> <1 .DATAC>>
+ <TYPE? <2 .DATAC> FIX>
+ <OR <0? <2 .DATAC>>
+ <AND <TYPE? <2 .DATA> FIX> <G=? <2 .DATA> <2 .DATAC>>>>>>
+
+<DEFINE SUB-CASE-2 (STRNOD CPYNOD
+ "AUX" (DATA <GET-SUB-DATA .STRNOD>)
+ (DATAC <GET-SUB-DATA .CPYNOD>))
+ #DECL ((STRNOD CPYNOD) NODE (DATAC DATA) <OR FALSE LIST>)
+ <AND .DATA
+ .DATAC
+ <==? <1 .DATA> <1 .DATAC>>
+ <TYPE? <2 .DATA> FIX>
+ <OR <0? <2 .DATA>>
+ <AND <TYPE? <2 .DATAC> FIX> <L? <2 .DATA> <2 .DATAC>>>>>>
+
+
+<DEFINE GET-SUB-DATA (NOD "AUX" SYM TNOD (NTYP <NODE-TYPE .NOD>))
+ #DECL ((NOD TNOD) NODE (SYM) SYMTAB (NTYP) FIX)
+ <COND (<OR <==? .NTYP ,LVAL-CODE> <==? .NTYP ,SET-CODE>>
+ (<NODE-NAME .NOD> 0))
+ (<AND <==? .NTYP ,REST-CODE>
+ <COND (<OR <==? <SET NTYP <NODE-TYPE <SET TNOD <1 <KIDS .NOD>>>>>
+ ,LVAL-CODE>
+ <==? .NTYP ,SET-CODE>>
+ <SET SYM <NODE-NAME .TNOD>>)>>
+ (.SYM <NODE-NAME <2 <KIDS .NOD>>>))>><ENDPACKAGE>
+\f
\ No newline at end of file
--- /dev/null
+
+<PACKAGE "BITANA">
+
+<ENTRY BIT-ANA GETBITS-ANA PUTBITS-ANA BITLOG>
+
+<USE "SYMANA" "CHKDCL" "COMPDEC">
+
+"MUDDLE BITS,GETBITS,PUTBITS,ANDB,XORB,EQVB AND ORB COMPILER ROUTINES."
+
+<DEFINE BIT-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (POSN 0) POS WIDTH)
+ #DECL ((WIDTH POS NOD) NODE (K) <LIST [REST NODE]>)
+ <COND (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <ARGCHK <LENGTH .K> '(1 2) BITS>
+ <EANA <SET WIDTH <1 .K>> FIX BITS>
+ <COND (<NOT <EMPTY? <REST .K>>>
+ <EANA <SET POS <2 .K>> FIX BITS>
+ <SET POSN <NODE-NAME .POS>> ;"May be position field.")>
+ <COND (<AND <==? <NODE-TYPE .WIDTH> ,QUOTE-CODE>
+ <OR <NOT <ASSIGNED? POS>> ;"Only one arg."
+ <==? <NODE-TYPE .POS> ,QUOTE-CODE>>>
+ <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
+ <PUT .NOD ,NODE-NAME <BITS <NODE-NAME .WIDTH> .POSN>>
+ <PUT .NOD ,KIDS ()>)
+ (ELSE <PUT .NOD ,NODE-TYPE ,BITS-CODE>)>)>
+ <TYPE-OK? BITS .RTYP>>
+
+<PUT ,BITS ANALYSIS ,BIT-ANA>
+
+<DEFINE GETBITS-ANA (N R) #DECL ((N) NODE) <PGBITS .N .R 2 ,GETBITS-CODE>>
+
+<PUT ,GETBITS ANALYSIS ,GETBITS-ANA>
+
+<DEFINE PUTBITS-ANA (N R) <PGBITS .N .R '(2 3) ,PUTBITS-CODE>>
+
+<PUT ,PUTBITS ANALYSIS ,PUTBITS-ANA>
+
+<DEFINE PGBITS (NOD RTYP NARG COD "AUX" (K <KIDS .NOD>) (NAM <NODE-NAME .NOD>))
+ #DECL ((NOD) NODE (COD) FIX (K) <LIST [REST NODE]>)
+ <COND (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <ARGCHK <LENGTH .K> .NARG .NAM>
+ <PUT .NOD ,NODE-TYPE .COD>
+ <EANA <1 .K>
+ <COND (<==? .COD ,GETBITS-CODE>
+ '<OR <PRIMTYPE WORD>
+ <PRIMTYPE STORAGE>>)
+ (ELSE '<PRIMTYPE WORD>)>
+ .NAM>
+ <EANA <2 .K> BITS .NAM>
+ <AND <==? <LENGTH .K> 3>
+ <EANA <3 .K> '<PRIMTYPE WORD> .NAM>>)>
+ <TYPE-OK? <COND (<==? .COD ,GETBITS-CODE> WORD)
+ (<ISTYPE? <RESULT-TYPE <1 .K>>>)
+ (ELSE '<PRIMTYPE WORD>)>
+ .RTYP>>
+
+<DEFINE BITLOG (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>))
+ #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX)
+ <COND (<SEGFLUSH .NOD .RTYP>)
+ (<0? .LN>
+ <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
+ <PUT .NOD ,KIDS ()>
+ <PUT .NOD ,NODE-NAME <APPLY <NODE-SUBR .NOD>>>)
+ (<1? .LN> <PUT .NOD ,NODE-TYPE ,ID-CODE>)
+ (ELSE
+ <PUT .NOD ,NODE-TYPE ,BITL-CODE>
+ <MAPF <>
+ <FUNCTION (K1)
+ #DECL ((K1) NODE)
+ <EANA .K1 '<PRIMTYPE WORD> <NODE-NAME .NOD>>>
+ .K>)>
+ <TYPE-OK? WORD .RTYP>>
+
+<PUT ,ANDB ANALYSIS ,BITLOG>
+
+<PUT ,ORB ANALYSIS ,BITLOG>
+
+<PUT ,XORB ANALYSIS ,BITLOG>
+
+<PUT ,EQVB ANALYSIS ,BITLOG>
+
+<ENDPACKAGE>
+
--- /dev/null
+
+"MUDDLE BITS,GETBITS,PUTBITS,ANDB,XORB,EQVB AND ORB COMPILER ROUTINES."
+
+<DEFINE BIT-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (POSN 0) POS WIDTH)
+ #DECL ((WIDTH POS NOD) NODE (K) <LIST [REST NODE]>)
+ <COND (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <ARGCHK <LENGTH .K> '(1 2) BITS>
+ <EANA <SET WIDTH <1 .K>> FIX BITS>
+ <COND (<NOT <EMPTY? <REST .K>>>
+ <EANA <SET POS <2 .K>> FIX BITS>
+ <SET POSN <NODE-NAME .POS>> ;"May be position field.")>
+ <COND (<AND <==? <NODE-TYPE .WIDTH> ,QUOTE-CODE>
+ <OR <NOT <ASSIGNED? POS>> ;"Only one arg."
+ <==? <NODE-TYPE .POS> ,QUOTE-CODE>>>
+ <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
+ <PUT .NOD ,NODE-NAME <BITS <NODE-NAME .WIDTH> .POSN>>
+ <PUT .NOD ,KIDS ()>)
+ (ELSE <PUT .NOD ,NODE-TYPE ,BITS-CODE>)>)>
+ <TYPE-OK? BITS .RTYP>>
+
+<PUT ,BITS ANALYSIS ,BIT-ANA>
+
+<DEFINE GETBITS-ANA (N R) #DECL ((N) NODE) <PGBITS .N .R 2 ,GETBITS-CODE>>
+
+<PUT ,GETBITS ANALYSIS ,GETBITS-ANA>
+
+<DEFINE PUTBITS-ANA (N R) <PGBITS .N .R '(2 3) ,PUTBITS-CODE>>
+
+<PUT ,PUTBITS ANALYSIS ,PUTBITS-ANA>
+
+<DEFINE PGBITS (NOD RTYP NARG COD "AUX" (K <KIDS .NOD>) (NAM <NODE-NAME .NOD>))
+ #DECL ((NOD) NODE (COD) FIX (K) <LIST [REST NODE]>)
+ <COND (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <ARGCHK <LENGTH .K> .NARG .NAM>
+ <PUT .NOD ,NODE-TYPE .COD>
+ <EANA <1 .K>
+ <COND (<==? .COD ,GETBITS-CODE>
+ '<OR <PRIMTYPE WORD>
+ <PRIMTYPE STORAGE>>)
+ (ELSE '<PRIMTYPE WORD>)>
+ .NAM>
+ <EANA <2 .K> BITS .NAM>
+ <IF <==? <LENGTH .K> 3>
+ <EANA <3 .K> '<PRIMTYPE WORD> .NAM>>)>
+ <TYPE-OK? <COND (<==? .COD ,GETBITS-CODE> WORD)
+ (<ISTYPE? <RESULT-TYPE <1 .K>>>)
+ (ELSE '<PRIMTYPE WORD>)>
+ .RTYP>>
+
+<DEFINE BITLOG (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>))
+ #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX)
+ <COND (<SEGFLUSH .NOD .RTYP>)
+ (<0? .LN>
+ <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
+ <PUT .NOD ,KIDS ()>
+ <PUT .NOD ,NODE-NAME <APPLY <NODE-SUBR .NOD>>>)
+ (<1? .LN> <PUT .NOD ,NODE-TYPE ,ID-CODE>)
+ (ELSE
+ <PUT .NOD ,NODE-TYPE ,BITL-CODE>
+ <MAPF <>
+ <FUNCTION (K1)
+ #DECL ((K1) NODE)
+ <EANA .K1 '<PRIMTYPE WORD> <NODE-NAME .NOD>>>
+ .K>)>
+ <TYPE-OK? WORD .RTYP>>
+
+<PUT ,ANDB ANALYSIS ,BITLOG>
+
+<PUT ,ORB ANALYSIS ,BITLOG>
+
+<PUT ,XORB ANALYSIS ,BITLOG>
+
+<PUT ,EQVB ANALYSIS ,BITLOG>
+
+<DEFINE BITLOG-GEN (N W
+ "AUX" (K <KIDS .N>) (REG <UPDATE-WHERE .N .W>) (FST <1 .K>)
+ (INS <LGINS <NODE-SUBR .N>>))
+ #DECL ((FST N) NODE (K) <LIST [REST NODE]> (REG) DATUM)
+ <COND (<==? <NODE-TYPE .FST> ,QUOTE-CODE>
+ <PUT .K 1 <2 .K>>
+ <PUT .K 2 .FST>)>
+ <SET REG <GEN <1 .K> .REG>>
+ <RET-TMP-AC <DATTYP .REG> .REG>
+ <PUT .REG
+ ,DATTYP
+ <COND (<ISTYPE? <RESULT-TYPE .N>>) (ELSE WORD)>>
+ <MAPF <>
+ <FUNCTION (NN "AUX" (NXT <GEN .NN DONT-CARE>) TT)
+ #DECL ((NN) NODE (NXT) DATUM)
+ <COND (<TYPE? <DATVAL .REG> AC>)
+ (<TYPE? <SET TT <DATVAL .NXT>> AC>
+ <PUT .NXT ,DATVAL <DATVAL .REG>>
+ <PUT .REG ,DATVAL .TT>
+ <FIX-ACLINK .TT .REG .NXT>)
+ (ELSE <TOACV .REG>)>
+ <PUT <SET TT <DATVAL .REG>> ,ACPROT T>
+ <MUNG-AC .TT .REG>
+ <IMCHK .INS <ACSYM .TT> <DATVAL .NXT> T>
+ <PUT .TT ,ACPROT <>>
+ <RET-TMP-AC .NXT>>
+ <REST .K>>
+ <MOVE:ARG .REG .W>>
+
+<DEFINE LGINS (SUBR)
+ <NTH '![(`AND `ANDI `ANDCMI )
+ (`IOR `IORI `ORCMI )
+ (`XOR `XORI )
+ (`EQV `EQVI )!]
+ <LENGTH <MEMQ .SUBR ,LSUBRS>>>>
+
+<SETG LSUBRS ![,EQVB ,XORB ,ORB ,ANDB!]>
+
+<DEFINE GETBITS-GEN (N W
+ "AUX" (WRDN <1 <KIDS .N>>) (BP <2 <KIDS .N>>) REG POS WDTH
+ BAC AC BPW WRD BPD TEM)
+ #DECL ((WRDN N BP) NODE (POS WDTH) FIX (WRD REG BPD) DATUM (AC BAC) AC
+ (BPW) <PRIMTYPE WORD>)
+ <COND
+ (<==? <NODE-TYPE .BP> ,QUOTE-CODE>
+ <SET WRD <GEN .WRDN DONT-CARE>>
+ <SET BPW <NODE-NAME .BP>>
+ <SET POS <CHTYPE <GETBITS .BPW #BITS *360600000000*> FIX>>
+ <SET WDTH <CHTYPE <GETBITS .BPW #BITS *300600000000*> FIX>>
+ <COND
+ (<AND <==? <+ .POS .WDTH> 36>
+ <N==? .WDTH 18>
+ <TYPE? <DATVAL .WRD> AC>
+ <NOT <ACRESIDUE <SET AC <DATVAL .WRD>>>>
+ <OR <==? .W DONT-CARE>
+ <AND <TYPE? .W DATUM> <==? .AC <DATVAL .WRD>>>>>
+ <MUNG-AC .AC <SET REG .WRD>>
+ <EMIT <INSTRUCTION `LSH <ACSYM .AC> <- .POS>>>)
+ (ELSE
+ <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
+ ,ACPROT
+ T>
+ <COND (<AND <==? .WDTH 18> ;"Could be half word hack."
+ <COND (<0? .POS>
+ <EMIT <INSTRUCTION `HRRZ
+ <ACSYM .AC>
+ !<ADDR:VALUE .WRD>>>
+ T)
+ (<==? .POS 18>
+ <EMIT <INSTRUCTION `HLRZ
+ <ACSYM .AC>
+ !<ADDR:VALUE .WRD>>>
+ T)>>)
+ (ELSE
+ <EMIT <INSTRUCTION `LDB
+ <ACSYM .AC>
+ [<FORM <CHTYPE .BPW OPCODE!-OP!-PACKAGE>
+ !<ADDR:VALUE .WRD>>]>>)>
+ <PUT .AC ,ACPROT <>>
+ <RET-TMP-AC .WRD>)>)
+ (<==? <NODE-TYPE .BP> ,BITS-CODE>
+ <SET WRD
+ <GEN .WRDN
+ <COND (<SIDE-EFFECTS .BP> <DATUM WORD ANY-AC>)
+ (ELSE DONT-CARE)>>>
+ <SET BPD
+ <1 <SET TEM <RBITS-GEN .BP <DATUM BITS ANY-AC> .WRD>>>>
+ <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
+ ,ACPROT
+ T>
+ <TOACV .BPD>
+ <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
+ <SET TEM <2 .TEM>>
+ <PUT .TEM 1 <1 <ADDR:VALUE .WRD>>>
+ <PUTREST .TEM <REST <ADDR:VALUE .WRD>>>
+ <EMIT <INSTRUCTION `LDB <ACSYM .AC> <ADDRSYM .BAC>>>
+ <PUT .BAC ,ACPROT <>>
+ <PUT .AC ,ACPROT <>>
+ <RET-TMP-AC .WRD>
+ <RET-TMP-AC .BPD>)
+ (ELSE ;"Non constant byte pointer."
+ <SET WRD
+ <GEN .WRDN
+ <COND (<SIDE-EFFECTS .BP> <DATUM WORD ANY-AC>)
+ (ELSE DONT-CARE)>>>
+ <SET BPD <GEN .BP DONT-CARE>>
+ <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
+ ,ACPROT
+ T>
+ <SET BPD <MOVE:ARG .BPD <DATUM BITS ANY-AC>>>
+ <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
+ <MUNG-AC .BAC .BPD>
+ <EMIT <INSTRUCTION `HRRI <ACSYM .BAC> !<ADDR:VALUE .WRD>>>
+ <EMIT <INSTRUCTION `LDB <ACSYM .AC> <ADDRSYM .BAC>>>
+ <PUT .BAC ,ACPROT <>>
+ <PUT .AC ,ACPROT <>>
+ <RET-TMP-AC .WRD>
+ <RET-TMP-AC .BPD>)>
+ <MOVE:ARG .REG .W>>
+
+<DEFINE PUTBITS-GEN (N W
+ "AUX" (K <KIDS .N>) (SWRD <1 .K>) (BP <2 .K>) BAC POS WDTH
+ FLD BPW BPD SWRDD (FLG T) TEM NUM)
+ #DECL ((N SWRD BP) NODE (FLD BPD REG SWRDD) DATUM (AC BAC PAC) AC
+ (POS WDTH) FIX (BPW) <PRIMTYPE WORD> (NUM) <OR FALSE FIX>)
+ <COND
+ (<==? <NODE-TYPE .BP> ,QUOTE-CODE>
+ <SET POS
+ <CHTYPE <GETBITS <SET BPW <NODE-NAME .BP>> #BITS *360600000000*> FIX>>
+ <SET WDTH <CHTYPE <GETBITS .BPW #BITS *300600000000*> FIX>>
+ <COND
+ (<AND <==? <NODE-TYPE .SWRD> ,QUOTE-CODE>
+ <0? <CHTYPE <NODE-NAME .SWRD> FIX>>>
+ <SET SWRDD <GEN <3 .K> <REG? <RESULT-TYPE .SWRD> .W>>>
+ <MUNG-AC <DATVAL .SWRDD> .SWRDD>
+ <COND (<L? <+ .POS .WDTH> 36>
+ <IMCHK '(`AND `ANDI )
+ <ACSYM <DATVAL .SWRDD>>
+ <REFERENCE:ADR <GETBITS -1 <BITS .WDTH>>>>)>
+ <EMIT <INSTRUCTION `LSH <ACSYM <DATVAL .SWRDD>> .POS>>)
+ (ELSE
+ <SET SWRDD
+ <GEN .SWRD
+ <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)> .W>>>
+ <MUNG-AC <DATVAL .SWRDD> .SWRDD>
+ <COND
+ (<AND
+ <==? .WDTH 18>
+ <COND
+ (<0? .POS>
+ <COND (<AND <SET NUM <ZERQ .K>> <OR <L=? .NUM 0> <G=? .NUM 262143>>>
+ <EMIT <INSTRUCTION <COND (<0? .NUM> `HLLZS ) (ELSE `HLLOS )>
+ <ADDRSYM <DATVAL .SWRDD>>>>)
+ (ELSE <PCLOB .SWRDD '(`HRR `HRRI ) <3 .K>>)>)
+ (<==? .POS 18>
+ <COND (<AND <SET NUM <ZERQ .K>> <OR <L=? .NUM 0> <G=? .NUM 262143>>>
+ <EMIT <INSTRUCTION <COND (<0? .NUM> `HRRZS ) (ELSE `HRROS )>
+ <ADDRSYM <DATVAL .SWRDD>>>>)
+ (ELSE <PCLOB .SWRDD '(`HRL `HRLI ) <3 .K>>)>
+ T)>>)
+ (<AND <OR <AND <L? .POS 18> <L=? <+ .POS .WDTH> 18>> <G? .POS 18>>
+ <SET NUM <ZERQ .K>>
+ <OR <0? .NUM> <L? .WDTH <POPWR2 <+ .NUM 1>>>>>
+ <EMIT <INSTRUCTION <COND (<0? .NUM>
+ <COND (<L? .POS 18> `ANDCMI ) (ELSE `TLZ )>)
+ (ELSE
+ <COND (<L? .POS 18> `IORI ) (ELSE `TLO )>)>
+ <ACSYM <DATVAL .SWRDD>>
+ <LSH <LSH -1 <- .WDTH 36>>
+ <COND (<L? .POS 18> .POS)
+ (ELSE <- .POS 18>)>>>>)
+ (ELSE
+ <SET FLD <GEN <3 .K> <DATUM WORD ANY-AC>>>
+ <PUT <DATVAL .FLD> ,ACPROT T>
+ <TOACV .SWRDD>
+ <PUT <DATVAL .SWRDD> ,ACPROT T>
+ <EMIT <INSTRUCTION `DPB
+ <ACSYM <DATVAL .FLD>>
+ [<FORM <CHTYPE .BPW OPCODE!-OP!-PACKAGE>
+ <ADDRSYM <DATVAL .SWRDD>>>]>>
+ <PUT <DATVAL .FLD> ,ACPROT <>>
+ <PUT <DATVAL .SWRDD> ,ACPROT <>>
+ <RET-TMP-AC .FLD>)>)>)
+ (ELSE
+ <COND (<NOT <AND <NOT <SIDE-EFFECTS .N>> <MEMQ <NODE-TYPE .SWRD> ,SNODES>>>
+ <SET SWRDD
+ <GEN .SWRD
+ <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
+ .W>>>)>
+ <PREFER-DATUM .W>
+ <SET BPD
+ <COND (<==? <NODE-TYPE .BP> ,BITS-CODE>
+ <SET FLG <>>
+ <1 <SET TEM
+ <RBITS-GEN .BP
+ <DATUM BITS ANY-AC>
+ <COND (<ASSIGNED? SWRDD> .SWRDD)
+ (ELSE ,NO-DATUM)>>>>)
+ (ELSE <GEN .BP DONT-CARE>)>>
+ <PREFER-DATUM .W>
+ <COND (<SET NUM <ZERQ .K>>
+ <SET FLD <MOVE:ARG <REFERENCE .NUM> <DATUM WORD ANY-AC>>>)
+ (ELSE <SET FLD <GEN <3 .K> <DATUM WORD ANY-AC>>>)>
+ <DATTYP-FLUSH .FLD>
+ <PUT .FLD ,DATTYP WORD>
+ <COND (<NOT <ASSIGNED? SWRDD>>
+ <SET SWRDD
+ <GEN .SWRD
+ <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
+ .W>>>)>
+ <COND (<NOT <TYPE? <DATVAL .SWRDD> AC>>
+ <SET SWRDD
+ <MOVE:ARG
+ .SWRDD
+ <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
+ .W>>>)>
+ <PUT <DATVAL .SWRDD> ,ACPROT T>
+ <TOACV .FLD>
+ <PUT <DATVAL .FLD> ,ACPROT T>
+ <TOACV .BPD>
+ <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
+ <COND (<NOT .FLG>
+ <PUT <2 .TEM> 1 <ADDRSYM <DATVAL .SWRDD>>>
+ <PUTREST <2 .TEM> ()>)>
+ <MUNG-AC <DATVAL .SWRDD> .SWRDD>
+ <COND (.FLG
+ <MUNG-AC .BAC .BPD>
+ <EMIT <INSTRUCTION `HRRI <ACSYM .BAC> <ADDRSYM <DATVAL .SWRDD>>>>)>
+ <EMIT <INSTRUCTION `DPB <ACSYM <DATVAL .FLD>> <ADDRSYM .BAC>>>
+ <PUT .BAC ,ACPROT <>>
+ <PUT <DATVAL .SWRDD> ,ACPROT <>>
+ <PUT <DATVAL .FLD> ,ACPROT <>>
+ <RET-TMP-AC .BPD>
+ <RET-TMP-AC .FLD>)>
+ <MOVE:ARG .SWRDD .W>>
+
+<DEFINE ZERQ (L "AUX" NUM)
+ #DECL ((L) <LIST [REST NODE]>)
+ <COND (<==? <LENGTH .L> 2> 0)
+ (<AND <==? <NODE-TYPE <SET NUM <3 .L>>> ,QUOTE-CODE>
+ <==? <PRIMTYPE <SET NUM <NODE-NAME .NUM>>> WORD>
+ <OR <AND <0? <SET NUM <CHTYPE .NUM FIX>>> 0>
+ <AND <POPWR2 <+ .NUM 1>> .NUM>>>)>>
+
+<DEFINE PCLOB (DEST INS SRC "AUX" SRCD)
+ #DECL ((DEST SRCD) DATUM (SRC) NODE)
+ <SET SRCD <GEN .SRC DONT-CARE>>
+ <TOACV .DEST>
+ <PUT <DATVAL .DEST> ,ACPROT T>
+ <IMCHK .INS <ACSYM <DATVAL .DEST>> <DATVAL .SRCD>>
+ <PUT <DATVAL .DEST> ,ACPROT <>>
+ <RET-TMP-AC .SRCD>>
+
+<DEFINE BITS-GEN (N W) <1 <RBITS-GEN .N .W DONT-CARE>>>
+
+<DEFINE RBITS-GEN (N W ADDR
+ "AUX" (K <KIDS .N>) (WDTHN <1 .K>) WDTH POS TEM
+ (REG <REG? WORD .W>) POSD (FLG T))
+ #DECL ((POS N WDTHN) NODE (REG WDTH POSD) DATUM (K) <LIST [REST NODE]>)
+ <COND (<==? <LENGTH .K> 2> <SET POS <2 .K>>)>
+ <COND
+ (<==? <NODE-TYPE .WDTHN> ,QUOTE-CODE>
+ <SET TEM <MAKE-PTR .ADDR T <NODE-NAME .WDTHN>>>)
+ (<OR <NOT <ASSIGNED? POS>>
+ <==? <NODE-TYPE .POS> ,QUOTE-CODE>>
+ <SET TEM
+ <MAKE-PTR .ADDR
+ <>
+ <COND (<ASSIGNED? POS> <NODE-NAME .POS>) (ELSE 0)>>>
+ <SET POS .WDTHN>
+ <SET FLG <>>)
+ (ELSE
+ <SET WDTH <GEN .WDTHN .REG>>
+ <MUNG-AC <DATVAL .REG> .REG>
+ <EMIT <INSTRUCTION `LSH <ACSYM <DATVAL .REG>> 24>>
+ <COND (<TYPE? .ADDR DATUM>
+ <EMIT <SET TEM <INSTRUCTION `HRRI <ACSYM <DATVAL .REG>> 0>>>
+ <SET TEM <REST .TEM 2>>)
+ (ELSE <SET TEM '(0)>)>)>
+ <SET POSD <GEN .POS <DATUM WORD ANY-AC>>>
+ <PUT <DATVAL .POSD> ,ACPROT T>
+ <COND (<NOT <ASSIGNED? WDTH>>
+ <SET WDTH <DATUM WORD ANY-AC>>
+ <PUT .WDTH ,DATVAL <GETREG .WDTH>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM <DATVAL .WDTH>> .TEM>>
+ <SET TEM <REST <1 .TEM>>>)
+ (ELSE <TOACV .WDTH>)>
+ <PUT <DATVAL .WDTH> ,ACPROT T>
+ <EMIT <INSTRUCTION `DPB
+ <ACSYM <DATVAL .POSD>>
+ [<FORM (<COND (.FLG 123264) (ELSE 98688)>)
+ <ADDRSYM <DATVAL .WDTH>>>]>>
+ <PUT <DATVAL .WDTH> ,ACPROT <>>
+ <PUT <DATVAL .POSD> ,ACPROT <>>
+ <RET-TMP-AC .POSD>
+ <COND (<TYPE? <DATTYP .WDTH> AC>
+ <RET-TMP-AC <DATTYP .WDTH> .WDTH>)>
+ <PUT .WDTH ,DATTYP BITS>
+ [<MOVE:ARG .WDTH .W> .TEM]>
+
+<DEFINE MAKE-PTR (AD W-P CNST "AUX" (BP <BITS 6 <COND (.W-P 24) (ELSE 30)>>))
+ #DECL ((CNST) FIX)
+ <COND (<TYPE? .AD DATUM>
+ [<FORM (<GETBITS <PUTBITS 0 .BP .CNST> <BITS 18 18>>) HERE>])
+ (ELSE
+ [<FORM (<GETBITS <PUTBITS 0 .BP .CNST> <BITS 18 18>>) 0>])>>
+\f
\ No newline at end of file
--- /dev/null
+<PACKAGE "BITSGEN">
+
+<ENTRY BITLOG-GEN GETBITS-GEN PUTBITS-GEN BITS-GEN>
+
+<USE "CACS" "CODGEN" "COMCOD" "COMPDEC" "CHKDCL">
+
+<DEFINE BITLOG-GEN (N W
+ "AUX" (K <KIDS .N>) (REG <UPDATE-WHERE .N .W>) (FST <1 .K>)
+ (INS <LGINS <NODE-SUBR .N>>))
+ #DECL ((FST N) NODE (K) <LIST [REST NODE]> (REG) DATUM)
+ <COND (<==? <NODE-TYPE .FST> ,QUOTE-CODE>
+ <PUT .K 1 <2 .K>>
+ <PUT .K 2 .FST>)>
+ <SET REG <GEN <1 .K> .REG>>
+ <RET-TMP-AC <DATTYP .REG> .REG>
+ <PUT .REG
+ ,DATTYP
+ <COND (<ISTYPE? <RESULT-TYPE .N>>) (ELSE WORD)>>
+ <MAPF <>
+ <FUNCTION (NN "AUX" (NXT <GEN .NN DONT-CARE>) TT)
+ #DECL ((NN) NODE (NXT) DATUM)
+ <COND (<TYPE? <DATVAL .REG> AC>)
+ (<TYPE? <SET TT <DATVAL .NXT>> AC>
+ <PUT .NXT ,DATVAL <DATVAL .REG>>
+ <PUT .REG ,DATVAL .TT>
+ <FIX-ACLINK .TT .REG .NXT>)
+ (ELSE <TOACV .REG>)>
+ <PUT <SET TT <DATVAL .REG>> ,ACPROT T>
+ <MUNG-AC .TT .REG>
+ <IMCHK .INS <ACSYM .TT> <DATVAL .NXT> T>
+ <PUT .TT ,ACPROT <>>
+ <RET-TMP-AC .NXT>>
+ <REST .K>>
+ <MOVE:ARG .REG .W>>
+
+<DEFINE LGINS (SUBR)
+ <NTH '![(`AND `ANDI `ANDCMI )
+ (`IOR `IORI `ORCMI )
+ (`XOR `XORI )
+ (`EQV `EQVI )!]
+ <LENGTH <MEMQ .SUBR ,LSUBRS>>>>
+
+<SETG LSUBRS ![,EQVB ,XORB ,ORB ,ANDB!]>
+
+<DEFINE GETBITS-GEN (N W
+ "AUX" (WRDN <1 <KIDS .N>>) (BP <2 <KIDS .N>>) REG POS WDTH
+ BAC AC BPW WRD BPD TEM)
+ #DECL ((WRDN N BP) NODE (POS WDTH) FIX (WRD REG BPD) DATUM (AC BAC) AC
+ (BPW) <PRIMTYPE WORD>)
+ <COND
+ (<==? <NODE-TYPE .BP> ,QUOTE-CODE>
+ <SET WRD <GEN .WRDN DONT-CARE>>
+ <SET BPW <NODE-NAME .BP>>
+ <SET POS <CHTYPE <GETBITS .BPW #BITS *360600000000*> FIX>>
+ <SET WDTH <CHTYPE <GETBITS .BPW #BITS *300600000000*> FIX>>
+ <COND
+ (<AND <==? <+ .POS .WDTH> 36>
+ <N==? .WDTH 18>
+ <TYPE? <DATVAL .WRD> AC>
+ <NOT <ACRESIDUE <SET AC <DATVAL .WRD>>>>
+ <OR <==? .W DONT-CARE>
+ <AND <TYPE? .W DATUM> <==? .AC <DATVAL .WRD>>>>>
+ <MUNG-AC .AC <SET REG .WRD>>
+ <EMIT <INSTRUCTION `LSH <ACSYM .AC> <- .POS>>>)
+ (ELSE
+ <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
+ ,ACPROT
+ T>
+ <COND (<AND <==? .WDTH 18> ;"Could be half word hack."
+ <COND (<0? .POS>
+ <EMIT <INSTRUCTION `HRRZ
+ <ACSYM .AC>
+ !<ADDR:VALUE .WRD>>>
+ T)
+ (<==? .POS 18>
+ <EMIT <INSTRUCTION `HLRZ
+ <ACSYM .AC>
+ !<ADDR:VALUE .WRD>>>
+ T)>>)
+ (ELSE
+ <EMIT <INSTRUCTION `LDB
+ <ACSYM .AC>
+ [<FORM <CHTYPE .BPW OPCODE!-OP!-PACKAGE>
+ !<ADDR:VALUE .WRD>>]>>)>
+ <PUT .AC ,ACPROT <>>
+ <RET-TMP-AC .WRD>)>)
+ (<==? <NODE-TYPE .BP> ,BITS-CODE>
+ <SET WRD
+ <GEN .WRDN
+ <COND (<SIDE-EFFECTS .BP> <DATUM WORD ANY-AC>)
+ (ELSE DONT-CARE)>>>
+ <SET BPD
+ <1 <SET TEM <RBITS-GEN .BP <DATUM BITS ANY-AC> .WRD>>>>
+ <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
+ ,ACPROT
+ T>
+ <TOACV .BPD>
+ <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
+ <SET TEM <2 .TEM>>
+ <PUT .TEM 1 <1 <ADDR:VALUE .WRD>>>
+ <PUTREST .TEM <REST <ADDR:VALUE .WRD>>>
+ <EMIT <INSTRUCTION `LDB <ACSYM .AC> <ADDRSYM .BAC>>>
+ <PUT .BAC ,ACPROT <>>
+ <PUT .AC ,ACPROT <>>
+ <RET-TMP-AC .WRD>
+ <RET-TMP-AC .BPD>)
+ (ELSE ;"Non constant byte pointer."
+ <SET WRD
+ <GEN .WRDN
+ <COND (<SIDE-EFFECTS .BP> <DATUM WORD ANY-AC>)
+ (ELSE DONT-CARE)>>>
+ <SET BPD <GEN .BP DONT-CARE>>
+ <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
+ ,ACPROT
+ T>
+ <SET BPD <MOVE:ARG .BPD <DATUM BITS ANY-AC>>>
+ <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
+ <MUNG-AC .BAC .BPD>
+ <EMIT <INSTRUCTION `HRRI <ACSYM .BAC> !<ADDR:VALUE .WRD>>>
+ <EMIT <INSTRUCTION `LDB <ACSYM .AC> <ADDRSYM .BAC>>>
+ <PUT .BAC ,ACPROT <>>
+ <PUT .AC ,ACPROT <>>
+ <RET-TMP-AC .WRD>
+ <RET-TMP-AC .BPD>)>
+ <MOVE:ARG .REG .W>>
+
+<DEFINE PUTBITS-GEN (N W
+ "AUX" (K <KIDS .N>) (SWRD <1 .K>) (BP <2 .K>) BAC POS WDTH
+ FLD BPW BPD SWRDD (FLG T) TEM NUM)
+ #DECL ((N SWRD BP) NODE (FLD BPD REG SWRDD) DATUM (AC BAC PAC) AC
+ (POS WDTH) FIX (BPW) <PRIMTYPE WORD> (NUM) <OR FALSE FIX>)
+ <COND
+ (<==? <NODE-TYPE .BP> ,QUOTE-CODE>
+ <SET POS
+ <CHTYPE <GETBITS <SET BPW <NODE-NAME .BP>> #BITS *360600000000*> FIX>>
+ <SET WDTH <CHTYPE <GETBITS .BPW #BITS *300600000000*> FIX>>
+ <COND
+ (<AND <==? <NODE-TYPE .SWRD> ,QUOTE-CODE>
+ <0? <CHTYPE <NODE-NAME .SWRD> FIX>>>
+ <SET SWRDD <GEN <3 .K> <REG? <RESULT-TYPE .SWRD> .W>>>
+ <MUNG-AC <DATVAL .SWRDD> .SWRDD>
+ <COND (<L? <+ .POS .WDTH> 36>
+ <IMCHK '(`AND `ANDI )
+ <ACSYM <DATVAL .SWRDD>>
+ <REFERENCE:ADR <GETBITS -1 <BITS .WDTH>>>>)>
+ <EMIT <INSTRUCTION `LSH <ACSYM <DATVAL .SWRDD>> .POS>>)
+ (ELSE
+ <SET SWRDD
+ <GEN .SWRD
+ <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)> .W>>>
+ <MUNG-AC <DATVAL .SWRDD> .SWRDD>
+ <COND
+ (<AND
+ <==? .WDTH 18>
+ <COND
+ (<0? .POS>
+ <COND (<AND <SET NUM <ZERQ .K>> <OR <L=? .NUM 0> <G=? .NUM 262143>>>
+ <EMIT <INSTRUCTION <COND (<0? .NUM> `HLLZS ) (ELSE `HLLOS )>
+ <ADDRSYM <DATVAL .SWRDD>>>>)
+ (ELSE <PCLOB .SWRDD '(`HRR `HRRI ) <3 .K>>)>)
+ (<==? .POS 18>
+ <COND (<AND <SET NUM <ZERQ .K>> <OR <L=? .NUM 0> <G=? .NUM 262143>>>
+ <EMIT <INSTRUCTION <COND (<0? .NUM> `HRRZS ) (ELSE `HRROS )>
+ <ADDRSYM <DATVAL .SWRDD>>>>)
+ (ELSE <PCLOB .SWRDD '(`HRL `HRLI ) <3 .K>>)>
+ T)>>)
+ (<AND <OR <AND <L? .POS 18> <L=? <+ .POS .WDTH> 18>> <G? .POS 18>>
+ <SET NUM <ZERQ .K>>
+ <OR <0? .NUM> <L? .WDTH <POPWR2 <+ .NUM 1>>>>>
+ <EMIT <INSTRUCTION <COND (<0? .NUM>
+ <COND (<L? .POS 18> `ANDCMI ) (ELSE `TLZ )>)
+ (ELSE
+ <COND (<L? .POS 18> `IORI ) (ELSE `TLO )>)>
+ <ACSYM <DATVAL .SWRDD>>
+ <LSH <LSH -1 <- .WDTH 36>>
+ <COND (<L? .POS 18> .POS)
+ (ELSE <- .POS 18>)>>>>)
+ (ELSE
+ <SET FLD <GEN <3 .K> <DATUM WORD ANY-AC>>>
+ <PUT <DATVAL .FLD> ,ACPROT T>
+ <TOACV .SWRDD>
+ <PUT <DATVAL .SWRDD> ,ACPROT T>
+ <EMIT <INSTRUCTION `DPB
+ <ACSYM <DATVAL .FLD>>
+ [<FORM <CHTYPE .BPW OPCODE!-OP!-PACKAGE>
+ <ADDRSYM <DATVAL .SWRDD>>>]>>
+ <PUT <DATVAL .FLD> ,ACPROT <>>
+ <PUT <DATVAL .SWRDD> ,ACPROT <>>
+ <RET-TMP-AC .FLD>)>)>)
+ (ELSE
+ <COND (<NOT <AND <NOT <SIDE-EFFECTS .N>> <MEMQ <NODE-TYPE .SWRD> ,SNODES>>>
+ <SET SWRDD
+ <GEN .SWRD
+ <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
+ .W>>>)>
+ <PREFER-DATUM .W>
+ <SET BPD
+ <COND (<==? <NODE-TYPE .BP> ,BITS-CODE>
+ <SET FLG <>>
+ <1 <SET TEM
+ <RBITS-GEN .BP
+ <DATUM BITS ANY-AC>
+ <COND (<ASSIGNED? SWRDD> .SWRDD)
+ (ELSE ,NO-DATUM)>>>>)
+ (ELSE <GEN .BP DONT-CARE>)>>
+ <PREFER-DATUM .W>
+ <COND (<SET NUM <ZERQ .K>>
+ <SET FLD <MOVE:ARG <REFERENCE .NUM> <DATUM WORD ANY-AC>>>)
+ (ELSE <SET FLD <GEN <3 .K> <DATUM WORD ANY-AC>>>)>
+ <DATTYP-FLUSH .FLD>
+ <PUT .FLD ,DATTYP WORD>
+ <COND (<NOT <ASSIGNED? SWRDD>>
+ <SET SWRDD
+ <GEN .SWRD
+ <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
+ .W>>>)>
+ <COND (<NOT <TYPE? <DATVAL .SWRDD> AC>>
+ <SET SWRDD
+ <MOVE:ARG
+ .SWRDD
+ <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
+ .W>>>)>
+ <PUT <DATVAL .SWRDD> ,ACPROT T>
+ <TOACV .FLD>
+ <PUT <DATVAL .FLD> ,ACPROT T>
+ <TOACV .BPD>
+ <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
+ <COND (<NOT .FLG>
+ <PUT <2 .TEM> 1 <ADDRSYM <DATVAL .SWRDD>>>
+ <PUTREST <2 .TEM> ()>)>
+ <MUNG-AC <DATVAL .SWRDD> .SWRDD>
+ <COND (.FLG
+ <MUNG-AC .BAC .BPD>
+ <EMIT <INSTRUCTION `HRRI <ACSYM .BAC> <ADDRSYM <DATVAL .SWRDD>>>>)>
+ <EMIT <INSTRUCTION `DPB <ACSYM <DATVAL .FLD>> <ADDRSYM .BAC>>>
+ <PUT .BAC ,ACPROT <>>
+ <PUT <DATVAL .SWRDD> ,ACPROT <>>
+ <PUT <DATVAL .FLD> ,ACPROT <>>
+ <RET-TMP-AC .BPD>
+ <RET-TMP-AC .FLD>)>
+ <MOVE:ARG .SWRDD .W>>
+
+<DEFINE ZERQ (L "AUX" NUM)
+ #DECL ((L) <LIST [REST NODE]>)
+ <COND (<==? <LENGTH .L> 2>)
+ (<AND <==? <NODE-TYPE <SET NUM <3 .L>>> ,QUOTE-CODE>
+ <==? <PRIMTYPE <SET NUM <NODE-NAME .NUM>>> WORD>
+ <OR <AND <0? <SET NUM <CHTYPE .NUM FIX>>> 0>
+ <AND <POPWR2 <+ .NUM 1>> .NUM>>>)>>
+
+<DEFINE PCLOB (DEST INS SRC "AUX" SRCD)
+ #DECL ((DEST SRCD) DATUM (SRC) NODE)
+ <SET SRCD <GEN .SRC DONT-CARE>>
+ <TOACV .DEST>
+ <PUT <DATVAL .DEST> ,ACPROT T>
+ <IMCHK .INS <ACSYM <DATVAL .DEST>> <DATVAL .SRCD>>
+ <PUT <DATVAL .DEST> ,ACPROT <>>
+ <RET-TMP-AC .SRCD>>
+
+<DEFINE BITS-GEN (N W) <1 <RBITS-GEN .N .W DONT-CARE>>>
+
+<DEFINE RBITS-GEN (N W ADDR
+ "AUX" (K <KIDS .N>) (WDTHN <1 .K>) WDTH POS TEM
+ (REG <REG? WORD .W>) POSD (FLG T))
+ #DECL ((POS N WDTHN) NODE (REG WDTH POSD) DATUM (K) <LIST [REST NODE]>)
+ <COND (<==? <LENGTH .K> 2> <SET POS <2 .K>>)>
+ <COND
+ (<==? <NODE-TYPE .WDTHN> ,QUOTE-CODE>
+ <SET TEM <MAKE-PTR .ADDR T <NODE-NAME .WDTHN>>>)
+ (<OR <NOT <ASSIGNED? POS>>
+ <==? <NODE-TYPE .POS> ,QUOTE-CODE>>
+ <SET TEM
+ <MAKE-PTR .ADDR
+ <>
+ <COND (<ASSIGNED? POS> <NODE-NAME .POS>) (ELSE 0)>>>
+ <SET POS .WDTHN>
+ <SET FLG <>>)
+ (ELSE
+ <SET WDTH <GEN .WDTHN .REG>>
+ <MUNG-AC <DATVAL .REG> .REG>
+ <EMIT <INSTRUCTION `LSH <ACSYM <DATVAL .REG>> 24>>
+ <COND (<TYPE? .ADDR DATUM>
+ <EMIT <SET TEM <INSTRUCTION `HRRI <ACSYM <DATVAL .REG>> 0>>>
+ <SET TEM <REST .TEM 2>>)
+ (ELSE <SET TEM '(0)>)>)>
+ <SET POSD <GEN .POS <DATUM WORD ANY-AC>>>
+ <PUT <DATVAL .POSD> ,ACPROT T>
+ <COND (<NOT <ASSIGNED? WDTH>>
+ <SET WDTH <DATUM WORD ANY-AC>>
+ <PUT .WDTH ,DATVAL <GETREG .WDTH>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM <DATVAL .WDTH>> .TEM>>
+ <SET TEM <REST <1 .TEM>>>)
+ (ELSE <TOACV .WDTH>)>
+ <PUT <DATVAL .WDTH> ,ACPROT T>
+ <EMIT <INSTRUCTION `DPB
+ <ACSYM <DATVAL .POSD>>
+ [<FORM (<COND (.FLG 123264) (ELSE 98688)>)
+ <ADDRSYM <DATVAL .WDTH>>>]>>
+ <PUT <DATVAL .WDTH> ,ACPROT <>>
+ <PUT <DATVAL .POSD> ,ACPROT <>>
+ <RET-TMP-AC .POSD>
+ <COND (<TYPE? <DATTYP .WDTH> AC>
+ <RET-TMP-AC <DATTYP .WDTH> .WDTH>)>
+ <PUT .WDTH ,DATTYP BITS>
+ [<MOVE:ARG .WDTH .W> .TEM]>
+
+<DEFINE MAKE-PTR (AD W-P CNST "AUX" (BP <BITS 6 <COND (.W-P 24) (ELSE 30)>>))
+ #DECL ((CNST) FIX)
+ <COND (<TYPE? .AD DATUM>
+ [<FORM (<GETBITS <PUTBITS 0 .BP .CNST> <BITS 18 18>>) HERE>])
+ (ELSE
+ [<FORM (<GETBITS <PUTBITS 0 .BP .CNST> <BITS 18 18>>) 0>])>>
+\f
+<ENDPACKAGE>
--- /dev/null
+<PACKAGE "BITSGEN">
+
+<ENTRY BITLOG-GEN GETBITS-GEN PUTBITS-GEN BITS-GEN>
+
+<USE "CACS" "CODGEN" "COMCOD" "COMPDEC" "CHKDCL">
+
+<DEFINE BITLOG-GEN (N W
+ "AUX" (K <KIDS .N>) (REG <UPDATE-WHERE .N .W>) (FST <1 .K>)
+ (INS <LGINS <NODE-SUBR .N>>))
+ #DECL ((FST N) NODE (K) <LIST [REST NODE]> (REG) DATUM)
+ <COND (<==? <NODE-TYPE .FST> ,QUOTE-CODE>
+ <PUT .K 1 <2 .K>>
+ <PUT .K 2 .FST>)>
+ <SET REG <GEN <1 .K> .REG>>
+ <RET-TMP-AC <DATTYP .REG> .REG>
+ <PUT .REG
+ ,DATTYP
+ <COND (<ISTYPE? <RESULT-TYPE .N>>) (ELSE WORD)>>
+ <MAPF <>
+ <FUNCTION (NN "AUX" (NXT <GEN .NN DONT-CARE>) TT)
+ #DECL ((NN) NODE (NXT) DATUM)
+ <COND (<TYPE? <DATVAL .REG> AC>)
+ (<TYPE? <SET TT <DATVAL .NXT>> AC>
+ <PUT .NXT ,DATVAL <DATVAL .REG>>
+ <PUT .REG ,DATVAL .TT>
+ <FIX-ACLINK .TT .REG .NXT>)
+ (ELSE <TOACV .REG>)>
+ <PUT <SET TT <DATVAL .REG>> ,ACPROT T>
+ <MUNG-AC .TT .REG>
+ <IMCHK .INS <ACSYM .TT> <DATVAL .NXT> T>
+ <PUT .TT ,ACPROT <>>
+ <RET-TMP-AC .NXT>>
+ <REST .K>>
+ <MOVE:ARG .REG .W>>
+
+<DEFINE LGINS (SUBR)
+ <NTH '![(`AND `ANDI `ANDCMI )
+ (`IOR `IORI `ORCMI )
+ (`XOR `XORI )
+ (`EQV `EQVI )!]
+ <LENGTH <MEMQ .SUBR ,LSUBRS>>>>
+
+<SETG LSUBRS ![,EQVB ,XORB ,ORB ,ANDB!]>
+
+<DEFINE GETBITS-GEN (N W
+ "AUX" (WRDN <1 <KIDS .N>>) (BP <2 <KIDS .N>>) REG POS WDTH
+ BAC AC BPW WRD BPD TEM)
+ #DECL ((WRDN N BP) NODE (POS WDTH) FIX (WRD REG BPD) DATUM (AC BAC) AC
+ (BPW) <PRIMTYPE WORD>)
+ <COND
+ (<==? <NODE-TYPE .BP> ,QUOTE-CODE>
+ <SET WRD <GEN .WRDN DONT-CARE>>
+ <SET BPW <NODE-NAME .BP>>
+ <SET POS <CHTYPE <GETBITS .BPW #BITS *360600000000*> FIX>>
+ <SET WDTH <CHTYPE <GETBITS .BPW #BITS *300600000000*> FIX>>
+ <COND
+ (<AND <==? <+ .POS .WDTH> 36>
+ <N==? .WDTH 18>
+ <TYPE? <DATVAL .WRD> AC>
+ <NOT <ACRESIDUE <SET AC <DATVAL .WRD>>>>
+ <OR <==? .W DONT-CARE>
+ <AND <TYPE? .W DATUM> <==? .AC <DATVAL .WRD>>>>>
+ <MUNG-AC .AC <SET REG .WRD>>
+ <EMIT <INSTRUCTION `LSH <ACSYM .AC> <- .POS>>>)
+ (ELSE
+ <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
+ ,ACPROT
+ T>
+ <COND (<AND <==? .WDTH 18> ;"Could be half word hack."
+ <COND (<0? .POS>
+ <EMIT <INSTRUCTION `HRRZ
+ <ACSYM .AC>
+ !<ADDR:VALUE .WRD>>>
+ T)
+ (<==? .POS 18>
+ <EMIT <INSTRUCTION `HLRZ
+ <ACSYM .AC>
+ !<ADDR:VALUE .WRD>>>
+ T)>>)
+ (ELSE
+ <EMIT <INSTRUCTION `LDB
+ <ACSYM .AC>
+ [<FORM <CHTYPE .BPW OPCODE!-OP!-PACKAGE>
+ !<ADDR:VALUE .WRD>>]>>)>
+ <PUT .AC ,ACPROT <>>
+ <RET-TMP-AC .WRD>)>)
+ (<==? <NODE-TYPE .BP> ,BITS-CODE>
+ <SET WRD
+ <GEN .WRDN
+ <COND (<SIDE-EFFECTS .BP> <DATUM WORD ANY-AC>)
+ (ELSE DONT-CARE)>>>
+ <SET BPD
+ <1 <SET TEM <RBITS-GEN .BP <DATUM BITS ANY-AC> .WRD>>>>
+ <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
+ ,ACPROT
+ T>
+ <TOACV .BPD>
+ <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
+ <SET TEM <2 .TEM>>
+ <PUT .TEM 1 <1 <ADDR:VALUE .WRD>>>
+ <PUTREST .TEM <REST <ADDR:VALUE .WRD>>>
+ <EMIT <INSTRUCTION `LDB <ACSYM .AC> <ADDRSYM .BAC>>>
+ <PUT .BAC ,ACPROT <>>
+ <PUT .AC ,ACPROT <>>
+ <RET-TMP-AC .WRD>
+ <RET-TMP-AC .BPD>)
+ (ELSE ;"Non constant byte pointer."
+ <SET WRD
+ <GEN .WRDN
+ <COND (<SIDE-EFFECTS .BP> <DATUM WORD ANY-AC>)
+ (ELSE DONT-CARE)>>>
+ <SET BPD <GEN .BP DONT-CARE>>
+ <PUT <SGETREG <SET AC <DATVAL <SET REG <REG? WORD .W T>>>> .REG>
+ ,ACPROT
+ T>
+ <SET BPD <MOVE:ARG .BPD <DATUM BITS ANY-AC>>>
+ <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
+ <MUNG-AC .BAC .BPD>
+ <EMIT <INSTRUCTION `HRRI <ACSYM .BAC> !<ADDR:VALUE .WRD>>>
+ <EMIT <INSTRUCTION `LDB <ACSYM .AC> <ADDRSYM .BAC>>>
+ <PUT .BAC ,ACPROT <>>
+ <PUT .AC ,ACPROT <>>
+ <RET-TMP-AC .WRD>
+ <RET-TMP-AC .BPD>)>
+ <MOVE:ARG .REG .W>>
+
+<DEFINE PUTBITS-GEN (N W
+ "AUX" (K <KIDS .N>) (SWRD <1 .K>) (BP <2 .K>) BAC POS WDTH
+ FLD BPW BPD SWRDD (FLG T) TEM NUM)
+ #DECL ((N SWRD BP) NODE (FLD BPD REG SWRDD) DATUM (AC BAC PAC) AC
+ (POS WDTH) FIX (BPW) <PRIMTYPE WORD> (NUM) <OR FALSE FIX>)
+ <COND
+ (<==? <NODE-TYPE .BP> ,QUOTE-CODE>
+ <SET POS
+ <CHTYPE <GETBITS <SET BPW <NODE-NAME .BP>> #BITS *360600000000*> FIX>>
+ <SET WDTH <CHTYPE <GETBITS .BPW #BITS *300600000000*> FIX>>
+ <COND
+ (<AND <==? <NODE-TYPE .SWRD> ,QUOTE-CODE>
+ <0? <CHTYPE <NODE-NAME .SWRD> FIX>>>
+ <SET SWRDD <GEN <3 .K> <REG? <RESULT-TYPE .SWRD> .W>>>
+ <MUNG-AC <DATVAL .SWRDD> .SWRDD>
+ <COND (<L? <+ .POS .WDTH> 36>
+ <IMCHK '(`AND `ANDI )
+ <ACSYM <DATVAL .SWRDD>>
+ <REFERENCE:ADR <GETBITS -1 <BITS .WDTH>>>>)>
+ <EMIT <INSTRUCTION `LSH <ACSYM <DATVAL .SWRDD>> .POS>>)
+ (ELSE
+ <SET SWRDD
+ <GEN .SWRD
+ <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)> .W>>>
+ <MUNG-AC <DATVAL .SWRDD> .SWRDD>
+ <COND
+ (<AND
+ <==? .WDTH 18>
+ <COND
+ (<0? .POS>
+ <COND (<AND <SET NUM <ZERQ .K>> <OR <L=? .NUM 0> <G=? .NUM 262143>>>
+ <EMIT <INSTRUCTION <COND (<0? .NUM> `HLLZS ) (ELSE `HLLOS )>
+ <ADDRSYM <DATVAL .SWRDD>>>>)
+ (ELSE <PCLOB .SWRDD '(`HRR `HRRI ) <3 .K>>)>)
+ (<==? .POS 18>
+ <COND (<AND <SET NUM <ZERQ .K>> <OR <L=? .NUM 0> <G=? .NUM 262143>>>
+ <EMIT <INSTRUCTION <COND (<0? .NUM> `HRRZS ) (ELSE `HRROS )>
+ <ADDRSYM <DATVAL .SWRDD>>>>)
+ (ELSE <PCLOB .SWRDD '(`HRL `HRLI ) <3 .K>>)>
+ T)>>)
+ (<AND <OR <AND <L? .POS 18> <L=? <+ .POS .WDTH> 18>> <G? .POS 18>>
+ <SET NUM <ZERQ .K>>
+ <OR <0? .NUM> <L? .WDTH <POPWR2 <+ .NUM 1>>>>>
+ <EMIT <INSTRUCTION <COND (<0? .NUM>
+ <COND (<L? .POS 18> `ANDCMI ) (ELSE `TLZ )>)
+ (ELSE
+ <COND (<L? .POS 18> `IORI ) (ELSE `TLO )>)>
+ <ACSYM <DATVAL .SWRDD>>
+ <LSH <LSH -1 <- .WDTH 36>>
+ <COND (<L? .POS 18> .POS)
+ (ELSE <- .POS 18>)>>>>)
+ (ELSE
+ <SET FLD <GEN <3 .K> <DATUM WORD ANY-AC>>>
+ <PUT <DATVAL .FLD> ,ACPROT T>
+ <TOACV .SWRDD>
+ <PUT <DATVAL .SWRDD> ,ACPROT T>
+ <EMIT <INSTRUCTION `DPB
+ <ACSYM <DATVAL .FLD>>
+ [<FORM <CHTYPE .BPW OPCODE!-OP!-PACKAGE>
+ <ADDRSYM <DATVAL .SWRDD>>>]>>
+ <PUT <DATVAL .FLD> ,ACPROT <>>
+ <PUT <DATVAL .SWRDD> ,ACPROT <>>
+ <RET-TMP-AC .FLD>)>)>)
+ (ELSE
+ <COND (<NOT <AND <NOT <SIDE-EFFECTS .N>> <MEMQ <NODE-TYPE .SWRD> ,SNODES>>>
+ <SET SWRDD
+ <GEN .SWRD
+ <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
+ .W>>>)>
+ <PREFER-DATUM .W>
+ <SET BPD
+ <COND (<==? <NODE-TYPE .BP> ,BITS-CODE>
+ <SET FLG <>>
+ <1 <SET TEM
+ <RBITS-GEN .BP
+ <DATUM BITS ANY-AC>
+ <COND (<ASSIGNED? SWRDD> .SWRDD)
+ (ELSE ,NO-DATUM)>>>>)
+ (ELSE <GEN .BP DONT-CARE>)>>
+ <PREFER-DATUM .W>
+ <COND (<SET NUM <ZERQ .K>>
+ <SET FLD <MOVE:ARG <REFERENCE .NUM> <DATUM WORD ANY-AC>>>)
+ (ELSE <SET FLD <GEN <3 .K> <DATUM WORD ANY-AC>>>)>
+ <DATTYP-FLUSH .FLD>
+ <PUT .FLD ,DATTYP WORD>
+ <COND (<NOT <ASSIGNED? SWRDD>>
+ <SET SWRDD
+ <GEN .SWRD
+ <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
+ .W>>>)>
+ <COND (<NOT <TYPE? <DATVAL .SWRDD> AC>>
+ <SET SWRDD
+ <MOVE:ARG
+ .SWRDD
+ <REG? <COND (<ISTYPE? <RESULT-TYPE .SWRD>>) (ELSE TUPLE)>
+ .W>>>)>
+ <PUT <DATVAL .SWRDD> ,ACPROT T>
+ <TOACV .FLD>
+ <PUT <DATVAL .FLD> ,ACPROT T>
+ <TOACV .BPD>
+ <PUT <SET BAC <DATVAL .BPD>> ,ACPROT T>
+ <COND (<NOT .FLG>
+ <PUT <2 .TEM> 1 <ADDRSYM <DATVAL .SWRDD>>>
+ <PUTREST <2 .TEM> ()>)>
+ <MUNG-AC <DATVAL .SWRDD> .SWRDD>
+ <COND (.FLG
+ <MUNG-AC .BAC .BPD>
+ <EMIT <INSTRUCTION `HRRI <ACSYM .BAC> <ADDRSYM <DATVAL .SWRDD>>>>)>
+ <EMIT <INSTRUCTION `DPB <ACSYM <DATVAL .FLD>> <ADDRSYM .BAC>>>
+ <PUT .BAC ,ACPROT <>>
+ <PUT <DATVAL .SWRDD> ,ACPROT <>>
+ <PUT <DATVAL .FLD> ,ACPROT <>>
+ <RET-TMP-AC .BPD>
+ <RET-TMP-AC .FLD>)>
+ <MOVE:ARG .SWRDD .W>>
+
+<DEFINE ZERQ (L "AUX" NUM)
+ #DECL ((L) <LIST [REST NODE]>)
+ <COND (<==? <LENGTH .L> 2>)
+ (<AND <==? <NODE-TYPE <SET NUM <3 .L>>> ,QUOTE-CODE>
+ <==? <PRIMTYPE <SET NUM <NODE-NAME .NUM>>> WORD>
+ <OR <AND <0? <SET NUM <CHTYPE .NUM FIX>>> 0>
+ <AND <POPWR2 <+ .NUM 1>> .NUM>>>)>>
+
+<DEFINE PCLOB (DEST INS SRC "AUX" SRCD)
+ #DECL ((DEST SRCD) DATUM (SRC) NODE)
+ <SET SRCD <GEN .SRC DONT-CARE>>
+ <TOACV .DEST>
+ <PUT <DATVAL .DEST> ,ACPROT T>
+ <IMCHK .INS <ACSYM <DATVAL .DEST>> <DATVAL .SRCD>>
+ <PUT <DATVAL .DEST> ,ACPROT <>>
+ <RET-TMP-AC .SRCD>>
+
+<DEFINE BITS-GEN (N W) <1 <RBITS-GEN .N .W DONT-CARE>>>
+
+<DEFINE RBITS-GEN (N W ADDR
+ "AUX" (K <KIDS .N>) (WDTHN <1 .K>) WDTH POS TEM
+ (REG <REG? WORD .W>) POSD (FLG T))
+ #DECL ((POS N WDTHN) NODE (REG WDTH POSD) DATUM (K) <LIST [REST NODE]>)
+ <COND (<==? <LENGTH .K> 2> <SET POS <2 .K>>)>
+ <COND
+ (<==? <NODE-TYPE .WDTHN> ,QUOTE-CODE>
+ <SET TEM <MAKE-PTR .ADDR T <NODE-NAME .WDTHN>>>)
+ (<OR <NOT <ASSIGNED? POS>>
+ <==? <NODE-TYPE .POS> ,QUOTE-CODE>>
+ <SET TEM
+ <MAKE-PTR .ADDR
+ <>
+ <COND (<ASSIGNED? POS> <NODE-NAME .POS>) (ELSE 0)>>>
+ <SET POS .WDTHN>
+ <SET FLG <>>)
+ (ELSE
+ <SET WDTH <GEN .WDTHN .REG>>
+ <MUNG-AC <DATVAL .REG> .REG>
+ <EMIT <INSTRUCTION `LSH <ACSYM <DATVAL .REG>> 24>>
+ <COND (<TYPE? .ADDR DATUM>
+ <EMIT <SET TEM <INSTRUCTION `HRRI <ACSYM <DATVAL .REG>> 0>>>
+ <SET TEM <REST .TEM 2>>)
+ (ELSE <SET TEM '(0)>)>)>
+ <SET POSD <GEN .POS <DATUM WORD ANY-AC>>>
+ <PUT <DATVAL .POSD> ,ACPROT T>
+ <COND (<NOT <ASSIGNED? WDTH>>
+ <SET WDTH <DATUM WORD ANY-AC>>
+ <PUT .WDTH ,DATVAL <GETREG .WDTH>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM <DATVAL .WDTH>> .TEM>>
+ <SET TEM <REST <1 .TEM>>>)
+ (ELSE <TOACV .WDTH>)>
+ <PUT <DATVAL .WDTH> ,ACPROT T>
+ <EMIT <INSTRUCTION `DPB
+ <ACSYM <DATVAL .POSD>>
+ [<FORM (<COND (.FLG 123264) (ELSE 98688)>)
+ <ADDRSYM <DATVAL .WDTH>>>]>>
+ <PUT <DATVAL .WDTH> ,ACPROT <>>
+ <PUT <DATVAL .POSD> ,ACPROT <>>
+ <RET-TMP-AC .POSD>
+ <COND (<TYPE? <DATTYP .WDTH> AC>
+ <RET-TMP-AC <DATTYP .WDTH> .WDTH>)>
+ <PUT .WDTH ,DATTYP BITS>
+ [<MOVE:ARG .WDTH .W> .TEM]>
+
+<DEFINE MAKE-PTR (AD W-P CNST "AUX" (BP <BITS 6 <COND (.W-P 24) (ELSE 30)>>))
+ #DECL ((CNST) FIX)
+ <COND (<TYPE? .AD DATUM>
+ [<FORM (<GETBITS <PUTBITS 0 .BP .CNST> <BITS 18 18>>) HERE>])
+ (ELSE
+ [<FORM (<GETBITS <PUTBITS 0 .BP .CNST> <BITS 18 18>>) 0>])>>
+\f
+<ENDPACKAGE>
--- /dev/null
+<PACKAGE "BITTST">
+
+<ENTRY BIT-TEST-GEN>
+
+<USE "CACS" "CODGEN" "COMCOD" "CHKDCL" "COMPDEC">
+
+<DEFINE BIT-TEST-GEN (N W
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
+ "AUX" (NN <1 <KIDS .N>>) (SDIR .DIR) (B2 <MAKE:TAG>)
+ (FLS <==? .W FLUSHED>) N2 (IMMEDIATE T)
+ (TY <ISTYPE-GOOD? <RESULT-TYPE .NN>>) REG REG2
+ (CONST <NODE-SUBR .N>))
+ #DECL ((N NN N2) NODE (REG) DATUM)
+ <COND (<==? <LENGTH <KIDS .N>> 2> <SET N2 <2 <KIDS .N>>>)>
+ <SET REG
+ <GEN .NN
+ <DATUM <COND (.TY .TY)
+ (<MEMQ <NODE-TYPE .NN> ,SNODES> DONT-CARE)
+ (ELSE ANY-AC)>
+ ANY-AC>>>
+ <COND (<ASSIGNED? N2>
+ <SET REG2 <GEN .N2 DONT-CARE>>
+ <COND (<TYPE? <DATTYP .REG2> AC>
+ <RET-TMP-AC <DATTYP .REG2> .REG2>
+ <PUT .REG2 ,DATTYP WORD>)>)>
+ <RET-TMP-AC <DATTYP .REG> .REG>
+ <PUT .REG ,DATTYP WORD>
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <SET DIR <COND (<AND .BRANCH <NOT .FLS>> <NOT .DIR>) (ELSE .DIR)>>
+ <EMIT
+ <INSTRUCTION
+ <COND (<OR <ASSIGNED? N2>
+ <AND <NOT <0? <CHTYPE <ANDB .CONST 262143> FIX>>>
+ <NOT <0? <CHTYPE <GETBITS .CONST <BITS 18 18>> FIX>>>>>
+ <SET IMMEDIATE <>>
+ <COND (.DIR `TDNN ) (ELSE `TDNE )>)
+ (<0? <CHTYPE <ANDB .CONST 262143> FIX>>
+ <COND (.DIR `TLNN ) (ELSE `TLNE )>)
+ (.DIR `TRNN )
+ (ELSE `TRNE )>
+ <ACSYM <DATVAL .REG>>
+ !<COND (<ASSIGNED? N2> <ADDR:VALUE .REG2>)
+ (<NOT .IMMEDIATE> ([.CONST]))
+ (<0? <CHTYPE <ANDB .CONST 262143> FIX>>
+ (<CHTYPE <GETBITS .CONST <BITS 18 18>> FIX>))
+ (ELSE (.CONST))>>>
+ <RET-TMP-AC .REG>
+ <COND (<AND .BRANCH .FLS> <BRANCH:TAG .BRANCH> FLUSHED)
+ (.BRANCH
+ <BRANCH:TAG .B2>
+ <SET W <MOVE:ARG <REFERENCE .SDIR> .W>>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B2>
+ .W)
+ (ELSE
+ <BRANCH:TAG <SET BRANCH <MAKE:TAG>>>
+ <TRUE-FALSE .N .BRANCH .W>)>>
+
+<ENDPACKAGE>
\ No newline at end of file
--- /dev/null
+
+<FLOAD "PS:<COMPIL>NT.NBIN">
+
+<SETG OPLEN 836>
+
+<DEFINE BEGIN-HACK (SNM
+ "AUX" (CH1 <OPEN "READB" "PS:<COMPIL>OPS.VEC">)
+ (CH2 <OPEN "READB" "PS:<COMPIL>OPS.OVEC">))
+ #DECL ((SNM) <SPECIAL STRING>)
+ <READB <SETG OPT <IUVECTOR ,OPLEN>> .CH1>
+ <READB <SETG OOPT <IUVECTOR ,OPLEN>> .CH2>
+ <SET READ-TABLE <SETG READ-TABLE <IVECTOR 128 0>>>
+ <PUT .READ-TABLE <+ <ASCII !"`> 1> ,OPCS>
+ <PRINTTYPE OPCODE!-OP ,OUTPUT-OPCODE>
+ <CLOSE .CH1>
+ <CLOSE .CH2>
+ T>
+
+<DEFINE END-HACK ()
+ <GUNASSIGN OPT>
+ <GUNASSIGN READ-TABLE>
+ <UNASSIGN READ-TABLE>
+ <GUNASSIGN OOPT>
+ <PRINTTYPE OPCODE!-OP ,PRINT>
+ T>
+
+ \f
\ No newline at end of file
--- /dev/null
+;"Build GDM Schema Directory
+
+ Contains directory related parser action routines and
+ the routines that create the schema directory. Directory
+ data structure definitions are contained in GDM-DIR.MUD
+"
+
+<PACKAGE "BUILD-DIR">
+
+<ENTRY
+ DIR-AC
+ DIR-ACCESS-ENT
+ DIR-ACCESS-FCN
+ DIR-ACCESS-PATH
+ DIR-ACCESS-UNIQUE
+ DIR-AP-OPTIONS
+ DIR-AYREA
+ DIR-BIT
+ DIR-CHR-BITS
+ DIR-CHR-REP
+ DIR-CONTEXT
+ DIR-CONTEXT-DBA
+ DIR-COTYPE
+ DIR-DATABASE-ID
+ DIR-DB-DEF
+ DIR-DB-MAPPING
+ DIR-DBMS-DEF
+ DIR-DBMS-OPTIONS
+ DIR-DBMS-TABLE
+ DIR-DELETE-DB
+ DIR-DELETE-DBMS
+ DIR-DELETE-DIR
+ DIR-DEMO-CMD
+ DIR-DEMO-OFF
+ DIR-DEMO-ON
+ DIR-DIR-CMD
+ DIR-ENTITY-EXTENT
+ DIR-ENTITY-FUNC-EXTENT
+ DIR-ENTITY-PRED-OPTN
+ DIR-ENTITY-TYPE
+ DIR-ENTITY-TYPE-EMPTY
+ DIR-FCN-DEF
+ DIR-FLUSH-DIR
+ DIR-FOP-CALC
+ DIR-FOP-CUR
+ DIR-FOP-KEY
+ DIR-FOP-OWN
+ DIR-FOP-POS
+ DIR-FOP-USE-CUR
+ DIR-FOP-USE-NCUR
+ DIR-FUNC-AOPS
+ DIR-FUNC-EXTENT
+ DIR-FUNC-ROPS
+ DIR-INT-BITS
+ DIR-INT-REP
+ DIR-INT-STR
+ DIR-KEY
+ DIR-LOCAL-LDI
+ DIR-MAX-ONLY
+ DIR-MAX-PRED
+ DIR-MAX-QPRED
+ DIR-MAX-QREL
+ DIR-MIN-MAX
+ DIR-NO-AOPS
+ DIR-NO-QUANT
+ DIR-NO-ROPS
+ DIR-OPTIONAL
+ DIR-OWNER
+ DIR-PRED-ITER
+ DIR-PRED-OPTN
+ DIR-PRED-QUANT
+ DIR-PRINT-CH
+ DIR-PRINT-DB
+ DIR-PRINT-DBMS
+ DIR-PRINT-DIR
+ DIR-PRINT-ET
+ DIR-QPRED-OPTN
+ DIR-RANGE-ENTITY
+ DIR-RANGE-INTEGER
+ DIR-RANGE-STR
+ DIR-READ-DIR
+ DIR-READ-DIR-FILE
+ DIR-REMOTE-LDI
+ DIR-REPEAT-GRP
+ DIR-SET
+ DIR-SET-OF
+ DIR-SPELLED
+ DIR-SPELLED-2
+ DIR-SUPERTYPE
+ DIR-SUPPORTED-AOPS
+ DIR-SUPPORTED-COPS
+ DIR-SUPPORTED-DOPS
+ DIR-SUPPORTED-EOPS
+ DIR-SUPPORTED-FOPS
+ DIR-SUPPORTED-GOPS
+ DIR-SUPPORTED-LOPS
+ DIR-SUPPORTED-QOPS
+ DIR-SUPPORTED-QNTS
+ DIR-SUPPORTED-ROPS
+ DIR-SYS-EP
+ DIR-SYS-EP-ACCESS
+ DIR-SYS-EP-KEYS
+ DIR-SYS-EP-OPTN
+ DIR-SYS-EP-SET
+ DIR-VIEW-DEF
+ DIR-VISIBLE
+ DIR-VISIBLE-CONSTRAINTS
+ DIR-WRITE-DIR
+ DIR-WRITE-DIR-FILE
+ PP-DIR
+
+;"The following atoms are tokens that are referenced in here. They
+ must be included here so ==? comparisons will work. They were moved from gdm-parser"
+ AC
+;" ACCESS"
+ ALL
+;" ASCII"
+ BCD
+ BIT
+ CHR-BIT
+ CHR-REP
+ CONSTANT
+ CREATE
+ DEMO-OFF
+ DEMO-ON
+ EQUALITY
+ EXPRESSION
+ FIELD
+ FOUND
+ INEQUALITY
+ INT-BIT
+ INT-REP
+ INT-STR
+ MULTIPLE
+ NESTED
+ NON_QUANTIFIED
+ ONES
+ OWNED
+ PARALLEL
+ PRINTING
+ PROPAGATE
+ QUANTIFIED
+ RANGE
+ REFERENCE
+ REPEATING
+ RESTRICTED
+;" SET"
+ SPELLED
+ STRICT
+ SYS-EP
+ TWOS
+ UNIQUE
+>
+
+<USE "GDM-DIR" "GDM-UTIL" "PARSE-DEFINITIONS" "DEMO">
+<USE "EM" "BUILD-VIEW" "BUILD-CONSTRAINTS">
+
+
+;"\f"
+;"CREATE-DB performs context analysis of a data base schema definition
+ command. If no errors are detected, the new entity types defined
+ in the schema are added to the ENTITY-TYPE-TABLE."
+
+<DEFINE CREATE-DB (DB "AUX" (VID <+ 1 <LENGTH ,VIEW-TAB>>)
+ (EV <IVECTOR <LENGTH <3 .DB>><>>)
+ (EID-BASE <LENGTH ,ET-TABLE>)
+ I
+ DBMS-ID
+ FV
+ "ACT" ACT)
+ #DECL ((DB EV FV) VECTOR
+ (I VID EID-BASE DBMS-ID) FIX)
+
+;"Check that database name matches name on END statement"
+
+ <COND (<2 .DB>
+ <COND (<NOT <==? <1 .DB> <2 .DB>>>
+ <ERR "Name on END statement does not match database name">
+ <RETURN <> .ACT>)>)>
+
+;"Check that database name is unique"
+
+ <MAPF <>
+ <FUNCTION (V)
+ #DECL ((V) VIEW)
+ <COND (<==? <1 .DB> <V-NAME .V>>
+ <ERR <STRING "Database name "
+ <SPNAME <1 .DB>>
+ " is already defined.">>
+ <RETURN <> .ACT>)>>
+ ,VIEW-TAB>
+
+;"Check that database name matches an existing DBMS name and save its
+ DBMS id."
+
+ <SET I 0>
+ <COND (<NOT <MAPF <>
+ <FUNCTION (D)
+ #DECL ((D) DBMS)
+ <SET I <+ .I 1>>
+ <COND (<==? <DB-SCHEMA-NAME .D> <1 .DB>>
+ <SET DBMS-ID .I>
+ <MAPLEAVE>)>>
+ ,DBMS-TAB>>
+ <ERR <STRING "No local DBMS defined for "
+ <SPNAME <1 .DB>> ".">>
+ <RETURN <> .ACT>)>
+
+;"Build entity type table for database"
+
+ <SET I 0>
+ <MAPF <>
+ <FUNCTION (E)
+ #DECL ((E) LIST)
+ <COND (<FIND-ETID .EV <1 .E>>
+ <ERR <STRING "Entity type "
+ <SPNAME <1 .E>>
+ " is defined more than once.">>
+ <RETURN <> .ACT>)>
+ <SET I <+ .I 1>>
+ <PUT .EV .I <CHTYPE [<1 .E>
+ <+ .I .EID-BASE>
+ .VID
+ <CHTYPE () ETID-LIST>
+ <CHTYPE () ETID-LIST>
+ <CHTYPE () ETID-LIST>
+ <CREATE-FUNCTIONS <1 .E>
+ <2 .E> .DBMS-ID .ACT>
+ <CREATE-DEFAULT-EREP .DBMS-ID>
+ ET-LOCAL-SCHEMA] ENTITY-TYPE>>>
+ <3 .DB>>
+
+;"Make a pass through all functions of type F-ENTITY and replace
+ entity type name with ETID. Also set '# chars to print' default
+ for all functions of type F-STRING."
+
+ <MAPF <>
+ <FUNCTION (E "AUX" (FL <ET-FUNCTIONS .E>))
+ #DECL ((E) ENTITY-TYPE (FL) VECTOR)
+ <PUT <ET-MAP-INFO .E> ,E-SPELLING <SPNAME <ET-NAME .E>>>
+ <MAPF <>
+ <FUNCTION (F "AUX" X)
+ #DECL ((F) ENTITY-FUNC (X) <OR FIX FALSE>)
+ <PUT <F-MAP-INFO .F> ,F-SPELLING <SPNAME <F-NAME .F>>>
+ <COND (<==? <F-TYPE .F> F-ENTITY>
+ <SET X <FIND-ETID .EV <F-ETID .F>>>
+ <COND (.X
+ <PUT .F ,F-ETID .X>)
+ (ELSE
+ <ERR <STRING "Entity type "
+ <SPNAME <F-ETID .F>>
+ " is undefined.">>)>)>
+ <COND (<==? <F-TYPE .F> F-STRING>
+ <PUT <F-MAP-INFO .F> ,F-MIN-CHR <F-MIN .F>>
+ <PUT <F-MAP-INFO .F> ,F-MAX-CHR <F-MAX .F>>
+ <PUT <F-MAP-INFO .F> ,F-CONV-CHARS <F-MAX .F>>)>>
+ .FL>>
+ .EV>
+
+;"Process mapping information"
+
+ <MAPF <>
+ <FUNCTION (E "AUX" ETID EMAP)
+ #DECL ((E) LIST (ETID) <OR FIX FALSE> (EMAP) E-PHY-REP)
+ <COND (<NOT <SET ETID <FIND-ETID .EV <1 .E>>>>
+ <ERR <STRING "Entity name " <SPNAME <1 .E>>
+ " is undefined.">>
+ <RETURN <> .ACT>)>
+ <SET ETID <- .ETID .EID-BASE>> ;"Setup index into EV"
+ <SET EMAP <ET-MAP-INFO <.ETID .EV>>>
+ <SET FV <ET-FUNCTIONS <.ETID .EV>>>
+ <COND ( <NOT <FIND KEY <2 .E> 1>>
+ <ERR "Entity " <SPNAME <ET-NAME <.ETID .EV>>> " does not have any keys.">
+ <RETURN <> .ACT>)>
+ <MAPF <>
+ <FUNCTION (M)
+ #DECL ((M) LIST)
+ <COND (<==? <1 .M> FOUND>
+ <PUT .EMAP ,E-CONTEXT <2 .M>>)>
+ <COND (<==? <1 .M> SYS-EP>
+ <MAPF <>
+ <FUNCTION (OPTN)
+ #DECL ((OPTN) LIST)
+ <COND ( <==? <1 .OPTN> SETNAME>
+ <PUT .EMAP ,E-SYS-SET <2 .OPTN>>)
+ ( <==? <1 .OPTN> ACCESS>
+ <PUT .EMAP ,E-SYS-EP-AP-ONLY T>)
+ ( <==? <1 .OPTN> KEYS>
+ <PUT .EMAP ,E-SYS-EP-KEYS <2 .OPTN>>)>
+ >
+ <2 .M>
+ >
+ <PUT .EMAP ,E-SYS-EP T>)>
+ <COND (<==? <1 .M> SPELLED>
+ <PUT .EMAP ,E-SPELLING <2 .M>>)>
+ <COND (<==? <1 .M> AREA>
+ <PUT .EMAP ,E-AREAS <2 .M>>)>
+ <COND (<==? <1 .M> OWNED>
+ <MAPF <>
+ <FUNCTION (OWNER "AUX" X)
+ #DECL ((OWNER) IDENTIFIER (X) <OR FALSE FIX>)
+ <COND (<SET X <FIND-ETID .EV <ID-NAME .OWNER>>>
+ <PUT .EMAP ,E-OWNERS <CHTYPE (.X !<E-OWNERS .EMAP>) ETID-LIST>>)
+ (ELSE
+ <ERR <STRING "Entity type "
+ <SPNAME <ID-NAME .OWNER>>
+ " is undefined.">>
+ <RETURN <> .ACT>)>>
+ <2 .M>>)>
+ <COND (<==? <1 .M> PRED-OPTN>
+ <MAPF <>
+ <FUNCTION (M)
+ #DECL ((M) LIST)
+ <COND (<==? <1 .M> ITER-DOMAIN>
+ <PUT .EMAP ,E-ITER-PRED <2 .M>>)>
+ <COND (<==? <1 .M> QUANT-DOMAIN>
+ <PUT .EMAP ,E-QUANT-PRED <2 .M>>)>
+ <COND (<==? <1 .M> NO-QUANT>
+ <PUT .EMAP ,E-NO-QUANT T>)>
+ >
+ <2 .M>>)>
+ <COND ( <==? <1 .M> KEY>
+ <MAPR <>
+ <FUNCTION (ID "AUX" X)
+ #DECL((ID) LIST (X) <OR FIX FALSE>)
+ <COND (<SET X <FIND-FID .FV <ID-NAME <1 .ID>>>>
+ <PUT .ID 1 .X>)
+ (ELSE
+ <ERR "Function "
+ <SPNAME <ID-NAME <1 .ID>>>
+ " is not defined in entity type "
+ <SPNAME <ET-NAME <.ETID .EV>>>>
+ <RETURN <> .ACT>)>>
+ <2 .M>>
+ <PUT .EMAP ,E-KEY <CHTYPE <2 .M> FCNID-LIST>>)>
+ >
+ <2 .E>>
+ <MAPF <>
+ <FUNCTION (F "AUX" FID FMAP)
+ #DECL ((F) LIST (FID) <OR FIX FALSE> (FMAP) F-PHY-REP)
+ <COND (<NOT <SET FID <FIND-FID .FV <1 .F>>>>
+ <ERR <STRING "Function " <SPNAME <1 .F>>
+ " is not defined in entity type "
+ <SPNAME <ET-NAME <.ETID .EV>>>>>
+ <RETURN <> .ACT>)>
+ <SET FMAP <F-MAP-INFO <.FID .FV>>>
+
+;"If this is really an integer string then setup correct defaults."
+
+ <MAPF <>
+ <FUNCTION (FM)
+ #DECL ((FM) LIST)
+ <COND (<==? <1 .FM> INT-STR>
+ <PUT .FMAP ,F-REP
+ <DB-DEF-STR-REP <DB-OPTIONS <.DBMS-ID ,DBMS-TAB>>>>
+ <PUT .FMAP ,F-BITS
+ <DB-DEF-STR-BITS <DB-OPTIONS <.DBMS-ID ,DBMS-TAB>>>>
+ <PUT .FMAP ,F-CONV-CHARS
+ <3 .FM>>)>>
+ <2 .F>>
+
+ <MAPF <>
+ <FUNCTION (FM)
+ #DECL ((FM) LIST)
+ <COND (<==? <1 .FM> ACCESS>
+ <PUT .FMAP ,F-AP-SPELLING <F-SPELLING .FMAP>>
+ <MAPF <>
+ <FUNCTION (OPTN "AUX" X)
+ #DECL ((OPTN) LIST (X) <OR FIX FALSE>)
+ <COND (<==? <1 .OPTN> UNIQUE>
+ <PUT .FMAP ,F-AP-UNIQUE T>)
+ (<==? <1 .OPTN> SPELLED>
+ <PUT .FMAP ,F-AP-SPELLING <2 .OPTN>>)
+ (<==? <1 .OPTN> SELECTS>
+ <COND (<SET X <FIND-ETID .EV <ID-NAME <2 .OPTN>>>>
+ <PUT .FMAP ,F-AP-SELECTS .X>)
+ (ELSE
+ <ERR "Entity type "
+ <SPNAME <ID-NAME <2 .OPTN>>>
+ " is undefined.">
+ <RETURN <> .ACT>)>)
+ (<==? <1 .OPTN> WITH>
+ <MAPR <>
+ <FUNCTION (ID "AUX" X)
+ #DECL((ID) LIST (X) <OR FIX FALSE>)
+ <COND (<SET X <FIND-FID .FV <ID-NAME <1 .ID>>>>
+ <PUT .ID 1 .X>)
+ (ELSE
+ <ERR "Function "
+ <SPNAME <ID-NAME <1 .ID>>>
+ " is not defined in entity type "
+ <SPNAME <ET-NAME <.ETID .EV>>>>
+ <RETURN <> .ACT>)>>
+ <2 .OPTN>>
+ <PUT .FMAP ,F-AP-CO-FCNS <CHTYPE <2 .OPTN> FCNID-LIST>>)>
+ >
+ <3 .FM>>
+ <COND (<==? <2 .FM> EQUALITY>
+ <PUT .EMAP ,E-AP-EQ-COUNT
+ <+ <E-AP-EQ-COUNT .EMAP> 1>>
+ <PUT .FMAP ,F-AP-EQ T>)>
+ <COND (<==? <2 .FM> INEQUALITY>
+ <PUT .FMAP ,F-AP-NQ T>)>
+ <COND (<==? <2 .FM> RANGE>
+ <PUT .FMAP ,F-AP-RANGE T>)>)>
+ <COND (<==? <1 .FM> SPELLED>
+ <PUT .FMAP ,F-SPELLING <2 .FM>>)>
+ <COND (<==? <1 .FM> SET>
+ <PUT .FMAP ,F-SET T>)>
+ <COND (<==? <1 .FM> REPEAT>
+ <PUT .FMAP ,F-REPEAT-GRP T>)>
+ <COND (<==? <1 .FM> INT-STR>
+ <PUT .FMAP ,F-INT-STR T>
+ <PUT .FMAP ,F-MIN-CHR <2 .FM>>
+ <PUT .FMAP ,F-MAX-CHR <3 .FM>>)>
+ <COND (<==? <1 .FM> PRINTING>
+ <PUT .FMAP ,F-CONV-CHARS <2 .FM>>)>
+ <COND (<==? <1 .FM> BIT>
+ <PUT .FMAP ,F-BITS <2 .FM>>
+ <COND (<==? <3 .FM> ASCII>
+ <PUT .FMAP ,F-REP DB-ASCII>)>
+ <COND (<==? <3 .FM> BCD>
+ <PUT .FMAP ,F-REP DB-BCD>)>
+ <COND (<==? <3 .FM> ONES>
+ <PUT .FMAP ,F-REP DB-ONES-COMP>)>
+ <COND (<==? <3 .FM> TWOS>
+ <PUT .FMAP ,F-REP DB-TWOS-COMP>)>)>
+ <COND (<==? <1 .FM> AOPS>
+ <PUT .FMAP ,F-ARITH-OPS <2 .FM>>)>
+ <COND (<==? <1 .FM> ROPS>
+ <PUT .FMAP ,F-REL-OPS <2 .FM>>)>
+ >
+ <2 .F>>>
+ <3 .E>>>
+ <4 .DB>>
+
+;"Add entity type constraints"
+
+ <COND ( <NOT <BUILD-CONSTRAINTS .EV <5 .DB>>>
+ <RETURN <> .ACT>)>
+
+;"Now add structures to schema directory"
+
+ <PUT ,SCHEMA-DIR ,VIEW-TABLE
+ [!<VIEW-TABLE ,SCHEMA-DIR> <CHTYPE [<1 .DB>] VIEW>]>
+ <SETG VIEW-TAB <VIEW-TABLE ,SCHEMA-DIR>>
+ <PUT ,SCHEMA-DIR ,ENTITY-TYPE-TABLE
+ [!<ENTITY-TYPE-TABLE ,SCHEMA-DIR> !.EV]>
+ <SETG ET-TABLE <ENTITY-TYPE-TABLE ,SCHEMA-DIR>>
+ <SETG LEN-ET-TABLE <LENGTH ,ET-TABLE>>
+ <MSG <STRING "Database " <SPNAME <1 .DB>> " added to global schema.">>
+
+> ;"CREATE-DB"
+"\f"
+;"CREATE-DBMS performs context analysis of the local DBMS specification
+ command. If no errors are found a new entry will be created in the
+ DBMS-TABLE."
+
+<DEFINE CREATE-DBMS (DBMS-ENTRY)
+ #DECL ((DBMS-ENTRY) DBMS)
+ <COND (<NOT <MAPF <> ;"Make one pass to insure unique DBMS name"
+ <FUNCTION (E)
+ <COND (.E
+ <COND (<==? <DB-SCHEMA-NAME .DBMS-ENTRY>
+ <DB-SCHEMA-NAME .E>>
+ <ERR <STRING "Local DBMS " <SPNAME <DB-SCHEMA-NAME .E>> " is already defined.">>
+ <MAPLEAVE>)>)>>
+ <DBMS-TABLE ,SCHEMA-DIR>>>
+ <PUT ,SCHEMA-DIR ,DBMS-TABLE [!<DBMS-TABLE ,SCHEMA-DIR>
+ .DBMS-ENTRY]>
+ <SETG DBMS-TAB <DBMS-TABLE ,SCHEMA-DIR>>
+ <MSG <STRING "DBMS " <SPNAME <DB-SCHEMA-NAME .DBMS-ENTRY>>
+ " added to global schema.">>)>>
+;"\f"
+;"CREATE-DEFAULT-EREP creates a default physical entity type
+ representation. DBMS-ID is the index into the DBMS-TABLE."
+
+<DEFINE CREATE-DEFAULT-EREP (DBMS-ID)
+ #DECL ((DBMS-ID) FIX)
+ <CHTYPE [.DBMS-ID <> <> <CHTYPE () ETID-LIST> <> 0 <> <>
+ <> <> <> <> <> <> <>] E-PHY-REP>>
+
+
+
+
+
+;"CREATE-DEFAULT-FREP creates a default physical function
+ representation. FUNC-TYPE is the function type (string, integer...)
+ and DBMS-ID is the index into the DBMS-TABLE"
+
+<DEFINE CREATE-DEFAULT-FREP (FUNC-TYPE DBMS-ID
+ "AUX" (O <DB-OPTIONS <.DBMS-ID ,DBMS-TAB>>))
+ #DECL ((FUNC-TYPE) ATOM (DBMS-ID) FIX (O) DBMS-OPTIONS)
+ <COND (<==? .FUNC-TYPE F-STRING>
+ <CHTYPE [<> <> <> <DB-DEF-STR-BITS .O>
+ <DB-DEF-STR-REP .O>
+ <> <> <>
+ ,SYS-DEF-INT-BITS
+ 0 0 0 <> <> <> <> <>
+ <DB-REL-OPS .O>
+ <DB-ARITH-OPS .O>] F-PHY-REP>)
+ (ELSE
+ <CHTYPE [<> <> <> <DB-DEF-INT-BITS .O>
+ <DB-DEF-INT-REP .O>
+ <> <> <>
+ ,SYS-DEF-INT-BITS
+ ,SYS-DEF-PRINT-INT
+ 0 0 <> <> <> <> <>
+ <DB-REL-OPS .O>
+ <DB-ARITH-OPS .O>] F-PHY-REP>)>>
+;"\f"
+;"CREATE-FUNCTIONS creates a vector of entity function specifications."
+
+<DEFINE CREATE-FUNCTIONS (ENAME FL DBMS-ID ERROR-EXIT "AUX" (V []))
+ #DECL ((FL) LIST (DBMS-ID) FIX (V) VECTOR
+ (ENAME) ATOM
+ (ERROR-EXIT) ACTIVATION)
+ <MAPF <>
+ <FUNCTION (F)
+ #DECL ((F) ENTITY-FUNC)
+ <MAPF <>
+ <FUNCTION (VF)
+ #DECL ((VF) ENTITY-FUNC)
+ <COND (<==? <F-NAME .VF> <F-NAME .F>>
+ <ERR <STRING "Function name "
+ <SPNAME <F-NAME .F>>
+ " in entity type "
+ <SPNAME .ENAME>
+ " defined more than once.">>
+ <RETURN <> .ERROR-EXIT>)>>
+ .V>
+ <PUT .F ,F-MAP-TYPE F-LOCAL-SCHEMA>
+ <PUT .F ,F-MAP-INFO <CREATE-DEFAULT-FREP <F-TYPE .F> .DBMS-ID>>
+ <SET V [!.V .F]>>
+ .FL>>
+;"\f"
+
+;"DEMO-COMMAND processes various demo commands."
+
+<DEFINE DEMO-COMMAND (CMD)
+ #DECL ((CMD) ATOM)
+ <COND (<==? .CMD DEMO-ON>
+ <SETG DEMO T>
+ <DEMO-INIT >
+ <CALL-ALL-LDIS-SIMPLE "DEMO-CMD" ON>)
+ (<==? .CMD DEMO-OFF>
+ <SETG DEMO <>>
+ <CALL-ALL-LDIS-SIMPLE "DEMO-CMD" <>>)
+ (ELSE
+ <ERR "Unknown demo command.">)>
+ <RESERVE-SPACE> ;"tries to make sure there is enough garbage collection room"
+ <>>
+;"\f"
+;"All routines beginning with DIR- are DBA command action routines."
+
+;"DIR-AC returns the keyword AC
+ Production: ALPHA_COLLATING "
+
+<DEFINE DIR-AC (X)
+ AC>
+
+
+;"DIR-ACCESS-ENT returns a list which indicates the entity
+ selected by an access path.
+ Production: SELECTS entity-name ; "
+
+<DEFINE DIR-ACCESS-ENT (X ENTITY Y)
+ #DECL ( (ENTITY) IDENTIFIER)
+ (SELECTS .ENTITY)>
+
+
+
+;"DIR-ACCESS-FCN returns a list which indicates other functions
+ which must be present to make a complete access path.
+ Production: WITH functin_list ; "
+
+<DEFINE DIR-ACCESS-FCN (X FCN-LIST Y)
+ #DECL ( (FCN-LIST) LIST)
+ (WITH .FCN-LIST)>
+
+
+
+;"DIR-ACCESS-PATH returns a list containing the keyword ACCESS and
+ the type of comparison that can be done.
+ Production: ACCESS PATH VIA compare_type ; "
+
+<DEFINE DIR-ACCESS-PATH (W X Y CTYPE Z)
+ #DECL ((CTYPE) ATOM)
+ (ACCESS .CTYPE ())>
+
+
+
+
+;"DIR-ACCESS-UNIQUE returns a list indicating that the access path is unique.
+ Production: UNIQUE ; "
+
+<DEFINE DIR-ACCESS-UNIQUE (X Y)
+ (UNIQUE)>
+
+
+;"DIR-AP-OPTIONS returns a list containing the keyword ACCESS and the
+ list of options specified for the access path.
+ Production: ACCESS PATH VIA compare_type access_paht_list "
+
+<DEFINE DIR-AP-OPTIONS (V W X CTYPE OPTN)
+ #DECL ((CTYPE) ATOM (OPTN) LIST)
+ (ACCESS .CTYPE .OPTN)>
+
+
+
+
+;"DIR-AYREA creates a list containing the keyword AREA and a list
+ area names.
+ Production: AREAS area_list "
+
+<DEFINE DIR-AYREA (X AREA-LIST Y)
+ #DECL ((AREA-LIST) LIST)
+ (AREA <CHTYPE .AREA-LIST AREAS>)>
+;"\f"
+;"DIR-BIT returns a list containing the keyword BIT and the bit size
+ of the function value and its representation.
+ Production: number BIT representation "
+
+<DEFINE DIR-BIT (NUM X VREP)
+ #DECL ((NUM) FIX (VREP) ATOM)
+ (BIT .NUM .VREP)>
+
+
+
+
+
+;"DIR-CHR-BITS returns a list containing the keyword CHR-BIT and
+ the character size in bits.
+ Production: DEFAULT CHAR BIT SIZE IS number "
+
+<DEFINE DIR-CHR-BITS (V W X Y Z BIT-SIZE)
+ #DECL ((BIT-SIZE) FIX)
+ (CHR-BIT .BIT-SIZE)>
+
+
+
+
+;"DIR-CHR-REP returns a list containing the keyword CHR-REP and
+ the character representation.
+ Production: DEFAULT CHAR REP IS representation "
+
+<DEFINE DIR-CHR-REP (W X Y Z VREP)
+ #DECL ((VREP) ATOM)
+ (CHR-REP .VREP)>
+
+
+
+
+;"\f"
+;"DIR-CONTEXT returns a list containing the keyword FOUND and a string
+ representing the context in which the entity type is found.
+ Production: FOUND UNDER character_string ; "
+
+<DEFINE DIR-CONTEXT (X Y CONTEXT Z)
+ #DECL ((CONTEXT) STRING)
+ (FOUND .CONTEXT)>
+
+
+
+
+
+;"DIR-CONTEXT-DBA is the main entry point for context analysis. Determines
+ the DBA command type and invokes the appropriate routine."
+
+<DEFINE DIR-CONTEXT-DBA (COMMAND "ACT" ACT)
+ #DECL ((COMMAND) <OR DBMS-DEF DB-DEF VIEW-DEF DIR-CMD DEMO-CMD>
+ (ACT) ACTIVATION)
+ <COND (<TYPE? .COMMAND DBMS-DEF>
+ <CREATE-DBMS <1 .COMMAND>>)
+ (<TYPE? .COMMAND DIR-CMD>
+ <RETURN <> .ACT>)
+ (<TYPE? .COMMAND DB-DEF>
+ <CREATE-DB <1 .COMMAND>>)
+ (<TYPE? .COMMAND VIEW-DEF>
+ <CREATE-VIEW .COMMAND>)
+ (<TYPE? .COMMAND DEMO-CMD>
+ <DEMO-COMMAND <1 .COMMAND>>)>>
+;"\f"
+
+ ;"Production: SHARE entity_name WITH entity_list ; "
+
+<DEFINE DIR-COTYPE (X ID Y EL Z)
+ #DECL ((EL) LIST (ID) IDENTIFIER)
+ <ERR "Share statement not implemented">
+ <CHTYPE [.ID .EL] SHARE>
+>
+
+
+
+
+
+;"DIR-DATABASE-ID is called when a database definition containing a
+ database name on its END statement is recognized. The name is saved
+ and later checked against the database name for consistency.
+ Production: basic_database database_name ; "
+
+<DEFINE DIR-DATABASE-ID (BASIC-DB DB-NAME X)
+ #DECL ((BASIC-DB) VECTOR (DB-NAME) IDENTIFIER)
+ <PUT .BASIC-DB 2 <ID-NAME .DB-NAME>>>
+
+
+
+
+
+;"DIR-DB-DEF changes the structure built while parsing a data base
+ definition command to be a vector of type DB-DEF.
+ Production: database_definition "
+
+<DEFINE DIR-DB-DEF (STRUCT)
+ #DECL ((STRUCT) VECTOR)
+ <CHTYPE [.STRUCT] DB-DEF>>
+
+
+
+
+
+;"DIR-DB-MAPPING inserts the list containing entity mapping information
+ into the vector describing the database.
+ Production: DATABASE db_visible_part db_map_part END "
+
+<DEFINE DIR-DB-MAPPING (X VP MP Y)
+ #DECL ((VP) VECTOR (MP) LIST)
+ <PUT .VP 4 .MP>>
+
+
+
+
+
+;"DIR-DBMS-DEF changes the structure built while parsing a local
+ DBMS specification command to be a vector of type DBMS-DEF.
+ Production: dbms_definition "
+
+<DEFINE DIR-DBMS-DEF (STRUCT)
+ #DECL ((STRUCT) DBMS)
+ <CHTYPE [.STRUCT] DBMS-DEF>>
+;"\f"
+;"DIR-DBMS-OPTIONS builds a complete DBMS-TABLE entry by formating
+ a DBMS options list and adding it to the fixed portion of a
+ DBMS-TABLE entry. The DBMS options list contains information
+ describing which operations are supported on a local DBMS.
+ Production: basic_dbms_definition dbms_option_list ; "
+
+<DEFINE DIR-DBMS-OPTIONS (DBMS-ENTRY OPTION-LIST X
+ "AUX" (OPT <CHTYPE <VECTOR ,SYS-DEF-INT-BITS
+ ,SYS-DEF-INT-REP
+ ,SYS-DEF-STR-BITS
+ ,SYS-DEF-STR-REP
+ <> <> <>
+ ,SYS-INFINITY
+ ,SYS-INFINITY
+ ,SYS-INFINITY
+ ,SYS-INFINITY
+ <> <> <> <> <> <> <> <>
+ <> <> <> <> <> <> <> <>
+ <> <> <> <>
+ > DBMS-OPTIONS>))
+ #DECL ((DBMS-ENTRY) DBMS (OPTION-LIST) LIST (OPT) DBMS-OPTIONS)
+ <MAPF <>
+ <FUNCTION (O)
+ <COND (<TYPE? .O GLOBAL-OPS>
+ <PUT .OPT ,DB-GLOBAL-OPS .O>)
+ (<TYPE? .O DISPLAY-OPS>
+ <PUT .OPT ,DB-DISPLAY-OPS .O>)
+ (<TYPE? .O FIND-OPS>
+ <PUT .OPT ,DB-FIND-OPS .O>)
+ (<TYPE? .O QUANTIFIERS-OPS>
+ <PUT .OPT ,DB-QUANTIFIERS .O>)
+ (<TYPE? .O LIST>
+ <COND (<==? <1 .O> INT-BIT>
+ <PUT .OPT ,DB-DEF-INT-BITS <2 .O>>)
+ (<==? <1 .O> INT-REP>
+ <COND (<==? <2 .O> ONES>
+ <PUT .OPT ,DB-DEF-INT-REP DB-ONES-COMP>)
+ (<==? <2 .O> TWOS>
+ <PUT .OPT ,DB-DEF-INT-REP DB-TWOS-COMP>)>)
+ (<==? <1 .O> CHR-BIT>
+ <PUT .OPT ,DB-DEF-STR-BITS <2 .O>>)
+ (<==? <1 .O> CHR-REP>
+ <COND (<==? <2 .O> ASCII>
+ <PUT .OPT ,DB-DEF-STR-REP DB-ASCII>)
+ (<==? <2 .O> BCD>
+ <PUT .OPT ,DB-DEF-STR-REP DB-BCD>)>)
+ (<==? <1 .O> MAX-PRED>
+ <PUT .OPT ,DB-MAX-NON-QUANT-ITER <2 .O>>)
+ (<==? <1 .O> MAX-QPRED>
+ <PUT .OPT ,DB-MAX-QUANT-ITER <2 .O>>)
+ (<==? <1 .O> MAX-QREL>
+ <PUT .OPT ,DB-MAX-QUANT-REL <2 .O>>)
+ (<==? <1 .O> PRED-OPTN>
+ <MAPF <>
+ <FUNCTION (O)
+ <COND(<TYPE? .O ARITHMETIC-OPS>
+ <PUT .OPT ,DB-ARITH-OPS .O>)
+ (<TYPE? .O COMPARE-OPS>
+ <PUT .OPT ,DB-COMPARE-OPS .O>)
+ (<TYPE? .O LOGICAL-OPS>
+ <PUT .OPT ,DB-LOG-OPS .O>)
+ (<TYPE? .O QUANTIFIED-OPS>
+ <PUT .OPT ,DB-QUANT-REL .O>)
+ (<TYPE? .O RELATIONAL-OPS>
+ <PUT .OPT ,DB-REL-OPS .O>)
+ (<AND <TYPE? .O LIST>
+ <==? <1 .O> EXIST-OPS>>
+ <PUT .OPT ,DB-EXIST-OPS <2 .O>>)
+ (<==? .O ACCESS>
+ <PUT .OPT ,DB-AP-REQUIRED T>)
+ (<==? .O RESTRICTED>
+ <PUT .OPT ,DB-AP-ONLY T>)
+ (<FATAL-ERROR "DIR-DBMS-OPTIONS: Unknown option" .O>)>>
+ <2 .O>>)
+ (<==? <1 .O> QPRED-OPTN>
+ <MAPF <>
+ <FUNCTION (O)
+ <COND(<TYPE? .O ARITHMETIC-OPS>
+ <PUT .OPT ,DB-QP-ARITH-OPS .O>)
+ (<TYPE? .O COMPARE-OPS>
+ <PUT .OPT ,DB-QP-COMPARE-OPS .O>)
+ (<TYPE? .O LOGICAL-OPS>
+ <PUT .OPT ,DB-QP-LOG-OPS .O>)
+ (<TYPE? .O QUANTIFIED-OPS>
+ <PUT .OPT ,DB-QP-QUANT-REL .O>)
+ (<TYPE? .O RELATIONAL-OPS>
+ <PUT .OPT ,DB-QP-REL-OPS .O>)
+ (<AND <TYPE? .O LIST>
+ <==? <1 .O> EXIST-OPS>>
+ <PUT .OPT ,DB-QP-EXIST-OPS <2 .O>>)
+ (<==? .O ACCESS>
+ <PUT .OPT ,DB-QP-AP-REQUIRED T>)
+ (<==? .O RESTRICTED>
+ <PUT .OPT ,DB-QP-AP-ONLY T>)
+ (<FATAL-ERROR "DIR-DBMS-OPTIONS: Unknown option" .O>)>>
+ <2 .O>>)
+ (<FATAL-ERROR "DIR-DBMS-OPTIONS: Unknown option" .O>)>)
+ (<==? .O MULTIPLE>
+ <PUT .OPT ,DB-MULTIPLE-ITER T>)
+ (<==? .O PROPAGATE>
+ <PUT .OPT ,DB-RESTRICT-PROP T>)
+ (<==? .O STRICT>
+ <PUT .OPT ,DB-STRICT-NESTING-ONLY T>)
+ (<FATAL-ERROR "DIR-DBMS-OPTIONS: Unknown option" .O>)>>
+ .OPTION-LIST>
+ <PUT .DBMS-ENTRY ,DB-OPTIONS .OPT>>
+;"\f"
+;"DIR-DBMS-TABLE builds the fixed portion of a DBMS-TABLE entry.
+ Production: LOCAL NODE IS
+ LOCAL SCHEMA IS identifier
+ DBMS IS identifier
+ HOST IS identifier
+ LDI IS procedure_name ldi_choice "
+
+<DEFINE DIR-DBMS-TABLE (A B C D E F SCHEMA-NAME H I SYS-NAME K L M SYS-TYPE
+ O P HOST R S PROC-NAME LDI)
+ #DECL ((SCHEMA-NAME SYS-NAME HOST) IDENTIFIER (SYS-TYPE) ATOM
+ (PROC-NAME) STRING (LDI) LDI-DATA)
+ <PUT .LDI ,LDI-PROC-NAME .PROC-NAME>
+ <CHTYPE [ <ID-NAME .SCHEMA-NAME>
+ <ID-NAME .SYS-NAME>
+ .SYS-TYPE
+ <ID-NAME .HOST>
+ .LDI
+ <> ] DBMS>>
+
+
+
+
+;"DIR-DELETE-DB deletes a database specification from the schema directory.
+ Production: DELETE DATABASE identifier ; "
+
+<DEFINE DIR-DELETE-DB (X Y ID Z)
+ #DECL ((ID) IDENTIFIER)
+ <ERR "Not implemented yet">
+ <>>
+
+
+
+
+;"DIR-DELETE-DBMS deletes a DBMS specification from the schema directory.
+ Production: DELETE DBMS identifier ; "
+
+<DEFINE DIR-DELETE-DBMS (X Y ID Z)
+ #DECL ((ID) IDENTIFIER)
+ <ERR "Not implemented yet">
+ <>>
+;"\f"
+;"DIR-DELETE-DIR deletes the schema directory.
+ Production: DELETE DIRECTORY ; "
+
+<DEFINE DIR-DELETE-DIR (X Y Z)
+ <SETG SCHEMA-DIR <CHTYPE <IVECTOR 3 '<VECTOR>> DIRECTORY>> ;"poof"
+ <RENAME ,DIRECTORY-FILE-NAME> ;"Delete the disk file, too"
+ <WRITE-DIRECTORY>
+ <INITIALIZE-DIRECTORY>> ;"Read it back in and init various ptrs"
+
+
+
+
+
+;"DIR-DEMO-CMD is called when a demo command is recognized
+ Production: demo_command "
+
+<DEFINE DIR-DEMO-CMD (STRUCT)
+ #DECL ((STRUCT) ATOM)
+ <CHTYPE [.STRUCT] DEMO-CMD>>
+
+
+
+
+;"DIR-DEMO-OFF returns the keyword DEMO-OFF
+ Production: DEMO OFF ; "
+
+<DEFINE DIR-DEMO-OFF (X Y Z)
+ DEMO-OFF>
+
+
+
+
+;"DIR-DEMO-ON returns the keyword DEMO-ON
+ Production: DEMO ON ; "
+
+<DEFINE DIR-DEMO-ON (X Y Z)
+ DEMO-ON>
+
+
+
+
+;"DIR-DIR-CMD changes the structure built while parsing a directory
+ command to be a vector of type DIR-CMD.
+ Production: directory_command "
+
+<DEFINE DIR-DIR-CMD (STRUCT)
+ #DECL ((STRUCT) ANY)
+ <CHTYPE [.STRUCT] DIR-CMD>>
+
+
+
+
+
+;"DIR-ENTITY-EXTENT creates a list containing an entity name and its
+ associated mapping information plus and empty list since no function
+ mapping was supplied.
+ Production: EXTENT identifier IS db_entity_map db_extent_end "
+
+<DEFINE DIR-ENTITY-EXTENT (X ENAME Y EMAP Z)
+ #DECL ((ENAME) IDENTIFIER (EMAP) LIST)
+ (<ID-NAME .ENAME> .EMAP ())>
+
+
+
+
+;"\f"
+;"DIR-ENTITY-FUNC-EXTENT creates a list containing an entity name its
+ associated mapping info and its function mapping info.
+ Production: EXTENT identifier IS db_entity_map db_func_map db_extent_end "
+
+<DEFINE DIR-ENTITY-FUNC-EXTENT (X ENAME Y EMAP FMAP Z)
+ #DECL ((ENAME) IDENTIFIER (EMAP FMAP) LIST)
+ (<ID-NAME .ENAME> .EMAP .FMAP)>
+
+
+
+
+
+;"DIR-ENTITY-PRED-OPTN returns the predicate options of the entity
+ Production: RESTRICTED predicate_option_list "
+
+<DEFINE DIR-ENTITY-PRED-OPTN (X OPTN)
+ #DECL ( (OPTN) LIST)
+ (PRED-OPTN .OPTN)>
+
+
+
+
+;"DIR-ENTITY-TYPE creates a two element list containing the entity
+ name and a list describing its functions.
+ Production: TYPE entity_name IS ENTITY entity_body entity_end ; "
+
+<DEFINE DIR-ENTITY-TYPE (W ENAME X Y EBODY Z V)
+ #DECL ((ENAME) IDENTIFIER (EBODY) LIST)
+ (<ID-NAME .ENAME> .EBODY)>
+
+
+;"Production: TYPE entity_name IS ENTITY entity_end ; "
+<DEFINE DIR-ENTITY-TYPE-EMPTY(W ENAME X Y Z V)
+ #DECL((ENAME) IDENTIFIER)
+ (<ID-NAME .ENAME> () )
+>
+
+
+;"DIR-FCN-DEF adds the function name to an ENTITY-FUNC vector
+ Production: function_name : value_format ; "
+
+<DEFINE DIR-FCN-DEF (ID X F Y)
+ #DECL ((ID) IDENTIFIER (F) ENTITY-FUNC)
+ <PUT .F ,F-NAME <ID-NAME .ID>>>
+
+
+
+
+;"DIR-FLUSH-DIR deletes the schema directory in memory only.
+ Production: FLUSH DIRECTORY ; or
+ FLUSH ; "
+
+<DEFINE DIR-FLUSH-DIR (X Y "OPT" Z "AUX" FOO)
+ #DECL ((FOO) <OR ATOM FALSE>)
+ <SET FOO ,DONT-RELOAD-DIR>
+ <SETG DONT-RELOAD-DIR T>
+ <SETG SCHEMA-DIR <CHTYPE <IVECTOR 3 '<VECTOR>> DIRECTORY>> ;"poof"
+ <INITIALIZE-DIRECTORY>
+ <SETG DONT-RELOAD-DIR .FOO>
+>
+
+
+
+
+;"DIR-FOP-CALC returns the keyword FIND-CALC.
+ Production: CALC "
+
+<DEFINE DIR-FOP-CALC (X)
+ FIND-CALC>
+
+;"DIR-FOP-CUR returns the keyword FIND-CUR.
+ Production: CURRENT "
+
+<DEFINE DIR-FOP-CUR (X)
+ FIND-CUR>
+
+;"DIR-FOP-KEY returns the keyword FIND-KEY.
+ Production: DATABASE_KEY "
+
+<DEFINE DIR-FOP-KEY (X)
+ FIND-KEY>
+
+;"DIR-FOP-OWN returns the keyword FIND-OWN.
+ Production: OWNER "
+
+<DEFINE DIR-FOP-OWN (X)
+ FIND-OWN>
+
+;"DIR-FOP-POS returns the keyword FIND-POS.
+ Production: POSITIONAL "
+
+<DEFINE DIR-FOP-POS (X)
+ FIND-POS>
+
+;"DIR-FOP-USE-CUR returns the keyword FIND-USE-CUR.
+ Production: USING_CURRENT "
+
+<DEFINE DIR-FOP-USE-CUR (X)
+ FIND-USE-CUR>
+
+;"DIR-FOP-USE-NCUR returns the keyword FIND-USE-NCUR.
+ Production: USING_NON_CURRENT "
+
+<DEFINE DIR-FOP-USE-NCUR (X)
+ FIND-USE-NCUR>
+
+
+;"DIR-FUNC-AOPS returns a list containing the arithmetic operators
+ supported for the specific function.
+ Production: RESTRICTED TO ARITHMETIC OPERATIONS supported_arith_list ; "
+
+<DEFINE DIR-FUNC-AOPS (V W X Y OPS Z)
+ #DECL ((OPS) LIST)
+ (AOPS <DIR-SUPPORTED-AOPS X Y Z .OPS>)>
+
+
+
+
+;"DIR-FUNC-EXTENT creates a list containing the function name and its
+ associated mapping information.
+ Production: identifier IS db_func_map "
+
+<DEFINE DIR-FUNC-EXTENT (FNAME X MAPPING)
+ #DECL ((FNAME) IDENTIFIER (MAPPING) LIST)
+ (<ID-NAME .FNAME> .MAPPING)>
+
+
+
+
+;"DIR-FUNC-ROPS returns a list containing the relational operators
+ supported for the specific function.
+ Production: RESTRICTED TO RELATIONAL OPERATIONS supported_rel_list ; "
+
+<DEFINE DIR-FUNC-ROPS (V W X Y OPS Z)
+ #DECL ((OPS) LIST)
+ (ROPS <DIR-SUPPORTED-ROPS X Y Z .OPS>)>
+;"\f"
+
+
+
+
+;"DIR-INT-BITS returns a list containing the keyword INT-BIT and
+ the default bit size for integers.
+ Production: DEFAULT INTEGER BIT SIZE IS number "
+
+<DEFINE DIR-INT-BITS (V W X Y Z BIT-SIZE)
+ #DECL ((BIT-SIZE) FIX)
+ (INT-BIT .BIT-SIZE)>
+
+
+
+
+
+;"DIR-INT-REP returns a list containing the keyword INT-REP and
+ the default representation for integers.
+ Production: DEFAULT INTEGER REP IS representation "
+
+<DEFINE DIR-INT-REP (W X Y Z VREP)
+ #DECL ((VREP) ATOM)
+ (INT-REP .VREP)>
+
+
+
+
+;"DIR-INT-STR creates a list containing the keyword INT-STR and
+ the min/max number of characters in the integer string.
+ Production: STORED AS STRING ( number_characters ) "
+
+<DEFINE DIR-INT-STR (X Y Z V MIN-MAX W)
+ #DECL ((MIN-MAX) LIST)
+ (INT-STR <1 .MIN-MAX> <2 .MIN-MAX>)>
+
+
+
+
+;"DIR-KEY returns the key specification for the entity.
+ Production: KEY key_spec ; "
+
+<DEFINE DIR-KEY (Y KEY-SPEC Z)
+ #DECL ( (KEY-SPEC) <OR ATOM LIST>)
+ <COND (<TYPE? .KEY-SPEC ATOM>
+ (KEY ()) ) ;"DATABASE_KEY"
+ (ELSE
+ (KEY .KEY-SPEC) )>>
+
+
+
+;"DIR-LOCAL-LDI builds an LDI-DATA vector containing information
+ about a local LDI.
+ Production: LOCAL "
+
+<DEFINE DIR-LOCAL-LDI (X)
+ <CHTYPE <VECTOR T
+ <>
+ <>
+ <>> LDI-DATA>>
+
+
+
+
+;"DIR-MAX-ONLY creates a list containing the range of a STRING.
+ Production: number "
+
+<DEFINE DIR-MAX-ONLY (VMAX)
+ #DECL ((VMAX) FIX)
+ (.VMAX .VMAX)>
+
+
+
+;"DIR-MAX-PRED returns the non-quantified iteration predicate limit.
+ Production: MAXIMUM OF number NON_QUANTIFIED ITERATION PREDICATES "
+
+<DEFINE DIR-MAX-PRED (V W NUM X Y Z)
+ #DECL ( (NUM) FIX)
+ (MAX-PRED .NUM)>
+
+
+
+
+;"DIR-MAX-QPRED returns the quantified iteration predicate limit.
+ Production: MAXIMUM OF number QUANTIFIED ITERATION PREDICATES "
+
+<DEFINE DIR-MAX-QPRED (V W NUM X Y Z)
+ #DECL ( (NUM) FIX)
+ (MAX-QPRED .NUM)>
+
+
+
+
+;"DIR-MAX-QREL returns the quantified relation within a predicate limit.
+ Production: MAXIMUM OF number QUANTIFIED RELATIONS PER ITERATION "
+
+<DEFINE DIR-MAX-QREL (V W NUM X Y Z U)
+ #DECL ( (NUM) FIX)
+ (MAX-QREL .NUM)>
+
+
+
+
+;"DIR-MIN-MAX creates a list containing the range of a STRING.
+ Production: number .. number "
+
+<DEFINE DIR-MIN-MAX (VMIN X VMAX)
+ #DECL ((VMIN VMAX) FIX)
+ (.VMIN .VMAX)>
+
+
+
+
+;"DIR-NO-AOPS is called to process a declaration of no arithmetic ops.
+ Production: RESTRICTED TO NO ARITHMETIC OPERATINS ; "
+
+<DEFINE DIR-NO-AOPS (U V W X Y Z)
+ (AOPS <DIR-SUPPORTED-AOPS X Y Z '()>) >
+
+
+
+
+;"DIR-NO-QUANT is called for an entity which cannot be the domain
+ of a quantification.
+ Production: TO NO QUANTIFICATION ; "
+
+<DEFINE DIR-NO-QUANT (W X Y Z)
+ (NO-QUANT)>
+
+
+
+
+;"DIR-NO-ROPS is called to process a declaration of no relational ops.
+ Production: RESTRICTED TO NO RELATIONAL OPERATINS ; "
+
+<DEFINE DIR-NO-ROPS (U V W X Y Z)
+ (ROPS <DIR-SUPPORTED-ROPS X Y Z '()>) >
+
+
+
+
+;"DIR-OPTIONAL is called when a partial function is recognized.
+ Production: range_type PARTIAL "
+
+<DEFINE DIR-OPTIONAL (F)
+ #DECL ((F) ENTITY-FUNC)
+ .F> ;"No-op for now"
+
+
+
+
+
+;"DIR-OWNER creates a list containing the keyword OWNED and a list
+ of entity types that are owners.
+ Production: OWNED BY entity_list ; "
+
+<DEFINE DIR-OWNER (X Y EL Z)
+ #DECL ((EL) LIST)
+ (OWNED .EL)>
+
+
+
+
+;"\f"
+;"DIR-PRED-ITER returns information on the type of predicates
+ permitted when an entity is the domain of an iteration.
+ Production: WHEN DOMAIN OF ITERATION TO type PREDICATES ; "
+
+<DEFINE DIR-PRED-ITER (S U V W X TYP Y Z)
+ #DECL ( (TYP) LIST)
+ (ITER-DOMAIN <DIR-SUPPORTED-PRED-TYPES .TYP>)>
+
+
+
+
+;"DIR-PRED-OPTN returns the predicate options of the dbms
+ Production: WITHIN NON_QUANTIFIED PREDICATES predicate_option_list "
+
+<DEFINE DIR-PRED-OPTN (X Y Z OPTN)
+ #DECL ( (OPTN) LIST)
+ (PRED-OPTN .OPTN)>
+
+
+
+
+;"DIR-PRED-QUANT returns information on the type of predicates
+ permitted when an entity is the domain of a quantification.
+ Production: WHEN DOMAIN OF QUANTIFICATION TO type PREDICATES ; "
+
+<DEFINE DIR-PRED-QUANT (S U V W X TYP Y Z)
+ #DECL ( (TYP) LIST)
+ (QUANT-DOMAIN <DIR-SUPPORTED-PRED-TYPES .TYP>)>
+
+
+
+
+;"DIR-PRINT-CH creates a list containing the keyword PRINTING and
+ the max number of characters required to print a function value.
+ Production: number PRINTING CHARS "
+
+<DEFINE DIR-PRINT-CH (NUM X Y)
+ #DECL ((NUM) FIX)
+ (PRINTING .NUM)>
+
+
+
+
+
+;"DIR-PRINT-DB pretty prints a database or view.
+ Production: PRINT DATABASE identifier ; "
+
+<DEFINE DIR-PRINT-DB (X Y DNAME Z "AUX" (I 0))
+ #DECL ((DNAME) IDENTIFIER (I) FIX)
+ <COND (<MAPF <>
+ <FUNCTION (V)
+ #DECL ((V) VIEW)
+ <SET I <+ .I 1>>
+ <COND (<==? <V-NAME .V> <ID-NAME .DNAME>>
+ <PP-DATABASE .I>
+ <MAPLEAVE>)>>
+ ,VIEW-TAB>)
+ (<ERR <STRING "Database or view " <SPNAME <ID-NAME .DNAME>>
+ " is undefined.">>)>>
+
+
+
+
+
+;"DIR-PRINT-DBMS pretty prints a DBMS table entry.
+ Production: PRINT DBMS identifier ; "
+
+<DEFINE DIR-PRINT-DBMS (X Y SYS-NAME Z)
+ #DECL ((SYS-NAME) IDENTIFIER)
+ <COND (<MAPF <>
+ <FUNCTION (D)
+ #DECL ((D) DBMS)
+ <COND (<==? <DB-SCHEMA-NAME .D> <ID-NAME .SYS-NAME>>
+ <PP-DBMS .D>
+ <MAPLEAVE>)>>
+ ,DBMS-TAB>)
+ (<ERR <STRING "DBMS " <SPNAME <ID-NAME .SYS-NAME>>
+ " is undefined.">>)>>
+
+
+
+
+;"\f"
+;"DIR-PRINT-DIR pretty prints the schema directory.
+ Production: PRINT DIRECTORY ; "
+
+<DEFINE DIR-PRINT-DIR (X Y Z)
+ <PP-DIR>
+ <>> ;"Return false to skip context analysis"
+
+
+
+
+
+;"DIR-PRINT-ET prints an entity type table entry. Note that only
+ the current view context is searched.
+ Production: PRINT ENTITY TYPE identifier ; "
+
+<DEFINE DIR-PRINT-ET (W X Y ENAME Z)
+ #DECL ((ENAME) IDENTIFIER)
+ <COND (<FIND-ENTITY-TYPE .ENAME>
+ <PP-ENTITY-TYPE <<ID-ETID .ENAME> ,ET-TABLE>>)>>
+
+
+
+
+;"\f"
+;"DIR-QPRED-OPTN returns the quantified predicate optins.
+ Production: WITHIN QUANTIFIED PREDICATES predicate_option_list "
+
+<DEFINE DIR-QPRED-OPTN (X Y Z OPTN)
+ #DECL ( (OPTN) LIST)
+ (QPRED-OPTN .OPTN)>
+;"\f"
+;"DIR-RANGE-ENTITY creates a default ENTITY-FUNC vector for a
+ function whose range is entity. Elements in the vector may
+ be changed as more is learned about the function.
+ Production: entity_name "
+
+<DEFINE DIR-RANGE-ENTITY (E)
+ #DECL ((E) IDENTIFIER)
+ <CHTYPE [<> F-ENTITY F-SV <ID-NAME .E> <> <> <>] ENTITY-FUNC>>
+
+
+
+
+;"DIR-RANGE-INTEGER creates a default ENTITY-FUNC vector for a
+ function whose range is integer. Elements in the vector may
+ be changed as more is learned about the function.
+ Production: INTEGER "
+
+<DEFINE DIR-RANGE-INTEGER (X)
+ <CHTYPE <VECTOR <> F-INTEGER F-SV -34359738366 34359738367 <> <>>
+ ENTITY-FUNC>>
+
+
+
+;"DIR-RANGE-STR creates a default ENTITY-FUNC vector for a
+ function whose range is string. Elements in the vector may
+ be changed as more is learned about the function.
+ Production: STRING ( number_characters ) "
+
+<DEFINE DIR-RANGE-STR (X Y MIN-MAX Z)
+ #DECL ((MIN-MAX) LIST)
+ <CHTYPE [<> F-STRING F-SV <1 .MIN-MAX> <2 .MIN-MAX> <> <>]
+ ENTITY-FUNC>>
+
+
+
+
+;"DIR-READ-DIR reads the schema directory from disk.
+ (24-jun-81) Note that reading the directory with READ-DIRECTORY
+ is, in fact, useless because the atoms ET-TABLE, etc. which all
+ of Multibase uses are not rebound. The directory must be read
+ using INITIALIZE-DIRECTORY, which not only reads the directory,
+ but also rebinds these atoms.
+ Production: READ DIRECTORY ; "
+
+<DEFINE DIR-READ-DIR (X Y Z) <INITIALIZE-DIRECTORY>>
+<DEFINE DIR-READ-DIR-FILE (X Y FILE Z "AUX" ANS)
+ #DECL ((FILE) STRING (ANS) <OR ATOM FALSE>)
+ <COND (<SET ANS <FILE-EXISTS? .FILE>>
+ <SETG DIRECTORY-FILE-NAME .FILE>
+ <INITIALIZE-DIRECTORY>)
+ (ELSE
+ <ERR "File does not exist: " <1 .ANS>>
+ <>)>
+>
+
+
+
+
+;"DIR-REMOTE-LDI builds an LDI-DATA vector containing information
+ about a remote LDI.
+ Production: REMOTE host socket "
+
+<DEFINE DIR-REMOTE-LDI (X HOST SOCKET)
+ #DECL ((HOST) IDENTIFIER (SOCKET) FIX)
+ <CHTYPE [ <>
+ <>
+ <ID-NAME .HOST>
+ .SOCKET ] LDI-DATA>>
+
+
+
+
+;"DIR-REPEAT-GRP creates a list containing the keyword REPEAT.
+ Production: REPEATING GROUP "
+
+<DEFINE DIR-REPEAT-GRP (X Y)
+ '(REPEAT)>
+
+
+
+;"\f"
+
+
+;"DIR-SET creates a list containing the keyword SET.
+ Production: SET "
+
+<DEFINE DIR-SET (X)
+ '(SET)>
+
+
+
+
+;"DIR-SET-OF changes the range of a function to be multi-valued.
+ Production: SET OF range_type "
+
+<DEFINE DIR-SET-OF (X Y F)
+ #DECL ((F) ENTITY-FUNC)
+ <PUT .F ,F-RANGE F-MV>>
+
+
+
+;"DIR-SPELLED creates a list with the keyword SPELLED and a
+ string.
+ Production: SPELLED character_string ; "
+
+<DEFINE DIR-SPELLED (X STR "OPT" (Z <>))
+ #DECL ((STR) STRING)
+ (SPELLED .STR)>
+
+
+;"Production: WHEN SPELLED string ; "
+
+<DEFINE DIR-SPELLED-2 (X Y STR "OPT" (Z <>))
+ #DECL ((STR) STRING)
+ (SPELLED .STR)>
+
+
+
+
+
+ ;"Production: CONTAIN entity_name IN entity-list ; "
+
+<DEFINE DIR-SUPERTYPE (X ID Y EL Z)
+ #DECL ((EL) LIST (ID) IDENTIFIER)
+ <CHTYPE [.ID .EL] CONTAIN>
+>
+
+
+
+;"\f"
+;"DIR-SUPPORTED-AOPS creates a vector describing the arithmetic operations
+ supported by a dbms.
+ Production: SUPPORTED ARITHMETIC OPERATIONS supported_arith_list ; "
+
+<DEFINE DIR-SUPPORTED-AOPS (X Y Z AOP-LIST "OPT" S)
+ #DECL ( (AOP-LIST) LIST)
+ <CHTYPE [ <IN-LIST? '(ALL) .AOP-LIST>
+ <IN-LIST? '(+) .AOP-LIST>
+ <IN-LIST? '(-) .AOP-LIST>
+ <IN-LIST? '(*) .AOP-LIST>
+ <IN-LIST? '(/) .AOP-LIST>
+ <IN-LIST? '(&) .AOP-LIST>
+ ] ARITHMETIC-OPS>
+>
+
+
+;"DIR-SUPPORTED-COPS creates a vector describing compare operations
+ supported by a DBMS.
+ Production: SUPPORTED COMPARE OPERATIONS supported_comp_list ; "
+
+<DEFINE DIR-SUPPORTED-COPS (X Y Z COP-LIST)
+ #DECL ((COP-LIST) LIST)
+ <CHTYPE [ <IN-LIST? '(ALL) .COP-LIST>
+ <IN-LIST? '(CONSTANT) .COP-LIST>
+ <IN-LIST? '(FIELD) .COP-LIST>
+ <IN-LIST? '(EXPRESSION) .COP-LIST> ] COMPARE-OPS>>
+
+
+
+
+;"DIR-SUPPORTED-DOPS creates a vector describing display operations
+ supported by a DBMS.
+ Production: SUPPORTED DISPLAY OPERATIONS supported_comp_list ; "
+
+<DEFINE DIR-SUPPORTED-DOPS (X Y Z COP-LIST)
+ #DECL ((COP-LIST) LIST)
+ <CHTYPE [ <IN-LIST? '(ALL) .COP-LIST>
+ <IN-LIST? '(CONSTANT) .COP-LIST>
+ <IN-LIST? '(FIELD) .COP-LIST>
+ <IN-LIST? '(EXPRESSION) .COP-LIST> ] DISPLAY-OPS>>
+
+
+
+
+;"DIR-SUPPORTED-EOPS creates a description of the existential logical
+ operations supported by a dbms.
+ Production: SUPPORTED EXISTENTIAL OPERATIONS supported_log_list "
+
+<DEFINE DIR-SUPPORTED-EOPS (X Y Z LOP-LIST)
+ #DECL ( (LOP-LIST) LIST)
+ (EXIST-OPS <DIR-SUPPORTED-LOPS X Y Z .LOP-LIST>)>
+
+
+
+
+;"DIR-SUPPORTED-FOPS creates a vector describing FIND verbs supported
+ by a CODASYL DBMS.
+ Production: SUPPORTED FIND VERBS supported_find_list "
+
+<DEFINE DIR-SUPPORTED-FOPS (X Y Z FOP-LIST)
+ #DECL ((FOP-LIST) LIST)
+ <CHTYPE [ <IN-LIST? '(FIND-KEY) .FOP-LIST>
+ <IN-LIST? '(FIND-CUR) .FOP-LIST>
+ <IN-LIST? '(FIND-POS) .FOP-LIST>
+ <IN-LIST? '(FIND-OWN) .FOP-LIST>
+ <IN-LIST? '(FIND-CALC) .FOP-LIST>
+ <IN-LIST? '(FIND-USE-CUR) .FOP-LIST>
+ <IN-LIST? '(FIND-USE-NCUR) .FOP-LIST>
+ ] FIND-OPS>>
+
+
+
+
+;"DIR-SUPPORTED-GOPS creates a vector describing global
+ optimizations supported by a DBMS.
+ Production: SUPPORTED GLOBAL OPTIMIZATIONS global_optimization_list "
+
+<DEFINE DIR-SUPPORTED-GOPS (X Y Z GOP-LIST)
+ #DECL ((GOP-LIST) LIST)
+ <CHTYPE [ <IN-LIST? '(ALL) .GOP-LIST>
+ <IN-LIST? '(CREATE) .GOP-LIST>
+ <IN-LIST? '(REFERENCE) .GOP-LIST> ] GLOBAL-OPS>>
+
+
+
+
+;"DIR-SUPPORTED-LOPS creates a vector describing logical
+ operations supported by a DBMS.
+ Production: SUPPORTED LOGICAL OPERATIONS supported_log_list "
+
+<DEFINE DIR-SUPPORTED-LOPS (X Y Z LOP-LIST)
+ #DECL ((LOP-LIST) LIST)
+ <CHTYPE [ <IN-LIST? '(ALL) .LOP-LIST>
+ <IN-LIST? '(AND) .LOP-LIST>
+ <IN-LIST? '(NOT) .LOP-LIST>
+ <IN-LIST? '(OR) .LOP-LIST>
+ ] LOGICAL-OPS>>
+
+
+
+
+;"DIR-SUPPORTED-PRED-TYPES is an internal entry to decode allowable
+ predicate types."
+
+<DEFINE DIR-SUPPORTED-PRED-TYPES (TYP)
+ #DECL ((TYP) LIST)
+ <CHTYPE [ <IN-LIST? '(ALL) .TYP>
+ <IN-LIST? '(NO) .TYP>
+ <IN-LIST? '(QUANTIFIED) .TYP>
+ <IN-LIST? '(NON_QUANTIFIED) .TYP>
+ ] PREDICATE-TYPES>>
+
+
+
+
+;"DIR-SUPPORTED-QOPS creates a vector describing the quantificatin operations
+ supported by the dbms.
+ Productin: SUPPORTED QUANTIFIED RELATIONS supported_quant_list "
+
+<DEFINE DIR-SUPPORTED-QOPS (X Y Z QOP-LIST)
+ #DECL ( (QOP-LIST) LIST)
+ <CHTYPE [ <IN-LIST? '(ALL) .QOP-LIST>
+ <IN-LIST? '(NESTED) .QOP-LIST>
+ <IN-LIST? '(PARALLEL) .QOP-LIST>
+ ] QUANTIFIED-OPS>
+>
+
+
+
+
+;"DIR-SUPPORTED-QNTS creates a vector describing the quantificatin operations
+ supported by the dbms.
+ Productin: SUPPORTED QUANTIFIERS supported_qnt_list "
+
+<DEFINE DIR-SUPPORTED-QNTS (X Y QOP-LIST)
+ #DECL ( (QOP-LIST) LIST)
+ <CHTYPE [ <IN-LIST? '(ALL) .QOP-LIST>
+ <IN-LIST? '(SOME) .QOP-LIST>
+ <IN-LIST? '(EVERY) .QOP-LIST>
+ <IN-LIST? '(NO) .QOP-LIST>
+ ] QUANTIFIERS-OPS>
+>
+
+
+
+
+;"DIR-SUPPORTED-ROPS creates a vector describing relational
+ operations supported by a DBMS.
+ Production: SUPPORTED RELATIONAL OPERATIONS supported_rel_list "
+
+<DEFINE DIR-SUPPORTED-ROPS (X Y Z ROP-LIST "OPT" S)
+ #DECL ((ROP-LIST) LIST)
+ <CHTYPE [ <IN-LIST? '(ALL) .ROP-LIST>
+ <IN-LIST? '(\>) .ROP-LIST>
+ <IN-LIST? '(\<) .ROP-LIST>
+ <IN-LIST? '(\<=) .ROP-LIST>
+ <IN-LIST? '(\>=) .ROP-LIST>
+ <IN-LIST? '(/=) .ROP-LIST>
+ <IN-LIST? '(=) .ROP-LIST>
+ <IN-LIST? '(AC) .ROP-LIST>
+ <IN-LIST? '(ISIN) .ROP-LIST>
+ ] RELATIONAL-OPS>>
+
+
+
+
+;"\f"
+;"DIR-SYS-EP creates a list containing the keyword SYS-EP.
+ Production: SYSTEM ENTRY POINT ; "
+
+<DEFINE DIR-SYS-EP (W X Y Z)
+ (SYS-EP ())>
+
+
+
+
+;"DIR-SYS-EP-ACCESS creates a list containing the keyword ACCESS.
+ Productin: BY ACCESS PATH ONLY ; "
+
+<DEFINE DIR-SYS-EP-ACCESS (V W X Y Z)
+ (ACCESS)>
+
+
+
+;"DIR-SYS-EP-KEYS returns a list of key values to be used in
+ iterating over a system-entry point.
+ Productin: ITERATE USING KEYS key_list ; "
+
+<DEFINE DIR-SYS-EP-KEYS (W X Y KEYLIST Z)
+ #DECL ( (KEYLIST) LIST)
+ (KEYS <CHTYPE .KEYLIST KEY-LIST>)>
+
+
+
+
+;"DIR-SYS-EP-OPTN creates a list containing the keyword SYS-EP and
+ a list of options describing the system entry point.
+ Production: SYSTEM ENTRY POINT sys_ep_clause "
+
+<DEFINE DIR-SYS-EP-OPTN (W X Y OPTN)
+ #DECL ((OPTN) LIST)
+ (SYS-EP .OPTN)>
+
+
+
+
+;"DIR-SYS-EP-SET passes the system set name for a system entry point
+ Productin: VIA character_string ; "
+
+<DEFINE DIR-SYS-EP-SET (Y SET-NAME Z)
+ #DECL ( (SET-NAME) STRING)
+ (SETNAME .SET-NAME)>
+
+
+
+
+;"\f"
+;"DIR-VIEW-DEF changes the structure created by parsing a view
+ definition command into a vector of type VIEW-DEF.
+ Production: view_definition "
+
+<DEFINE DIR-VIEW-DEF (STRUCT)
+ #DECL ((STRUCT) VECTOR)
+ <CHTYPE [.STRUCT] VIEW-DEF>>
+
+
+
+
+
+;"DIR-VISIBLE processes the visible part of a view or database definition.
+ A vector is created containing the view/db name, a slot that will be
+ filled in later with the name specified on the END statement, the
+ list of entity definitions, no constraints and a slot that may be
+ filled in later with mapping info.
+ Production: identifier IS group_of_entities "
+
+<DEFINE DIR-VISIBLE (DB-NAME X EL)
+ #DECL ((DB-NAME) IDENTIFIER (EL) LIST)
+ [<ID-NAME .DB-NAME> <> .EL <> <>]>
+
+
+
+;"DIR-VISIBLE-CONSTRAINTS is just like DIR-VISIBLE except that a
+ list of constraints is added to the vector.
+ Production: identifier IS group_of_entities constraint_list "
+
+<DEFINE DIR-VISIBLE-CONSTRAINTS (DB-NAME X EL CL)
+ #DECL ((DB-NAME) IDENTIFIER (EL CL) LIST)
+ [<ID-NAME .DB-NAME> <> .EL <> .CL]>
+
+
+
+
+
+;"DIR-WRITE-DIR copies the schema directory to disk.
+ Production: WRITE DIRECTORY ; "
+
+<DEFINE DIR-WRITE-DIR (X Y Z) <WRITE-DIRECTORY>>
+
+
+<DEFINE DIR-WRITE-DIR-FILE (X Y FILE Z)
+ #DECL ((FILE) STRING)
+ <SETG DIRECTORY-FILE-NAME .FILE>
+ <WRITE-DIRECTORY>>
+"\f"
+;"FIND-ETID is used to lookup a given entity type name in a vector
+ of ENTITY-TYPEs. Returns the entity types ETID or false."
+
+<DEFINE FIND-ETID (EV ENAME)
+ #DECL ((EV) VECTOR (ENAME) ATOM)
+ <MAPF <>
+ <FUNCTION (E)
+ #DECL ((E) <OR FALSE ENTITY-TYPE>)
+ <COND (.E
+ <COND (<==? <ET-NAME .E> .ENAME>
+ <MAPLEAVE <ET-ETID .E>>)>)>>
+ .EV>>
+
+
+
+
+;"FIND-FID is used to lookup a given function name in a vector
+ of ENTITY-FUNCs. Returns the function's FID or false."
+
+<DEFINE FIND-FID (FV FNAME "AUX" (I 0))
+ #DECL ((FV) VECTOR (FNAME) ATOM (I) FIX)
+ <MAPF <>
+ <FUNCTION (F)
+ #DECL ((F) ENTITY-FUNC)
+ <SET I <+ .I 1>>
+ <COND (<==? <F-NAME .F> .FNAME>
+ <MAPLEAVE .I>)>>
+ .FV>>
+"\f"
+;"Pretty print routines for directory data structures"
+
+;"PP-DATABASE pretty prints all entity types in a database or view."
+
+<DEFINE PP-DATABASE (VID)
+ #DECL ((VID) FIX)
+ <MAPF <>
+ <FUNCTION (E)
+ #DECL ((E) ENTITY-TYPE)
+ <COND (<==? <ET-VID .E> .VID>
+ <PP-ENTITY-TYPE .E>)>>
+ ,ET-TABLE>>
+;"\f"
+;"PP-DBMS prints one entry in the DBMS-TABLE."
+
+<DEFINE PP-DBMS (D "AUX" GOP DOP FOP (L <DB-LDI-DATA .D>)
+ (O <DB-OPTIONS .D>))
+ #DECL ((D) DBMS (L) LDI-DATA (O) <OR DBMS-OPTIONS FALSE>
+ (GOP) <OR GLOBAL-OPS FALSE>
+ (DOP) <OR DISPLAY-OPS FALSE>
+ (FOP) <OR FIND-OPS FALSE>)
+ <TPRINC "Schema name: "> <PRINC <DB-SCHEMA-NAME .D>> <CRLF>
+ <TPRINC "DB system name: "> <PRINC <DB-SYS-NAME .D>> <CRLF>
+ <TPRINC "DB type: "> <PRINC <DB-SYS-TYPE .D>> <CRLF>
+ <TPRINC "Host: "> <PRINC <DB-HOST .D>> <CRLF>
+ <TPRINC "LDI procedure name: ">
+ <PRIN1 <LDI-PROC-NAME .L>>
+ <CRLF>
+ <COND (<LDI-LOCAL .L>
+ <TTPRINC "LDI is local">
+ <CRLF>)
+ (ELSE
+ <TTPRINC "LDI is remote host/socket: ">
+ <PRINC <LDI-HOST-NAME .L>>
+ <PRINC " ">
+ <PRINC <LDI-SOCKET .L>>
+ <CRLF>)>
+ <COND (.O
+ <SET GOP <DB-GLOBAL-OPS .O>>
+ <SET FOP <DB-FIND-OPS .O>>
+ <SET DOP <DB-DISPLAY-OPS .O>>
+ <COND (.DOP
+ <TPRINC "Supported display operations: ">
+ <COND (<DOP-ALL .DOP>
+ <PRINC "ALL ">)>
+ <COND (<DOP-CONSTANT .DOP>
+ <PRINC "CONSTANT ">)>
+ <COND (<DOP-FIELD .DOP>
+ <PRINC "FIELD ">)>
+ <COND (<DOP-EXP .DOP>
+ <PRINC "EXP">)>
+ <CRLF>)>
+ <COND (.GOP
+ <TPRINC "Supported global optimizations: ">
+ <COND (<GOP-ALL .GOP>
+ <PRINC "ALL ">)>
+ <COND (<GOP-TEMP-FILE .GOP>
+ <PRINC "TEMPORARY-FILES ">)>
+ <COND (<GOP-EXTERN-FILE .GOP>
+ <PRINC "EXTERNAL-FILES ">)>
+ <CRLF>)>
+ <COND (.FOP
+ <TPRINC "Supported find verbs: ">
+ <COND (<FOP-KEY .FOP>
+ <PRINC "DB_KEY ">)>
+ <COND (<FOP-CURRENT .FOP>
+ <PRINC "CURRENT ">)>
+ <COND (<FOP-POSITIONAL .FOP>
+ <PRINC "POSITIONAL ">)>
+ <COND (<FOP-OWNER .FOP>
+ <PRINC "OWNER ">)>
+ <COND (<FOP-CALC .FOP>
+ <PRINC "CALC ">)>
+ <COND (<FOP-USE-CUR .FOP>
+ <PRINC "USING_CURRENT ">)>
+ <COND (<FOP-USE-NON-CUR .FOP>
+ <PRINC "USING_NON_CURRENT ">)>
+ <CRLF>)>
+ <TPRINC "Max quantified predicates: ">
+ <PRINC <DB-MAX-QUANT-ITER .O>> <CRLF>
+ <TPRINC "Max non-quantified predicates: ">
+ <PRINC <DB-MAX-NON-QUANT-ITER .O>> <CRLF>
+ <TPRINC "Max quantified relations: ">
+ <PRINC <DB-MAX-QUANT-REL .O>> <CRLF>
+ <COND (<DB-STRICT-NESTING-ONLY .O>
+ <TPRINC "Strict nesting of entities required">
+ <CRLF>)>
+ <COND (<DB-MULTIPLE-ITER .O>
+ <TPRINC "Multiple iterations over entity supported">
+ <CRLF>)>
+ <COND (<DB-RESTRICT-PROP .O>
+ <TPRINC "Restrictions propagate to all occurrences">
+ <CRLF>)>
+ <TPRINC "In non-quantified predicates --"> <CRLF>
+ <PP-DBMS-PRED
+ <DB-ARITH-OPS .O> <DB-COMPARE-OPS .O>
+ <DB-EXIST-OPS .O> <DB-LOG-OPS .O>
+ <DB-QUANT-REL .O> <DB-REL-OPS .O>
+ <DB-AP-REQUIRED .O> <DB-AP-ONLY .O>
+ >
+ <CRLF>
+ <TPRINC "In quantified predicates --"> <CRLF>
+ <PP-DBMS-PRED
+ <DB-QP-ARITH-OPS .O> <DB-QP-COMPARE-OPS .O>
+ <DB-QP-EXIST-OPS .O> <DB-QP-LOG-OPS .O>
+ <DB-QP-QUANT-REL .O> <DB-QP-REL-OPS .O>
+ <DB-QP-AP-REQUIRED .O> <DB-QP-AP-ONLY .O>
+ >
+ <CRLF>
+ <TPRINC "Default integer bit size: ">
+ <PRINC <DB-DEF-INT-BITS .O>> <CRLF>
+ <TPRINC "Default integer representation: ">
+ <PRINC <DB-DEF-INT-REP .O>> <CRLF>
+ <TPRINC "Default character bit size: ">
+ <PRINC <DB-DEF-STR-BITS .O>> <CRLF>
+ <TPRINC "Default character representation: ">
+ <PRINC <DB-DEF-STR-REP .O>> <CRLF>)>>
+;"\f"
+<DEFINE PP-DBMS-PRED (AOP COP EOP LOP QUAN ROP AP-R AP-O)
+ #DECL ( (AOP) <OR ARITHMETIC-OPS FALSE>
+ (COP) <OR COMPARE-OPS FALSE>
+ (EOP LOP) <OR LOGICAL-OPS FALSE>
+ (QUAN) <OR QUANTIFIED-OPS FALSE>
+ (REL) <OR RELATIONAL-OPS FALSE>
+ (AP-R AP-O) <OR ATOM FALSE>
+ )
+ <COND (.AP-R
+ <TPRINC "Access path usage required"> <CRLF>)>
+ <COND (.AP-O
+ <TPRINC "Use access paths only"> <CRLF>)>
+ <COND (.AOP
+ <TPRINC "Supported arithmetic operations: ">
+ <COND (<AOP-ALL .AOP>
+ <PRINC "ALL ">)>
+ <COND (<AOP-PLUS .AOP>
+ <PRINC "PLUS ">)>
+ <COND (<AOP-MINUS .AOP>
+ <PRINC "MINUS ">)>
+ <COND (<AOP-MULTIPLY .AOP>
+ <PRINC "MULTIPLY ">)>
+ <COND (<AOP-DIVIDE .AOP>
+ <PRINC "DIVIDE ">)>
+ <COND (<AOP-CONCAT .AOP>
+ <PRINC "CONCATENATE ">)>
+ <CRLF>)>
+ <COND (.ROP
+ <TPRINC "Supported relational operations: ">
+ <COND (<ROP-ALL .ROP>
+ <PRINC "ALL ">)>
+ <COND (<ROP-GT .ROP>
+ <PRINC "GT ">)>
+ <COND (<ROP-LT .ROP>
+ <PRINC "LT ">)>
+ <COND (<ROP-LE .ROP>
+ <PRINC "LE ">)>
+ <COND (<ROP-GE .ROP>
+ <PRINC "GE ">)>
+ <COND (<ROP-NE .ROP>
+ <PRINC "NE ">)>
+ <COND (<ROP-EQ .ROP>
+ <PRINC "EQ ">)>
+ <COND (<ROP-AC .ROP>
+ <PRINC "ALPHA-COLLATE ">)>
+ <COND (<ROP-ISIN .ROP>
+ <PRINC "ISIN ">)>
+ <CRLF>)>
+ <COND (.LOP
+ <TPRINC "Supported logical operations: ">
+ <COND (<LOP-ALL .LOP>
+ <PRINC "ALL ">)>
+ <COND (<LOP-AND .LOP>
+ <PRINC "AND ">)>
+ <COND (<LOP-NOT .LOP>
+ <PRINC "NOT ">)>
+ <COND (<LOP-OR .LOP>
+ <PRINC "OR ">)>
+ <CRLF>)>
+ <COND (.EOP
+ <TPRINC "Supported existential logical operations: ">
+ <COND (<LOP-ALL .EOP>
+ <PRINC "ALL ">)>
+ <COND (<LOP-AND .EOP>
+ <PRINC "AND ">)>
+ <COND (<LOP-NOT .EOP>
+ <PRINC "NOT ">)>
+ <COND (<LOP-OR .EOP>
+ <PRINC "OR ">)>
+ <CRLF>)>
+ <COND (.COP
+ <TPRINC "Supported compare operations: ">
+ <COND (<COP-ALL .COP>
+ <PRINC "ALL ">)>
+ <COND (<COP-CONSTANT .COP>
+ <PRINC "CONSTANT ">)>
+ <COND (<COP-FIELD .COP>
+ <PRINC "FIELD ">)>
+ <COND (<COP-EXP .COP>
+ <PRINC "EXP">)>
+ <CRLF>)>
+ <COND (.QUAN
+ <TPRINC "Supported quantified relations: ">
+ <COND (<QOP-ALL .QUAN>
+ <PRINC "ALL ">)>
+ <COND (<QOP-NESTED .QUAN>
+ <PRINC "NESTED ">)>
+ <COND (<QOP-PARALLEL .QUAN>
+ <PRINC "PARALLEL ">)>
+ <CRLF>)>
+>
+;"\f"
+;"PP-DBMS-TABLE pretty prints the DBMS-TABLE."
+
+<DEFINE PP-DBMS-TABLE (DT "AUX" (I 0))
+ #DECL ((DT) VECTOR (I) FIX)
+ <CRLF> <PRINC "DBMS Table: "> <CRLF>
+ <MAPF <>
+ <FUNCTION (D)
+ <SET I <+ .I 1>>
+ <COND (.D
+ <PRINC " (">
+ <PRINC .I>
+ <PRINC ")">
+ <PP-DBMS .D>
+ <CRLF>)>>
+ .DT>>
+;"\f"
+;"PP-DIR pretty prints the entire schema directory."
+
+<DEFINE PP-DIR ("AUX" V E D)
+ #DECL ((V E D) <OR VECTOR FALSE>)
+ <COND (<NOT <GASSIGNED? SCHEMA-DIR>>
+ <INITIALIZE-DIRECTORY>)>
+ <SET V <VIEW-TABLE ,SCHEMA-DIR>>
+ <SET E <ENTITY-TYPE-TABLE ,SCHEMA-DIR>>
+ <SET D <DBMS-TABLE ,SCHEMA-DIR>>
+ <CRLF> <PRINC " *** Schema Directory ***"> <CRLF>
+ <COND (<AND .V
+ <NOT <EMPTY? .V>>>
+ <PP-VIEW-TABLE .V> <CRLF>)
+ (ELSE
+ <PRINC "View table is empty"> <CRLF>)>
+ <COND (<AND .E
+ <NOT <EMPTY? .E>>>
+ <PP-ENTITY-TYPE-TABLE .E> <CRLF>)
+ (ELSE
+ <PRINC "Entity Type table is empty"> <CRLF>)>
+ <COND (<AND .D
+ <NOT <EMPTY? .D>>>
+ <PP-DBMS-TABLE .D> <CRLF>)
+ (ELSE
+ <PRINC "DBMS table is empty"> <CRLF>)>>
+;"\f"
+<DEFINE PP-ENTITY-PRED (TYP)
+ #DECL ( (TYP) PREDICATE-TYPES)
+ <COND (<PT-ALL .TYP>
+ <PRINC "ALL ">)>
+ <COND (<PT-NO .TYP>
+ <PRINC "NO ">)>
+ <COND (<PT-QUANT .TYP>
+ <PRINC "QUANTIFIED ">)>
+ <COND (<PT-NON-QUANT .TYP>
+ <PRINC "NON-QUANTIFIED ">)>
+>
+;"\f"
+;"PP-ENTITY-TYPE pretty prints an entry in the ENTITY-TYPE-TABLE."
+
+<DEFINE PP-ENTITY-TYPE (E "AUX" (F <ET-FUNCTIONS .E>) M)
+ #DECL ((E) ENTITY-TYPE (F) VECTOR (M) <OR E-PHY-REP FALSE>)
+ <TPRINC "Entity type name: "> <PRINC <ET-NAME .E>> <CRLF>
+ <TPRINC "ETID: "> <PRINC <ET-ETID .E>> <CRLF>
+ <TPRINC "VID: "> <PRINC <ET-VID .E>> <CRLF>
+ <TPRINC "Supertypes: ">
+ <PLIST <CHTYPE <ET-SUPERTYPES .E> LIST>>
+ <CRLF>
+ <TPRINC "Subtypes: ">
+ <PLIST <CHTYPE <ET-SUBTYPES .E> LIST>>
+ <CRLF>
+ <TPRINC "Cotypes: ">
+ <PLIST <CHTYPE <ET-COTYPES .E> LIST>>
+ <CRLF>
+ <TPRINC "Map type: "> <PRINC <ET-MAP-TYPE .E>> <CRLF>
+ <TPRINC "Map info: "> <CRLF>
+ <SET M <ET-MAP-INFO .E>>
+ <COND (<TYPE? .M E-PHY-REP>
+ <TTPRINC "Spelled: "> <PRIN1 <E-SPELLING .M>> <CRLF>
+ <TTPRINC "DBMS id: "> <PRINC <E-DBMS-ID .M>> <CRLF>
+ <TTPRINC "System entry point: "> <PRINC <E-SYS-EP .M>> <CRLF>
+ <COND (<E-SYS-EP-AP-ONLY .M>
+ <TTPRINC "System entry point by access path only">
+ <CRLF>)>
+ <TTPRINC "Context: "> <PRIN1 <E-CONTEXT .M>> <CRLF>
+ <TTPRINC "Owners: "> <PLIST <CHTYPE <E-OWNERS .M> LIST>> <CRLF>
+ <TTPRINC "# Fast access paths via equality: ">
+ <PRINC <E-AP-EQ-COUNT .M>> <CRLF>
+ <COND (<E-AREAS .M>
+ <TTPRINC "Areas: "> <PLIST <CHTYPE <E-AREAS .M> LIST>>
+ <CRLF>)>
+ <COND (<E-SYS-SET .M>
+ <TTPRINC "System owned set: "> <PRIN1 <E-SYS-SET .M>>
+ <CRLF>)>
+ <COND (<E-SYS-EP-KEYS .M>
+ <TTPRINC "Iterate using keys: ">
+ <PLIST <CHTYPE <E-SYS-EP-KEYS .M> LIST>>
+ <CRLF>)>
+ <COND (<E-ITER-PRED .M>
+ <TTPRINC "When domain of iteration, may use ">
+ <PP-ENTITY-PRED <E-ITER-PRED .M>>
+ <PRINC "predicates">
+ <CRLF>)>
+ <COND (<E-QUANT-PRED .M>
+ <TTPRINC "When domain of quantification, may use ">
+ <PP-ENTITY-PRED <E-QUANT-PRED .M>>
+ <PRINC "predicates">
+ <CRLF>)>
+ <COND (<E-NO-QUANT .M>
+ <TTPRINC "May not be domain of quantified expression">
+ <CRLF>)>
+ <COND (<E-KEY .M>
+ <COND (<EMPTY? <E-KEY .M>>
+ <TTPRINC "Entity key is database_key.">)
+ (ELSE
+ <TTPRINC "Entity key uses functions: ">
+ <PLIST <CHTYPE <E-KEY .M> LIST>>)>)
+ (ELSE
+ <TTPRINC "Entity key is undefined.">)>
+ <CRLF>
+ )>
+ <TPRINC "Functions:"> <CRLF> <PP-FUNC-TABLE .F>>
+;"\f"
+;"PP-ENTITY-TYPE-TABLE pretty prints the ENTITY-TYPE-TABLE."
+
+<DEFINE PP-ENTITY-TYPE-TABLE (ET "AUX" (I 0))
+ #DECL ((ET) VECTOR (I) FIX)
+ <PRINC "Entity Type Table:"> <CRLF>
+ <MAPF <>
+ <FUNCTION (E)
+ <SET I <+ .I 1>>
+ <COND (.E
+ <PRINC " (">
+ <PRINC .I>
+ <PRINC ")">
+ <PP-ENTITY-TYPE .E>)>>
+ .ET>>
+;"\f"
+;"PP-FUNC-TABLE pretty prints an entity type's functions."
+
+<DEFINE PP-FUNC-TABLE (FT "AUX" (I 0) M)
+ #DECL ((FT) VECTOR (I) FIX (M) <OR F-PHY-REP FALSE>)
+ <MAPF <>
+ <FUNCTION (F)
+ <SET I <+ .I 1>>
+ <COND (.F
+ <TPRINC "(">
+ <PRINC .I>
+ <PRINC ")">
+ <TPRINC "Name: "> <PRINC <F-NAME .F>> <CRLF>
+ <TTPRINC "Type: "> <PRINC <F-TYPE .F>> <CRLF>
+ <TTPRINC "Range: "> <PRINC <F-RANGE .F>> <CRLF>
+ <TTPRINC "Min or ETID: ">
+ <PRINC <F-MIN .F>> <CRLF>
+ <TTPRINC "Max: "> <PRINC <F-MAX .F>> <CRLF>
+ <TTPRINC "Map type: "> <PRINC <F-MAP-TYPE .F>>
+ <CRLF>
+ <TTPRINC "Map info:"> <CRLF>
+ <SET M <F-MAP-INFO .F>>
+ <COND (<TYPE? .M F-PHY-REP>
+ <TTTPRINC "Spelled: ">
+ <PRIN1 <F-SPELLING .M>> <CRLF>
+ <COND (<OR <F-AP-EQ .M>
+ <F-AP-NQ .M>
+ <F-AP-RANGE .M>>
+ <TTTPRINC "Access path: ">
+ <COND (<F-AP-EQ .M>
+ <PRINC "EQ ">)>
+ <COND (<F-AP-NQ .M>
+ <PRINC "NQ ">)>
+ <COND (<F-AP-RANGE .M>
+ <PRINC "RANGE ">)>
+ <PRINC " when spelled ">
+ <PRIN1 <F-AP-SPELLING .M>>
+ <CRLF>
+ )>
+ <COND (<F-AP-UNIQUE .M>
+ <TTTPRINC "CALC keys are unique">
+ <CRLF>)>
+ <COND (<F-AP-CO-FCNS .M>
+ <TTTPRINC "Access path co-functions: ">
+ <PLIST <CHTYPE <F-AP-CO-FCNS .M> LIST>>
+ <CRLF>)>
+ <COND (<F-AP-SELECTS .M>
+ <TTTPRINC "Access path selects entity: ">
+ <PRINC <F-AP-SELECTS .M>>
+ <CRLF>)>
+ <COND (<OR <==? <F-TYPE .F> F-INTEGER>
+ <==? <F-TYPE .F> F-STRING>>
+ <COND (<F-INT-STR .M>
+ <TTTPRINC "Stored as character string"> <CRLF>)>
+ <TTTPRINC "Characters to print: ">
+ <PRINC <F-CONV-CHARS .M>> <CRLF>)>
+ <COND (<OR <==? <F-TYPE .F> F-STRING>
+ <F-INT-STR .M>>
+ <TTTPRINC "Min chars: ">
+ <PRINC <F-MIN-CHR .M>> <CRLF>
+ <TTTPRINC "Max chars: ">
+ <PRINC <F-MAX-CHR .M>> <CRLF>)>
+ <COND (<OR <==? <F-TYPE .F> F-INTEGER>
+ <F-INT-STR .M>>
+ <TTTPRINC "Size in bits at GDM: ">
+ <PRINC <F-CONV-BITS .M>> <CRLF>)>
+ <COND (<OR <F-SET .M>
+ <F-REPEAT-GRP .M>>
+ <COND (<F-SET .M>
+ <TTTPRINC "Implemented as: SET">
+ <CRLF>)>
+ <COND (<F-REPEAT-GRP .M>
+ <TTTPRINC "Implemented as: REPEATING GROUP">
+ <CRLF>)>)
+ (ELSE
+ <COND (<NOT <==? <F-TYPE .F>
+ F-ENTITY>>
+ <TTTPRINC "Size in bits at DBMS: ">
+ <PRINC <F-BITS .M>> <CRLF>
+ <TTTPRINC "Representation: ">
+ <PRINC <F-REP .M>> <CRLF>)>)>
+ <COND (<SET AOP <F-ARITH-OPS .M>>
+ <TTTPRINC "Restricted to arithmetic operations: ">
+ <COND (<AOP-ALL .AOP>
+ <PRINC "ALL ">)>
+ <COND (<AOP-PLUS .AOP>
+ <PRINC "PLUS ">)>
+ <COND (<AOP-MINUS .AOP>
+ <PRINC "MINUS ">)>
+ <COND (<AOP-MULTIPLY .AOP>
+ <PRINC "MULTIPLY ">)>
+ <COND (<AOP-DIVIDE .AOP>
+ <PRINC "DIVIDE ">)>
+ <COND (<AOP-CONCAT .AOP>
+ <PRINC "CONCATENATE ">)>
+ <CRLF>)>
+ <COND (<SET ROP <F-REL-OPS .M>>
+ <TTTPRINC "Restricted to relational operations: ">
+ <COND (<ROP-ALL .ROP>
+ <PRINC "ALL ">)>
+ <COND (<ROP-GT .ROP>
+ <PRINC "GT ">)>
+ <COND (<ROP-LT .ROP>
+ <PRINC "LT ">)>
+ <COND (<ROP-LE .ROP>
+ <PRINC "LE ">)>
+ <COND (<ROP-GE .ROP>
+ <PRINC "GE ">)>
+ <COND (<ROP-NE .ROP>
+ <PRINC "NE ">)>
+ <COND (<ROP-EQ .ROP>
+ <PRINC "EQ ">)>
+ <COND (<ROP-AC .ROP>
+ <PRINC "ALPHA-COLLATE ">)>
+ <COND (<ROP-ISIN .ROP>
+ <PRINC "ISIN ">)>
+ <CRLF>)>
+ )>)>>
+ .FT>>
+;"\f"
+;"PP-VIEW-TABLE pretty prints the VIEW-TABLE."
+
+<DEFINE PP-VIEW-TABLE (VT "AUX" (I 0))
+ #DECL ((VT) VECTOR (I) FIX)
+ <CRLF> <PRINC "View Table:"> <CRLF>
+ <MAPF <>
+ <FUNCTION (V)
+ <SET I <+ .I 1>>
+ <COND (.V
+ <PRINC " (">
+ <PRINC .I>
+ <PRINC ")">
+ <TPRINC "View name: ">
+ <PRINC <V-NAME .V>>
+ <CRLF>)>>
+ .VT>>
+
+
+<ENDPACKAGE> ;"BUILD-DIR"
+
+
+\0
\ No newline at end of file
--- /dev/null
+<PACKAGE "BUILDL">
+
+<ENTRY LIST-BUILD>
+
+<USE "CACS" "CODGEN" "COMCOD" "COMPDEC" "CHKDCL">
+
+<DEFINE LIST-BUILD (NOD W
+ "AUX" (K <KIDS .NOD>) (KK ()) N TEM TT T1 D1 D2 D3
+ (OOPSF <>))
+ #DECL ((K KK) <LIST [REST NODE]> (N NOD) NODE)
+ <COND
+ (<MAPF <>
+ <FUNCTION (N)
+ #DECL ((N) NODE)
+ <COND (<AND <G=? <LENGTH .N> <CHTYPE <INDEX ,SIDE-EFFECTS>
+ FIX>>
+ <SIDE-EFFECTS .N>>
+ <MAPLEAVE <>>)
+ (ELSE <SET KK (.N !.KK)> T)>>
+ .K>
+ <COND (<AND <==? <NODE-TYPE <SET N <1 .KK>>> ,SEG-CODE>
+ <==? <STRUCTYP <RESULT-TYPE <SET N <1 <KIDS .N>>>>> LIST>>
+ <SET TEM
+ <GEN .N
+ <COND (<EMPTY? <REST .KK>> .W)
+ (ELSE <DATUM LIST ,AC-E>)>>>
+ <SET KK <REST .KK>>)
+ (ELSE <SET TEM <REFERENCE ()>>)>
+ <MAPF <>
+ <FUNCTION (N "AUX" (COD <DEFERN <RESULT-TYPE .N>>))
+ #DECL ((N) NODE (COD) FIX)
+ <COND (<==? <NODE-TYPE .N> ,SEG-CODE>
+ <SET TEM
+ <SEG-BUILD-LIST <1 <KIDS .N>> .TEM <> <> <>>>)
+ (ELSE
+ <SET T1 <GEN .N <DATUM ,AC-C ,AC-D>>>
+ <SET TEM <MOVE:ARG .TEM <DATUM LIST ,AC-E>>>
+ <RET-TMP-AC .TEM>
+ <RET-TMP-AC .T1>
+ <REGSTO T>
+ <EMIT <INSTRUCTION `PUSHJ
+ `P*
+ <COND (<0? .COD> |C1CONS )
+ (ELSE |CICONS )>>>
+ <SET TEM <FUNCTION:VALUE T>>)>>
+ .KK>
+ <MOVE:ARG .TEM .W>)
+ (ELSE
+ <COND (<==? <NODE-TYPE <SET N <1 .K>>> ,SEG-CODE>
+ <SET TEM <SEG-BUILD-LIST <1 <KIDS .N>> <REFERENCE ()> T T <>>>
+ <SET D3 <2 .TEM>>
+ <SET D2 <1 .TEM>>
+ <SET OOPSF <3 .TEM>>)
+ (ELSE
+ <SET D1 <GEN .N <DATUM ,AC-C ,AC-D>>>
+ <SGETREG ,AC-E <>>
+ <MUNG-AC ,AC-E>
+ <EMIT <INSTRUCTION `MOVEI `E* 0>>
+ <RET-TMP-AC .D1>
+ <REGSTO T>
+ <EMIT <INSTRUCTION
+ `PUSHJ
+ `P*
+ <COND (<0? <DEFERN <RESULT-TYPE .N>>> |C1CONS )
+ (ELSE |CICONS )>>>
+ <SET D2 <DATUM LIST ,AC-B>>
+ <SET D3 <DATUM LIST ,AC-B>>
+ <PUT ,AC-B ,ACLINK (.D2)>
+ <REGSTO T>
+ <PUT ,AC-B ,ACLINK (.D3)>)>
+ <MAPR <>
+ <FUNCTION (L "AUX" (N <1 .L>))
+ #DECL ((N) NODE)
+ <COND
+ (<==? <NODE-TYPE .N> ,SEG-CODE>
+ <COND
+ (<AND <==? <STRUCTYP <RESULT-TYPE <SET N <1 <KIDS .N>>>>> LIST>
+ <EMPTY? <REST .L>>>
+ <SET D1 <GEN .N <DATUM LIST ANY-AC>>>
+ <COND (.OOPSF
+ <TOACV .D1>
+ <PUT <DATVAL .D1> ,ACPROT T>
+ <EMIT <INSTRUCTION `SKIPE
+ <ACSYM <SET TEM <GETREG <>>>>
+ !<ADDR:VALUE .D3>>>
+ <PUT <DATVAL .D1> ,ACPROT <>>)>
+ <EMIT <INSTRUCTION `HRRM
+ <ACSYM <DATVAL .D1>>
+ `@
+ !<ADDR:VALUE .D3>>>
+ <COND (.OOPSF
+ <EMIT <INSTRUCTION `SKIPN <ADDRSYM .TEM>>>
+ <COND (<TYPE? <DATVAL .D2> AC>
+ <EMIT <INSTRUCTION
+ `MOVE
+ <ACSYM <DATVAL .D2>>
+ !<ADDR:VALUE .D1>>>)
+ (ELSE
+ <EMIT <INSTRUCTION
+ `MOVEM
+ <ACSYM <DATVAL .D1>>
+ !<ADDR:VALUE .D2>>>)>)>
+ <RET-TMP-AC .D1>)
+ (ELSE <SET D3 <SEG-BUILD-LIST .N .D3 T <> <COND (.OOPSF .D2)>>>)>)
+ (ELSE
+ <SET D1 <GEN .N <DATUM ,AC-C ,AC-D>>>
+ <SGETREG ,AC-E <>>
+ <SET D1 <MOVE:ARG .D1 <DATUM ,AC-C ,AC-D>>>
+ <EMIT '<`MOVEI `E* >>
+ <RET-TMP-AC .D1>
+ <REGSTO T>
+ <EMIT <INSTRUCTION
+ `PUSHJ
+ `P*
+ <COND (<0? <DEFERN <RESULT-TYPE .N>>> |C1CONS )
+ (ELSE |CICONS )>>>
+ <COND (.OOPSF <EMIT <INSTRUCTION `SKIPE `C* !<ADDR:VALUE .D3>>>)>
+ <EMIT <INSTRUCTION `HRRM `B* `@ !<ADDR:VALUE .D3>>>
+ <EMIT <INSTRUCTION `MOVEM `B* !<ADDR:VALUE .D3>>>
+ <COND (.OOPSF
+ <EMIT '<`SKIPN `C >>
+ <EMIT <INSTRUCTION `MOVEM `B* !<ADDR:VALUE .D2>>>)>)>>
+ <REST .K>>
+ <RET-TMP-AC .D3>
+ <MOVE:ARG .D2 .W>)>>
+
+<DEFINE SEG-BUILD-LIST (NOD DAT FLG FST SMQ
+ "AUX" (TYP <RESULT-TYPE .NOD>) (TG2 <MAKE:TAG>)
+ (ITYP <ISTYPE? .TYP>) (TPS <STRUCTYP .TYP>)
+ (ET <GET-ELE-TYPE .TYP ALL>) (DF <DEFERN .ET>)
+ (ML <MINL .TYP>) (TG1 <MAKE:TAG>) TEM D1 D3 FDAT
+ D4)
+ #DECL ((NOD) NODE (DAT D1 D2 FDAT) DATUM (SMQ) <OR DATUM FALSE>)
+ <SET ET <ISTYPE-GOOD? .ET>>
+ <SET D1
+ <GEN .NOD
+ <DATUM <COND (<ISTYPE-GOOD? .ITYP> .ITYP)
+ (<ISTYPE-GOOD? .TPS> .TPS)
+ (ELSE ANY-AC)>
+ ANY-AC>>>
+ <COND (<ISTYPE-GOOD? .TPS> <DATTYP-FLUSH .D1> <PUT .D1 ,DATTYP .TPS>)>
+ <COND (<OR .FST <NOT .FLG>>
+ <COND (<0? .ML>
+ <SET DAT
+ <MOVE:ARG .DAT
+ <DATUM LIST
+ <COND (.FST ,AC-B) (ELSE ,AC-E)>>>>
+ <COND (.FST
+ <RET-TMP-AC .D1>
+ <SET FDAT <DATUM LIST <DATVAL .DAT>>>
+ <REGSTO T>
+ <PUT ,AC-B ,ACLINK (.FDAT)>
+ <PUT <DATVAL .D1> ,ACLINK (.D1)>
+ <COND (<TYPE? <DATTYP .D1> AC>
+ <PUT <DATTYP .D1> ,ACLINK (.D1)>)>)>
+ <MT-TEST .D1 .TG1 .TPS>)>
+ <SET TEM
+ <OFFPTR <COND (<==? .TPS UVECTOR> -1) (ELSE 0)> .D1 .TPS>>
+ <SET D3 <DATUM <COND (.ET) (ELSE .TEM)> .TEM>>
+ <SET D3 <MOVE:ARG .D3 <DATUM ,AC-C ,AC-D> T>>
+ <COND (<AND .FLG .FST> <RET-TMP-AC .FDAT>)
+ (<NOT .FLG>
+ <SET DAT <MOVE:ARG .DAT <DATUM LIST ,AC-E>>>
+ <RET-TMP-AC .DAT>)>
+ <RET-TMP-AC .D3>
+ <REGSTO T>
+ <AND .FST <EMIT '<`MOVEI `E* >>>
+ <EMIT <INSTRUCTION `PUSHJ
+ `P*
+ <COND (<0? .DF> |C1CONS ) (ELSE |CICONS )>>>
+ <COND (<AND .FST <0? .ML>>
+ <EMIT <INSTRUCTION `MOVEM `B* !<ADDR:VALUE .DAT>>>)>)>
+ <COND (<OR <NOT .FST> <NOT <0? .ML>>>
+ <SET FDAT <DATUM LIST ,AC-B>>
+ <PUT ,AC-B ,ACLINK (.FDAT)>)>
+ <COND (<OR .FST <NOT .FLG>> <SET D1 <1REST .D1 .TPS>>)>
+ <COND (<OR <NOT .FST> <NOT <0? .ML>>>
+ <SET DAT <MOVE:ARG .FDAT <DATUM LIST ,AC-E> T>>)>
+ <RET-TMP-AC .D1>
+ <RET-TMP-AC .FDAT>
+ <REGSTO T>
+ <PUT <DATVAL .D1> ,ACLINK (.D1)>
+ <COND (<TYPE? <DATTYP .D1> AC> <PUT <DATTYP .D1> ,ACLINK (.D1)>)>
+ <PUT ,AC-B ,ACLINK (.FDAT)>
+ <COND (<L=? .ML 1> <MT-TEST .D1 .TG1 .TPS>)>
+ <SET D4 <DATUM !.D1>>
+ <LABEL:TAG .TG2>
+ <SET TEM <OFFPTR <COND (<==? .TPS UVECTOR> -1) (ELSE 0)> .D1 .TPS>>
+ <SET D3
+ <MOVE:ARG <DATUM <COND (.ET) (ELSE .TEM)> .TEM>
+ <DATUM ,AC-C ,AC-D>
+ T>>
+ <SGETREG ,AC-E <>>
+ <RET-TMP-AC .D3>
+ <COND (.FLG <EMIT '<`MOVEI `E* >>)
+ (ELSE <EMIT <INSTRUCTION `HRRZ `E* `@ !<ADDR:VALUE .FDAT>>>)>
+ <REGSTO T>
+ <EMIT <INSTRUCTION `PUSHJ
+ `P*
+ <COND (<0? .DF> |C1CONS ) (ELSE |CICONS )>>>
+ <COND (.SMQ <EMIT <INSTRUCTION `SKIPE `C* !<ADDR:VALUE .FDAT>>>)>
+ <EMIT <INSTRUCTION `HRRM `B* `@ !<ADDR:VALUE .FDAT>>>
+ '<EMIT <INSTRUCTION `MOVEM `B* !<ADDR:VALUE .FDAT>>>
+ <COND (.SMQ
+ <EMIT '<`SKIPN `C >>
+ <EMIT <INSTRUCTION `MOVEM `B* !<ADDR:VALUE .SMQ>>>)>
+ <REST-N-JMP .D1 .TPS .TG2 .D4>
+ <COND (.FLG <SET FDAT <DATUM LIST ,AC-B>> <PUT ,AC-B ,ACLINK (.FDAT)>)
+ (ELSE <SET DAT <MOVE:ARG .DAT <DATUM LIST ,AC-E>>>)>
+ <LABEL:TAG .TG1>
+ <COND (<AND .FLG .FST> (.DAT .FDAT <0? .ML>)) (.FLG .FDAT) (ELSE .DAT)>>
+
+<DEFINE MT-TEST (D TG TP) #DECL ((TP) ATOM (D) DATUM)
+ <SET D <TOACV .D>>
+ <COND (<==? .TP LIST> <EMIT <INSTRUCTION `JUMPE <ACSYM <DATVAL .D>> .TG>>)
+ (ELSE <EMIT <INSTRUCTION `JUMPGE <ACSYM <DATVAL .D>> .TG>>)>>
+
+<DEFINE 1REST (D TP
+ "AUX" (DD
+ <DATUM <COND (<ISTYPE-GOOD? .TP> .TP) (ELSE ANY-AC)>
+ ANY-AC>) AC)
+ #DECL ((TP) ATOM (D DD) DATUM (AC) AC)
+ <COND (<==? .TP LIST>
+ <PUT .DD ,DATVAL <SET AC <GETREG .DD>>>
+ <EMIT <INSTRUCTION `HRRZ <ACSYM .AC> `@ !<ADDR:VALUE .D>>>
+ <RET-TMP-AC .D>)
+ (ELSE
+ <SET DD <MOVE:ARG .D .DD>>
+ <EMIT <INSTRUCTION `ADD
+ <ACSYM <DATVAL .DD>>
+ <COND (<==? .TP UVECTOR> '[<1 (1)>])
+ (ELSE '[<2 (2)>])>>>)>
+ .DD>
+
+<DEFINE REST-N-JMP (D TP TG D1 "AUX" (AC <DATVAL .D1>))
+ #DECL ((D D1) DATUM (TP) ATOM (AC) AC)
+ <COND (<==? .TP LIST>
+ <EMIT <INSTRUCTION `HRRZ <ACSYM .AC> `@ !<ADDR:VALUE .D>>>
+ <EMIT <INSTRUCTION `JUMPN <ACSYM .AC> .TG>>
+ <RET-TMP-AC .D>
+ <PUT .AC ,ACLINK (.D1 !<ACLINK .AC>)>)
+ (ELSE
+ <EMIT <INSTRUCTION `MOVE <ACSYM .AC> !<ADDR:VALUE .D>>>
+ <COND (<TYPE? <DATTYP .D1> AC>
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM <DATTYP .D1>>
+ !<ADDR:TYPE .D>>>
+ <PUT <DATTYP .D1> ,ACLINK (.D1 !<ACLINK
+ <DATTYP .D1>>)>)>
+ <RET-TMP-AC .D>
+ <PUT .AC ,ACLINK (.D1 !<ACLINK .AC>)>
+ <COND (<==? .TP UVECTOR>
+ <EMIT <INSTRUCTION `AOBJN <ACSYM .AC> .TG>>)
+ (ELSE
+ <EMIT <INSTRUCTION `ADD <ACSYM .AC> '[<2 (2)>]>>
+ <EMIT <INSTRUCTION `JUMPL <ACSYM .AC> .TG>>)>)>
+ T>
+
+
+<ENDPACKAGE>\ 3\ 3
\ No newline at end of file
--- /dev/null
+<PACKAGE "CACS">
+
+<ENTRY GETREG SGETREG RET-TMP-AC TOACT TOACV FLUSH-RESIDUE TOACT FLUSH-RESIDUE
+ SAVE-STATE MUNG-AC TOACV AC+1OK? DATTYP-FLUSH SAVE:RES PREFER-DATUM
+ MERGE-STATE GET2REG SMASH-INACS SAVE-NUM-SYM ANY2ACS RESTORE-STATE KILL-LIST
+ CHECK:VARS CALL-INTERRUPT SINACS FREE-ACS REGSTO FIX-NUM-SYM SPEC-OFFPTR
+ KILL-LOOP-AC SMASH-NUM-SYM GET-NUM-SYM STORE-VAR STORE-TVAR STOREV VAR-STORE
+ KILL-STORE UNPREFER>
+
+<USE "COMPDEC" "CHKDCL" "COMCOD" "CODGEN" "CUP">
+
+<DEFINE GETREG (DAT
+ "OPTIONAL" (TYPE-AC <>)
+ "AUX" AC (BEST <>) (OLDAGE <CHTYPE <MIN> FIX>)(WINNAGE -1))
+ #DECL ((DAT) ANY (BEST) <OR FALSE AC> (VALUE) AC (WINNAGE OLDAGE) FIX)
+ <MAPF <>
+ <FUNCTION (AC "AUX" (SCORE 0) PAC NAC)
+ #DECL ((AC PAC NAC) AC (SCORE) FIX)
+ <PROG ()
+ <COND (<ACPROT .AC> <RETURN>)>
+ <COND (<ACLINK .AC>
+ <COND (<G? .WINNAGE ,LINKED> <RETURN>)>
+ <COND (<G? <ACAGE .AC> .OLDAGE> <RETURN>)>
+ <SET WINNAGE ,LINKED>
+ <SET OLDAGE <ACAGE <SET BEST .AC>>>
+ <RETURN>)>
+ <COND (<ACRESIDUE .AC>
+ <COND (<G? .WINNAGE ,NO-RESIDUE> <RETURN>)>
+ <COND (<ALL-STORED? <ACRESIDUE .AC>>
+ <COND (<G? .WINNAGE ,STORED-RESIDUE> <RETURN>)>
+ <SET SCORE ,STORED-RESIDUE>)
+ (<G? .WINNAGE ,NOT-STORED-RESIDUE> <RETURN>)
+ (ELSE <SET SCORE ,NOT-STORED-RESIDUE>)>)
+ (ELSE <SET SCORE ,NO-RESIDUE>)>
+ <COND (<NOT <ACPREF .AC>> <SET SCORE <+ .SCORE ,NOT-PREF>>)>
+ <COND (<NOT .TYPE-AC> <SET SCORE <+ .SCORE <RATE .AC PREV>>>)
+ (ELSE <SET SCORE <+ .SCORE ,P-N-CLEAN>>)>
+ <SET SCORE <+ .SCORE <RATE .AC NEXT>>>
+ <COND (<G? .SCORE .WINNAGE>
+ <SET WINNAGE .SCORE>
+ <SET BEST .AC>)>>>
+ ,ALLACS>
+ <SET BEST <CHTYPE .BEST AC>>
+ ;"Make sure the poor compiler knows this guy is an AC"
+ <COND (<TYPE? .DAT DATUM> <PUT .BEST ,ACLINK (.DAT)>)
+ (ELSE <PUT .BEST ,ACLINK .DAT>)>
+ <COND (<ACRESIDUE .BEST>
+ <MAPF <>
+ <FUNCTION (SYMT "AUX" (INAC <SINACS .SYMT>) IAC)
+ #DECL ((INAC) DATUM)
+ <COND (<AND <TYPE? <SET IAC <DATTYP .INAC>> AC>
+ <N==? .IAC .BEST>>
+ <FLUSH-RESIDUE .IAC .SYMT>)>
+ <COND (<AND <TYPE? <SET IAC <DATVAL .INAC>> AC>
+ <N==? .IAC .BEST>>
+ <FLUSH-RESIDUE .IAC .SYMT>)>
+ <STOREV .SYMT>>
+ <ACRESIDUE .BEST>>
+ <PUT .BEST ,ACRESIDUE <>>)>
+ <PUT .BEST ,ACAGE <SETG ATIME <+ ,ATIME 1>>>
+ .BEST>
+
+<DEFINE ALL-STORED? (L) #DECL ((L) LIST)
+ <MAPF <> <FUNCTION (S) <COND (<AND <TYPE? .S SYMTAB>
+ <NOT <STORED .S>>>
+ <MAPLEAVE <>>)> T> .L>>
+
+<DEFINE RATE (AC PREV-OR-NEXT
+ "AUX" (PREV <==? .PREV-OR-NEXT PREV>) (SCORE 0) OTHAC)
+ #DECL ((AC OTHAC) AC (PREV-OR-NEXT) ATOM)
+ <PROG ()
+ <COND (.PREV
+ <COND (<OR <==? .AC ,AC-A>
+ <ACPROT <SET OTHAC
+ <NTH ,ALLACS <- <ACNUM .AC> 1>>>>>
+ <RETURN 0>)>)
+ (<OR <==? .AC ,LAST-AC>
+ <ACPROT <SET OTHAC <NTH ,ALLACS <+ <ACNUM .AC> 1>>>>>
+ <RETURN 0>)>
+ <COND (<ACLINK .OTHAC> <RETURN ,P-N-LINKED>)>
+ <COND (<ACRESIDUE .OTHAC>
+ <COND (<ALL-STORED? <ACRESIDUE .OTHAC>>
+ <RETURN ,P-N-STO-RES>)
+ (ELSE <RETURN ,P-N-NO-STO-RES>)>)
+ (ELSE <RETURN ,P-N-CLEAN>)>>>
+
+<DEFINE UNPREFER () <MAPF <> <FUNCTION (X) <PUT .X ,ACPREF <>>> ,ALLACS>>
+
+<DEFINE PREFER-DATUM (WHERE)
+ #DECL ((WHERE) <OR DATUM ATOM>)
+ <COND (<NOT <TYPE? .WHERE ATOM>>
+ <PREF-AC <1 .WHERE>>
+ <PREF-AC <2 .WHERE>>)>>
+
+<DEFINE PREF-AC (DAT) <COND (<TYPE? .DAT AC> <PUT .DAT ,ACPREF T>)>>
+
+<DEFINE RELREG (AC D "AUX" (ACL <ACLINK .AC>))
+ #DECL ((AC) AC (ACL) <OR FALSE <LIST [REST DATUM]>> (D) DATUM)
+ <COND (.ACL
+ <REPEAT ((ACP ()))
+ #DECL ((ACP) LIST)
+ <AND <EMPTY? .ACL> <RETURN>>
+ <COND (<==? <1 .ACL> .D>
+ <COND (<==? .ACL <ACLINK .AC>>
+ <PUT .AC ,ACLINK <REST .ACL>>)
+ (ELSE <PUTREST .ACP <REST .ACL>>)>)>
+ <SET ACL <REST <SET ACP .ACL>>>>
+ <AND <EMPTY? <ACLINK .AC>> <PUT .AC ,ACLINK <>>>)>
+ <PUT .AC ,ACPROT <>>
+ .AC>
+
+<DEFINE GETTMP (TYP) <CHTYPE <VECTOR <CREATE-TMP .TYP> <>> TEMP>>
+
+<DEFINE SAVE:REG (AC FLS
+ "OPTIONAL" (HANDLE-VARS T)
+ "AUX" TMP (ACL <ACLINK .AC>) (TYPS <>) (VALS <>) TTMP HLAC)
+ #DECL ((AC) AC (TMP) TEMP (ACL) <OR FALSE <LIST [REST DATUM]>> (TTMP) DATUM)
+ <COND
+ (<AND .HANDLE-VARS <ACRESIDUE .AC>>
+ <MAPF <>
+ <FUNCTION (SYM "AUX" SAC (INAC <SINACS .SYM>))
+ #DECL ((SYM) SYMBOL (INAC) DATUM)
+ <COND (<AND <TYPE? .SYM SYMTAB> <NOT <STORED .SYM>>>
+ <STOREV .SYM .FLS>)>
+ <COND (.FLS
+ <COND (<AND <TYPE? <SET SAC <DATTYP .INAC>> AC>
+ <N==? .SAC .AC>>
+ <FLUSH-RESIDUE .SAC .SYM>)
+ (<AND <TYPE? <SET SAC <DATVAL .INAC>> AC>
+ <N==? .SAC .AC>>
+ <FLUSH-RESIDUE .SAC .SYM>)>
+ <SMASH-INACS .SYM <>>
+ <COND (<AND .FLS
+ <TYPE? .SYM SYMTAB>
+ <TYPE? <NUM-SYM .SYM> LIST>
+ <1 <NUM-SYM .SYM>>>
+ <PUT <NUM-SYM .SYM> 1 <>>)>)>>
+ <ACRESIDUE .AC>>)>
+ <COND
+ (.ACL
+ <SET TMP
+ <GETTMP <COND (<AND <TYPE? <DATTYP <1 .ACL>> ATOM>
+ <VALID-TYPE? <DATTYP <1 .ACL>>>>
+ <DATTYP <1 .ACL>>)
+ (ELSE <>)>>>
+ <OR .FLS <PUT .TMP ,TMPAC <DATUM !<1 .ACL>>>>
+ <COND (<TYPE? <DATTYP <SET TTMP <1 .ACL>>> TEMP>
+ <PUT <CHTYPE <DATVAL .TTMP> AC> ,ACPROT T>
+ <TOACT .TTMP>
+ <PUT <CHTYPE <DATVAL .TTMP> AC> ,ACPROT <>>)
+ (<TYPE? <DATVAL .TTMP> TEMP>
+ <PUT <CHTYPE <DATTYP .TTMP> AC> ,ACPROT T>
+ <TOACV .TTMP>
+ <PUT <CHTYPE <DATTYP .TTMP> AC> ,ACPROT <>>)>
+ <MAPF <>
+ <FUNCTION (D)
+ #DECL ((D) DATUM)
+ <COND (<TYPE? <SET HLAC <DATTYP .D>> AC>
+ <OR .TYPS <SET TYPS .HLAC>>
+ <PUT <PUT .HLAC ,ACLINK <>> ,ACPROT <>>
+ <OR .FLS
+ <MEMQ .TMP <ACRESIDUE .HLAC>>
+ <PUT .HLAC
+ ,ACRESIDUE
+ (.TMP !<ACRESIDUE <DATTYP .D>>)>>
+ <PUT .D ,DATTYP .TMP>)
+ (<TYPE? .HLAC OFFPTR>
+ <SET VALS <HACK-OFFPTR .HLAC .TMP>>
+ <SET VALS <3 .HLAC>>)>
+ <COND (<TYPE? <SET HLAC <DATVAL .D>> AC>
+ <OR .VALS <SET VALS .HLAC>>
+ <PUT <PUT .HLAC ,ACLINK <>> ,ACPROT <>>
+ <OR .FLS
+ <MEMQ .TMP <ACRESIDUE .HLAC>>
+ <PUT .HLAC ,ACRESIDUE (.TMP !<ACRESIDUE
+ .HLAC>)>>
+ <PUT .D ,DATVAL .TMP>)
+ (<TYPE? .HLAC OFFPTR>
+ <SET VALS <HACK-OFFPTR .HLAC .TMP>>
+ <SET TYPS <3 .HLAC>>)>>
+ .ACL>
+ <OR .TYPS <SET TYPS <DATTYP <1 .ACL>>>>
+ <SET VALS <CHTYPE <OR .VALS <DATVAL <1 .ACL>>> AC>>
+ <COND (<TYPE? .TYPS AC>
+ <STORE-TMP <ACSYM .TYPS> <ACSYM .VALS> <STEMP:ADDR .TMP>>)
+ (ELSE <STORE-TMP .TYPS <ACSYM .VALS> <STEMP:ADDR .TMP>>)>)>
+ <AND .FLS
+ <NOT .HANDLE-VARS>
+ <MESSAGE INCONSISTENCY "AC-LOSSAGE">>
+ <AND .FLS <PUT .AC ,ACRESIDUE <>>>
+ .AC>
+
+<DEFINE RETTMP (TMP "AUX" INAC AC)
+ #DECL ((TMP) TEMP (INAC) <OR FALSE DATUM>)
+ <COND (<SET INAC <SINACS .TMP>>
+ <COND (<TYPE? <SET AC <DATTYP .INAC>> AC>
+ <FLUSH-RESIDUE .AC .TMP>)>
+ <COND (<TYPE? <SET AC <DATVAL .INAC>> AC>
+ <FLUSH-RESIDUE .AC .TMP>)>)>>
+
+<DEFINE MUNG-AC (AC "OPTIONAL" (GD <>) (FLS T) "AUX" ACL (ACPR <ACPROT .AC>))
+ #DECL ((AC) AC (GD ACL) <PRIMTYPE LIST>)
+ <COND
+ (<ACRESIDUE .AC>
+ <MAPF <>
+ <FUNCTION (V "AUX" (INAC <SINACS .V>) TT)
+ #DECL ((INAC) <OR DATUM FALSE>)
+ <STOREV .V .FLS>
+ <AND .INAC
+ .FLS
+ <OR <COND (<OR <AND <==? .AC <DATTYP .INAC>>
+ <TYPE? <SET TT <DATVAL .INAC>> AC>>
+ <AND <==? .AC <DATVAL .INAC>>
+ <TYPE? <SET TT <DATTYP .INAC>> AC>>>
+ <MUNG-AC .TT .GD .FLS>)>
+ <PROG ()
+ <AND <TYPE? <SET TT <DATTYP .INAC>> AC>
+ <NOT <==? .TT .AC>>
+ <MUNG-AC .TT .INAC .FLS>>
+ <AND <TYPE? <SET TT <DATVAL .INAC>> AC>
+ <NOT <==? .TT .AC>>
+ <MUNG-AC .TT .INAC .FLS>>>>>>
+ <ACRESIDUE .AC>>
+ <COND (.FLS <PUT .AC ,ACRESIDUE <>>)>)>
+ <COND (<AND .GD <SET ACL <ACLINK .AC>>>
+ <REPEAT ((OA ()))
+ #DECL ((OA) LIST)
+ <AND <EMPTY? .ACL> <RETURN <SET GD <>>>>
+ <COND (<==? <1 .ACL> .GD>
+ <COND (<EMPTY? .OA>
+ <COND (<EMPTY? <REST .ACL>>
+ <PUT .AC ,ACLINK <>>)
+ (ELSE <PUT .AC ,ACLINK <REST .ACL>>)>)
+ (ELSE <PUTREST .OA <REST .ACL>>)>
+ <RETURN>)>
+ <SET ACL <REST <SET OA .ACL>>>>)
+ (ELSE <SET GD <>>)>
+ <COND (.GD
+ <PUT .AC ,ACPROT <>>
+ <SGETREG .AC .GD>
+ <PUT .AC ,ACPROT .ACPR>)>
+ .AC>
+
+<DEFINE VAR-STORE ("OPTIONAL" (FLS T))
+ <UNPREFER>
+ <MAPF <> <FUNCTION (AC) <MUNG-AC .AC <> .FLS>> ,ALLACS>>
+
+<DEFINE GET:ACS () <MAPF ,LIST
+ <FUNCTION (X) <CHTYPE <VECTOR !.X> AC>>
+ ,ALLACS>>
+
+<DEFINE REGSTO (FLUSH-RES "OPTIONAL" (HANDLE-VARS T))
+ <MAPF <>
+ <FUNCTION (AC) #DECL ((AC) AC) <SAVE:REG .AC .FLUSH-RES .HANDLE-VARS>>
+ ,ALLACS>>
+
+<DEFINE SGETREG (AC DAT "AUX" (ACL <ACLINK .AC>))
+ #DECL ((AC) AC (ACL) <OR FALSE <LIST [REST DATUM]>>)
+ <AND <ACPROT .AC>
+ <MESSAGE INCONSISTENCY "NEEDED AC IS PROTECTED? ">>
+ <COND
+ (.ACL
+ <COND
+ (<MAPF <>
+ <FUNCTION (AC1)
+ #DECL ((AC1) AC)
+ <COND
+ (<AND <NOT <ACLINK .AC1>> <NOT <ACPROT .AC1>>>
+ <MUNG-AC .AC1>
+ <PUT .AC1 ,ACLINK .ACL>
+ <PUT .AC1 ,ACRESIDUE <ACRESIDUE .AC>>
+ <MAPF <>
+ <FUNCTION (D "AUX" (L <MEMQ .AC .D>))
+ #DECL ((D) DATUM (L) <PRIMTYPE LIST>)
+ <COND (.L <PUT .L 1 .AC1>)
+ (ELSE
+ <MESSAGE INCONSISTENCY " AC LOSSAGE ">)>>
+ .ACL>
+ <MAPF <>
+ <FUNCTION (SYM "AUX" L)
+ #DECL ((SYM) SYMBOL)
+ <COND (<SET L <MEMQ .AC <CHTYPE <SINACS .SYM> DATUM>>>
+ <PUT .L 1 .AC1>)>>
+ <ACRESIDUE .AC1>>
+ <PUT .AC ,ACRESIDUE <>>
+ <MOVE:VALUE .AC .AC1>
+ <MAPLEAVE T>)>> ,ALLACS>)
+ (ELSE <SAVE:REG .AC T>)>)
+ (ELSE <MUNG-AC .AC>)>
+ <COND (<TYPE? .DAT DATUM> <PUT .AC ,ACLINK (.DAT)>)
+ (ELSE <PUT .AC ,ACLINK .DAT>)>
+ <PUT .AC ,ACAGE <SETG ATIME <+ ,ATIME 1>>>
+ .AC>
+
+<DEFINE DATUM (TY VA) #DECL ((VALUE) DATUM) <CHTYPE (.TY .VA) DATUM>>
+
+<DEFINE OFFPTR (OFF DAT TYP) <CHTYPE (.OFF .DAT .TYP) OFFPTR>>
+
+<DEFINE SPEC-OFFPTR (OFF DAT TYP AT) <CHTYPE (.OFF .DAT .TYP .AT) OFFPTR>>
+
+<DEFINE DATTYP-FLUSH (DAT)
+ #DECL ((DAT) DATUM)
+ <COND (<N==? <DATVAL .DAT> <DATTYP .DAT>>
+ <RET-TMP-AC <DATTYP .DAT> .DAT>)>>
+
+<DEFINE RET-TMP-AC (ADR "OPTIONAL" D "AUX" (AD .ADR))
+ #DECL ((D) DATUM)
+ <COND (<TYPE? .ADR AC> <RELREG .ADR .D>)
+ (<TYPE? .ADR TEMP> <RETTMP .ADR>)
+ (<TYPE? .ADR DATUM>
+ <REPEAT ()
+ <AND <EMPTY? .ADR> <RETURN>>
+ <RET-TMP-AC <DATTYP .ADR> .AD>
+ <RET-TMP-AC <DATVAL .ADR> .AD>
+ <SET ADR <REST .ADR 2>>>)
+ (<TYPE? .ADR OFFPTR> <RET-TMP-AC <2 .ADR>>)>>
+
+
+<DEFINE TOACV (DAT "AUX" AC)
+ #DECL ((DAT) DATUM (AC) AC)
+ <TEMP-MOD .DAT>
+ <COND (<NOT <TYPE? <DATVAL .DAT> AC>>
+ <MOVE:VALUE <DATVAL .DAT> <SET AC <GETREG .DAT>>>
+ <RET-TMP-AC <DATVAL .DAT>>
+ <PUT .DAT ,DATVAL .AC>)>
+ .DAT>
+
+<DEFINE TOACT (DAT "AUX" AC)
+ #DECL ((DAT) DATUM (AC) AC)
+ <TEMP-MOD .DAT>
+ <COND (<NOT <TYPE? <DATTYP .DAT> AC>>
+ <MOVE:TYP <DATTYP .DAT> <SET AC <GETREG .DAT>>>
+ <DATTYP-FLUSH .DAT>
+ <PUT .DAT ,DATTYP .AC>)>
+ .DAT>
+
+<DEFINE AC+1OK? (AC)
+ <COND (<TYPE? .AC AC>
+ <REPEAT ((F ,ALLACS) (AC .AC))
+ #DECL ((F) <UVECTOR [REST AC]> (AC) AC)
+ <AND <==? .AC <1 .F>> <RETURN <NOT <ACLINK <2 .F>>>>>
+ <AND <EMPTY? <REST <SET F <REST .F>>>> <RETURN <>>>>)>>
+
+<DEFINE GET2REG ()
+ #DECL ((VALUE) <OR AC FALSE>)
+ <REPEAT ((F ,ALLACS))
+ #DECL ((F) <UVECTOR [REST AC]>)
+ <AND <NOT <ACLINK <1 .F>>>
+ <NOT <ACLINK <2 .F>>>
+ <RETURN <1 .F>>>
+ <AND <EMPTY? <REST <SET F <REST .F>>>> <RETURN <>>>>>
+
+<DEFINE ANY2ACS ("AUX" T)
+ #DECL ((VALUE) DATUM)
+ <RELREG <DATTYP <SET T <DATUM <GETREG ()> <GETREG <>>>>>
+ .T>
+ .T>
+
+<DEFINE GET1REG ()
+ #DECL ((VALUE) <OR AC FALSE>)
+ <REPEAT ((F ,ALLACS))
+ #DECL ((F) <UVECTOR [REST AC]>)
+ <OR <ACLINK <1 .F>> <RETURN <1 .F>>>
+ <AND <EMPTY? <SET F <REST .F>>> <RETURN <>>>>>
+
+<DEFINE FREE-ACS ("OPTIONAL" (SUPER-FREE <>) "AUX" (N 0))
+ #DECL ((N VALUE) FIX)
+ <MAPF <>
+ <FUNCTION (AC)
+ #DECL ((AC) AC)
+ <COND (<AND <NOT <ACPROT .AC>>
+ <NOT <ACLINK .AC>>
+ <OR <NOT .SUPER-FREE>
+ <AND <NOT <ACRESIDUE .AC>>
+ <NOT <ACPREF .AC>>>>>
+ <SET N <+ .N 1>>)>>
+ ,ALLACS>
+ .N>
+
+<DEFINE SAVE-STATE ("AUX" (STATV #SAVED-STATE ()) ST)
+ #DECL ((STATV) SAVED-STATE (ST) <OR FALSE <LIST NODE>>)
+ <MAPF <>
+ <FUNCTION (AC) #DECL ((AC) AC)
+ <SET STATV
+ <CHTYPE
+ ((.AC
+ <LIST !<ACRESIDUE .AC>>
+ !<MAPF ,LIST
+ <FUNCTION (X)
+ (.X
+ <DATUM !<SINACS .X>>
+ <AND <TYPE? .X SYMTAB> <STORED .X>>
+ <AND <TYPE? .X SYMTAB>
+ <AND <SET ST <PROG-AC .X>>
+ <NOT <MEMQ .X <LOOP-VARS <1 .ST>>>>>>)>
+ <CHTYPE <ACRESIDUE .AC> LIST>>)
+ !.STATV)
+ SAVED-STATE>>>
+ ,ALLACS>
+ .STATV>
+
+<DEFINE RESTORE-STATE (STATV
+ "OPTIONAL" (NORET T)
+ "AUX" (MUNGED-SYMS ()) PA OACR)
+ #DECL ((STATV) SAVED-STATE (PA) <OR FALSE <LIST NODE>> (OACR) <OR FALSE LIST>)
+ <MAPF <>
+ <FUNCTION (ACLST
+ "AUX" (AC <1 .ACLST>) (SMT <2 .ACLST>) (SYMT <REST .ACLST 2>))
+ #DECL ((ACLST)
+ <LIST AC
+ <OR FALSE <LIST [REST SYMBOL]>>
+ [REST <LIST SYMBOL ANY>]>
+ (SYMT)
+ <LIST [REST <LIST SYMBOL ANY>]>
+ (AC)
+ AC
+ (SMT)
+ <OR FALSE <LIST [REST SYMBOL]>>)
+ <AND .SMT <EMPTY? .SMT> <SET SMT <>>>
+ <MAPF <>
+ <FUNCTION (ST)
+ <OR <MEMQ .ST .MUNGED-SYMS> <SMASH-INACS .ST <> <>>>>
+ <ACRESIDUE .AC>>
+ <AND .SMT <SET SMT <LIST !.SMT>>>
+ <SET OACR <ACRESIDUE .AC>>
+ <PUT .AC ,ACRESIDUE .SMT>
+ <MAPF <>
+ <FUNCTION (SYMB "AUX" (SYMT <1 .SYMB>) (INAC <2 .SYMB>))
+ #DECL ((SYMB) <LIST SYMBOL ANY> (SYMT) SYMBOL)
+ <COND (<TYPE? .SYMT SYMTAB>
+ <PUT .SYMT
+ ,STORED
+ <GET-STORED .SYMT <3 .SYMB> <4 .SYMB>>>
+ <COND (<SET PA <PROG-AC .SYMT>>
+ <AND <STORED .SYMT>
+ <NOT <MEMQ .SYMT <LOOP-VARS <1 .PA>>>>
+ <NOT .NORET>
+ <NOT <MEMQ .SYMT .OACR>>
+ <KILL-LOOP-AC .SYMT>
+ <FLUSH-RESIDUE .AC .SYMT>
+ <SET INAC <>>>)
+ (<4 .SYMB>
+ <FLUSH-RESIDUE .AC .SYMT>
+ <SET INAC <>>)>)>
+ <OR <MEMQ .SYMT .MUNGED-SYMS>
+ <SET MUNGED-SYMS (.SYMT !.MUNGED-SYMS)>>
+ <SMASH-INACS .SYMT .INAC>>
+ .SYMT>>
+ .STATV>>
+
+<DEFINE GET-STORED (SYMT PREV-STORED PROG-AC-POSS "AUX" PAC)
+ #DECL ((PREV-STORED PROG-AC-POSS) <OR FALSE ATOM> (PAC) <OR FALSE <LIST NODE>>
+ (SYMT) SYMTAB)
+ <COND (.PROG-AC-POSS
+ <AND .PREV-STORED
+ <OR <NOT <SET PAC <PROG-AC .SYMT>>>
+ <NOT <MEMQ .SYMT <LOOP-VARS <1 .PAC>>>>>>)
+ (.PREV-STORED)>>
+
+<DEFINE MERGE-STATE (STATV)
+ #DECL ((STATV) SAVED-STATE)
+ <MAPF <>
+ <FUNCTION (STATV
+ "AUX" (AC <1 .STATV>) (DATS <REST .STATV 2>)
+ (STATAC <ACRESIDUE .AC>) (NINACS ()) (NRES ()))
+ #DECL ((STATV) <LIST AC ANY [REST <LIST SYMBOL ANY>]>
+ (AC) AC (DATS) <LIST [REST <LIST SYMBOL ANY>]>
+ (STATAC) <OR FALSE <LIST [REST SYMBOL]>>
+ (NRES) <LIST [REST SYMBOL]>
+ (NINACS) <LIST [REST <LIST SYMBOL ANY>]>)
+ <MAPF <>
+ <FUNCTION (ACX
+ "AUX" (SYMT <1 .ACX>) (INAC <2 .ACX>) (OINAC <SINACS .SYMT>)
+ (TEM <>) (PMERG T))
+ #DECL ((ACX) <LIST SYMBOL ANY>
+ (SYMT) SYMBOL
+ (INAC OINAC) <PRIMTYPE LIST>)
+ <COND (<TYPE? .SYMT SYMTAB>
+ <COND (<STORED .SYMT>
+ <PUT .SYMT
+ ,STORED
+ <GET-STORED .SYMT <3 .ACX> <4 .ACX>>>)>
+ <COND (<AND <SS-POTENT-SLOT .ACX> <NOT <PROG-AC .SYMT>>>
+ <SET PMERG <>>)>)>
+ <COND
+ (<AND <MEMQ .SYMT .STATAC>
+ .OINAC
+ .INAC
+ .PMERG
+ <==? <DATVAL .INAC> <DATVAL .OINAC>>
+ <OR <==? <DATTYP .INAC> <DATTYP .OINAC>>
+ <AND <TYPE? .SYMT SYMTAB>
+ <SET TEM
+ <ISTYPE? <1 <CHTYPE <DECL-SYM .SYMT>
+ LIST>>>>
+ <OR <==? <DATTYP .INAC> .TEM>
+ <==? <DATTYP .OINAC> .TEM>>>>>
+ <SET NRES (.SYMT !.NRES)>
+ <SET NINACS
+ ((.SYMT <DATUM <OR .TEM <DATTYP .INAC>> <DATVAL .INAC>>)
+ !.NINACS)>
+ <COND (<AND .TEM
+ <OR <TYPE? <SET TEM <DATTYP .INAC>> AC>
+ <TYPE? <SET TEM <DATTYP .OINAC>> AC>>>
+ <FLUSH-RESIDUE .TEM .SYMT>)>)>
+ <COND (<AND .OINAC
+ <OR <==? .AC <DATTYP .OINAC>>
+ <==? .AC <DATVAL .OINAC>>>>
+ <SMASH-INACS .SYMT <> <>>)>>
+ .DATS>
+ <MAPF <>
+ <FUNCTION (SYMT)
+ #DECL ((SYMT) SYMBOL)
+ <SMASH-INACS .SYMT <> <>>>
+ <ACRESIDUE .AC>>
+ <PUT .AC ,ACRESIDUE <COND (<NOT <EMPTY? .NRES>> .NRES)>>
+ <MAPF <>
+ <FUNCTION (SYMB "AUX" (SYMT <1 .SYMB>) (ELEIN <2 .SYMB>))
+ #DECL ((SYMT) SYMBOL)
+ <SMASH-INACS .SYMT .ELEIN>>
+ .NINACS>>
+ .STATV>>
+
+<DEFINE SINACS (SYM)
+ #DECL ((SYM) SYMBOL (VALUE) <OR DATUM FALSE>)
+ <COND (<TYPE? .SYM TEMP> <TMPAC .SYM>)
+ (<TYPE? .SYM COMMON> <COMMON-DATUM .SYM>)
+ (<INACS .SYM>)>>
+
+<DEFINE SMASH-INACS (ITEM OBJ "OPTIONAL" (SMASH-NUM-SYM T))
+ #DECL ((ITEM) SYMBOL)
+ <COND (<TYPE? .ITEM COMMON> <PUT .ITEM ,COMMON-DATUM .OBJ>)
+ (<TYPE? .ITEM TEMP> <PUT .ITEM ,TMPAC .OBJ>)
+ (ELSE <PUT .ITEM ,INACS .OBJ>)>>
+
+<DEFINE TEMP-MOD (DAT "AUX" TAC VAC TDAC VDAC)
+ #DECL ((DAT) DATUM)
+ <COND (<TYPE? <SET TDAC <DATTYP .DAT>> TEMP>
+ <COND (<SET TAC <TMPAC .TDAC>>
+ <AND <TYPE? <SET TAC <DATTYP .TAC>> AC>
+ <PUT .TAC ,ACLINK (.DAT)>
+ <PUT .DAT ,DATTYP .TAC>
+ <OR <MEMQ .TDAC <CHTYPE <ACRESIDUE .TAC> LIST>>
+ <PUT .TAC
+ ,ACRESIDUE
+ (.TDAC !<ACRESIDUE .TAC>)>>>)>)>
+ <COND (<TYPE? <SET VDAC <DATVAL .DAT>> TEMP>
+ <COND (<SET VAC <TMPAC .VDAC>>
+ <AND <TYPE? <SET VAC <DATVAL .VAC>> AC>
+ <PUT .VAC ,ACLINK (.DAT)>
+ <PUT .DAT ,DATVAL .VAC>
+ <OR <MEMQ .VDAC <CHTYPE <ACRESIDUE .VAC> LIST>>
+ <PUT .VAC
+ ,ACRESIDUE
+ (.VDAC !<ACRESIDUE .VAC>)>>>)>)>>
+
+<DEFINE POTENT-L-V? (SYM "AUX" PA) #DECL ((SYM) SYMTAB (PA) <OR FALSE <LIST NODE>>)
+ <COND (<AND <STORED .SYM>
+ <SET PA <PROG-AC .SYM>>
+ <NOT <MEMQ .SYM <LOOP-VARS <1 .PA>>>>> T)>>
+
+
+
+<DEFINE SAVE:RES ("AUX" (SYM-LIST ())) #DECL ((SYM-LIST) LIST)
+ <MAPF <>
+ <FUNCTION (AC)
+ #DECL ((AC) AC)
+ <MAPF <>
+ <FUNCTION (SYMT "AUX" ONSYMT OP!-PACKAGE)
+ <COND (<AND <TYPE? .SYMT SYMTAB>
+ <NOT <MEMQ .SYMT .SYM-LIST>>>
+ <SET OP!-PACKAGE <POTLV .SYMT>>
+ <SET ONSYMT <NUM-SYM .SYMT>>
+ <SMASH-NUM-SYM .SYMT>
+ <SET SYM-LIST
+ (.SYMT
+ <INACS .SYMT>
+ .ONSYMT
+ .OP!-PACKAGE
+ <>
+ !.SYM-LIST)>
+ <COND (<NOT <STORED .SYMT>> <STOREV .SYMT <>>)
+ (<POTENT-L-V? .SYMT>
+ <COND (<NOT .OP!-PACKAGE>
+ <PUT .SYMT ,STORED <>>
+ <STOREV .SYMT <>>
+ <PUT .SYMT ,POTLV T>)>
+ <PUT .SYM-LIST 5 <LIST !<NUM-SYM .SYMT>>>)>)>>
+ <ACRESIDUE .AC>>>
+ ,ALLACS>
+ .SYM-LIST>
+
+<DEFINE SAVE-NUM-SYM (SYM-LIST "AUX" (L (())) (LP .L) TMP)
+ #DECL ((SYM-LIST) <LIST [REST SYMTAB ANY ANY <OR FALSE ATOM> ANY]>)
+ <REPEAT ()
+ <COND (<EMPTY? .SYM-LIST> <RETURN <REST .L>>)>
+ <SET LP
+ <REST
+ <PUTREST
+ .LP
+ (<LIST !<COND (<AND <TYPE? <SET TMP <NUM-SYM <1 .SYM-LIST>>> LIST>
+ <NOT <EMPTY? .TMP>>>
+ <REST .TMP>)
+ (ELSE ())>>)>>>
+ <SET SYM-LIST <REST .SYM-LIST 5>>>>
+
+<DEFINE FIX-NUM-SYM (L1 L2 "AUX" LL TMP)
+ #DECL ((L1) <LIST [REST LIST]>
+ (L2) <LIST [REST SYMTAB ANY ANY <OR FALSE ATOM> ANY]>)
+ <REPEAT ()
+ <COND (<OR <EMPTY? .L1> <EMPTY? .L2>> <RETURN>)
+ (<AND <TYPE? <SET TMP <NUM-SYM <1 .L2>>> LIST>
+ <NOT <EMPTY? .TMP>>>
+ <SET LL <1 .L1>>
+ <REPEAT ((L <REST .TMP>))
+ <COND (<EMPTY? .L> <RETURN>)>
+ <COND (<NOT <MEMQ <1 .L> .LL>>
+ <PUTREST .TMP <REST .L>>
+ <SET L <REST .TMP>>)
+ (ELSE <SET L <REST <SET TMP .L>>>)>>)>
+ <SET L1 <REST .L1>>
+ <SET L2 <REST .L2 5>>>>
+
+<DEFINE CHECK:VARS (RES UNK "AUX" SLOT TEM SYMT PRGAC)
+ #DECL ((RES)
+ <LIST [REST SYMTAB ANY ANY <OR FALSE ATOM> <OR FALSE LIST>]>
+ (SYMT)
+ SYMTAB
+ (SLOT)
+ LIST
+ (PRGAC)
+ <OR FALSE <LIST NODE>>
+ (TEM)
+ <OR FALSE LIST>)
+ <REPEAT ((PTR .RES))
+ <COND (<EMPTY? .PTR> <RETURN>)>
+ <SET SYMT <1 .PTR>>
+ <COND (<AND <INACS .SYMT> .UNK>
+ <COND (<AND <1 <SET SLOT <NUM-SYM .SYMT>>>
+ <NOT <EMPTY? <REST .SLOT>>>>
+ <PUT .SYMT ,STORED <POTENT-L-V? .SYMT>>
+ <MAPF <> ,KILL-STORE <REST .SLOT>>)>)>
+ <COND (<AND <POTLV .SYMT>
+ <NOT <AND <SET PRGAC <PROG-AC .SYMT>>
+ <MEMQ .SYMT <LOOP-VARS <1 .PRGAC>>>>>
+ <SET TEM <5 .PTR>>
+ <G=? <LENGTH .TEM> 1>
+ <NUM-SYM .SYMT>
+ <1 .TEM>>
+ <MAPF <> ,KILL-STORE <REST .TEM>>)>
+ <COND (<=? <NUM-SYM .SYMT> '(#FALSE ())>
+ <PUT .SYMT ,NUM-SYM <3 .PTR>>
+ <COND (<AND <TYPE? <NUM-SYM .SYMT> LIST>
+ <NOT <EMPTY? <NUM-SYM .SYMT>>>>
+ <PUT <NUM-SYM .SYMT> 1 <>>)>)
+ (ELSE <PUT .SYMT ,NUM-SYM <3 .PTR>>)>
+ <PUT .SYMT ,POTLV <4 .PTR>>
+ <SET PTR <REST .PTR 5>>>>
+
+
+<DEFINE STORE-TVAR (NAME DAT1 DAT2 ADDR)
+ <EMIT <CHTYPE [,STORE:TVAR
+ .NAME
+ .ADDR
+ .DAT1
+ .DAT2
+ <NOT <TYPE? .DAT1 AC>>]
+ TOKEN>>>
+
+<DEFINE KILL-STORE (SS)
+ <SET SS <CHTYPE .SS ATOM>>
+ <SET KILL-LIST (.SS !.KILL-LIST)>
+ <EMIT <CHTYPE [,KILL:STORE .SS] TOKEN>>>
+
+<DEFINE STORE-VAR (NAME DAT ADDR BOOL)
+ #DECL ((DAT) DATUM)
+ <EMIT <CHTYPE [,STORE:VAR
+ .NAME
+ .ADDR
+ <COND (<TYPE? <DATTYP .DAT> AC> <ACSYM <DATTYP .DAT>>)
+ (<DATTYP .DAT>)>
+ <COND (<TYPE? <DATVAL .DAT> AC> <ACSYM <DATVAL .DAT>>)
+ (<DATVAL .DAT>)>
+ .BOOL]
+ TOKEN>>>
+
+<DEFINE FLUSH-RESIDUE (AC SYMT) #DECL ((AC) AC (SYMT) SYMBOL)
+ <AND <NOT <EMPTY? <ACRESIDUE .AC>>>
+ <PUT .AC ,ACRESIDUE <RES-FLS <ACRESIDUE .AC> .SYMT>>>>
+
+
+<DEFINE CALL-INTERRUPT ("AUX" (ACDATA ![0 0!]) (ACLIST ()) (ACNUM 1))
+ #DECL ((ACNUM) FIX (ACDATA) <UVECTOR FIX FIX> (ACLIST) <SPECIAL LIST>)
+ <MAPF <>
+ <FUNCTION (AC "AUX" TYP (ACL <ACLINK .AC>) (ACR <ACRESIDUE .AC>))
+ #DECL ((AC) AC (ACR) <OR FALSE LIST> (ACL) <OR FALSE <LIST [REST DATUM]>>)
+ <COND (.ACL
+ <COND (<L? .ACNUM 7>
+ <PUT .ACDATA
+ 1
+ <DEPOSIT-DATA <1 .ACDATA>
+ .ACNUM
+ .AC
+ <DATTYP <1 .ACL>>>>)
+ (ELSE
+ <PUT .ACDATA
+ 2
+ <DEPOSIT-DATA <2 .ACDATA>
+ <- .ACNUM 6>
+ .AC
+ <DATTYP <1 .ACL>>>>)>)
+ (.ACR
+ <COND (<L? .ACNUM 7>
+ <PUT .ACDATA
+ 1
+ <DEPOSIT-DATA <1 .ACDATA>
+ .ACNUM
+ .AC
+ <SINACS <1 .ACR>>>>)
+ (ELSE
+ <PUT .ACDATA
+ 2
+ <DEPOSIT-DATA
+ <2 .ACDATA>
+ <- .ACNUM 6>
+ .AC
+ <SINACS <1 .ACR>>>>)>)>
+ <SET ACNUM <+ .ACNUM 1>>>
+ ,ALLACS>
+ <COND (<AND <0? <1 .ACDATA>> <0? <2 .ACDATA>>> <EMIT '<INTGO!-OP!-PACKAGE>>)
+ (ELSE
+ <EMIT '<`SKIPGE |INTFLG >>
+ <MAPR <>
+ <FUNCTION (PTR "AUX" (TYP <1 .PTR>))
+ #DECL ((TYP) ATOM)
+ <PUT .PTR
+ 1
+ <FORM 0 <FORM TYPE-WORD!-OP!-PACKAGE .TYP>>>>
+ .ACLIST>
+ <EMIT <INSTRUCTION <COND (<0? <2 .ACDATA>> `SAVAC* ) (ELSE `LSAVA* )>
+ <COND (<0? <2 .ACDATA>>
+ [<FORM (<GETBITS <1 .ACDATA> <BITS 18 18>>)
+ <GETBITS <1 .ACDATA> <BITS 18>>>
+ !.ACLIST])
+ (ELSE
+ [<FORM (<GETBITS <1 .ACDATA> <BITS 18 18>>)
+ <GETBITS <1 .ACDATA> <BITS 18>>>
+ <FORM (<GETBITS <2 .ACDATA> <BITS 18 18>>)
+ <GETBITS <2 .ACDATA> <BITS 18>>>
+ !.ACLIST])>>>)>>
+
+<DEFINE DEPOSIT-DATA (DATA ACNUM AC DAT "AUX" TYP)
+ #DECL ((DATA ACNUM) FIX (AC) AC (DAT) DATUM)
+ <COND (<TYPE? <SET TYP <DATTYP .DAT>> ATOM>
+ <DEPOSIT-TYPE .DATA .ACNUM .TYP>)
+ (<TYPE? .TYP AC>
+ <COND (<N=? .AC .TYP> <DEPOSIT-AC .DATA .ACNUM .TYP>)
+ (.DATA)>)
+ (<TYPE? .TYP OFFPTR> <DEPOSIT-TYPE .DATA .ACNUM <3 .TYP>>)>>
+
+<DEFINE DEPOSIT-TYPE (DATA ACNUM TYP "AUX" (ACL .ACLIST))
+ #DECL ((DATA ACNUM) FIX (TYP) ATOM (ACLIST ACL) LIST)
+ <COND (<==? <TYPEPRIM .TYP> TEMPLATE>
+ <SET DATA
+ <CHTYPE <PUTBITS .DATA
+ <NTH ,DATABITS .ACNUM>
+ #WORD *000000000077*>
+ FIX>>
+ <COND (<EMPTY? .ACL> <SET ACLIST (.TYP)>)
+ (<PUTREST <REST .ACL <- <LENGTH .ACL> 1>> (.TYP)>)>)
+ (<==? <TYPEPRIM .TYP> WORD>)
+ (<SET DATA
+ <CHTYPE <PUTBITS .DATA
+ <NTH ,DATABITS .ACNUM>
+ <+ <CHTYPE <PRIM-CODE <TYPE-C .TYP>> FIX> 8>>
+ FIX>>)>
+ .DATA>
+
+<DEFINE DEPOSIT-AC (DATA ACNUM TYP)
+ #DECL ((DATA ACNUM) FIX (TYP) AC)
+ <CHTYPE <PUTBITS .DATA <NTH ,DATABITS .ACNUM> <ACNUM .TYP>>
+ FIX>>
+
+<SETG DATABITS
+ ![<BITS 6 30>
+ <BITS 6 24>
+ <BITS 6 18>
+ <BITS 6 12>
+ <BITS 6 6>
+ <BITS 6 0>!]>
+
+<GDECL (DATABITS) <UVECTOR [6 BITS]>>
+
+<DEFINE FIND-AC-TYPE (OBJ) <COND (<TYPE? .OBJ OFFPTR> <3 .OBJ>) (.OBJ)>>
+
+<DEFINE FIND-AC-VAL (OBJ) <COND (<TYPE? .OBJ OFFPTR> <DATVAL <2 .OBJ>>)>>
+
+<DEFINE FIND-TYPE-OF-ACL (DAT "AUX" D1)
+ #DECL ((DAT) DATUM)
+ <COND (<OR <TYPE? <SET D1 <DATTYP .DAT>> OFFPTR>
+ <TYPE? <SET D1 <DATVAL .DAT>> OFFPTR>>
+ <3 <CHTYPE .D1 OFFPTR>>) ;"This CHTYPE to get around compiler bug."
+ (<AND <TYPE? <SET D1 <DATTYP .DAT>> ATOM> <VALID-TYPE? .D1>>
+ .D1)>>
+
+<DEFINE HACK-OFFPTR (OFF TMP "AUX" DAT)
+ #DECL ((OFF) OFFPTR (TMP) TEMP)
+ <SET DAT <2 .OFF>>
+ <PUT .DAT ,DATVAL .TMP>>
+
+
+
+<DEFINE STOREV (SYM "OPTIONAL" (FLS T) "AUX" (DAT <SINACS .SYM>))
+ #DECL ((SYM) <OR TEMP SYMTAB COMMON> (DAT) <OR FALSE DATUM>)
+ <SMASH-INACS .SYM <> <>>
+ <COND
+ (<TYPE? .SYM SYMTAB>
+ <AND
+ .DAT
+ <NOT <STORED .SYM>>
+ <PROG ((SLOT <NUM-SYM .SYM>) NT ADDR)
+ <SET NT <GET-NUM-SYM .SYM>>
+ <COND
+ (<TYPE? <ADDR-SYM .SYM> TEMPV>
+ <STORE-TVAR .NT
+ <COND (<TYPE? <DATTYP .DAT> AC> <ACSYM <DATTYP .DAT>>)
+ (ELSE <DATTYP .DAT>)>
+ <ACSYM <CHTYPE <DATVAL .DAT> AC>>
+ <DATVAL <SET ADDR
+ <LADDR .SYM <> <ISTYPE-GOOD? <DATTYP .DAT>> <>>>>>)
+ (<STORE-VAR
+ .NT
+ .DAT
+ <DATVAL <SET ADDR <LADDR .SYM <> <ISTYPE-GOOD? <DATTYP .DAT>> <>>>>
+ <ISTYPE-GOOD? <DATTYP .ADDR>>>)>
+ <RET-TMP-AC .ADDR>
+ <PUT .SYM ,STORED T>>>)>
+ <COND (.FLS <SMASH-INACS .SYM <>>)
+ (<SMASH-INACS .SYM .DAT>)>>
+
+
+<DEFINE GET-NUM-SYM (SYM "AUX" (SLOT <NUM-SYM .SYM>) NT)
+ <COND (<AND <TYPE? .SLOT LIST> <1 .SLOT>>
+ <PUTREST .SLOT (<SET NT <MAKE:TAG "VAR">> !<REST .SLOT>)>)
+ (ELSE <SET NT T>)>
+ .NT>
+
+
+<DEFINE KILL-LOOP-AC (SYMT "AUX" PNOD)
+ <COND (<AND <TYPE? .SYMT SYMTAB>
+ <SET PNOD <PROG-AC .SYMT>>
+ <NOT <MEMQ .SYMT <LOOP-VARS <PROG-SLOT .PNOD>>>>>
+ <PUT .SYMT ,PROG-AC <>>)>>
+
+
+<DEFINE SMASH-NUM-SYM (SYM) #DECL ((SYM) SYMTAB) <PUT .SYM ,NUM-SYM (T)>>
+
+
+<ENDPACKAGE>
\ No newline at end of file
--- /dev/null
+<PACKAGE "CARANA">
+
+<ENTRY ARITH-ANA MOD-ANA ABS-ANA ROT-ANA LSH-ANA FIX-ANA FLOAT-ANA ARITHP-ANA
+ HACK-BOUNDS BIT-TEST-ANA>
+
+<USE "SYMANA" "CHKDCL" "COMPDEC" "ADVMESS">
+
+" This file contains analyzers and code generators for arithmetic
+ SUBRs and predicates. For convenience many of the SUBRs that are
+similar are combined into one analyzer/generator. For more info
+on analyzers see SYMANA and on generators see CODGEN.
+"
+
+<SETG ASTATE ![![2 3 5!] ![2 4 5!] ![4 3 5!] ![4 4 5!] ![5 5 5!]!]>
+
+" Analyze +,-,* and /. Take care of no arg and one arg problems."
+
+<DEFINE ARITH-ANA (NOD RTYP
+ "AUX" (NN <NODE-NAME .NOD>) (DEFLT <GET-DF .NN>) (STATE 1)
+ (K <KIDS .NOD>) (FIXDIV <>) RT)
+ #DECL ((NOD) <SPECIAL NODE> (K) <LIST [REST NODE]> (STYP) FIX
+ (STATE) <SPECIAL FIX> (DEFLT) <OR FIX FLOAT>)
+ <SET RT <COND (<NOT <TYPE-OK? .RTYP FLOAT>> FIX) (ELSE '<OR FIX FLOAT>)>>
+ <COND
+ (<EMPTY? .K>
+ <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
+ <PUT .NOD ,RESULT-TYPE <TYPE .DEFLT>>
+ <PUT .NOD ,NODE-NAME .DEFLT>
+ <PUT .NOD ,KIDS ()>
+ <TYPE-OK? <TYPE .DEFLT> .RTYP>)
+ (<AND <EMPTY? <REST .K>>
+ <N==? <NODE-TYPE <1 .K>> ,SEGMENT-CODE>
+ <N==? <NODE-TYPE <1 .K>> ,SEG-CODE>
+ <COND (<==? <NODE-SUBR .NOD> ,/>
+ <SET FIXDIV T>
+ <PUT .NOD
+ ,KIDS
+ <SET K
+ (<NODE1 ,QUOTE-CODE .NOD <TYPE .DEFLT> .DEFLT ()>
+ !.K)>>
+ <>)
+ (ELSE T)>>
+ <COND (<==? <NODE-SUBR .NOD> ,-> <PUT .NOD ,NODE-TYPE ,ABS-CODE>
+ ;"Treat like a call
+ to ABS.")
+ (ELSE <PUT .NOD ,NODE-TYPE ,ID-CODE>)>
+ <EANA <1 .K> .RT <NODE-NAME .NOD>>)
+ (ELSE
+ <MAPF <> <FUNCTION (N) <ARITH-ELE .N .RT>> .K>
+ <COND (<L? .STATE 5>
+ <COND (<AND .FIXDIV <N==? .STATE 2>>
+ <PUT <PUT <1 .K> ,NODE-NAME 1.0> ,RESULT-TYPE FLOAT>)>
+ <PUT .NOD
+ ,NODE-TYPE
+ <COND (<OR <==? .NN MAX> <==? .NN MIN>> ,MIN-MAX-CODE)
+ (ELSE ,ARITH-CODE)>>
+ <MAPF <>
+ <FUNCTION (NN)
+ #DECL ((NN) NODE)
+ <COND (<==? <NODE-TYPE .NN> ,SEGMENT-CODE>
+ <PUT .NN ,NODE-TYPE ,SEG-CODE>)>>
+ .K>)
+ (ELSE
+ <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>
+ <PUT .NOD
+ ,STACKS
+ <* <MAPF ,+
+ <FUNCTION (N "AUX" (CD <NODE-TYPE .N>))
+ #DECL ((N) NODE (CD) FIX)
+ <COND (<OR <==? .CD ,SEGMENT-CODE>
+ <==? .CD ,SEG-CODE>>
+ <PUT .NOD ,SEGS T>
+ <PUT .N ,NODE-TYPE ,SEGMENT-CODE>
+ <MAPRET>)
+ (ELSE 1)>>
+ .K>
+ 2>>)>
+ <TYPE-OK? <NTH '[FIX FLOAT FLOAT <OR FIX FLOAT>] <- .STATE 1>> .RTYP>)>>
+
+<DEFINE GET-DF (S)
+ #DECL ((S) ATOM)
+ <NTH '[0 0 1 1 1.7014117E+38 -1.7014117E+38]
+ <LENGTH <MEMQ .S '![MAX MIN * / - +!]>>>>
+
+<DEFINE ARITH-ELE (N RT "AUX" TT TEM (FL <>))
+ #DECL ((N NOD) NODE (STATE TT) FIX)
+ <COND (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
+ <==? <NODE-TYPE .N> ,SEG-CODE>>
+ <SET FL T>
+ <SET TEM
+ <EANA <1 <KIDS .N>>
+ <FORM STRUCTURED [REST .RT]>
+ <NODE-NAME .NOD>>>
+ <PUT .N ,RESULT-TYPE <RESULT-TYPE <1 <KIDS .N>>>>
+ <SET TEM <OR <AND <ISTYPE? .TEM> <GET-ELE-TYPE .TEM ALL>> ANY>>)
+ (ELSE
+ <SET TEM <EANA .N .RT <NODE-NAME .NOD>>>
+ <AND <==? <NODE-TYPE .N> ,QUOTE-CODE>
+ <OR <==? .STATE 4> <==? .STATE 3>>
+ <PUT .N ,NODE-NAME <FLOAT <NODE-NAME .N>>>
+ <PUT .N ,RESULT-TYPE FLOAT>>)>
+ <SET TT
+ <COND (<==? <ISTYPE? .TEM> FIX> 1)
+ (<==? .TEM FLOAT> 2)
+ (<NOT <TYPE-OK? .TEM FLOAT>>
+ <PUT .N
+ ,RESULT-TYPE
+ <COND (.FL
+ <TYPE-MERGE '<STRUCTURED [REST FIX]>
+ <RESULT-TYPE .N>>)
+ (ELSE FIX)>>
+ 1)
+ (<NOT <TYPE-OK? .TEM FIX>>
+ <PUT .N
+ ,RESULT-TYPE
+ <COND (.FL
+ <TYPE-MERGE '<STRUCTURED [REST FLOAT]>
+ <RESULT-TYPE .N>>)
+ (ELSE FLOAT)>>
+ 2)
+ (ELSE 3)>>
+ <COND (<AND .VERBOSE <==? .TT 3>>
+ <ADDVMESS <PARENT .N>
+ ("Arithmetic can't open compile because: " .N
+ " is of type: " .TEM)>)>
+ <SET STATE <NTH <NTH ,ASTATE .STATE> .TT>>>
+
+<DEFINE ABS-ANA (N RT "AUX" (K <KIDS .N>) TEM)
+ #DECL ((N) NODE (K) <LIST [REST NODE]>)
+ <COND (<SEGFLUSH .N .RT>)
+ (ELSE
+ <ARGCHK <LENGTH .K> 1 ABS>
+ <PUT .N ,NODE-TYPE ,ABS-CODE>
+ <SET TEM <EANA <1 .K> '<OR FIX FLOAT> ABS>>
+ <TYPE-OK? <TYPE-OK? '<OR FLOAT <FIX (0 34359738367)>> .RT>
+ .TEM>)>>
+
+<PUT ,ABS ANALYSIS ,ABS-ANA>
+
+<DEFINE MOD-ANA (N R "AUX" (K <KIDS .N>))
+ #DECL ((N) NODE (K) <LIST [REST NODE]>)
+ <COND (<SEGFLUSH .N .R>)
+ (ELSE
+ <ARGCHK <LENGTH .K> 2 MOD>
+ <EANA <1 .K> FIX MOD>
+ <EANA <2 .K> FIX MOD>
+ <PUT .N ,NODE-TYPE ,MOD-CODE>)>
+ <TYPE-OK? <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <FORM FIX (0 <- <NODE-NAME <2 .K>> 1>)>)
+ (ELSE FIX)> .R>>
+
+<PUT ,MOD ANALYSIS ,MOD-ANA>
+
+<DEFINE ROT-LSH-ANA (N R COD "AUX" (K <KIDS .N>) (NAM <NODE-NAME .N>))
+ <COND (<SEGFLUSH .N .R>)
+ (ELSE
+ <ARGCHK <LENGTH .K> 2 .NAM>
+ <EANA <1 .K> '<PRIMTYPE WORD> .NAM>
+ <EANA <2 .K> FIX .NAM>
+ <PUT .N ,NODE-TYPE .COD>)>
+ <TYPE-OK? WORD .R>>
+
+<DEFINE ROT-ANA (N R) <ROT-LSH-ANA .N .R ,ROT-CODE>>
+
+<DEFINE LSH-ANA (N R) <ROT-LSH-ANA .N .R ,LSH-CODE>>
+
+<PUT ,ROT ANALYSIS ,ROT-ANA>
+
+<PUT ,LSH ANALYSIS ,LSH-ANA>
+
+<DEFINE FLOAT-ANA (N R)
+ #DECL ((N) NODE)
+ <FL-FI-ANA .N .R FLOAT FIX ,FLOAT-CODE>>
+
+<PUT ,FLOAT ANALYSIS ,FLOAT-ANA>
+
+<DEFINE FIX-ANA (N R) #DECL ((N) NODE) <FL-FI-ANA .N .R FIX FLOAT ,FIX-CODE>>
+
+<PUT ,FIX ANALYSIS ,FIX-ANA>
+
+<DEFINE FL-FI-ANA (N RT OT IT COD "AUX" (K <KIDS .N>) TY NUM)
+ #DECL ((N NUM) NODE (OT IT) ATOM (K) <LIST [REST NODE]> (COD) FIX)
+ <COND (<SEGFLUSH .N .RT>)
+ (ELSE
+ <ARGCHK <LENGTH .K> 1 .OT>
+ <SET TY <EANA <SET NUM <1 .K>> '<OR FIX FLOAT> .OT>>
+ <COND (<==? <NODE-TYPE .NUM> ,QUOTE-CODE>
+ <PUT .N ,NODE-TYPE ,QUOTE-CODE>
+ <PUT .N ,NODE-NAME <APPLY ,.OT <NODE-NAME .NUM>>>)
+ (ELSE
+ <PUT .N ,NODE-TYPE .COD>)>)>
+ <TYPE-OK? .OT .RT>>
+
+<DEFINE ARITHP-ANA (NOD RTYP
+ "AUX" (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>) (WHO ())
+ (GLN .NOD) (GLE ()) (NN <NODE-NAME .NOD>)
+ (N
+ <COND (<OR <==? .NN 0?>
+ <==? .NN 1?>
+ <==? <NODE-TYPE .NOD> ,0-TST-CODE>>
+ 1)
+ (ELSE 2)>) (K <KIDS .NOD>) TEM (STATE 1))
+ #DECL ((WHO) <SPECIAL LIST> (WHON GLN) <SPECIAL ANY>
+ (NOD NOD2) <SPECIAL NODE> (TEM) NODE (K) <LIST [REST NODE]>
+ (STATE) <SPECIAL FIX> (COD N) FIX (GLE) <SPECIAL LIST>)
+ <COND (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <ARGCHK <LENGTH .K> .N <NODE-NAME .NOD>>
+ <MAPF <> <FUNCTION (N) <ARITH-ELE .N '<OR FIX FLOAT>>> .K>
+ <COND (<AND <==? .N 2>
+ <OR <AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
+ <0? <NODE-NAME <1 .K>>>
+ <SET TEM <2 .K>>
+ <PUT .NOD
+ ,NODE-NAME
+ <FLOPP <NODE-NAME .NOD>>>>
+ <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <0? <NODE-NAME <2 .K>>>
+ <SET TEM <1 .K>>>>>
+ <PUT .NOD ,NODE-TYPE ,0-TST-CODE>
+ <PUT .NOD ,KIDS (.TEM)>)
+ (<==? <NODE-TYPE .NOD> ,0-TST-CODE>)
+ (<OR <==? <NODE-NAME .NOD> 0?> <==? <NODE-NAME .NOD> N0?>>
+ <PUT .NOD ,NODE-TYPE ,0-TST-CODE>)
+ (<L? .STATE 5>
+ <PUT .NOD
+ ,NODE-TYPE
+ <COND (<==? .N 2> ,TEST-CODE)
+ (<==? <NODE-NAME .NOD> 0?> ,0-TST-CODE)
+ (ELSE ,1?-CODE)>>)
+ (<==? <NODE-SUBR .NOD> ,1?> <PUT .NOD ,NODE-TYPE ,1?-CODE>)
+ (<OR <==? <NODE-SUBR .NOD> ,==?>
+ <==? <NODE-SUBR .NOD> ,N==?>>
+ <PUT .NOD ,NODE-TYPE ,EQ-CODE>)
+ (ELSE <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
+ <COND (<==? .STATE 2> <HACK-BOUNDS .WHO .GLE .NOD .K>)>
+ <CHECK-FOR-BIT-HACK .NOD>)>
+ <TYPE-OK? '<OR FALSE ATOM> .RTYP>>
+
+<DEFINE CHECK-FOR-BIT-HACK (N "AUX" (NN <1 <KIDS .N>>) DATA CONST K)
+ #DECL ((NN DATA N) NODE (CONST) <PRIMTYPE WORD>)
+ <COND (<AND <==? <NODE-TYPE .N> ,0-TST-CODE>
+ <==? <NODE-TYPE .NN> ,CHTYPE-CODE>
+ <SET NN <1 <KIDS .NN>>>
+ <OR <AND <==? <NODE-TYPE .NN> ,GETBITS-CODE>
+ <SET K <KIDS .NN>>
+ <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <SET DATA <1 .K>>
+ <SET CONST <PUTBITS 0 <NODE-NAME <2 .K>> -1>>>
+ <AND <==? <NODE-TYPE .NN> ,BITL-CODE>
+ <==? <NODE-SUBR .NN> ,ANDB>
+ <==? <LENGTH <SET K <KIDS .NN>>> 2>
+ <OR <AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
+ <SET CONST <NODE-NAME <1 .K>>>
+ <SET DATA <2 .K>>>
+ <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <SET CONST <NODE-NAME <2 .K>>>
+ <SET DATA <1 .K>>>
+ <SET CONST 0>>>>>
+ <PUT .N ,NODE-TYPE ,BIT-TEST-CODE>
+ <PUT .N ,NODE-SUBR .CONST>
+ <PUT .N ,KIDS <COND (<ASSIGNED? DATA> (.DATA)) (ELSE .K)>>
+ <COND (<ASSIGNED? DATA> <PUT .DATA ,PARENT .N>)
+ (ELSE
+ <PUT <1 .K> ,PARENT .N>
+ <PUT <2 .K> ,PARENT .N>)>)>>
+
+<DEFINE BIT-TEST-ANA (N R "AUX" (K <KIDS .N>))
+ #DECL ((N) NODE (K) <LIST [REST NODE]>)
+ <EANA <1 .K> '<PRIMTYPE WORD> BIT-TEST>
+ <COND (<NOT <EMPTY? <SET K <REST .K>>>>
+ <EANA <1 .K> '<PRIMTYPE WORD> BIT-TEST>)>
+ <TYPE-OK? <RESULT-TYPE .N> .R>>
+
+<DEFINE HACK-BOUNDS (WHO GLE NOD K "AUX" NUM YES NO NOD2 (HACKT <>))
+ #DECL ((WHO GLE) LIST (NOD NOD2) NODE (K) <LIST [REST NODE]>)
+ <SET NUM
+ <COND (<OR <==? <NODE-NAME .NOD> 0?> <==? <NODE-TYPE .NOD> ,0-TST-CODE>>
+ <SET NOD2 <1 .K>>
+ 0)
+ (<==? <NODE-NAME .NOD> 1?> <SET NOD2 <1 .K>> 1)
+ (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
+ <SET NOD2 <2 .K>>
+ <NODE-NAME <1 .K>>)
+ (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <SET NOD2 <1 .K>>
+ <PUT .NOD ,NODE-NAME <FLOPP <NODE-NAME .NOD>>>
+ <PUT .NOD ,KIDS (<2 .K> <1 .K>)>
+ <NODE-NAME <2 .K>>)>>
+ <COND (.NUM
+ <SET YES <FORM FIX <GTV .NOD .NUM>>>
+ <SET NO <FORM FIX <NGTV .NOD .NUM>>>
+ <MAPF <>
+ <FUNCTION (L "AUX" (SYM <2 .L>))
+ #DECL ((L) <LIST ANY SYMTAB> (SYM) SYMTAB)
+ <SET TRUTH
+ <ADD-TYPE-LIST .SYM .YES .TRUTH <> <REST .L 2>>>
+ <SET UNTRUTH
+ <ADD-TYPE-LIST .SYM .NO .UNTRUTH <> <REST .L 2>>>>
+ .WHO>)>
+ <COND (<AND .NUM <G=? .NUM 0>>
+ <COND (<OR <AND <NOT <0? .NUM>>
+ <OR <==? <NODE-NAME .NOD> G=?>
+ <==? <NODE-NAME .NOD> L?>>>
+ <AND <0? .NUM>
+ <OR <AND <==? <NODE-NAME .NOD> G?> <SET HACKT T>>
+ <==? <NODE-NAME .NOD> L=?>>>>
+ <SET NUM <+ .NUM 1>>)>
+ <OR .HACKT <SET HACKT <MEMQ <NODE-NAME .NOD> '![1? L? L=? ==?!]>>>
+ <COND (<==? <NODE-NAME .NOD> 0?> <SET NUM 1>)>
+ <COND (<L=? .NUM 0> STRUCTURED)
+ (ELSE <SET NUM <CHTYPE (STRUCTURED !<ANY-PAT .NUM>) FORM>>)>
+ <MAPF <>
+ <FUNCTION (L "AUX" (SYM <2 .L>) (FLG <1 .L>))
+ #DECL ((L) <LIST ANY SYMTAB> (SYM) SYMTAB)
+ <COND (.HACKT
+ <SET TRUTH
+ <ADD-TYPE-LIST .SYM
+ .NUM
+ .TRUTH
+ <>
+ <REST .L 2>>>)
+ (ELSE
+ <SET UNTRUTH
+ <ADD-TYPE-LIST .SYM
+ .NUM
+ .UNTRUTH
+ <>
+ <REST .L 2>>>)>
+ T>
+ .GLE>)>>
+
+<SETG APSUBTAB [1? 0? L? L=? G? G=? ==? N==?]>
+
+<SETG DCLTAB
+ [(1 1)
+ (0 0)
+ ('<+ .VAL 1> ,PLUSINF)
+ ('.VAL ,PLUSINF)
+ (,MINUSINF '<- .VAL 1>)
+ (,MINUSINF '.VAL)
+ ('.VAL '.VAL)
+ (,MINUSINF '<- .VAL 1> '<+ .VAL 1> ,PLUSINF)]>
+
+<SETG NDCLTAB
+ [(,MINUSINF 0 2 ,PLUSINF)
+ (,MINUSINF -1 1 ,PLUSINF)
+ (,MINUSINF '.VAL)
+ (,MINUSINF '<- .VAL 1>)
+ ('.VAL ,PLUSINF)
+ ('<+ .VAL 1> ,PLUSINF)
+ (,MINUSINF '<- .VAL 1> '<+ .VAL 1> ,PLUSINF)
+ ('.VAL '.VAL)]>
+
+<DEFINE NGTV (NOD VAL)
+ #DECL ((VAL) <SPECIAL ANY> (NOD) NODE)
+ <EVAL <NTH ,NDCLTAB
+ <- 9 <LENGTH <MEMQ <NODE-NAME .NOD> ,APSUBTAB>>>>>>
+
+<DEFINE GTV (NOD VAL)
+ #DECL ((NOD) NODE (VAL) <SPECIAL ANY>)
+ <EVAL <NTH ,DCLTAB
+ <- 9 <LENGTH <MEMQ <NODE-NAME .NOD> ,APSUBTAB>>>>>>
+
+<DEFINE FLOPP (SUBR)
+ #DECL ((SUBR VALUE) ATOM)
+ <1 <REST <MEMQ .SUBR '![G? L? G? G=? L=? G=? ==? ==? N==? N==?!]>>>>
+
+<PUT ,+ ANALYSIS ,ARITH-ANA>
+
+<PUT ,- ANALYSIS ,ARITH-ANA>
+
+<PUT ,* ANALYSIS ,ARITH-ANA>
+
+<PUT ,/ ANALYSIS ,ARITH-ANA>
+
+<PUT ,MAX ANALYSIS ,ARITH-ANA>
+
+<PUT ,MIN ANALYSIS ,ARITH-ANA>
+
+<PUT ,0? ANALYSIS ,ARITHP-ANA>
+
+<PUT ,1? ANALYSIS ,ARITHP-ANA>
+
+<PUT ,L? ANALYSIS ,ARITHP-ANA>
+
+<PUT ,G? ANALYSIS ,ARITHP-ANA>
+
+<PUT ,G=? ANALYSIS ,ARITHP-ANA>
+
+<PUT ,L=? ANALYSIS ,ARITHP-ANA>
+
+<ENDPACKAGE>\ 3\ 3\ 3\ 3
\ No newline at end of file
--- /dev/null
+<PACKAGE "CARGEN">
+
+<ENTRY ARITH-GEN ABS-GEN FLOAT-GEN FIX-GEN MOD-GEN ROT-GEN LSH-GEN 1?-GEN
+ GEN-FLOAT GENFLOAT MIN-MAX PRED:BRANCH:GEN 0-TEST FLIP TEST-GEN>
+
+<USE "CACS" "CODGEN" "CHKDCL" "COMCOD" "COMPDEC" "CONFOR" "STRGEN">
+
+
+" This file contains analyzers and code generators for arithmetic
+ SUBRs and predicates. For convenience many of the SUBRs that are
+similar are combined into one analyzer/generator. For more info
+on analyzers see SYMANA and on generators see CODGEN.
+"
+
+"A type TRANS specifies to an inferior node what arithmetic transforms are
+prohibited, permitted or desired. A transform consists of 3 main elements:
+a NODE, an input, an output. The input and output are UVECTORS of 7 fixes:
+
+1) negative ok 0-no, 1-ok, 2-pref
+2) + or - const ok 0-no, 1-ok, 2-pref
+3) const for + or -
+4) * or / const ok 0-no, 1-* ok, 2-* pref, 3-/ ok, 4-/ pref
+5) hw ok 0-no, 1-ok, 2-pref
+6) hw swapped also 0-no, 1-ok, 2-pref
+"
+
+<SETG SNODES ![,QUOTE-CODE ,LVAL-CODE ,GVAL-CODE!]>
+
+<SETG SNODES1 <REST ,SNODES>>
+
+<DEFINE COMMUTE (K OP L "AUX" TT FK KK TYP NN N CD CD1)
+ #DECL ((K KK FK) <LIST [REST NODE]> (N NN) NODE (CD1 CD) FIX (L) LIST)
+ <PROG ((REDO <>))
+ <COND (<EMPTY? <SET KK <REST <SET FK .K>>>> <RETURN>)>
+ <SET TYP <ISTYPE? <RESULT-TYPE <1 .KK>>>>
+ <REPEAT ()
+ <AND <EMPTY? .KK> <RETURN>>
+ <COND
+ (<==? .TYP
+ <SET TYP <ISTYPE? <RESULT-TYPE <SET NN <1 .KK>>>>>>
+ <SET CD1 <NODE-TYPE .NN>>
+ <COND
+ (<AND <==? <SET CD <NODE-TYPE <SET N <1 .FK>>>> ,QUOTE-CODE>
+ <==? .CD1 ,QUOTE-CODE>>
+ <PUT .N
+ ,NODE-NAME
+ <APPLY ,.OP <NODE-NAME .N> <NODE-NAME .NN>>>
+ <PUTREST .FK <SET KK <REST .KK>>>
+ <SET REDO T>
+ <AGAIN>)
+ (<==? .CD ,QUOTE-CODE>
+ <PUT .KK 1 .N>
+ <PUT .FK 1 .NN>
+ <SET REDO T>)
+ (<AND <NOT <MEMQ .CD1 ,SNODES>>
+ <MEMQ .CD ,SNODES>
+ <NOT <SIDE-EFFECTS .NN>>>
+ <COND (<AND <==? .CD ,LVAL-CODE>
+ <COND (<==? <LENGTH <SET TT <TYPE-INFO .N>>> 2> <2 .TT>)
+ (ELSE T)>
+ <SET TT <NODE-NAME .N>>
+ <NOT <MAPF <>
+ <FUNCTION (LL)
+ <AND <==? <1 .LL> .TT> <MAPLEAVE>>>
+ .L>>>
+ <SET L ((<NODE-NAME .N> <>) !.L)>)>
+ <PUT .KK 1 .N>
+ <PUT .FK 1 .NN>
+ <SET REDO T>)>)>
+ <SET KK <REST <SET FK .KK>>>>
+ <COND (.REDO <SET REDO <>> <AGAIN>)>
+ .K>
+ .L>
+
+" Generate code for +,-,* and /. Note sexy AOS and SOS generator. Also
+note bug causing result to be left in AC even if not wanted."
+
+<DEFINE ARITH-GEN AG (NOD WHERE
+ "AUX" REG (K <KIDS .NOD>) REG1 T1
+ (ATYP
+ <LENGTH <MEMQ <NODE-NAME .NOD> '![/ * - +!]>>) TT
+ (MODE 1) (TEM <1 .K>) SEGF SHFT TRIN
+ (COM <OR <==? .ATYP 1> <==? .ATYP 3>>) INA
+ (DONE <>) (NEGF <>) (ONO .NO-KILL)
+ (NO-KILL .NO-KILL))
+ #DECL ((NOD TEM TT) NODE (K) <LIST [REST NODE]> (ATYP MODE) FIX
+ (REG1 REG) DATUM (WHERE COM) ANY (NO-KILL) <SPECIAL LIST>)
+ <SET REG <GOODACS .NOD .WHERE>>
+ <SET NO-KILL
+ <COMMUTE <REST .K <NTH '![0 1 0 1!] .ATYP>>
+ <NTH '![+ + * *!] .ATYP>
+ .NO-KILL>>
+ <COND
+ (<AND <==? <RESULT-TYPE .NOD> FIX> ;"All this hair to try for AOS or SOS."
+ <OR <==? .ATYP 1> <==? .ATYP 2>> ;"+ or - only."
+ <==? <LENGTH .K> 2>
+ <==? <NODE-TYPE <SET TEM <1 .K>>> ,LVAL-CODE>
+ <==? <NODE-TYPE <SET TT <2 .K>>> ,QUOTE-CODE>
+ <==? <NODE-NAME .TT> 1>
+ <NOT <EMPTY? <SET T1 <PARENT .NOD>>>>
+ <==? <NODE-TYPE <SET TT .T1>> ,SET-CODE>
+ <==? <NODE-NAME .TEM> <NODE-NAME .TT>>
+ <STORED <NODE-NAME .TEM>>
+ <OR <NOT <SET INA <INACS <NODE-NAME .TEM>>>>
+ <NOT <PROG-AC <NODE-NAME .TEM>>>>>
+ <COND (<SET INA <INACS <NODE-NAME .TEM>>>
+ <AND <TYPE? <DATTYP .INA> AC> <MUNG-AC <DATTYP .INA> .INA>>
+ <AND <TYPE? <DATVAL .INA> AC> <MUNG-AC <DATVAL .INA> .INA>>)>
+ <PUT <NODE-NAME .TEM> ,INACS <>>
+ <EMIT <INSTRUCTION <NTH '![`AOS `SOS !] .ATYP>
+ !<COND (<TYPE? <DATVAL .REG> AC>
+ <SGETREG <DATVAL .REG> .REG>
+ (<ACSYM <DATVAL .REG>>))
+ (<==? <DATVAL .REG> ANY-AC>
+ <PUT .REG ,DATVAL <GETREG .REG>>
+ (<ACSYM <DATVAL .REG>>))
+ (ELSE
+ <SET REG <DATUM <1 .WHERE> <2 .WHERE>>>
+ ())>
+ !<ADDR:VALUE <LADDR <NODE-NAME .TEM>
+ <>
+ <1 <TYPE-INFO .TT>>>>>>
+ <PUT <NODE-NAME .TEM> ,INACS .REG>
+ <SET STORE-SET T>
+ <RETURN <COND (<G? <LENGTH .WHERE> 2>
+ <MOVE:ARG .REG <CHTYPE <REST .WHERE 2> DATUM>>)
+ (ELSE .REG)>
+ .AG>)
+ (<AND <==? <RESULT-TYPE .NOD> FIX>
+ <==? <LENGTH .K> 2>
+ <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
+ <COND
+ (<AND <ASSIGNED? TRANSFORM>
+ <==? <PARENT .NOD> <1 .TRANSFORM>>
+ <SET TRIN <2 .TRANSFORM>>
+ <COND
+ (<AND <L=? .ATYP 2>
+ <OR <1? <2 .TRIN>>
+ <AND <==? <2 .TRIN> 2>
+ <==? <3 .TRIN>
+ <COND (<1? .ATYP> <- <NODE-NAME <2 .K>>>)
+ (ELSE <NODE-NAME <2 .K>>)>>>>>
+ <PUT <PUT <3 .TRANSFORM> 2 1>
+ 3
+ <COND (<1? .ATYP> <- <NODE-NAME <2 .K>>>)
+ (ELSE <NODE-NAME <2 .K>>)>>)
+ (<AND <==? .ATYP 3>
+ <OR <1? <4 .TRIN>>
+ <AND <==? <4 .TRIN> 4>
+ <==? <5 .TRIN> <NODE-NAME <2 .K>>>>>>
+ <PUT <PUT <3 .TRANSFORM> 4 4> 5 <NODE-NAME <2 .K>>>)
+ (ELSE <>)>>
+ <RETURN <GEN <1 .K> .WHERE> .AG>)
+ (<N==? <NODE-TYPE <SET TEM <1 .K>>> ,SEG-CODE>
+ <PROG ((TRANSFORM
+ <MAKE-TRANS .NOD
+ 0
+ <COND (<L? .ATYP 3> 2) (ELSE 0)>
+ <COND (<1? .ATYP> <NODE-NAME <2 .K>>)
+ (<==? .ATYP 2> <- <NODE-NAME <2 .K>>>)
+ (ELSE 0)>
+ <COND (<G? .ATYP 2>
+ <COND (<==? .ATYP 3> 2) (ELSE 4)>)
+ (ELSE 0)>
+ <COND (<G? .ATYP 2> <NODE-NAME <2 .K>>) (ELSE 1)>
+ 0
+ 0>))
+ #DECL ((TRANSFORM) <SPECIAL TRANS>)
+ <SET REG
+ <GEN .TEM
+ <COND (<AND <TYPE? <DATVAL .REG> AC>
+ <ACLINK <DATVAL .REG>>>
+ <DATUM <DATTYP .REG> ANY-AC>)
+ (ELSE .REG)>>>
+ <SET DONE T>
+ <MAPF <>
+ <FUNCTION (NN)
+ #DECL ((NN) FIX)
+ <COND (<NOT <0? .NN>>
+ <RETURN <MOVE:ARG .REG .WHERE> .AG>)>>
+ <3 .TRANSFORM>>>)>)>
+ <COND (.DONE)
+ (<==? <NODE-TYPE <SET TEM <1 .K>>> ,SEG-CODE>
+ <SET REG1
+ <GEN <SET TEM <1 <KIDS .TEM>>>
+ <DATUM <STRUCTYP <RESULT-TYPE .TEM>> ANY-AC>>>
+ <SET MODE
+ <SEGINS .ATYP T .TEM .REG .REG1 1 <GET-DF <NODE-NAME .NOD>>>>)
+ (ELSE
+ <SET REG
+ <GEN .TEM
+ <COND (<AND <TYPE? <DATVAL .REG> AC>
+ <ACLINK <DATVAL .REG>>>
+ <DATUM <DATTYP .REG> ANY-AC>)
+ (ELSE .REG)>>>
+ <AND <==? <RESULT-TYPE .TEM> FLOAT> <SET MODE 2>>)>
+ <AND <TYPE? <DATTYP .REG> ATOM>
+ <PUT .REG ,DATTYP <NTH '![FIX FLOAT!] .MODE>>>
+ <MAPR <>
+ <FUNCTION (N
+ "AUX" NN TEM TRANSFORM
+ (NXT
+ <COND
+ (<==? <NODE-TYPE <SET NN <1 .N>>> ,SEG-CODE>
+ <SET SEGF T>
+ <GEN <SET NN <1 <KIDS .NN>>>
+ <DATUM <STRUCTYP <RESULT-TYPE .NN>> ANY-AC>>)
+ (ELSE
+ <SET SEGF <>>
+ <SET TRANSFORM
+ <MAKE-TRANS .NOD
+ <COND (<AND .NEGF <G? .ATYP 2>> 2)
+ (ELSE 1)>
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0>>
+ <GEN .NN DONT-CARE>)>) (COM .COM))
+ #DECL ((N) <LIST NODE> (NXT REG) DATUM (MODE) FIX (NN) NODE
+ (TRANSFORM) <SPECIAL TRANS>)
+ <COND
+ (.SEGF
+ <SET MODE <SEGINS .ATYP <> .NN .REG .NXT .MODE 0>>
+ <RET-TMP-AC .NXT>)
+ (ELSE
+ <AND <ASSIGNED? TRANSFORM>
+ <NOT <0? <1 <3 .TRANSFORM>>>>
+ <PROG ()
+ <SET COM <NOT .COM>>
+ <SET NEGF <NOT .NEGF>>>>
+ <COND (<==? .MODE 2>
+ <COND (<==? <ISTYPE? <RESULT-TYPE .NN>> FIX>
+ <TOACV .NXT>
+ <DATTYP-FLUSH <SET NXT <GEN-FLOAT .NXT>>>
+ <PUT .NXT ,DATTYP FLOAT>)>)
+ (<==? <ISTYPE? <RESULT-TYPE .NN>> FLOAT>
+ <TOACV .REG>
+ <DATTYP-FLUSH <SET REG <GEN-FLOAT .REG>>>
+ <PUT .REG ,DATTYP FLOAT>
+ <SET MODE 2>)>
+ <COND (<AND .COM
+ <NOT <TYPE? <DATVAL .REG> AC>>
+ <TYPE? <DATVAL .NXT> AC>>
+ <SET TEM .NXT>
+ <SET NXT .REG>
+ <SET REG .TEM>)>
+ <SET NXT <SAME-AC-FIX .REG .NXT>>
+ <COND (<AND <==? .ATYP 3>
+ <==? .MODE 1>
+ <==? <NODE-TYPE .NN> ,QUOTE-CODE>
+ <SET SHFT <POPWR2 <NODE-NAME .NN>>>>
+ <SHIFT-INS .REG .SHFT .ATYP>)
+ (ELSE
+ <SET REG
+ <ARITH-INS <COND (<AND .NEGF <L? .ATYP 3>>
+ <SET NEGF <>>
+ <- 3 .ATYP>)
+ (ELSE .ATYP)>
+ .REG
+ .NXT
+ <AND <EMPTY? <REST .N>>
+ <TYPE? .WHERE DATUM>
+ <==? <DATVAL .WHERE> <DATVAL .NXT>>>
+ .MODE>>)>)>>
+ <REST .K>>
+ <COND (.NEGF
+ <COND (<AND <ASSIGNED? TRANSFORM>
+ <==? <1 .TRANSFORM> <PARENT .NOD>>
+ <NOT <0? <1 <2 .TRANSFORM>>>>>
+ <PUT <3 .TRANSFORM> 1 1>)
+ (ELSE <EMIT <INSTRUCTION `MOVNS !<ADDR:VALUE .REG>>>)>)>
+ <DELAY-KILL .NO-KILL .ONO>
+ <MOVE:ARG .REG .WHERE>>
+
+<DEFINE SAME-AC-FIX (D1 D2 "AUX" (ACQ <DATVAL .D1>))
+ #DECL ((D1 D2) DATUM)
+ <COND
+ (<AND <TYPE? .ACQ AC> <==? .ACQ <DATVAL .D2>>>
+ <COND
+ (<ACRESIDUE .ACQ>
+ <MAPF <>
+ <FUNCTION (SYM)
+ #DECL ((SYM) SYMTAB)
+ <COND (<STORED .SYM>
+ <PUT .SYM ,INACS <>>
+ <RET-TMP-AC .D2>
+ <FLUSH-RESIDUE .ACQ .SYM>
+ <SET D2 <LADDR .SYM <> <ISTYPE-GOOD? <DATTYP .D2>>>>
+ <MAPLEAVE>)>>
+ <ACRESIDUE .ACQ>>)
+ (ELSE <RET-TMP-AC .D2>)>)>
+ .D2>
+
+<DEFINE SHIFT-INS (REG SHFT ATYP)
+ #DECL ((REG) DATUM (SHFT ATYP) FIX)
+ <TOACV .REG>
+ <MUNG-AC <DATVAL .REG> .REG>
+ <EMIT <INSTRUCTION `ASH
+ <ACSYM <DATVAL .REG>>
+ <COND (<==? .ATYP 3> .SHFT) (ELSE <- .SHFT>)>>>>
+
+<DEFINE SEGINS (ATYP FD N REG REG2 MD DEFLT
+ "AUX" SAC SL TYP (STYP <RESULT-TYPE .N>) (TG <MAKE:TAG>)
+ (LOOP <MAKE:TAG>) RAC)
+ #DECL ((N) NODE (ATYP SL MD) FIX (REG REG2) DATUM (RAC SAC) AC)
+ <SET TYP
+ <COND (<==? <GET-ELE-TYPE .STYP ALL> FIX> 1) (ELSE 2)>>
+ <SET STYP <STRUCTYP .STYP>>
+ <SET SL <MINL <RESULT-TYPE .N>>>
+ <COND (.FD
+ <COND (<TYPE? <DATVAL .REG> AC>
+ <SGETREG <SET RAC <DATVAL .REG>> .REG>)
+ (ELSE <SET RAC <GETREG .REG>> <PUT .REG ,DATVAL .RAC>)>
+ <PUT .RAC ,ACPROT T>
+ <MUNG-AC .RAC .REG>
+ <SET SAC <DATVAL <TOACV .REG2>>>
+ <MUNG-AC .SAC .REG2>
+ <PUT .RAC ,ACPROT <>>
+ <SET MD .TYP>
+ <AND <==? .TYP 2> <==? .DEFLT 1> <SET DEFLT 1.0>>
+ <IMCHK '(`MOVE `MOVEI `MOVNI )
+ <ACSYM .RAC>
+ <REFERENCE:ADR .DEFLT>>
+ <COND (<L? .SL 1>
+ <EMPTY-JUMP .STYP .SAC .TG>)>
+ <COND (<OR <==? .ATYP 2> <==? .ATYP 4>>
+ <GETEL .RAC .SAC .STYP>
+ <ADVANCE .STYP .SAC>
+ <SET SL <- .SL 1>>)
+ (ELSE <SET SL 1>)>)
+ (ELSE
+ <TOACV .REG>
+ <AND <1? .MD>
+ <==? .TYP 2>
+ <DATTYP-FLUSH <SET REG <GEN-FLOAT .REG>>>
+ <PUT .REG ,DATTYP FLOAT>>
+ <SET RAC <DATVAL .REG>>
+ <PUT .RAC ,ACPROT T>
+ <MUNG-AC .RAC .REG>
+ <SET SAC <DATVAL <TOACV .REG2>>>
+ <MUNG-AC .SAC .REG2>
+ <PUT .RAC ,ACPROT <>>)>
+ <COND (<L? .SL 1> <EMPTY-JUMP .STYP .SAC .TG>)>
+ <LABEL:TAG .LOOP>
+ <EMITSEG .RAC .SAC .STYP .ATYP .TYP .MD>
+ <ADVANCE-AND-CHECK .STYP .SAC .LOOP>
+ <LABEL:TAG .TG>
+ <RET-TMP-AC .REG2>
+ .MD>
+
+<DEFINE ADVANCE (STYP SAC "AUX" AMT)
+ #DECL ((STYP) ATOM (SAC) AC (AMT) FIX)
+ <SET AMT <COND (<==? .STYP UVECTOR> 1) (ELSE 2)>>
+ <COND (<==? .STYP LIST>
+ <EMIT <INSTRUCTION `HRRZ <ACSYM .SAC> (<ADDRSYM .SAC>)>>)
+ (ELSE
+ <EMIT <INSTRUCTION `ADD <ACSYM .SAC> [<FORM .AMT (.AMT)>]>>)>>
+
+<DEFINE ADVANCE-AND-CHECK (STYP SAC TG)
+ #DECL ((SAC) AC (STYP) ATOM)
+ <COND (<==? .STYP UVECTOR>
+ <EMIT <INSTRUCTION `AOBJN <ACSYM .SAC> .TG>>)
+ (<==? .STYP LIST>
+ <EMIT <INSTRUCTION `HRRZ <ACSYM .SAC> (<ADDRSYM .SAC>)>>
+ <EMIT <INSTRUCTION `JUMPN <ACSYM .SAC> .TG>>)
+ (ELSE
+ <EMIT <INSTRUCTION `ADD <ACSYM .SAC> '[<2 (2)>]>>
+ <EMIT <INSTRUCTION `JUMPL <ACSYM .SAC> .TG>>)>>
+
+<DEFINE EMPTY-JUMP (STYP SAC TG)
+ #DECL ((SAC) AC (STYP TG) ATOM)
+ <COND (<==? .STYP LIST>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM .SAC> .TG>>)
+ (ELSE <EMIT <INSTRUCTION `JUMPGE <ACSYM .SAC> .TG>>)>>
+
+<DEFINE EMITSEG (RAC SAC STYP ATYP TYP MD "AUX" DAT)
+ #DECL ((SAC RAC) AC (TYP MD ATYP) FIX (DAT) DATUM)
+ <COND (<AND <==? .MD 2> <==? .TYP 1>>
+ <SET DAT <DATUM FIX ANY-AC>>
+ <PUT .DAT ,DATVAL <GETREG .DAT>>
+ <GETEL <DATVAL .DAT> .SAC .STYP>
+ <DATTYP-FLUSH <SET DAT <GEN-FLOAT .DAT>>>
+ <PUT .DAT ,DATTYP FLOAT>
+ <GENINS .ATYP .MD .RAC 0 <ADDRSYM <DATVAL .DAT>>>
+ <RET-TMP-AC .DAT>)
+ (ELSE
+ <GENINS .ATYP
+ .MD
+ .RAC
+ <COND (<==? .STYP UVECTOR> 0) (ELSE 1)>
+ (<ADDRSYM .SAC>)>)>>
+
+<DEFINE GENINS (ATYP MD RAC OFFS ADD "AUX" INS)
+ #DECL ((MD ATYP OFFS) FIX (RAC) AC)
+ <COND (<G? .ATYP 4>
+ <EMIT <INSTRUCTION <NTH '![`CAMG `CAML!] <- .ATYP 4>>
+ <ACSYM .RAC>
+ .OFFS
+ .ADD>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .RAC> .OFFS .ADD>>)
+ (ELSE
+ <SET INS <NTH <NTH <2 ,INS1> .MD> .ATYP>>
+ <AND <TYPE? .INS LIST> <SET INS <1 .INS>>>
+ <EMIT <INSTRUCTION .INS <ACSYM .RAC> .OFFS .ADD>>)>>
+
+<DEFINE GETEL (RAC SAC STYP)
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM .RAC>
+ <COND (<==? .STYP UVECTOR> 0) (ELSE 1)>
+ (<ADDRSYM .SAC>)>>>
+
+<SETG INS1
+ ![![![`ADDM `SUBM `IMULM `IDIVM !]
+ ![`FADRM `FSBRM `FMPRM `FDVRM !]!]
+ ![![(`ADD `ADDI `SUBI )
+ (`SUB `SUBI `ADDI )
+ (`IMUL `IMULI )
+ (`IDIV `IDIVI )!]
+ ![(`FADR () () `FADRI )
+ (`FSBR () () `FSBRI )
+ (`FMPR () () `FMPRI )
+ (`FDVR () () `FDVRI )!]!]!]>
+
+" Do the actual arithmetic code generation here with all args set up."
+
+<DEFINE ARITH-INS (ATYP REG REG2 MEM MODE "AUX" RTM INS T TT REG+1)
+ #DECL ((ATYP MODE) FIX (REG REG2) DATUM (T) AC)
+ <PROG ()
+ <COND
+ (<==? .ATYP 4>
+ <COND (<AND <TYPE? <DATVAL .REG> AC>
+ <OR <AC+1OK? <DATVAL .REG>>
+ <AND <N==? <DATVAL .REG> ,LAST-AC>
+ <==? <NTH ,ALLACS <+ <ACNUM <DATVAL .REG>> 1>>
+ <DATVAL .REG2>>>>>)
+ (<SET TT <GET2REG>>
+ <SET REG <MOVE:ARG .REG <DATUM <DATTYP .REG> .TT>>>)
+ (<TYPE? <DATVAL .REG> AC>
+ <COND (<AND <NOT .MEM>
+ <OR <==? <DATVAL .REG> ,LAST-AC>
+ <N==? <NTH ,ALLACS <+ 1 <ACNUM <DATVAL .REG>>>>
+ <DATVAL .REG2>>>>
+ <EMIT <INSTRUCTION `PUSH `P* <ADDRSYM <DATVAL .REG>> 1>>
+ <SET RTM T>)>)
+ (ELSE <TOACV .REG> <AGAIN>)>
+ <AND <NOT <ASSIGNED? RTM>>
+ <NOT .MEM>
+ <MUNG-AC <SET REG+1 <NTH ,ALLACS <+ 1 <ACNUM <DATVAL .REG>>>>>>
+ <PUT .REG+1 ,ACPROT T>>)
+ (<NOT <TYPE? <DATVAL .REG> AC>> <TOACV .REG>)>
+ <PUT <DATVAL .REG> ,ACPROT T>
+ <SET INS <NTH <NTH <NTH ,INS1 <COND (.MEM 1) (ELSE 2)>> .MODE> .ATYP>>
+ <OR .MEM <MUNG-AC <DATVAL .REG> .REG>>
+ <COND (<TYPE? .INS LIST>
+ <IMCHK .INS <ACSYM <DATVAL .REG>> <DATVAL .REG2>>)
+ (ELSE
+ <EMIT <INSTRUCTION .INS
+ <ACSYM <DATVAL .REG>>
+ !<ADDR:VALUE .REG2>>>)>
+ <AND <ASSIGNED? REG+1> <PUT .REG+1 ,ACPROT <>>>
+ <PUT <DATVAL .REG> ,ACPROT <>>
+ <AND <ASSIGNED? RTM>
+ <EMIT <INSTRUCTION `POP `P* <ADDRSYM <DATVAL .REG>> 1>>>
+ <COND (.MEM <RET-TMP-AC .REG> .REG2) (ELSE <RET-TMP-AC .REG2> .REG)>>>
+
+<DEFINE MIN-MAX (NOD WHERE
+ "AUX" (MAX? <==? MAX <NODE-NAME .NOD>>) (K <KIDS .NOD>) REG
+ (MODE 1) REG1 SEGF (C <OR <AND .MAX? 5> 6>) TEM
+ (ONO .NO-KILL) (NO-KILL .ONO))
+ #DECL ((NOD) NODE (MODE C) FIX (MAX?) ANY (REG) DATUM (K) <LIST [REST NODE]>
+ (NO-KILL) <SPECIAL LIST>)
+ <SET NO-KILL <COMMUTE .K <NODE-NAME .NOD> .NO-KILL>>
+ <SET REG <REG? <RESULT-TYPE .NOD> .WHERE>>
+ <COND (<==? <NODE-TYPE <SET TEM <1 .K>>> ,SEG-CODE>
+ <SET REG1
+ <GEN <SET TEM <1 <KIDS .TEM>>>
+ <DATUM <STRUCTYP <RESULT-TYPE .TEM>> ANY-AC>>>
+ <SET MODE
+ <SEGINS .C
+ T
+ .TEM
+ .REG
+ .REG1
+ 1
+ <OR <AND .MAX? <MAX>> <MIN>>>>)
+ (ELSE
+ <SET REG <GEN .TEM .REG>>
+ <AND <==? <RESULT-TYPE .TEM> FLOAT> <SET MODE 2>>)>
+ <MAPF <>
+ <FUNCTION (N
+ "AUX" (NXT
+ <COND
+ (<==? <NODE-TYPE .N> ,SEG-CODE>
+ <SET SEGF T>
+ <GEN <SET N <1 <KIDS .N>>>
+ <DATUM <STRUCTYP <RESULT-TYPE .N>> ANY-AC>>)
+ (ELSE <SET SEGF <>> <GEN .N DONT-CARE>)>))
+ #DECL ((NXT REG) DATUM (N) NODE (MODE) FIX)
+ <COND (.SEGF
+ <SET MODE <SEGINS .C <> .N .REG .NXT .MODE 0>>
+ <RET-TMP-AC .NXT>)
+ (ELSE
+ <COND (<==? .MODE 2>
+ <COND (<==? <ISTYPE? <RESULT-TYPE .N>> FIX>
+ <DATTYP-FLUSH <SET NXT <GEN-FLOAT .NXT>>>
+ <PUT .NXT ,DATTYP FLOAT>)>)
+ (<==? <ISTYPE? <RESULT-TYPE .N>> FLOAT>
+ <DATTYP-FLUSH <SET REG <GEN-FLOAT .REG>>>
+ <PUT .REG ,DATTYP FLOAT>
+ <SET MODE 2>)>
+ <COND (<AND <NOT <TYPE? <DATVAL .REG> AC>>
+ <TYPE? <DATVAL .NXT> AC>>
+ <SET TEM .NXT>
+ <SET NXT .REG>
+ <SET REG .TEM>)>
+ <COND (<TYPE? <DATVAL .REG> AC>
+ <MUNG-AC <DATVAL .REG> .REG>)>
+ <TOACV .REG> ;"Make sure in AC"
+ <PUT <DATVAL .REG> ,ACPROT T>
+ <IMCHK <COND (.MAX? '(`CAMG `CAIG )) (ELSE '(`CAML `CAIL ))>
+ <ACSYM <DATVAL .REG>>
+ <DATVAL .NXT>>
+ <MOVE:VALUE <DATVAL .NXT> <DATVAL .REG>>
+ <PUT <DATVAL .REG> ,ACPROT <>>
+ <RET-TMP-AC .NXT>)>>
+ <REST .K>>
+ <DELAY-KILL .NO-KILL .ONO>
+ <MOVE:ARG .REG .WHERE>>
+
+<DEFINE ABS-GEN ACT (N W
+ "AUX" (K1 <1 <KIDS .N>>) NUM (TRIN <>)
+ (ABSFLG <==? <NODE-NAME .N> ABS>) TEM T2 (DONE <>))
+ #DECL ((N K1) NODE (NUM) DATUM (TEM) <DATUM ANY AC> (TRANSFORM) TRANS)
+ <PROG ((TRANSFORM <MAKE-TRANS .N 2 0 0 0 1 0 0>))
+ #DECL ((TRANSFORM) <SPECIAL TRANS>)
+ <SET NUM
+ <GEN .K1
+ <COND (<AND <==? <NODE-TYPE .K1> ,LNTH-CODE>
+ <TYPE? .W DATUM>>
+ <DATUM !.W>)
+ (ELSE DONT-CARE)>>>
+ <COND (<NOT <0? <1 <3 .TRANSFORM>>>>
+ <RETURN <MOVE:ARG .NUM .W> .ACT>)>>
+ <COND (<AND <ASSIGNED? TRANSFORM>
+ <==? <1 .TRANSFORM> <PARENT .N>>
+ <NOT .ABSFLG>>
+ <SET TRIN <2 .TRANSFORM>>)>
+ <COND
+ (<AND <TYPE? .W DATUM>
+ <REPEAT ((W <CHTYPE .W LIST>))
+ #DECL ((W) LIST)
+ <COND (<EMPTY? .W> <RETURN <>>)
+ (<OR <=? <DATVAL .W> <DATVAL .NUM>>
+ <AND <TYPE? <DATVAL .NUM> AC>
+ <==? <DATVAL .W> ANY-AC>>>
+ <RETURN T>)
+ (ELSE <SET W <REST .W 2>>)>>>
+ <COND (<NOT <AND .TRIN <NOT <0? <1 .TRIN>>>>>
+ <AND <TYPE? <DATVAL .NUM> AC> <MUNG-AC <DATVAL .NUM> .NUM>>
+ <EMIT <INSTRUCTION <COND (.ABSFLG `MOVMS ) (ELSE `MOVNS )>
+ !<ADDR:VALUE .NUM>>>)
+ (ELSE <PUT <3 .TRANSFORM> 1 1>)>
+ <MOVE:ARG .NUM .W>)
+ (<AND <==? .W DONT-CARE> <TYPE? <DATVAL .NUM> AC>>
+ <COND (<NOT <AND .TRIN <NOT <0? <1 .TRIN>>>>>
+ <AND <TYPE? <DATVAL .NUM> AC> <MUNG-AC <DATVAL .NUM> .NUM>>
+ <EMIT <INSTRUCTION <COND (.ABSFLG `MOVMS ) (ELSE `MOVNS )>
+ !<ADDR:VALUE .NUM>>>)
+ (ELSE <PUT <3 .TRANSFORM> 1 1>)>
+ <MOVE:ARG .NUM .W>)
+ (<AND .TRIN <NOT <0? <1 .TRIN>>>>
+ <PUT <3 .TRANSFORM> 1 1>
+ <MOVE:ARG .NUM .W>)
+ (ELSE
+ <COND (<SET T2
+ <OR <ISTYPE? <DATTYP .NUM>> <ISTYPE? <RESULT-TYPE .K1>>>>
+ <SET TEM <REG? .T2 .W T>>)
+ (ELSE
+ <SET TEM <REG? TUPLE .W T>>
+ <COND (<AND <NOT <==? <DATVAL .TEM> <DATTYP .NUM>>>
+ <==? <DATVAL .NUM> <DATTYP .TEM>>>
+ <MUNG-AC <DATVAL .TEM> .TEM>
+ <EMIT <INSTRUCTION <COND (.ABSFLG `MOVM ) (ELSE `MOVN )>
+ <ACSYM <DATVAL .TEM>>
+ !<ADDR:VALUE .NUM>>>
+ <RET-TMP-AC <DATVAL .NUM> .NUM>
+ <SET DONE T>)>
+ <COND (<==? <DATTYP .TEM> ANY-AC>
+ <PUT .TEM ,DATTYP <GETREG .TEM>>)
+ (<TYPE? <DATTYP .TEM> AC> <SGETREG <DATTYP .TEM> .TEM>)>
+ <MOVE:TYP <DATTYP .NUM> <DATTYP .TEM>>)>
+ <RET-TMP-AC .NUM>
+ <PUT <DATVAL .TEM> ,ACLINK (.TEM !<ACLINK <DATVAL .TEM>>)>
+ <COND (<NOT .DONE>
+ <MUNG-AC <DATVAL .TEM> .TEM>
+ <EMIT <INSTRUCTION <COND (.ABSFLG `MOVM ) (ELSE `MOVN )>
+ <ACSYM <DATVAL .TEM>>
+ !<ADDR:VALUE .NUM>>>)>
+ <MOVE:ARG .TEM .W>)>>
+
+<DEFINE MOD-GEN (N W
+ "AUX" (N1 <GEN <1 <KIDS .N>> DONT-CARE>) NN
+ (N2 <GEN <SET NN <2 <KIDS .N>>> DONT-CARE>) TEM T1 TT
+ (ACE ,LAST-AC) (ACD ,LAST-AC-1))
+ #DECL ((N) NODE (N1 N2) DATUM (ACE ACD TT T1) AC)
+ <COND
+ (<AND <==? <NODE-TYPE .NN> ,QUOTE-CODE>
+ <POPWR2 <NODE-NAME .NN>>>
+ <SET N1 <MOVE:ARG .N1 <REG? FIX .W>>>
+ <MUNG-AC <DATVAL .N1> .N1>
+ <IMCHK '(`AND `ANDI )
+ <ACSYM <DATVAL .N1>>
+ <REFERENCE:ADR <- <NODE-NAME .NN> 1>>>)
+ (ELSE
+ <PROG ()
+ <COND (<AC+1OK? <SET TEM <DATVAL .N1>>> <SET T1 .TEM>)
+ (<SET TEM <GET2REG>>
+ <SET N1 <MOVE:ARG .N1 <DATUM FIX <SET T1 .TEM>>>>)
+ (<TYPE? <SET TEM <DATVAL .N1>> AC>
+ <COND (<==? <SET T1 .TEM> .ACE>
+ <SET N1 <MOVE:ARG .N1 <DATUM FIX <SGETREG .ACD <>>>>>
+ <SET T1 .ACD>)
+ (ELSE <SGETREG <NTH ,ALLACS <+ <ACNUM .T1> 1>> <>>)>)
+ (ELSE
+ <SET TEM <ACPROT .ACE>>
+ <PUT .ACE ,ACPROT T>
+ <TOACV .N1>
+ <PUT .ACE ,ACPROT .TEM>
+ <AGAIN>)>
+ <PUT <SET TT <NTH ,ALLACS <+ <ACNUM .T1> 1>>> ,ACPROT T>
+ <MUNG-AC .T1 .N1>
+ <PUT .TT ,ACPROT <>>
+ <AND <ACLINK .T1> <RET-TMP-AC .T1 .N1>>
+ <RET-TMP-AC <DATTYP .N1> .N1>
+ <PUT .N1 ,DATTYP FIX>
+ <PUT .N1 ,DATVAL <SET TT <NTH ,ALLACS <+ <ACNUM .T1> 1>>>>
+ <MUNG-AC <PUT .TT ,ACLINK (.N1 !<ACLINK .TT>)> .N1>
+ <PUT .T1 ,ACPROT T>
+ <IMCHK '(`IDIV `IDIVI ) <ACSYM .T1> <DATVAL .N2>>
+ <EMIT <INSTRUCTION `SKIPGE <ADDRSYM .TT>>>
+ <IMCHK '(`ADD `ADDI ) <ACSYM .TT> <DATVAL .N2>>
+ <RET-TMP-AC .N2>
+ <PUT .T1 ,ACPROT <>>>)>
+ <MOVE:ARG .N1 .W>>
+
+<DEFINE ROT-GEN (N W) <ROT-LSH-GEN .N .W `ROT>>
+
+<DEFINE LSH-GEN (N W) <ROT-LSH-GEN .N .W `LSH>>
+
+<DEFINE ROT-LSH-GEN (N W INS
+ "AUX" (K <KIDS .N>) (A1 <1 .K>) (A2 <2 .K>) W1 W2 AC1)
+ #DECL ((N A1 A2) NODE (K) <LIST [2 NODE]> (W1 W2) DATUM (AC1) AC)
+ <COND (<==? <NODE-TYPE .A2> ,QUOTE-CODE> ;" LSH-ROT by fixed amount"
+ <SET W1 <GEN .A1 DONT-CARE>>
+ <TOACV .W1>
+ <RET-TMP-AC <DATTYP .W1> .W1>
+ <PUT .W1 ,DATTYP WORD>
+ <MUNG-AC <DATVAL .W1> .W1>
+ <EMIT <INSTRUCTION .INS <ACSYM <DATVAL .W1>> <NODE-NAME .A2>>>)
+ (ELSE
+ <COND (<AND <MEMQ <NODE-TYPE .A1> ,SNODES>
+ <NOT <MEMQ <NODE-TYPE .A2> ,SNODES>>
+ <NOT <SIDE-EFFECTS .A2>>>
+ <SET W2 <GEN .A2 DONT-CARE>>
+ <SET W1 <GEN .A1 DONT-CARE>>)
+ (ELSE
+ <SET W1 <GEN .A1 DONT-CARE>>
+ <SET W2 <GEN .A2 DONT-CARE>>)>
+ <TOACV .W1>
+ <RET-TMP-AC <DATTYP .W1> .W1>
+ <PUT .W1 ,DATTYP WORD>
+ <SET AC1 <DATVAL .W1>>
+ <PUT .AC1 ,ACPROT T>
+ <TOACV .W2>
+ <PUT .AC1 ,ACPROT <>>
+ <MUNG-AC .AC1 .W1>
+ <EMIT <INSTRUCTION .INS
+ <ACSYM <DATVAL .W1>>
+ (<ADDRSYM <CHTYPE <DATVAL .W2> AC>>)>>
+ <RET-TMP-AC .W2>)>
+ <MOVE:ARG .W1 .W>>
+
+<DEFINE FLOAT-GEN (N W
+ "AUX" (NUM <1 <KIDS .N>>) TEM1 (RT <RESULT-TYPE .NUM>) BR
+ TEM)
+ #DECL ((N NUM) NODE (TEM TEM1) DATUM (BR) ATOM)
+ <COND (<==? .RT FLOAT>
+ <MESSAGE WARNING "UNECESSARY FLOAT ">
+ <GEN .NUM .W>)
+ (<==? <ISTYPE? .RT> FIX>
+ <SET TEM <GEN-FLOAT <GEN .NUM <GOODACS .N .W>>>>
+ <RET-TMP-AC <DATTYP .TEM> .TEM>
+ <PUT .TEM ,DATTYP FLOAT>
+ <MOVE:ARG .TEM .W>)
+ (ELSE
+ <SET TEM <GEN .NUM DONT-CARE>>
+ <EMIT <INSTRUCTION GETYP!-OP `O* !<ADDR:TYPE .TEM>>>
+ <RET-TMP-AC <DATTYP <SET TEM <MOVE:ARG .TEM <REG? FLOAT .W>>>>
+ .TEM>
+ <PUT .TEM ,DATTYP FLOAT>
+ <SET TEM1 <DATUM !.TEM>>
+ <MOVE:ARG <GEN-FLOAT .TEM <SET BR <MAKE:TAG>>> .TEM1>
+ <LABEL:TAG .BR>
+ <MOVE:ARG .TEM1 .W>)>>
+
+<DEFINE FIX-GEN (N W
+ "AUX" (NUM <1 <KIDS .N>>) (RT <RESULT-TYPE .NUM>) TEM TEM1 BR)
+ #DECL ((N NUM) NODE (TEM TEM1) DATUM (BR) ATOM)
+ <COND (<==? <ISTYPE? .RT> FIX>
+ <MESSAGE WARNING "UNECESSARY FIX ">
+ <GEN .NUM .W>)
+ (<==? .RT FLOAT>
+ <SET TEM <GEN-FIX <GEN .NUM DONT-CARE>>>
+ <RET-TMP-AC <DATTYP .TEM> .TEM>
+ <PUT .TEM ,DATTYP FIX>
+ <MOVE:ARG .TEM .W>)
+ (ELSE
+ <SET TEM <GEN .NUM DONT-CARE>>
+ <EMIT <INSTRUCTION GETYP!-OP `O* !<ADDR:TYPE .TEM>>>
+ <RET-TMP-AC <DATTYP <SET TEM <MOVE:ARG .TEM <REG? FIX .W>>>>
+ .TEM>
+ <PUT .TEM ,DATTYP FIX>
+ <SET TEM1 <DATUM !.TEM>>
+ <MOVE:ARG <GEN-FIX .TEM <SET BR <MAKE:TAG>>> .TEM1>
+ <LABEL:TAG .BR>
+ <MOVE:ARG .TEM1 .W>)>>
+
+<DEFINE GEN-FLOAT (DAT "OPTIONAL" (BR <>) "AUX" TT T RTM)
+ #DECL ((DAT) DATUM (T) AC)
+ <PROG ()
+ <COND (<AC+1OK? <DATVAL .DAT>>)
+ (<SET TT <GET2REG>>
+ <SET DAT <MOVE:ARG .DAT <DATUM <DATTYP .DAT> .TT>>>)
+ (<TYPE? <DATVAL .DAT> AC>
+ <EMIT <INSTRUCTION `PUSH `P* <ADDRSYM <DATVAL .DAT>> 1>>
+ <SET RTM T>)
+ (ELSE <TOACV .DAT> <AGAIN>)>
+ <SET T <DATVAL .DAT>>
+ <OR <ASSIGNED? RTM>
+ <PUT <NTH ,ALLACS <+ <ACNUM .T> 1>> ,ACPROT T>>
+ <MUNG-AC .T .DAT>
+ <AND <NOT <ASSIGNED? RTM>>
+ <PUT <NTH ,ALLACS <+ <ACNUM .T> 1>> ,ACPROT <>>
+ <MUNG-AC <NTH ,ALLACS <+ <ACNUM .T> 1>>>>
+ <COND (.BR
+ <EMIT <INSTRUCTION `CAIE `O* '<TYPE-CODE!-OP!-PACKAGE FIX>>>
+ <BRANCH:TAG .BR>)>
+ <EMIT <INSTRUCTION `IDIVI <ACSYM .T> 131072>>
+ <EMIT <INSTRUCTION `FSC <ACSYM .T> 172>>
+ <EMIT <INSTRUCTION `FSC <AC1SYM .T> 155>>
+ <EMIT <INSTRUCTION `FADR <ACSYM .T> <ACNUM .T> 1>>
+ <AND <ASSIGNED? RTM>
+ <EMIT <INSTRUCTION `POP `P* <ADDRSYM .T> 1>>>
+ .DAT>>
+
+<DEFINE GEN-FIX (DAT "OPTIONAL" (BR <>) "AUX" TEM TT (ACE ,LAST-AC)
+ (ACD ,LAST-AC-1) T1 NXTAC)
+ #DECL ((DAT) DATUM (ACE ACD TT TEM) AC)
+ <PROG ()
+ <COND (<AC+1OK? <SET T1 <DATVAL .DAT>>> <SET TEM .T1>)
+ (<SET T1 <GET2REG>>
+ <SET DAT <MOVE:ARG .DAT <DATUM FIX <SET TEM .T1>>>>)
+ (<TYPE? <SET T1 <DATVAL .DAT>> AC>
+ <COND (<==? <SET TEM .T1> .ACE>
+ <MOVE:ARG .DAT
+ <DATUM FIX <SET TEM <SGETREG .ACD <>>>>>)
+ (ELSE
+ <SGETREG <NTH ,ALLACS <+ <ACNUM .TEM> 1>> <>>)>)
+ (ELSE
+ <SET T1 <ACPROT .ACE>>
+ <PUT .ACE ,ACPROT T>
+ <TOACV .DAT>
+ <PUT .ACE ,ACPROT .T1>
+ <AGAIN>)>
+ <PUT <SET NXTAC <NTH ,ALLACS <+ <ACNUM .TEM> 1>>>
+ ,ACPROT
+ T>
+ <MUNG-AC .TEM .DAT>
+ <PUT .NXTAC ,ACPROT <>>
+ <AND <ACLINK .TEM> <RET-TMP-AC .TEM .DAT>>
+ <RET-TMP-AC <DATTYP .DAT> .DAT>
+ <PUT .DAT ,DATTYP FIX>
+ <PUT .DAT ,DATVAL <SET TT .NXTAC>>
+ <MUNG-AC <PUT .TT ,ACLINK (.DAT !<ACLINK .TT>)> .DAT>
+ <COND (.BR
+ <EMIT '<`CAIE 0 <TYPE-CODE!-OP!-PACKAGE FLOAT>>>
+ <BRANCH:TAG .BR>)>
+ <EMIT <INSTRUCTION `MULI <ACSYM .TEM> 256>>
+ <EMIT <INSTRUCTION `TSC <ACSYM .TEM> <ADDRSYM .TEM>>>
+ <EMIT <INSTRUCTION `ASH <ACSYM .TT> (<ADDRSYM .TEM>) -163>>
+ .DAT>>
+
+<DEFINE FLOP (SUBR)
+ #DECL ((SUBR VALUE) ATOM)
+ <1 <REST <MEMQ .SUBR
+ '![G? L? G? G=? L=? G=? ==? ==? N==? N==? 1? -1? 1? 0?
+ 0?!]>>>>
+
+<DEFINE FLIP (SUBR "AUX" N)
+ #DECL ((N) FIX (SUBR VALUE) ATOM)
+ <NTH ,0SUBRS
+ <- 13
+ <SET N <LENGTH <MEMQ .SUBR ,0SUBRS>>>
+ <COND (<0? <MOD .N 2>> -1) (ELSE 1)>>>>
+
+<SETG 0SUBRS ![1? N1? -1? N-1? 0? N0? G? L=? L? G=? ==? N==?!]>
+
+<DEFINE PRED? (N) #DECL ((N) FIX) <1? <NTH ,PREDV .N>>>
+
+<DEFINE PRED:BRANCH:GEN (TAG NOD TF
+ "OPTIONAL" (WHERE FLUSHED) (NF <>)
+ "AUX" TT
+ (W2
+ <COND (<==? .WHERE FLUSHED> DONT-CARE)
+ (<AND <TYPE? .WHERE DATUM>
+ <ISTYPE? <DATTYP .WHERE>>>
+ <DATUM ANY-AC <DATVAL .WHERE>>)
+ (ELSE .WHERE)>) TAG2)
+ #DECL ((NOD) NODE (TT) DATUM)
+ <COND (<==? <RESULT-TYPE .NOD> NO-RETURN>
+ <GEN .NOD FLUSHED>
+ ,NO-DATUM)
+ (<PRED? <NODE-TYPE .NOD>>
+ <APPLY <NTH ,GENERATORS <NODE-TYPE .NOD>>
+ .NOD
+ .WHERE
+ .NF
+ .TAG
+ .TF>)
+ (.NF
+ <SET TT <GEN .NOD DONT-CARE>>
+ <VAR-STORE <>>
+ <COND (<==? .WHERE FLUSHED>
+ <D:B:TAG .TAG .TT <NOT .TF> <RESULT-TYPE .NOD>>
+ <RET-TMP-AC .TT>)
+ (<D:B:TAG <SET TAG2 <MAKE:TAG>> .TT .TF <RESULT-TYPE .NOD>>
+ <RET-TMP-AC .TT>
+ <SET TT <MOVE:ARG <REFERENCE .TF> .WHERE>>
+ <BRANCH:TAG .TAG>
+ <LABEL:TAG .TAG2>
+ .TT)>)
+ (ELSE
+ <SET TT <GEN .NOD .W2>>
+ <VAR-STORE <>>
+ <D:B:TAG .TAG .TT .TF <RESULT-TYPE .NOD>>
+ <MOVE:ARG .TT .WHERE>)>>
+
+<DEFINE LN-LST (N)
+ #DECL ((N) NODE)
+ <AND <==? <NODE-TYPE .N> ,LNTH-CODE>
+ <==? <STRUCTYP <RESULT-TYPE <1 <KIDS .N>>>> LIST>>>
+
+<DEFINE 0-TEST (NOD WHERE
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
+ "AUX" (REG ,NO-DATUM) (NN <1 <KIDS .NOD>>)
+ (TRANSFORM
+ <MAKE-TRANS .NOD 1 1 0 1 1 1 <SW? <NODE-NAME .NOD>>>))
+ #DECL ((TRANSFORM) <SPECIAL TRANS> (NOD NN) NODE (REG) DATUM)
+ <OR <LN-LST .NN> <SET REG <GEN .NN DONT-CARE>>>
+ <TEST-DISP .NOD
+ .WHERE
+ .NOTF
+ .BRANCH
+ .DIR
+ .REG
+ <DO-TRANS 0 .TRANSFORM>
+ <NOT <0? <1 <3 .TRANSFORM>>>>>>
+
+<DEFINE SW? (SBR)
+ #DECL ((SBR) ATOM)
+ <COND (<MEMQ .SBR '![0? N0? 1? -1? N1? N-1? ==? N==?!]> 0)
+ (ELSE 1)>>
+
+<DEFINE MAKE-TRANS (N NEG +- +-V */ */V HW SW)
+ #DECL ((N) NODE (NEG +- +-V */ */V HW SW) FIX)
+ <CHTYPE [.N ![.NEG .+- .+-V .*/ .*/V .HW .SW!] <IUVECTOR 7 0>]
+ TRANS>>
+
+<DEFINE DO-TRANS (N TR "AUX" (X <3 .TR>) (NN <NODE-NAME <1 .TR>>))
+ #DECL ((TR) TRANS (N) FIX (X) <UVECTOR [7 FIX]>)
+ <COND (<AND <NOT <0? .N>> <NOT <0? <6 .X>>> <NOT <0? <7 .X>>>>
+ <COND (<==? .NN G?> <SET N <- .N 1>>)
+ (<==? .NN L=?> <SET N <- .N 1>>)>)>
+ <COND (<NOT <0? <1 .X>>> <SET N <- .N>>)>
+ <COND (<NOT <0? <2 .X>>> <SET N <+ .N <3 .X>>>)>
+ <COND (<G? <4 .X> 2> <SET N </ .N <5 .X>>>)
+ (<NOT <0? <4 .X>>> <SET N <* .N <5 .X>>>)>
+ <COND (<NOT <0? <6 .X>>>
+ <SET N <CHTYPE <ANDB .N 262143> FIX>>
+ <COND (<NOT <0? <7 .X>>>
+ <SET N <CHTYPE <PUTBITS 0 <BITS 18 18> .N> FIX>>)>)>
+ .N>
+
+<DEFINE UPDATE-TRANS (NOD TR "AUX" (X <3 .TR>) FLG)
+ #DECL ((TR) TRANS)
+ <MAKE-TRANS .NOD
+ <COND (<NOT <0? <1 .X>>> 2) (ELSE 0)>
+ <COND (<SET FLG <NOT <0? <2 .X>>>> 2) (ELSE 0)>
+ <COND (.FLG <3 .X>) (ELSE 0)>
+ <COND (<SET FLG <G? <4 .X> 2>> 4)
+ (<SET FLG <NOT <0? <4 .X>>>> 2)
+ (ELSE 0)>
+ <COND (.FLG <5 .X>) (ELSE 1)>
+ <COND (<NOT <0? <6 .X>>> 2) (ELSE 0)>
+ <COND (<NOT <0? <7 .X>>> 2) (ELSE 0)>>>
+
+<DEFINE TEST-DISP (N W NF BR DI REG NUM NEG)
+ #DECL ((NUM) <OR FIX FLOAT> (N) NODE)
+ <COND (<==? .REG ,NO-DATUM>
+ <LIST-LNT-SPEC .N .W .NF .BR .DI .NUM>)
+ (<0? .NUM> <0-TEST1 .N .W .NF .BR .DI .REG .NEG>)
+ (<AND <OR <1? .NUM> <==? .NUM -1>>
+ <OR <==? <NODE-NAME .N> 1?>
+ <==? <ISTYPE? <RESULT-TYPE <1 <KIDS .N>>>> FIX>>>
+ <COND (<==? .NUM -1> <SET NEG T>)>
+ <1?-TEST .N .W .NF .BR .DI .REG .NEG>)
+ (ELSE <TEST-GEN2 .N .W .NF .BR .DI .REG .NUM .NEG>)>>
+
+<DEFINE 0-TEST1 (NOD WHERE NOTF BRANCH DIR REG NEG
+ "AUX" (SBR <NODE-NAME .NOD>) B2 (RW .WHERE)
+ (ARG <1 <KIDS .NOD>>) (SDIR .DIR)
+ (ATYP <ISTYPE? <RESULT-TYPE .ARG>>) (LDAT <>) S TT)
+ #DECL ((NOD ARG) NODE (REG) DATUM (LDAT) <OR FALSE DATUM> (S) SYMTAB)
+ <SET WHERE <UPDATE-WHERE .NOD .WHERE>>
+ <COND (.NEG
+ <COND (<==? <NODE-TYPE .NOD> ,0-TST-CODE> <SET SBR <FLOP .SBR>>)
+ (ELSE
+ <COND (<SET TT <MEMQ .SBR '![G? G=? G? L? L=? L?!]>>
+ <SET SBR <2 .TT>>)>)>)>
+ <COND (<AND <NOT <TYPE? <DATVAL .REG> AC>>
+ .ATYP
+ <==? <NODE-TYPE .ARG> ,LVAL-CODE>
+ <STORED <SET S <NODE-NAME .ARG>>>
+ <NOT <INACS .S>>
+ <OR <SPEC-SYM .S> <2 <TYPE-INFO .ARG>>>
+ <G? <FREE-ACS T> 0>>
+ <SET LDAT <DATUM .ATYP <GETREG <>>>>
+ <PUT .S ,INACS .LDAT>
+ <PUT <DATVAL .LDAT> ,ACRESIDUE (.S)>)>
+ <COND (.BRANCH
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <AND .DIR <SET SBR <FLIP .SBR>>>
+ <VAR-STORE <>>
+ <COND (<==? .RW FLUSHED>
+ <ZER-JMP .SBR .REG .BRANCH .LDAT>
+ <RET-TMP-AC .REG>)
+ (ELSE
+ <SET B2 <MAKE:TAG>>
+ <SET SBR <FLIP .SBR>>
+ <ZER-JMP .SBR .REG .B2 .LDAT>
+ <RET-TMP-AC .REG>
+ <SET RW
+ <MOVE:ARG <MOVE:ARG <REFERENCE .SDIR> .WHERE> .RW>>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B2>
+ .RW)>)
+ (ELSE
+ <AND .NOTF <SET SBR <FLIP .SBR>>>
+ <VAR-STORE <>>
+ <AND <TYPE? .WHERE ATOM> <SET WHERE <ANY2ACS>>>
+ <ZER-JMP .SBR .REG <SET BRANCH <MAKE:TAG>> .LDAT>
+ <RET-TMP-AC .REG>
+ <MOVE:ARG <REFERENCE T> .WHERE>
+ <RET-TMP-AC .WHERE>
+ <BRANCH:TAG <SET B2 <MAKE:TAG>>>
+ <LABEL:TAG .BRANCH>
+ <MOVE:ARG <REFERENCE <>> .WHERE>
+ <LABEL:TAG .B2>
+ <MOVE:ARG .WHERE .RW>)>>
+
+<DEFINE ZER-JMP (SBR REG BR LDAT "AUX" TEM)
+ #DECL ((REG) DATUM (LDAT) <OR FALSE DATUM>)
+ <COND (<TYPE? <SET TEM <DATVAL .REG>> AC>
+ <EMIT <INSTRUCTION <NTH ,0JMPS <LENGTH <MEMQ .SBR ,0SUBRS>>>
+ <ACSYM .TEM>
+ .BR>>)
+ (ELSE
+ <EMIT <INSTRUCTION <NTH ,0SKPS <LENGTH <MEMQ .SBR ,0SUBRS>>>
+ <COND (.LDAT <ACSYM <DATVAL .LDAT>>) (ELSE 0)>
+ !<ADDR:VALUE .REG>>>
+ <BRANCH:TAG .BR>)>>
+
+<SETG 0SKPS
+ ![`SKIPN `SKIPE `SKIPGE `SKIPL `SKIPLE `SKIPG `SKIPN `SKIPE !]>
+
+<SETG 0JMPS
+ ![`JUMPE `JUMPN `JUMPL `JUMPGE `JUMPG `JUMPLE `JUMPE `JUMPN !]>
+
+<DEFINE 1?-GEN (NOD WHERE
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
+ "AUX" (REG ,NO-DATUM) (NN <1 <KIDS .NOD>>)
+ (TRANSFORM
+ <MAKE-TRANS .NOD 1 2 -1 1 1 1 <SW? <NODE-NAME .NOD>>>))
+ #DECL ((NOD NN) NODE (REG) DATUM (TRANSFORM) <SPECIAL TRANS>)
+ <OR <LN-LST .NN> <SET REG <GEN .NN DONT-CARE>>>
+ <TEST-DISP .NOD
+ .WHERE
+ .NOTF
+ .BRANCH
+ .DIR
+ .REG
+ <DO-TRANS 1 .TRANSFORM>
+ <NOT <0? <1 <3 .TRANSFORM>>>>>>
+
+<DEFINE 1?-TEST (NOD WHERE NOTF BRANCH DIR REG NEG
+ "AUX" (SBR <NODE-NAME .NOD>) B2 (RW .WHERE) (K <1 <KIDS .NOD>>)
+ (SDIR .DIR) (NM <>) (ATYP <ISTYPE? <RESULT-TYPE .K>>)
+ (RFLG <MEMQ .ATYP ![FIX FLOAT!]>) (SDIR .DIR))
+ #DECL ((NOD K) NODE (REG) DATUM)
+ <SET REG
+ <MOVE:ARG .REG <DATUM <COND (.ATYP) (ELSE ANY-AC)> ANY-AC>>>
+ <SET NM <ACRESIDUE <DATVAL .REG>>>
+ <SET WHERE <UPDATE-WHERE .NOD .WHERE>>
+ <COND (.BRANCH
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <COND (<AND .CAREFUL <NOT .RFLG>> <CFFLARG .REG>)>
+ <VAR-STORE <>>
+ <COND (<==? .RW FLUSHED>
+ <COND (.RFLG
+ <GEN-COMP .ATYP
+ .REG
+ .DIR
+ .BRANCH
+ .SBR
+ .NEG
+ .NM>)
+ (ELSE
+ <GENFLOAT .REG .DIR .BRANCH .NEG>
+ <GEN-COMP FIX .REG .DIR .BRANCH .SBR .NEG .NM>)>
+ <RET-TMP-AC .REG>)
+ (ELSE
+ <SET B2 <MAKE:TAG>>
+ <COND (.RFLG
+ <GEN-COMP .ATYP
+ .REG
+ <NOT .DIR>
+ .B2
+ .SBR
+ .NEG
+ .NM>)
+ (ELSE
+ <GENFLOAT .REG <NOT .DIR> .B2 .NEG>
+ <GEN-COMP FIX .REG <NOT .DIR> .B2 .SBR .NEG .NM>)>
+ <RET-TMP-AC .REG>
+ <SET RW
+ <MOVE:ARG <MOVE:ARG <REFERENCE .SDIR> .WHERE> .RW>>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B2>
+ .RW)>)
+ (ELSE
+ <COND (<AND .CAREFUL <NOT .RFLG>> <CFFLARG .REG>)>
+ <VAR-STORE <>>
+ <AND <TYPE? .WHERE ATOM> <SET WHERE <ANY2ACS>>>
+ <COND (.RFLG
+ <GEN-COMP .ATYP
+ .REG
+ .NOTF
+ <SET BRANCH <MAKE:TAG>>
+ .SBR
+ .NEG
+ .NM>)
+ (ELSE
+ <GENFLOAT .REG .NOTF <SET BRANCH <MAKE:TAG>> .NEG>
+ <GEN-COMP FIX .REG .NOTF .BRANCH .SBR .NEG .NM>)>
+ <RET-TMP-AC .REG>
+ <MOVE:ARG <REFERENCE T> .WHERE>
+ <RET-TMP-AC .WHERE>
+ <BRANCH:TAG <SET B2 <MAKE:TAG>>>
+ <LABEL:TAG .BRANCH>
+ <MOVE:ARG <REFERENCE <>> .WHERE>
+ <LABEL:TAG .B2>
+ <MOVE:ARG .WHERE .RW>)>>
+
+<SETG AOJS
+ ![`AOJL `AOJLE `AOJG `AOJGE `AOJE `AOJN `AOJE `AOJN `AOJE
+`AOJN `AOJE `AOJN !]>
+
+<SETG SOJS
+ ![`SOJL `SOJLE `SOJG `SOJGE `SOJE `SOJN `SOJE `SOJN `SOJE
+`SOJN `SOJE `SOJN !]>
+
+<DEFINE GEN-COMP (TYP REG DIR BR SBR NEG NM)
+ #DECL ((REG) <DATUM ANY AC> (TYP BR) ATOM)
+ <COND
+ (<==? <ISTYPE? .TYP> FIX>
+ <AND .DIR <SET SBR <FLIP .SBR>>>
+ <COND (.NM
+ <EMIT <INSTRUCTION
+ <NTH <NTH ,SKIPS <LENGTH <MEMQ .SBR ,CMSUBRS>>>
+ <COND (.NEG 1) (ELSE 2)>>
+ <ACSYM <DATVAL .REG>>
+ <COND (.NEG '[-1]) (ELSE 1)>>>
+ <BRANCH:TAG .BR>)
+ (ELSE
+ <MUNG-AC <DATVAL .REG> .REG>
+ <EMIT <INSTRUCTION <NTH <COND (.NEG ,AOJS) (ELSE ,SOJS)>
+ <LENGTH <MEMQ .SBR ,CMSUBRS>>>
+ <ACSYM <DATVAL .REG>>
+ .BR>>)>)
+ (ELSE
+ <EMIT <INSTRUCTION <COND (.DIR `CAMN ) (ELSE `CAME )>
+ <ACSYM <DATVAL .REG>>
+ <COND (.NEG '[-1.0]) (ELSE '[1.0])>>>
+ <BRANCH:TAG .BR>)>>
+
+<DEFINE GENFLOAT (REG DIR BR NEG)
+ <EMIT <INSTRUCTION <COND (<NOT .DIR> `CAME ) (ELSE `CAMN )>
+ <ACSYM <DATVAL .REG>>
+ <COND (.NEG '[-1.0]) (ELSE '[1.0])>>>
+ <COND (.DIR <BRANCH:TAG .BR>)>>
+
+<DEFINE CFFLARG (DAT "AUX" (LABGOOD <MAKE:TAG>))
+ #DECL ((DAT) DATUM (LABGOOD) ATOM)
+ <EMIT <INSTRUCTION GETYP!-OP `O* !<ADDR:TYPE .DAT>>>
+ <EMIT <INSTRUCTION `CAIE `O* '<TYPE-CODE!-OP!-PACKAGE FLOAT>>>
+ <EMIT <INSTRUCTION `CAIN `O* '<TYPE-CODE!-OP!-PACKAGE FIX>>>
+ <DATTYP-FLUSH .DAT>
+ <BRANCH:TAG .LABGOOD>
+ <BRANCH:TAG |COMPERR>
+ <LABEL:TAG .LABGOOD>>
+
+<DEFINE TEST-GEN (NOD WHERE
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
+ "AUX" (K <1 <KIDS .NOD>>) (K2 <2 <KIDS .NOD>>) REGT REGT2
+ (S <SW? <NODE-NAME .NOD>>) TRANSFORM ATYP ATYP2 B2
+ (SDIR .DIR) (RW .WHERE) TRANS1 (FLS <==? .RW FLUSHED>)
+ TEM (ONO .NO-KILL) (NO-KILL .ONO)
+ "ACT" TA)
+ #DECL ((NOD K K2) NODE (REGT) DATUM (TRANSFORM) <SPECIAL TRANS>
+ (TRANS1) TRANS (NO-KILL) <SPECIAL LIST>)
+ <SET WHERE
+ <COND (<==? .WHERE FLUSHED> FLUSHED)
+ (ELSE <UPDATE-WHERE .NOD .WHERE>)>>
+ <COND (<OR <==? <NODE-TYPE .K2> ,QUOTE-CODE>
+ <AND <NOT <MEMQ <NODE-TYPE .K> ,SNODES>>
+ <NOT <SIDE-EFFECTS .NOD>>
+ <MEMQ <NODE-TYPE .K2> ,SNODES>>>
+ <COND (<AND <==? <NODE-TYPE .K> ,LVAL-CODE>
+ <COND (<==? <LENGTH <SET TEM <TYPE-INFO .K>>> 2> <2 .TEM>)
+ (ELSE T)>
+ <SET TEM <NODE-NAME .K>>
+ <NOT <MAPF <>
+ <FUNCTION (LL)
+ <AND <==? <1 .LL> .TEM> <MAPLEAVE>>>
+ .NO-KILL>>>
+ <SET NO-KILL ((<NODE-NAME .K> <>) !.NO-KILL)>)>
+ <SET K .K2>
+ <SET K2 <1 <KIDS .NOD>>>
+ <PUT .NOD ,NODE-NAME <FLOP <NODE-NAME .NOD>>>)>
+ <SET ATYP <ISTYPE? <RESULT-TYPE .K2>>>
+ <SET ATYP2 <ISTYPE-GOOD? <RESULT-TYPE .K>>>
+ <SET REGT
+ <DATUM <COND (.ATYP .ATYP) (ELSE ANY-AC)> ANY-AC>>
+ <SET REGT2
+ <COND (<OR <==? <NODE-TYPE .K> ,QUOTE-CODE>
+ <NOT <SIDE-EFFECTS .K2>>>
+ DONT-CARE)
+ (.ATYP2 <DATUM .ATYP2 ANY-AC>)
+ (ELSE <DATUM ANY-AC ANY-AC>)>>
+ <COND (<N==? <NODE-TYPE .K> ,QUOTE-CODE>
+ <COND (<OR <==? .ATYP FLOAT> <==? .ATYP2 FLOAT>>)
+ (ELSE
+ <SET TRANSFORM <MAKE-TRANS .NOD 1 1 0 1 1 <+ 2 <- .S>> .S>>
+ <PUT <2 .TRANSFORM> 6 1>
+ <PUT <2 .TRANSFORM> 7 0>)>
+ <SET REGT2 <GEN .K .REGT2>>
+ <COND (<ASSIGNED? TRANSFORM>
+ <SET TRANS1 .TRANSFORM>
+ <SET TRANSFORM <UPDATE-TRANS .NOD .TRANS1>>)>
+ <COND (<TYPE? <DATVAL .REGT2> AC>
+ <SET REGT <GEN .K2 DONT-CARE>>
+ <COND (<TYPE? <DATVAL .REGT2> AC>
+ <PUT .NOD ,NODE-NAME <FLOP <NODE-NAME .NOD>>>
+ <SET TEM .REGT>
+ <SET REGT .REGT2>
+ <SET REGT2 .TEM>
+ <COND (<ASSIGNED? TRANSFORM>
+ <SET TEM .TRANS1>
+ <SET TRANS1 .TRANSFORM>
+ <SET TRANSFORM .TEM>)>
+ <SET TEM .ATYP>
+ <SET ATYP .ATYP2>
+ <SET ATYP2 .TEM>)
+ (ELSE <TOACV .REGT>)>)
+ (ELSE <SET REGT <GEN .K2 .REGT>>)>)
+ (ELSE
+ <COND (<OR <==? .ATYP FIX>
+ <0? <NODE-NAME .K>>
+ <1? <NODE-NAME .K>>>
+ <SET TRANSFORM <MAKE-TRANS .NOD 1 1 0 1 1 <+ 2 <- .S>> .S>>)>
+ <COND (<==? .ATYP FIX>
+ <PUT <PUT <2 .TRANSFORM> 2 1> 3 <FIX <NODE-NAME .K>>>)>
+ <COND (<LN-LST .K2> <SET REGT ,NO-DATUM>)
+ (ELSE
+ <SET REGT <GEN .K2 .REGT>>
+ <DATTYP-FLUSH .REGT>
+ <PUT .REGT ,DATTYP .ATYP>)>
+ <RETURN
+ <TEST-DISP .NOD
+ .WHERE
+ .NOTF
+ .BRANCH
+ .DIR
+ .REGT
+ <COND (<ASSIGNED? TRANSFORM>
+ <DO-TRANS <FIX <NODE-NAME .K>> .TRANSFORM>)
+ (ELSE <NODE-NAME .K>)>
+ <AND <ASSIGNED? TRANSFORM> <NOT <0? <1 <3 .TRANSFORM>>>>>>
+ .TA>)>
+ <DELAY-KILL .NO-KILL .ONO>
+ <AND <ASSIGNED? TRANSFORM>
+ <CONFORM .REGT .REGT2 .TRANSFORM .TRANS1>
+ <PUT .NOD ,NODE-NAME <FLOP <NODE-NAME .NOD>>>>
+ <COND (.BRANCH
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <VAR-STORE <>>
+ <GEN-COMP2 <NODE-NAME .NOD>
+ .ATYP2
+ .ATYP
+ .REGT2
+ .REGT
+ <COND (.FLS .DIR) (ELSE <NOT .DIR>)>
+ <COND (.FLS .BRANCH) (ELSE <SET B2 <MAKE:TAG>>)>>
+ <COND (<NOT .FLS>
+ <SET RW <MOVE:ARG <MOVE:ARG <REFERENCE .SDIR> .WHERE> .RW>>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B2>
+ .RW)>)
+ (ELSE
+ <VAR-STORE <>>
+ <GEN-COMP2 <NODE-NAME .NOD>
+ .ATYP2
+ .ATYP
+ .REGT2
+ .REGT
+ .NOTF
+ <SET BRANCH <MAKE:TAG>>>
+ <MOVE:ARG <REFERENCE T> .WHERE>
+ <RET-TMP-AC .WHERE>
+ <BRANCH:TAG <SET B2 <MAKE:TAG>>>
+ <LABEL:TAG .BRANCH>
+ <MOVE:ARG <REFERENCE <>> .WHERE>
+ <LABEL:TAG .B2>
+ <MOVE:ARG .WHERE .RW>)>>
+
+<DEFINE TEST-GEN2 (NOD WHERE NOTF BRANCH DIR REG NUM NEG
+ "AUX" (SDIR .DIR) (RW .WHERE) (FLS <==? .RW FLUSHED>) B2
+ (SBR <NODE-NAME .NOD>))
+ #DECL ((NOD) NODE (REG) DATUM (NUM) <OR FIX FLOAT>)
+ <SET WHERE
+ <COND (<==? .WHERE FLUSHED> FLUSHED)
+ (ELSE <UPDATE-WHERE .NOD .WHERE>)>>
+ <TOACV .REG>
+ <COND (.BRANCH
+ <COND (.NEG <SET SBR <FLOP .SBR>>)>
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <VAR-STORE <>>
+ <GEN-COMP2 .SBR
+ <TYPE .NUM>
+ <ISTYPE? <DATTYP .REG>>
+ <REFERENCE .NUM>
+ .REG
+ <COND (.FLS .DIR) (ELSE <NOT .DIR>)>
+ <COND (.FLS .BRANCH) (ELSE <SET B2 <MAKE:TAG>>)>>
+ <COND (<NOT .FLS>
+ <SET RW
+ <MOVE:ARG <MOVE:ARG <REFERENCE .SDIR> .WHERE> .RW>>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B2>
+ .RW)>)
+ (ELSE
+ <VAR-STORE <>>
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <COND (.NEG <SET SBR <FLOP .SBR>>)>
+ <GEN-COMP2 .SBR
+ <TYPE .NUM>
+ <ISTYPE? <DATTYP .REG>>
+ <REFERENCE .NUM>
+ .REG
+ .NOTF
+ <SET BRANCH <MAKE:TAG>>>
+ <MOVE:ARG <REFERENCE T> .WHERE>
+ <RET-TMP-AC .WHERE>
+ <BRANCH:TAG <SET B2 <MAKE:TAG>>>
+ <LABEL:TAG .BRANCH>
+ <MOVE:ARG <REFERENCE <>> .WHERE>
+ <LABEL:TAG .B2>
+ <MOVE:ARG .WHERE .RW>)>>
+
+<DEFINE GEN-COMP2 (SB T1 T2 R1 R2 D BR)
+ #DECL ((R1) DATUM (R2) <DATUM ANY AC> (SB T1 T2 BR) ATOM)
+ <AND .D <SET SB <FLIP .SB>>>
+ <COND (<==? .T1 .T2>)
+ (<==? <ISTYPE? .T1> FIX>
+ <DATTYP-FLUSH <SET R1 <GEN-FLOAT .R1>>>
+ <PUT .R1 ,DATTYP FLOAT>)
+ (ELSE
+ <DATTYP-FLUSH <GEN-FLOAT .R2>>
+ <PUT .R2 ,DATTYP FLOAT>)>
+ <OR <TYPE? <DATVAL .R2> AC> <TOACV .R2>>
+ <PUT <DATVAL .R2> ,ACPROT T>
+ <IMCHK <NTH ,SKIPS <LENGTH <MEMQ .SB ,CMSUBRS>>>
+ <ACSYM <DATVAL .R2>>
+ <DATVAL .R1>>
+ <RET-TMP-AC .R1>
+ <RET-TMP-AC .R2>
+ <BRANCH:TAG .BR>>
+
+<DEFINE GET-DF (S)
+ #DECL ((S) ATOM)
+ <NTH '[0 0 1 1 1.7014117E+38 -1.7014117E+38]
+ <LENGTH <MEMQ .S '![MAX MIN * / - +!]>>>>
+
+<SETG CMSUBRS '![0? N0? 1? N1? -1? N-1? ==? N==? G? G=? L? L=?!]>
+
+<SETG SKIPS
+ '![(`CAMGE `CAIGE )
+ (`CAMG `CAIG )
+ (`CAMLE `CAILE )
+ (`CAML `CAIL )
+ (`CAMN `CAIN )
+ (`CAME `CAIE )
+ (`CAMN `CAIN )
+ (`CAME `CAIE )
+ (`CAMN `CAIN )
+ (`CAME `CAIE )
+ (`CAMN `CAIN )
+ (`CAME `CAIE )!]>
+
+<ENDPACKAGE>
--- /dev/null
+<PACKAGE "CASE">
+
+<ENTRY CASE-FCN CASE-GEN>
+
+<USE "PASS1" "CODGEN" "CHKDCL" "CACS" "COMPDEC" "COMCOD">
+
+<SETG PMAX ,NUMPRI!-MUDDLE>
+
+<SETG MAX-DENSE 2>
+
+<NEWTYPE OR LIST>
+
+<FLOAD "PRCOD.NBIN">
+
+<DEFINE CASE-FCN (OBJ AP
+ "AUX" (OP!-PACKAGE .PARENT) (PARENT .PARENT) (FLG T) (WIN T)
+ TYP (DF <>) P TEM X)
+ #DECL ((PARENT) <SPECIAL NODE> (OBJ) <FORM ANY> (VALUE) NODE)
+ <COND
+ (<AND
+ <G? <LENGTH .OBJ> 3>
+ <PROG ()
+ <COND (<AND <TYPE? <SET X <2 .OBJ>> FORM>
+ <==? <LENGTH .X> 2>
+ <==? <1 .X> GVAL>
+ <MEMQ <SET P <2 .X>> '![==? TYPE? PRIMTYPE?!]>>)
+ (ELSE <SET WIN <>>)>
+ 1>
+ <MAPF <>
+ <FUNCTION (O)
+ <COND
+ (<AND .FLG <==? .O DEFAULT>> <SET DF T>)
+ (<AND .DF <TYPE? .O LIST>> <SET DF <>> <SET FLG <>>)
+ (<AND <NOT .DF> <TYPE? .O LIST> <NOT <EMPTY? .O>>>
+ <COND
+ (<SET TEM <VAL-CHK <1 .O>>>
+ <COND (<ASSIGNED? TYP> <OR <==? .TYP <TYPE .TEM>> <SET WIN <>>>)
+ (ELSE <SET TYP <TYPE .TEM>>)>)
+ (<OR <TYPE? <SET TEM <1 .O>> OR>
+ <AND <N==? .P ==?>
+ <TYPE? .TEM SEGMENT>
+ <==? <LENGTH .TEM> 2>
+ <==? <1 .TEM> QUOTE>
+ <NOT <MONAD? <SET TEM <2 .TEM>>>>>>
+ <MAPF <>
+ <FUNCTION (TY)
+ <COND (<NOT <SET TY <VAL-CHK .TY>>> <SET WIN <>>)
+ (ELSE
+ <COND (<ASSIGNED? TYP>
+ <OR <==? .TYP <TYPE .TY>>
+ <SET WIN <>>>)
+ (ELSE <SET TYP <TYPE .TY>>)>)>>
+ .TEM>)
+ (ELSE <SET WIN <>>)>)
+ (ELSE <MAPLEAVE <>>)>
+ T>
+ <REST .OBJ 3>>
+ <NOT .DF>>
+ <COND (<AND .WIN
+ <NOT <OR <AND <==? <TYPEPRIM .TYP> WORD> <==? .P ==?>>
+ <AND <N==? .P ==?> <==? .TYP ATOM>>>>>
+ <SET WIN <>>)>
+ <COND
+ (.WIN
+ <SET PARENT <NODECOND ,CASE-CODE .OP!-PACKAGE <> CASE ()>>
+ <PUT
+ .PARENT
+ ,KIDS
+ (<PCOMP <2 .OBJ> .PARENT>
+ <PCOMP <3 .OBJ> .PARENT>
+ !<MAPF ,LIST
+ <FUNCTION (CLA "AUX" TT)
+ #DECL ((CLA) <OR ATOM LIST> (TT) NODE)
+ <COND (.DF <SET CLA (ELSE !.CLA)>)>
+ <COND
+ (<NOT <TYPE? .CLA ATOM>>
+ <PUT <SET TT <NODEB ,BRANCH-CODE .PARENT <> <> ()>>
+ ,PREDIC
+ <PCOMP <COND (<TYPE? <SET TEM <1 .CLA>> SEGMENT>
+ <FORM QUOTE
+ <MAPF ,LIST ,VAL-CHK <2 .TEM>>>)
+ (<TYPE? .TEM OR>
+ <FORM QUOTE <MAPF ,LIST ,VAL-CHK .TEM>>)
+ (ELSE <VAL-CHK .TEM>)>
+ .TT>>
+ <PUT .TT
+ ,CLAUSES
+ <MAPF ,LIST
+ <FUNCTION (O) <PCOMP .O .TT>>
+ <REST .CLA>>>
+ <SET DF <>>
+ .TT)
+ (ELSE <SET DF T> <PCOMP .CLA .PARENT>)>>
+ <REST .OBJ 3>>)>)
+ (ELSE <PMACRO .OBJ .OP!-PACKAGE>)>)
+ (ELSE <MESSAGE ERROR "BAD CASE USAGE" .OBJ>)>>
+
+<DEFINE VAL-CHK (TEM "AUX" TT)
+ <OR <AND <OR <TYPE? .TEM ATOM> <==? <PRIMTYPE .TEM> WORD>>
+ .TEM>
+ <AND <TYPE? .TEM FORM>
+ <==? <LENGTH .TEM> 2>
+ <OR <AND <==? <1 .TEM> QUOTE> <2 .TEM>>
+ <AND <==? <1 .TEM> GVAL> <MANIFESTQ <2 .TEM>> ,<2 .TEM>>
+ <AND <==? <1 .TEM> ASCII>
+ <TYPE? <2 .TEM> CHARACTER FIX>
+ <EVAL .TEM>>>>
+ <AND <TYPE? .TEM FORM>
+ <==? <LENGTH .TEM> 3>
+ <==? <1 .TEM> CHTYPE>
+ <TYPE? <3 .TEM> ATOM>
+ <NOT <TYPE? <2 .TEM> FORM LIST VECTOR UVECTOR SEGMENT>>
+ <EVAL .TEM>>
+ <AND <TYPE? .TEM FORM>
+ <NOT <EMPTY? .TEM>>
+ <TYPE? <SET TT <1 .TEM>> ATOM>
+ <GASSIGNED? .TT>
+ <TYPE? ,.TT MACRO>
+ <VAL-CHK <EMACRO .TEM>>>>>
+
+<DEFINE EMACRO (OBJ "AUX" (ERR <GET ERROR!-INTERRUPTS INTERRUPT>) TEM)
+ <COND (.ERR <OFF .ERR>)>
+ <ON "ERROR"
+ <FUNCTION (FR "TUPLE" T)
+ <COND (<AND <GASSIGNED? MACACT> <LEGAL? ,MACACT>>
+ <DISMISS [!.T] ,MACACT>)
+ (ELSE <APPLY ,<PARSE "OVALRET!-COMBAT!-"> " ">)>>
+ 100>
+ <COND (<TYPE? <SET TEM
+ <PROG MACACT () #DECL ((MACACT) <SPECIAL ACTIVATION>)
+ <SETG MACACT .MACACT>
+ (<EXPAND .OBJ>)>>
+ VECTOR>
+ <OFF "ERROR">
+ <COND (.ERR <EVENT .ERR>)>
+ <ERROR " MACRO EXPANSION LOSSAGE " !.TEM>)
+ (ELSE <OFF "ERROR"> <AND .ERR <EVENT .ERR>> <1 .TEM>)>>
+
+
+
+<DEFINE DATFIX (W) <COND (<TYPE? .W DATUM> <DATUM !.W>) (ELSE .W)>>
+\f
+<DEFINE CASE-GEN (N W
+ "AUX" (K <KIDS .N>) (P <NODE-NAME <1 <KIDS <1 .K>>>>)
+ (N1 <2 .K>) (SKIP-CH <>) (RW .W) (LNT 0) (DF <>) DN
+ (DFT <MAKE:TAG "CASEDF">) MI MX RNGS W1 (TAGS (X))
+ (TBL <MAKE:TAG "CASETBL">) (ET <MAKE:TAG "CASEND">) NOW
+ DAC TG TT W2 (FIRST T) S1 (S2 ()) TNUM)
+ #DECL ((N DN N1) NODE (P) ATOM (S1) SAVED-STATE
+ (S2) <LIST [REST SAVED-STATE]> (RNGS) UVECTOR)
+ <REGSTO <>>
+ <SET W
+ <COND (<==? .W FLUSHED> FLUSHED) (ELSE <GOODACS .N .W>)>>
+ <PREFER-DATUM .W>
+ <SET W2
+ <GEN .N1
+ <COND (<AND <==? .P ==?> <SET TT <ISTYPE? <RESULT-TYPE .N1>>>>
+ <DATUM .TT ANY-AC>)
+ (ELSE DONT-CARE)>>>
+ <SET K
+ <MAPR ,UVECTOR
+ <FUNCTION (NP "AUX" (N <1 .NP>))
+ #DECL ((N) NODE)
+ <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE>
+ <SET DF T>
+ <MAPRET>)>
+ <COND (.DF <SET DN .N> <SET DF <>> <MAPRET>)>
+ <COND (<==? <RESULT-TYPE .N> FALSE>
+ <MESSAGE NOTE " CASE PHRASE ALWAYS FALSE " .N>
+ <MAPRET>)>
+ <COND (<AND <==? <RESULT-TYPE .N> ATOM>
+ <NOT <EMPTY? <REST .NP>>>>
+ <MESSAGE NOTE
+ " NON REACHABLE CASE CLAUSE(S) "
+ <2 .NP>>
+ (.N () FOO))>
+ (.N () FOO)>
+ <REST .K 2>>>
+ <SET LNT
+ <LENGTH
+ <SET RNGS
+ <MAPF ,UVECTOR
+ <FUNCTION (L "AUX" (N <1 .L>) (NN <NODE-NAME <PREDIC .N>>))
+ #DECL ((N) NODE)
+ <PUT .L 3 <MAKE:TAG "CASE">>
+ <COND
+ (<==? .P ==?>
+ <COND (<TYPE? .NN LIST>
+ <MAPR <> <FUNCTION (L) <PUT .L 1 <FIX <1 .L>>>> .NN>)
+ (ELSE <SET NN <CHTYPE .NN FIX>>)>)
+ (<==? .P TYPE?>
+ <COND (<TYPE? .NN LIST>
+ <MAPR <>
+ <FUNCTION (L "AUX" TT)
+ <COND (<G? <SET TT <CHTYPE <1 .L> FIX>> ,PMAX>
+ <SET SKIP-CH T>)>
+ <PUT .L 1 .TT>>
+ .NN>)
+ (ELSE
+ <COND (<G? <SET NN <CHTYPE <TYPE-C .NN> FIX>> ,PMAX>
+ <SET SKIP-CH T>)>
+ .NN)>)
+ (<TYPE? .NN LIST>
+ <MAPR <>
+ <FUNCTION (L) <PUT .L 1 <CHTYPE <PTYPE-C <1 .L>> FIX>>>
+ .NN>)
+ (ELSE <SET NN <CHTYPE <PTYPE-C .NN> FIX>>)>
+ <COND (<TYPE? .NN LIST> <PUT .L 2 .NN> <MAPRET !.NN>)
+ (ELSE <PUT .L 2 (.NN)> .NN)>>
+ .K>>>>
+ <SORT <> .RNGS>
+ <COND (<L=? .LNT 3> <SET SKIP-CH T>)
+ (<G? <- <SET MX <NTH .RNGS .LNT>> <SET MI <SET TNUM <1 .RNGS>>>>
+ <* .LNT ,MAX-DENSE>>
+ <SET SKIP-CH T>)>
+ <MAPF <>
+ <FUNCTION (NUM)
+ <COND (<==? .NUM .TNUM>
+ <MESSAGE ERROR " DUPLICATE CASE ENTRY " .N>)>
+ <SET TNUM .NUM>>
+ <REST .RNGS>>
+ <COND
+ (<==? .P ==?>
+ <COND
+ (<NOT .TT>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O !<ADDR:TYPE .W2>>>
+ <EMIT
+ <INSTRUCTION
+ `CAIE
+ `O
+ <FORM
+ TYPE-CODE!-OP!-PACKAGE
+ <TYPE <COND (<TYPE? <SET TT <NODE-NAME <PREDIC <1 <1 .K>>>>> LIST>
+ <1 .TT>)
+ (ELSE .TT)>>>>>
+ <BRANCH:TAG .DFT>)>
+ <SET W2 <TOACV .W2>>
+ <SET DAC <DATVAL .W2>>)
+ (<==? .P TYPE?>
+ <SET DAC <GETREG <>>>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE
+ <ACSYM .DAC>
+ !<ADDR:TYPE .W2>>>)
+ (ELSE
+ <SET DAC <GETREG <>>>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE
+ <ACSYM .DAC>
+ !<ADDR:TYPE .W2>>>
+ <EMIT <INSTRUCTION `ASH <ACSYM .DAC> 1>>
+ <EMIT <INSTRUCTION `ADD <ACSYM .DAC> TYPVEC!-MUDDLE 1 `(TVP) >>
+ <EMIT <INSTRUCTION `LDB
+ <ACSYM .DAC>
+ [<FORM (576) (<ADDRSYM .DAC>)>]>>)>
+ <COND
+ (<NOT .SKIP-CH>
+ <MUNG-AC .DAC .W2>
+ <RET-TMP-AC .W2>
+ <COND (<0? .MI> <EMIT <INSTRUCTION `JUMPL <ACSYM .DAC> .DFT>>)
+ (<==? .MI 1>
+ <EMIT <INSTRUCTION `JUMPLE <ACSYM .DAC> .DFT>>)
+ (ELSE
+ <IMCHK '(`CAMGE `CAIGE) <ACSYM .DAC> <REFERENCE:ADR .MI>>
+ <BRANCH:TAG .DFT>)>
+ <COND (<0? .MX> <EMIT <INSTRUCTION `JUMPG <ACSYM .DAC> .DFT>>)
+ (<==? .MX -1>
+ <EMIT <INSTRUCTION `JUMPGE <ACSYM .DAC> .DFT>>)
+ (ELSE
+ <IMCHK '(`CAMLE `CAILE) <ACSYM .DAC> <REFERENCE:ADR .MX>>
+ <BRANCH:TAG .DFT>)>
+ <EMIT <INSTRUCTION `ADD <ACSYM .DAC> [<INSTRUCTION `SETZ .TBL>]>>
+ <EMIT <INSTRUCTION `JRST `@ <- .MI> (<ADDRSYM .DAC>)>>
+ <LABEL:TAG .DFT>
+ <SET S1 <SAVE-STATE>>
+ <COND (<ASSIGNED? DN>
+ <SET W1 <SEQ-GEN <KIDS .DN> <DATFIX .W>>>
+ <ACFIX .W .W1>
+ <COND (<N==? <RESULT-TYPE .DN> NO-RETURN>
+ <SET S2 (<SAVE-STATE>)>
+ <BRANCH:TAG .ET>)>
+ <VAR-STORE <>>)
+ (ELSE
+ <SET W1 <MOVE:ARG <REFERENCE <>> <DATFIX .W>>>
+ <ACFIX .W .W1>
+ <SET S2 (<SAVE-STATE>)>
+ <VAR-STORE <>>
+ <BRANCH:TAG .ET>)>
+ <LABEL:TAG .TBL>
+ <SET NOW <+ .MI 1>>
+ <REPEAT ()
+ <COND (<EMPTY? .RNGS> <RETURN>)>
+ <COND (<N==? .NOW <+ <1 .RNGS> 1>>
+ <SET NOW <+ .NOW 1>>
+ <EMIT <INSTRUCTION `SETZ .DFT>>)
+ (ELSE
+ <EMIT <INSTRUCTION `SETZ <DOTAGS <1 .RNGS> .K>>>
+ <SET NOW <+ .NOW 1>>
+ <SET RNGS <REST .RNGS>>)>>
+ <MAPF <>
+ <FUNCTION (L "AUX" (N <1 .L>) (TG <3 .L>))
+ <RET-TMP-AC .W1>
+ <RESTORE-STATE .S1>
+ <COND (<NOT .FIRST> <OR <==? .W1 ,NO-DATUM> <BRANCH:TAG .ET>>)
+ (ELSE <SET FIRST <>>)>
+ <LABEL:TAG .TG>
+ <COND
+ (<NOT <EMPTY? <KIDS .N>>>
+ <SET W1 <SEQ-GEN <KIDS .N> <DATFIX .W>>>)
+ (ELSE
+ <SET W1
+ <MOVE:ARG
+ <REFERENCE <COND (<==? .P ==?> T)
+ (ELSE <NODE-NAME <PREDIC .N>>)>>
+ <DATFIX .W>>>)>
+ <OR <==? .W1 ,NO-DATUM> <SET S2 (<SAVE-STATE> !.S2)>>
+ <ACFIX .W .W1>>
+ .K>)
+ (ELSE
+ <RET-TMP-AC .W2>
+ <SET S1 <SAVE-STATE>>
+ <REPEAT (L)
+ <COND (<EMPTY? .K> <RETURN>)>
+ <DISTAG <2 <SET L <1 .K>>> .DAC <SET TG <3 .L>>>
+ <COND (<NOT <EMPTY? <KIDS <1 .L>>>>
+ <SET W1 <SEQ-GEN <KIDS <1 .L>> <DATFIX .W>>>)
+ (ELSE <SET W1 <MOVE:ARG <REFERENCE T> <DATFIX .W>>>)>
+ <OR <==? .W1 ,NO-DATUM> <SET S2 (<SAVE-STATE> !.S2)>>
+ <VAR-STORE <>>
+ <RESTORE-STATE .S1>
+ <ACFIX .W .W1>
+ <OR <==? .W1 ,NO-DATUM> <BRANCH:TAG .ET>>
+ <LABEL:TAG .TG>
+ <SET K <REST .K>>
+ <RET-TMP-AC .W1>>
+ <COND (<ASSIGNED? DN> <SET W1 <SEQ-GEN <KIDS .DN> <DATFIX .W>>>)
+ (ELSE <SET W1 <MOVE:ARG <REFERENCE <>> <DATFIX .W>>>)>
+ <OR <==? .W1 ,NO-DATUM> <SET S2 (<SAVE-STATE> !.S2)>>)>
+ <COND (<AND <TYPE? .W DATUM> <N==? <RESULT-TYPE .N> NO-RETURN>>
+ <SET W2 .W>
+ <AND <ISTYPE? <DATTYP .W2>>
+ <TYPE? <DATTYP .W1> AC>
+ <NOT <==? <DATTYP .W2> <DATTYP .W1>>>
+ <RET-TMP-AC <DATTYP .W1> .W1>>
+ <AND <TYPE? <DATTYP .W2> AC>
+ <FIX-ACLINK <DATTYP .W2> .W2 .W1>>
+ <AND <TYPE? <DATVAL .W2> AC>
+ <FIX-ACLINK <DATVAL .W2> .W2 .W1>>)>
+ <MERGE-STATES .S2>
+ <LABEL:TAG .ET>
+ <MOVE:ARG .W .RW>>
+
+<DEFINE DOTAGS (N L)
+ #DECL ((N) FIX (L) <UVECTOR [REST <LIST NODE <LIST [REST FIX]> ATOM>]>)
+ <MAPF <>
+ <FUNCTION (LL) <COND (<MEMQ .N <2 .LL>> <MAPLEAVE <3 .LL>>)>>
+ .L>>
+
+<DEFINE DISTAG (L DAC ATM "AUX" TG)
+ #DECL ((L) <LIST [REST FIX]> (DAC) AC (ATM) ATOM)
+ <COND (<G=? <LENGTH .L> 2> <SET TG <MAKE:TAG>>)>
+ <REPEAT ()
+ <COND (<EMPTY? .L>
+ <BRANCH:TAG .ATM>
+ <AND <ASSIGNED? TG> <LABEL:TAG .TG>>
+ <RETURN>)
+ (<EMPTY? <REST .L>>
+ <IMCHK '(`CAME `CAIE) <ACSYM .DAC> <REFERENCE:ADR <1 .L>>>
+ <BRANCH:TAG .ATM>
+ <AND <ASSIGNED? TG> <LABEL:TAG .TG>>
+ <RETURN>)
+ (ELSE
+ <IMCHK '(`CAME `CAIE) <ACSYM .DAC> <REFERENCE:ADR <1 .L>>>
+ <IMCHK '(`CAMN `CAIN) <ACSYM .DAC> <REFERENCE:ADR <2 .L>>>
+ <BRANCH:TAG .TG>)>
+ <SET L <REST .L 2>>>>
+
+<DEFINE PTYPE-C (ATM) <PRIM-CODE <TYPE-C .ATM>>>
+
+<ENDPACKAGE>
+
+\f
\ No newline at end of file
--- /dev/null
+
+
+<USE "MACROS" "SORTX">
+
+<SET REDEFINE T>
+
+<PACKAGE "CC">
+
+<BEGIN-HACK "BTB">
+
+<BEGIN-MHACK>
+
+<COND (<NOT <GASSIGNED? CASE-CODE>> <SETG CASE-CODE ,SPARE1-CODE>)>
+
+<BLOCK (<ROOT>)>
+
+PRIMTYPE?
+
+<COND (<NOT <GASSIGNED? CASE>>
+ <SETG CASE (1)>)>
+
+<ENDBLOCK>
+
+<PROG ((CH <OR <OPEN "READB" "COMPIL;CASE FBIN">
+ <OPEN "READB" "COMPIL;CASE NBIN">>))
+ <COND (.CH <PRINC "Using Compiled CASE."> <CRLF>
+ <LOAD .CH><CLOSE .CH>)
+ (ELSE <GROUP-LOAD "COMPIL;CASE >">)>>
+
+<PUT ,CASE PAPPLY-OBJECT ,CASE-FCN>
+
+<PUT ,ANALYZERS ,CASE-CODE ,CASE-ANA>
+
+<PUT ,GENERATORS ,CASE-CODE ,CASE-GEN>
+
+<ENDPACKAGE>
+\f\ 3
\ No newline at end of file
--- /dev/null
+<PACKAGE "CBACK">
+
+<ENTRY BACK-GEN TOP-GEN>
+
+<USE "CODGEN" "CHKDCL" "CACS" "COMPDEC" "COMCOD" "STRGEN">
+
+
+<DEFINE BACK-GEN (NOD WHERE
+ "AUX" (K <KIDS .NOD>) (TYP <RESULT-TYPE <1 .K>>)
+ (TPS <STRUCTYP .TYP>)
+ (NUMKN <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>)
+ (NUM <COND (.NUMKN <NODE-NAME <2 .K>>) (ELSE 0)>))
+ #DECL ((NUMKN) <OR ATOM FALSE> (NUM) FIX (TPS) ATOM (NOD) NODE
+ (WHERE) <OR ATOM DATUM> (K) <LIST [REST NODE]>)
+ <APPLY <NTH ,BACKERS <LENGTH <MEMQ .TPS ,STYPES>>>
+ .NOD
+ .WHERE
+ .TYP
+ .TPS
+ .NUMKN
+ .NUM
+ <1 .K>
+ <2 .K>>>
+
+<DEFINE NO-BACK-ERROR (NOD "TUPLE" ERR)
+ <MESSAGE INCONSISTENCY "CANT OPEN-COMPILE BACK" .ERR .NOD>>
+
+<DEFINE VEC-BACK-GEN (NODE WHERE TYP TPS NUMKN NUM STRNOD NUMNOD
+ "AUX" (ONO .NO-KILL) (NO-KILL .ONO)
+ (CAREFL <AND .CAREFUL <N==? .TPS TUPLE>>)
+ (UV? <==? .TPS UVECTOR>) NAC SAC STR NUMN (RV <>)
+ TAC TDAT (W <GOODACS .NODE .WHERE>))
+ #DECL ((NOD NUMNOD STRNOD) NODE (W TDAT STR NUMN) DATUM (TAC SAC NAC) AC (NUM) FIX
+ (NO-KILL) <SPECIAL LIST> (RV CAREFL UV?) <OR ATOM FALSE>)
+ <COND
+ (.NUMKN
+ <COND (<L? .NUM 0> <MESSAGE INCONSISTENCY "ARG OUT OF RANGE BACK" .NODE>)
+ (<0? .NUM> <SET STR <GEN .STRNOD .W>>)
+ (ELSE
+ <SET STR <GEN .STRNOD .W>>
+ <COND (.CAREFL
+ <SET TAC <GETREG <SET TDAT <DATUM FIX ANY-AC>>>>
+ <MUNG-AC .TAC>
+ <PUT .TDAT ,DATVAL .TAC>
+ <SET TAC <DATVAL .TDAT>>
+ <EMIT <INSTRUCTION `HLRE `O !<ADDR:VALUE .STR>>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .TAC> !<ADDR:VALUE .STR>>>
+ <EMIT <INSTRUCTION `SUB <ACSYM .TAC> `O >>
+ <EMIT <INSTRUCTION `HLRZ <ACSYM .TAC> 1 (<ADDRSYM .TAC>)>>
+ <EMIT <INSTRUCTION `ADD <ACSYM .TAC> `O >>
+ <EMIT <INSTRUCTION `SUBI
+ <ACSYM .TAC>
+ <+ <COND (.UV? .NUM) (ELSE <* .NUM 2>)>
+ 1>>>
+ <EMIT <INSTRUCTION `JUMPLE <ACSYM .TAC> |COMPER >>
+ <RET-TMP-AC .TDAT>)>
+ <TOACV .STR>
+ <SET SAC <DATVAL .STR>>
+ <MUNG-AC .SAC .STR>
+ <EMIT <INSTRUCTION `SUB
+ <ACSYM .SAC>
+ <COND (.UV? [<FORM (.NUM) .NUM>])
+ (ELSE
+ [<FORM (<* .NUM 2>) <* .NUM 2>>])>>>)>)
+ (ELSE
+ <SET RV <COMMUTE-STRUC <> .NUMNOD .STRNOD>>
+ <COND (.RV <SET NUMN <GEN .NUMNOD DONT-CARE>> <SET STR <GEN .STRNOD .W>>)
+ (<SET STR <GEN .STRNOD .W>> <SET NUMN <GEN .NUMNOD DONT-CARE>>)>
+ <DELAY-KILL .NO-KILL .ONO>
+ <TOACV .NUMN>
+ <SET NAC <DATVAL .NUMN>>
+ <MUNG-AC .NAC .NUMN>
+ <COND (<NOT .UV?> <EMIT <INSTRUCTION `ASH <ACSYM .NAC> 1>>)>
+ <COND (.CAREFUL
+ <EMIT <INSTRUCTION `JUMPL <ACSYM .NAC> |COMPER >>
+ <SET TAC <GETREG <SET TDAT <DATUM FIX ANY-AC>>>>
+ <PUT .TDAT ,DATVAL .TAC>
+ <EMIT <INSTRUCTION `HLRE `O !<ADDR:VALUE .STR>>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .TAC> !<ADDR:VALUE .STR>>>
+ <EMIT <INSTRUCTION `SUB <ACSYM .TAC> `O >>
+ <EMIT <INSTRUCTION `HLRZ <ACSYM .TAC> 1 (<ADDRSYM .TAC>)>>
+ <EMIT <INSTRUCTION `ADD <ACSYM .TAC> `O >>
+ <EMIT <INSTRUCTION `SUB <ACSYM .TAC> <ADDRSYM .NAC>>>
+ <EMIT <INSTRUCTION `SOJLE <ACSYM .TAC> |COMPER >>
+ <RET-TMP-AC .TDAT>)>
+ <EMIT <INSTRUCTION `HRLI <ACSYM .NAC> (<ADDRSYM .NAC>)>>
+ <TOACV .STR>
+ <MUNG-AC <DATVAL .STR> .STR>
+ <EMIT <INSTRUCTION `SUB <ACSYM <CHTYPE <DATVAL .STR> AC>> <ADDRSYM .NAC>>>
+ <PUT .NAC ,ACPROT <>>
+ <RET-TMP-AC .NUMN>
+ <COND (<N==? .TPS TUPLE>
+ <RET-TMP-AC <DATTYP .STR> .STR>
+ <PUT .STR ,DATTYP .TPS>)>)>
+ <MOVE:ARG .STR .WHERE>>
+
+<GDECL (BACKERS) VECTOR>
+
+<SETG BACKERS
+ [,NO-BACK-ERROR
+ ,NO-BACK-ERROR
+ ,NO-BACK-ERROR
+ ,VEC-BACK-GEN
+ ,VEC-BACK-GEN
+ ,VEC-BACK-GEN
+ ,VEC-BACK-GEN
+ ,NO-BACK-ERROR]>
+
+<DEFINE TOP-GEN (N RW
+ "AUX" (NN <1 <KIDS .N>>) (TY <RESULT-TYPE .NN>)
+ (TPS <STRUCTYP .TY>) OAC SAC (FLG <>) W DAC D)
+ #DECL ((N NN) NODE (W D) DATUM (TPS) ATOM (OAC SAC DAC) AC)
+ <SET W <GOODACS .N .RW>>
+ <SET D <GEN .NN <DATUM <COND (<ISTYPE? .TY>) (ELSE .TPS)> ANY-AC>>>
+ <PUT <SET SAC <DATVAL .D>> ,ACPROT T>
+ <COND (<==? <DATVAL .W> <DATVAL .D>> <SET OAC <GETREG <>>> <SET FLG T>)
+ (<TYPE? <DATVAL .W> AC>
+ <PUT <CHTYPE <DATVAL .W> AC> ,ACPROT T>
+ <SET OAC <GETREG <>>>
+ <PUT <CHTYPE <DATVAL .W> AC> ,ACPROT <>>)
+ (ELSE <SET OAC <GETREG <>>>)>
+ <EMIT <INSTRUCTION `HLRE <ACSYM .OAC> <ADDRSYM .SAC>>>
+ <EMIT <INSTRUCTION `SUBM <ACSYM .SAC> <ADDRSYM .OAC>>>
+ <COND (<AND <NOT .FLG> <TYPE? <DATVAL .W> AC>>
+ <SET DAC <SGETREG <DATVAL .W> <>>>
+ <EMIT <INSTRUCTION `MOVEI <ACSYM .DAC> 2 (<ADDRSYM .OAC>)>>)
+ (<OR .FLG <0? <CHTYPE <FREE-ACS T> FIX>>>
+ <MUNG-AC <SET DAC .SAC> .D>
+ <EMIT <INSTRUCTION `MOVEI <ACSYM .SAC> 2 (<ADDRSYM .OAC>)>>)
+ (ELSE
+ <PUT .OAC ,ACPROT T>
+ <SET DAC <GETREG <>>>
+ <EMIT <INSTRUCTION `MOVEI <ACSYM .DAC> 2 (<ADDRSYM .OAC>)>>)>
+ <EMIT <INSTRUCTION `HLR <ACSYM .OAC> 1 (<ADDRSYM .OAC>)>>
+ <EMIT <INSTRUCTION `HRLI <ACSYM .OAC> -2 (<ADDRSYM .OAC>)>>
+ <EMIT <INSTRUCTION `SUB <ACSYM .DAC> <ADDRSYM .OAC>>>
+ <PUT .SAC ,ACPROT <>>
+ <PUT .OAC ,ACPROT <>>
+ <RET-TMP-AC .D>
+ <SET D <DATUM .TPS .DAC>>
+ <PUT .DAC ,ACLINK (.D)>
+ <MOVE:ARG .D .RW>>
+
+<ENDPACKAGE>
+\f
\ No newline at end of file
--- /dev/null
+<PACKAGE "CDRIVE">
+
+<ENTRY COMPILE COMPILE-GROUP COMP2>
+
+<USE "CODGEN" "SYMANA" "VARANA" "COMCOD" "COMPDEC" "PASS1" "TIMFCN" "ADVMES"
+ "CUP">
+"****** TOP LEVEL COMILER CALLS ******"
+
+"COMPILE -- compile one function or a group. Compile does not merge a group
+ into one big RSUBR (see COMPILE-GROUP).
+
+ The arguments to compile are:
+
+ FCNS -- an atom whose GVAL is a function, a locative to a function
+ or a list of the previous 2.
+
+ SRC-FLG -- a channel for assembly listing or #FALSE () for none.
+
+ BIN-FLG -- If false, don't assemble else do.
+
+ CAREFUL -- If true compile bounds checking else don't.
+
+ GLOSP -- Whether or not default is SPECIAL.
+"
+
+<DEFINE <ENTRY COMPILE> (FCNS
+ "OPTIONAL" (SRC-FLG <>) (BIN-FLG T) (CAREFUL T)
+ (GLOSP <>) (REASONABLE T) (GLUE T)
+ (ANALY-OK T) (VERBOSE <>)
+ "AUX" (IND (1)) (TAG:COUNT 0) "NAME" COMPILER)
+ #DECL ((FCNS SRC-FLG BIN-FLG CAREFUL GLOSP REASONABLE GLUE IND
+ TAG:COUNT COMPILER ANALY-OK VERBOSE) <SPECIAL ANY>)
+ <ZTMPLST>
+ <COND (<TYPE? .FCNS LIST>
+ <MAPF <> ,VERIFY .FCNS>
+ <MAPF <>
+ <FUNCTION (FCN) <PRINC <COMP2 .FCN>> <TERPRI>>
+ .FCNS>
+ <MAPF <> ,UNASSOC .FCNS>)
+ (ELSE <VERIFY .FCNS>
+ <PRINC <COMP2 .FCNS>>
+ <UNASSOC .FCNS>)>
+ <TERPRI>
+ "DONE">
+
+"COMP2 -- compile one thing (atom or locative) print time if second arg
+ missing or false. Assemble result if desired (time entire job)."
+
+<DEFINE COMP2 (TH "OPTIONAL" (SILENT <>)
+ "AUX" (CODE:TOP (())) MESS
+ (CODE:PTR .CODE:TOP)
+ (ST <TIME>) (RT <RTIME>) (DAT <DATE>))
+ #DECL ((CODE:PTR CODE:TOP) <SPECIAL LIST>)
+ <SET MESS <COMP1 .TH <> <> .SILENT>>
+ <COND (<TYPE? .MESS LIST>
+ <SETLOC <1 .MESS> <ASSEM? .SRC-FLG>>
+ <STRING "Job done in: "
+ <TIME-STR1 <FIX <+ 0.5 <- <TIME> .ST>>>> " / "
+ <TIME-DIF1 .DAT <DATE> .RT <RTIME>>>)
+ (ELSE .MESS)>>
+
+"VERIFY -- check types of arguments prior to compilation."
+
+<DEFINE VERIFY (THING)
+ <COND (<TYPE? .THING ATOM>
+ <IF-NOT <GASSIGNED? .THING>
+ <MESSAGE ERROR " UNASSIGNED " .THING>>
+ <IF-NOT <OR <TYPE? ,.THING FUNCTION>
+ <AND <TYPE? ,.THING MACRO>
+ <NOT <EMPTY? ,.THING>>
+ <TYPE? <1 ,.THING> FUNCTION>>>
+ <MESSAGE ERROR " NOT A FUNCTION " .THING>>)
+ (<TYPE? .THING LOCL LOCV LOCU LOCA LOCAS LOCD>
+ <IF-NOT <TYPE? <IN .THING> FUNCTION>
+ <MESSAGE ERROR " NOT A FUNCTION " .THING>>)
+ (ELSE <MESSAGE ERROR " ARG WRONG TYPE " .THING>)>>
+
+"COMP1 -- compile one object and time compilation. Make noise if second arg
+ there and not false."
+
+<DEFINE COMP1 (THING SUB? INT?
+ "OPTIONAL" (SILENT <>)
+ "EXTRA" (START-TIME <TIME>) (NM1 .THING) RDCL (REALT <RTIME>)
+ (TH .THING) (RDAT <DATE>)
+ "NAME" COMPILER)
+ #DECL ((SUB? INT? RDCL COMPILER) <SPECIAL ANY> (START-TIME) FLOAT)
+ <COND (<TYPE? .THING ATOM>
+ <COND (<GASSIGNED? SNAME-SETTER> <SNAME-SETTER .THING>)>
+ <COND (<NOT .SILENT>
+ <PRINC "COMPILING ">
+ <PRIN1 .THING>
+ <TERPRI>)>
+ <COND (<TYPE? ,.THING FUNCTION> <SET TH <GLOC .THING>>)
+ (ELSE <SET TH <AT ,.THING 1>>)>)
+ (ELSE
+ <OR .SILENT <PRINC "COMPILING LOCATIVE">>
+ <SET NM1 <MAKE:TAG "ANONF">>)>
+ <COMPILE-FUNCTION <IN .TH> .NM1 .THING>
+ (.TH
+ <STRING "Compilation done in "
+ <TIME-STR1 <FIX <+ 0.5 <- <TIME> .START-TIME>>>>
+ "cpu time, "
+ <ASCII 13>
+ <ASCII 10>
+ <TIME-DIF1 .RDAT <DATE> .REALT <RTIME>>
+ " real time. "
+ <ASCII 13>
+ <ASCII 10>>)>
+
+"COMPILE-GROUP -- compile into one RSUBR a group of functions. Eliminate identity
+ of internal RSUBRs. First arg same as for COMPILE. Second arg
+ specifies those FUNCTIONS to become external. Third arg
+ name of entire group upon completion of compilation."
+
+<DEFINE <ENTRY COMPILE-GROUP>
+ (FCNS EXTS GROUP-NAME
+ "OPTIONAL" (SRC-FLG <>)
+ (BIN-FLG T)
+ (CAREFUL T)
+ (GLOSP <>)
+ (REASONABLE T)
+ (GLUE T)
+ (TMPCHN <>)
+ (ANALY-OK T)
+ (VERBOSE <>)
+ "AUX" (FIRST T) (IND (1)) (TAG:COUNT 0)
+ (STRT <TIME>)
+ (RSTRT <RTIME>)
+ (RDAT <DATE>)
+ (CODE:TOP (()))
+ (CODE:PTR .CODE:TOP)
+ "NAME" COMPILER)
+ #DECL ((FCNS GROUP-NAME SEC-FLG BIN-FLG CAREFUL GLOSP REASONABLE GLUE
+ IND TAG:COUNT CODE:TOP CODE:PTR COMPILER ANALY-OK VERBOSE)
+ <SPECIAL ANY>)
+ <MAPF <> ,VERIFY .FCNS>
+ <ZTMPLST>
+ <GROUP:INITIAL .GROUP-NAME>
+ <MAPF <>
+ <FUNCTION (FCN "AUX" (MESS <COMP1 .FCN T <NOT <MEMQ .FCN .EXTS>>>))
+ <COND (<TYPE? .MESS LIST>)
+ (ELSE <RETURN <CHTYPE (.MESS) FALSE> .COMPILER>)>
+ <SET FIRST <>>
+ <TERPRI>
+ <ASSEM? .CODE:TOP <>>
+ <COND (.TMPCHN <OUTCOD .CODE:TOP .TMPCHN>
+ <SET CODE:PTR <SET CODE:TOP (())>>)>>
+ .FCNS>
+ <MAPF <> ,UNASSOC .FCNS>
+ <COND (.TMPCHN <CLOSE .TMPCHN>)
+ (ELSE <SETG .GROUP-NAME <ASSEM? .SRC-FLG>>)>
+ <STRING "Time for group: "
+ <TIME-STR1 <FIX <+ 0.5 <- <TIME> .STRT>>>> " / "
+ <TIME-DIF1 .RDAT <DATE> .RSTRT <RTIME>>>>
+
+<SETG WDCNTLC ![1623294726!]>
+
+<SETG WDSPACE ![17315143744!]>
+
+<DEFINE OUTCOD (L TMPCH "AUX" (OBLIST (<MOBLIST OP!-PACKAGE> <GET MUDDLE OBLIST>
+ !.OBLIST)) ACC ACC2)
+ #DECL ((L) LIST (TMPCH) CHANNEL (OBLIST) <SPECIAL LIST> (ACC ACC2) FIX)
+ <SET ACC <17 .TMPCH>>
+ <RESET .TMPCH>
+ <ACCESS .TMPCH .ACC>
+ <PRINC <ASCII 12> .TMPCH>
+ <REPEAT ()
+ <COND (<EMPTY? <SET L <REST .L>>> <RETURN>)>
+ <TERPRI .TMPCH>
+ <OR <TYPE? <1 .L> ATOM> <PRINC " " .TMPCH>>
+ <PRIN1 <1 .L> .TMPCH>>
+ <BUFOUT .TMPCH>
+ <PRINTB ,WDCNTLC .TMPCH>
+ <SET ACC2 <17 .TMPCH>>
+ <ACCESS .TMPCH <- .ACC 1>>
+ <PRINTB ,WDSPACE .TMPCH>
+ <ACCESS .TMPCH .ACC2>
+ <CLOSE .TMPCH>>
+
+<DEFINE UNASSOC (THING)
+ <COND (<TYPE? .THING ATOM>
+ <PUT ,.THING .IND>)
+ (ELSE <PUT <IN .THING> .IND>)>>
+
+"COMPILE-FUNCTION -- run the compiler on one function.
+ PASS1 builds internal structure.
+ ANA further specifies the structure and computes types for all nodes.
+ VARS allocates stack slots for variables.
+ CODE-GEN generates assembler source.
+"
+
+<DEFINE COMPILE-FUNCTION (FCN NAME "OPTIONAL" (RNAME .NAME) "AUX" INAME (LOCAL-TAGS ())
+ (VP (())))
+ #DECL ((LOCAL-TAGS) <SPECIAL LIST>)
+ <COND (.VERBOSE <SET VERBOSE .VP>)>
+ <REACS>
+ <SET INAME <NODE-NAME <SET FCN <PASS1 .FCN .NAME <> .RNAME>>>>
+ <ANA .FCN ANY>
+ <VARS .FCN>
+ <COND (.VERBOSE <ANA-MESS .VP>)>
+ <REACS>
+ <COND (<ACS .FCN> ;"AC call exists?"
+ <COND (<AND .INT? .SUB?>
+ <INT:INITIAL .NAME>)
+ (.SUB? <SUB:INT:INITIAL .NAME> <ARGS-TO-ACS .FCN>)
+ (ELSE <FCN:INT:INITIAL .NAME> <ARGS-TO-ACS .FCN>)>)
+ (<AND <ASSIGNED? GROUP-NAME>
+ <NOT <EMPTY? <ACS .FCN>>>
+ <OR .INT? <NOT <EMPTY? .INAME>>>>
+ <INT:LOSER:INITIAL .NAME .FCN>)
+ (.SUB? <SUB:INITIAL .NAME>)
+ (ELSE
+ <FUNCTION:INITIAL .NAME>)>
+ <CODE-GEN .FCN>
+ <CHECK-LOCAL-TAGS .LOCAL-TAGS>
+ <PUT .FCN ,BINDING-STRUCTURE ()>
+ <PUT .FCN ,KIDS ()>
+ <PUT .FCN ,SYMTAB ,LVARTBL>
+ <COND (<ACS .FCN>
+ <COND (.INT? <INT:FINAL .FCN>)
+ (ELSE
+ <PUT .RDCL 2 <RSUBR-DECLS .FCN>>
+ <FS:INT:FINAL <ACS .FCN>>)>)
+ (ELSE
+ <PUT .RDCL 2 <RSUBR-DECLS .FCN>>
+ <FCNSUB:FINAL .FCN>)>>
+
+
+
+
+<DEFINE TIME-STR1 (NSEC "AUX" (NMIN </ <FIX .NSEC> 60>)
+ (NHRS </ .NMIN 60>))
+ #DECL ((NSEC) <OR FIX FLOAT> (NMIN NHRS) FIX (VALUE) STRING)
+ <TIMEST1 .NHRS
+ <- .NMIN <* .NHRS 60>>
+ <- .NSEC <* .NMIN 60>>>>
+
+<DEFINE TIME-DIF1 (D1 D2 T1 T2
+ "AUX" (DY
+ <- <DAYS <1 .D2> <2 .D2> <3 .D2>>
+ <DAYS <1 .D1> <2 .D1> <3 .D1>>>))
+ #DECL ((D1 D2 T1 T2) <LIST FIX FIX FIX> (VALUE) STRING)
+ <TIME-STR1 <- <+ <* .DY 3600 24>
+ <* <1 .T2> 3600>
+ <* <2 .T2> 60>
+ <3 .T2>>
+ <+ <* <1 .T1> 3600> <* <2 .T1> 60> <3 .T1>>>>>
+
+<DEFINE TIMEST1 (HR MI SE)
+ #DECL ((HR MI SE) FIX)
+ <STRING <COND (<NOT <0? .HR>> <STRING <UNPARSE .HR> ":">) (ELSE "")>
+ <COND (<OR <NOT <0? .MI>> <NOT <0? .HR>>>
+ <STRING <COND (<L=? .MI 9>
+ <STRING <COND (<0? .HR> "") (ELSE "0")>
+ <CHTYPE <+ .MI 48> CHARACTER>>)
+ (ELSE
+ <STRING <CHTYPE <+ </ .MI 10> 48> CHARACTER>
+ <CHTYPE <+ <MOD .MI 10> 48>
+ CHARACTER>>)>
+ ":">)
+ (ELSE "")>
+ <COND (<L=? .SE 9>
+ <STRING <COND (<OR <NOT <0? .MI>> <NOT <0? .HR>>> "0")
+ (ELSE "")>
+ <CHTYPE <+ .SE 48> CHARACTER>>)
+ (ELSE
+ <STRING <CHTYPE <+ </ .SE 10> 48> CHARACTER>
+ <CHTYPE <+ <MOD .SE 10> 48> CHARACTER>>)>>>
+
+<ENDPACKAGE>\ 3\ 3\ 3
\ No newline at end of file
--- /dev/null
+
+<PACKAGE "CHKDCL">
+
+<ENTRY TYPE-AND
+ TYPE-OK?
+ TASTEFUL-DECL
+ GET-ELE-TYPE
+ STRUCTYP
+ TYPE-ATOM-OK?
+ ISTYPE-GOOD?
+ TYPE-MERGE
+ DEFERN
+ TOP-TYPE
+ ISTYPE?
+ TYPESAME
+ ANY-PAT
+ STRUC
+ GETBSYZ
+ GEN-DECL
+ REST-DECL
+ MINL
+ GET-RANGE>
+
+
+<USE "COMPDEC">
+
+<SETG DECL-RESTED 1>
+
+<SETG DECL-ELEMENT 2>
+
+<SETG DECL-ITEM-COUNT 3>
+
+<SETG DECL-IN-REST 4>
+
+<SETG DECL-IN-COUNT-VEC 5>
+
+<SETG DECL-REST-VEC 6>
+
+<MANIFEST DECL-RESTED
+ DECL-ELEMENT
+ DECL-ITEM-COUNT
+ DECL-IN-REST
+ DECL-IN-COUNT-VEC
+ DECL-REST-VEC>
+
+<SETG HIGHBOUND 2>
+
+<SETG LOWBOUND 1>
+
+<MANIFEST HIGHBOUND LOWBOUND>
+
+<SETG ALLWORDS '<PRIMTYPE WORD>>
+
+<DEFINE TASTEFUL-DECL (D "AUX" TEM)
+ <COND (<OR <NOT .D> <==? .D NO-RETURN>> ANY)
+ (<AND <TYPE? .D ATOM> <VALID-TYPE? .D>> .D)
+ (<AND <OR <TYPE? <SET TEM .D> ATOM> <SET TEM <ISTYPE? .D>>>
+ <GET .TEM DECL>>
+ .TEM)
+ (<TYPE? .D FORM SEGMENT>
+ <COND (<LENGTH? .D 1>
+ <OR <AND <EMPTY? .D> ANY> <TASTEFUL-DECL <1 .D>>>)
+ (<==? <1 .D> FIX> FIX)
+ (<AND <==? <LENGTH .D> 2> <==? <1 .D> NOT>> ANY)
+ (<TYPE? .D SEGMENT>
+ <CHTYPE <MAPF ,LIST ,TASTEFUL-DECL .D> SEGMENT>)
+ (ELSE <CHTYPE <MAPF ,LIST ,TASTEFUL-DECL .D> FORM>)>)
+ (<TYPE? .D VECTOR>
+ [<COND (<==? <1 .D> OPT> OPTIONAL) (ELSE <1 .D>)>
+ !<MAPF ,LIST ,TASTEFUL-DECL <REST .D>>])
+ (ELSE .D)>>
+
+<DEFINE TMERGE (P1 P2)
+ <COND (<OR <AND <TYPE? .P1 FORM SEGMENT>
+ <==? <LENGTH .P1> 2>
+ <TYPE? <2 .P1> LIST>>
+ <AND <TYPE? .P2 FORM SEGMENT>
+ <==? <LENGTH .P2> 2>
+ <TYPE? <2 .P2> LIST>>
+ <CTMATCH .P1 .P2 <> <> T>>
+ <CTMATCH .P1 .P2 T T <>>)
+ (<=? .P1 '<NOT ANY>> .P2)
+ (<=? .P2 '<NOT ANY>> .P1)
+ (ELSE <CHTYPE (OR !<PUT-IN <PUT-IN () .P1> .P2>) FORM>)>>
+
+<DEFINE TYPE-AND (P1 P2) <CTMATCH .P1 .P2 T <> <>>>
+
+<DEFINE TMATCH (P1 P2) <CTMATCH .P1 .P2 <> <> <>>>
+
+<DEFINE CTMATCH (P1 P2 ANDF ORF MAYBEF)
+ #DECL ((ANDF ORF MAYBEF) <SPECIAL <OR FALSE ATOM>>)
+ <DTMATCH .P1 .P2>>
+
+<DEFINE DTMATCH (PAT1 PAT2)
+ <OR .PAT1 <SET PAT1 ANY>>
+ <OR .PAT2 <SET PAT2 ANY>>
+ <COND (<=? .PAT1 .PAT2> .PAT1)
+ (<TYPE? <SET PAT1 <VTS .PAT1>> ATOM> <TYPMAT .PAT1 <VTS .PAT2>>)
+ (<TYPE? <SET PAT2 <VTS .PAT2>> ATOM> <TYPMAT .PAT2 .PAT1>)
+ (<AND <TYPE? .PAT1 FORM SEGMENT> <TYPE? .PAT2 FORM SEGMENT>>
+ <TEXP1 .PAT1 .PAT2>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
+
+<DEFINE VTS (X)
+ <OR <AND <TYPE? .X ATOM>
+ <OR <VALID-TYPE? .X>
+ <MEMQ .X '![STRUCTURED LOCATIVE APPLICABLE ANY!]>>
+ .X>
+ <AND <TYPE? .X ATOM> <GET .X DECL>>
+ .X>>
+
+<DEFINE 2-ELEM (OBJ)
+ #DECL ((OBJ) <PRIMTYPE LIST>)
+ <AND <NOT <EMPTY? .OBJ>> <NOT <EMPTY? <REST .OBJ>>>>>
+
+<DEFINE TYPMAT (TYP PAT "AUX" TEM)
+ #DECL ((TYP) ATOM)
+ <OR <SET TEM
+ <COND (<TYPE? .PAT ATOM>
+ <OR <AND <==? .PAT ANY> <COND (.ORF ANY) (ELSE .TYP)>>
+ <AND <==? .TYP ANY> <COND (.ORF ANY) (ELSE .PAT)>>
+ <AND <=? .PAT .TYP> .TYP>
+ <STRUC .TYP .PAT T>
+ <STRUC .PAT .TYP <>>>)
+ (<TYPE? .PAT FORM SEGMENT> <TEXP1 .PAT .TYP>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
+ <AND <EMPTY? .TEM>
+ <OR <AND <N==? <SET TEM <VTS .TYP>> .TYP> <DTMATCH .TEM .PAT>>
+ <AND <N==? <SET TEM <VTS .PAT>> .PAT>
+ <TYPMAT .TYP .TEM>>>>>>
+
+"\f"
+
+<DEFINE TEXP1 (FORT PAT)
+ #DECL ((FORT) <OR FORM SEGMENT>)
+ <COND (<EMPTY? .FORT> #FALSE (EMPTY-TYPE-FORM!-ERRORS))
+ (<MEMQ <1 .FORT> '![OR AND NOT PRIMTYPE!]> <ACTORT .FORT .PAT>)
+ (<AND <==? <1 .FORT> QUOTE> <2-ELEM .FORT>>
+ <DTMATCH <GEN-DECL <2 .FORT>> .PAT>)
+ (ELSE <FORMATCH .FORT .PAT>)>>
+
+<DEFINE ACTORT (FORT PAT "AUX" (ACTOR <1 .FORT>) TEM1)
+ #DECL ((FORT) <PRIMTYPE LIST>)
+ <COND
+ (<==? .ACTOR OR>
+ <COND
+ (<EMPTY? <SET FORT <REST .FORT>>>
+ #FALSE (EMPTY-OR-MATCH!-ERRORS))
+ (ELSE
+ <REPEAT (TEM (AL ()))
+ #DECL ((AL) LIST)
+ <COND
+ (<OR <AND <TYPE? <SET TEM <1 .FORT>> ATOM>
+ <PROG ()
+ <COND (<VALID-TYPE? .TEM>)
+ (<SET TEM1 <GET .TEM DECL>>
+ <SET TEM .TEM1>
+ <AND <TYPE? .TEM ATOM> <AGAIN>>)
+ (ELSE T)>>
+ <SET TEM <TYPMAT .TEM .PAT>>>
+ <AND <TYPE? .TEM FORM SEGMENT> <SET TEM <TEXP1 .TEM .PAT>>>>
+ <COND (<==? .ACTOR OR>
+ <COND (.ANDF
+ <COND (.TEM
+ <COND (<==? .TEM ANY> <RETURN ANY>)>
+ <COND (.ORF <SET AL <PUT-IN .AL .TEM>>)
+ (ELSE
+ <OR <MEMBER .TEM .AL>
+ <SET AL (.TEM !.AL)>>)>)>)
+ (ELSE <RETURN T>)>)>)
+ (<NOT <EMPTY? .TEM>> <RETURN .TEM>)>
+ <COND (<EMPTY? <SET FORT <REST .FORT>>>
+ <RETURN <AND <NOT <EMPTY? .AL>>
+ <COND (<EMPTY? <REST .AL>> <1 .AL>)
+ (ELSE
+ <ORSORT <CHTYPE (.ACTOR !.AL)
+ FORM>>)>>>)>>)>)
+ (<==? .ACTOR NOT> <NOT-IT .FORT .PAT>)
+ (ELSE <PTACT .FORT .PAT>)>>
+
+<DEFINE PTACT (FORTYP PAT)
+ <COND (<TYPE? .FORTYP FORM SEGMENT>
+ <COND (<AND <2-ELEM .FORTYP> <==? <1 .FORTYP> PRIMTYPE>>
+ <PRIMATCH .FORTYP .PAT>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
+ (<TYPE? .FORTYP ATOM> <TYPMAT .FORTYP .PAT>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
+
+"\f"
+
+<DEFINE STRUC (WRD TYP ACTAND)
+ #DECL ((TYP) ATOM)
+ <PROG ()
+ <COND (<COND (<==? .WRD STRUCTURED>
+ <COND (<==? .TYP LOCATIVE> <>)
+ (<==? .TYP APPLICABLE>
+ <RETURN <COND (.ORF '<OR APPLICABLE STRUCTURED>)
+ (ELSE
+ '<OR RSUBR RSUBR-ENTRY FUNCTION CLOSURE MACRO>)>>)
+ (<AND <VALID-TYPE? .TYP>
+ <MEMQ <TYPEPRIM .TYP>
+ '![LIST VECTOR UVECTOR TEMPLATE STRING TUPLE
+ STORAGE BYTES!]>>)>)
+ (<==? .WRD LOCATIVE>
+ <MEMQ .TYP '![LOCL LOCAS LOCD LOCV LOCU LOCS LOCA!]>)
+ (<==? .WRD APPLICABLE>
+ <COND (<==? .TYP LOCATIVE> <RETURN <>>)
+ (<==? .TYP STRUCTURED>
+ <RETURN <STRUC .TYP .WRD .ACTAND>>)
+ (<MEMQ .TYP
+ '![RSUBR SUBR FIX FSUBR FUNCTION
+ RSUBR-ENTRY MACRO CLOSURE
+ OFFSET!]>)>)>
+ <COND (.ORF .WRD) (ELSE .TYP)>)
+ (ELSE
+ <COND (<AND .ORF <NOT .ACTAND>> <ORSORT <FORM OR .WRD .TYP>>)
+ (ELSE <>)>)>>>
+
+<DEFINE PRIMATCH (PTYP PAT "AUX" PAT1 ACTOR TEM)
+ #DECL ((PAT1) <PRIMTYPE LIST>
+ (PTYP) <OR <FORM ANY ANY> <SEGMENT ANY ANY>>)
+ <COND (<AND <TYPE? .PAT FORM SEGMENT>
+ <SET PAT1 .PAT>
+ <==? <LENGTH .PAT1> 2>
+ <==? <1 .PAT1> PRIMTYPE>>
+ <COND (<==? <2 .PAT1> <2 .PTYP>> .PAT1)
+ (ELSE <COND (.ORF <ORSORT <FORM OR .PAT1 .PTYP>>)>)>)
+ (<TYPE? .PAT ATOM>
+ <COND (<==? .PAT ANY> <COND (.ORF ANY) (.ANDF .PTYP) (ELSE T)>)
+ (<MEMQ .PAT '![STRUCTURED LOCATIVE APPLICABLE!]>
+ <COND (<STRUC .PAT <2 .PTYP> T>
+ <COND (.ORF .PAT) (ELSE .PTYP)>)
+ (ELSE <COND (.ORF <ORSORT <FORM OR .PAT .PTYP>>)>)>)
+ (<AND <VALID-TYPE? .PAT>
+ <==? <TYPEPRIM .PAT> <2 .PTYP>>
+ <COND (.ORF .PTYP) (ELSE .PAT)>>)
+ (ELSE <COND (.ORF <ORSORT <FORM OR .PTYP .PAT>>)>)>)
+ (<AND <TYPE? .PAT FORM SEGMENT>
+ <SET PAT1 .PAT>
+ <NOT <EMPTY? .PAT1>>>
+ <COND (<==? <SET ACTOR <1 .PAT1>> OR> <ACTORT .PAT .PTYP>)
+ (<==? .ACTOR NOT>
+ <COND (.ORF <NOT-IT .PAT .PTYP>)
+ (ELSE
+ <SET TEM <PRIMATCH .PTYP <2 .PAT1>>>
+ <COND (<AND <NOT .TEM> <EMPTY? .TEM>> .PTYP)
+ (<NOT .TEM> .TEM)
+ (<N=? .TEM .PTYP> ANY)>)>)
+ (<SET TEM <PRIMATCH .PTYP <1 .PAT1>>>
+ <COND (.ORF .TEM)
+ (.ANDF <COND (<TYPE? .PAT FORM>
+ <FORM .TEM !<REST .PAT1>>)
+ (ELSE
+ <CHTYPE (.TEM !<REST .PAT1>) SEGMENT>)>)
+ (ELSE T)>)>)>>
+
+"\f"
+
+<DEFINE NOT-IT (NF PAT "AUX" T1)
+ #DECL ((NF) <OR FORM SEGMENT>)
+ <COND (<AND <TYPE? .PAT FORM SEGMENT>
+ <NOT <EMPTY? .PAT>>
+ <OR <==? <1 .PAT> OR> <==? <1 .PAT> AND>>>
+ <ACTORT .PAT .NF>)
+ (ELSE
+ <COND (<==? <LENGTH .NF> 2>
+ <COND (<NOT <SET T1 <TYPE-AND <2 .NF> .PAT>>>
+ <COND (.ORF .NF) (.ANDF .PAT) (ELSE T)>)
+ (<==? <2 .NF> ANY> <COND (.ORF .PAT)>)
+ (<AND <N==? .T1 .PAT>
+ <N=? .T1 .PAT>
+ <N=? <CANONICAL-DECL .PAT>
+ <CANONICAL-DECL .T1>>>
+ <COND (<OR .ANDF .ORF> ANY) (ELSE T)>)
+ (.ORF ANY)>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)>>
+
+<DEFINE NOTIFY (D)
+ <COND (<AND <TYPE? .D FORM SEGMENT>
+ <==? <LENGTH .D> 2>
+ <==? <1 .D> NOT>>
+ <2 .D>)
+ (ELSE <FORM NOT .D>)>>
+"\f"
+
+<DEFINE FORMATCH (FRM RPAT "AUX" TEM (PAT .RPAT) EX)
+ #DECL ((FRM) <OR <FORM ANY> <SEGMENT ANY>>
+ (RPAT) <OR ATOM FORM LIST SEGMENT VECTOR FIX>)
+ <COND
+ (<AND <TYPE? .RPAT ATOM> <TYPE? <1 .FRM> ATOM> <==? <1 .FRM> .RPAT>>
+ <COND (.ORF .RPAT) (ELSE .FRM)>)
+ (ELSE
+ <COND (<TYPE? .RPAT ATOM> <SET PAT <SET EX <GET .RPAT DECL '.RPAT>>>)
+ (ELSE <SET RPAT <1 .PAT>>)>
+ <COND
+ (<TYPE? .PAT ATOM>
+ <SET TEM
+ <COND (<AND .ORF <NOT <CTMATCH .PAT <1 .FRM> <> <> T>>>
+ <ORSORT <FORM OR .RPAT .FRM>>)
+ (ELSE
+ <COND (<TYPE? <1 .FRM> ATOM> <TYPMAT <1 .FRM> .PAT>)
+ (<TYPE? <1 .FRM> FORM> <ACTORT <1 .FRM> .PAT>)>)>>
+ <COND (<AND .ANDF <NOT .ORF> .TEM>
+ <COND (<TYPE? .FRM FORM> <CHTYPE (.TEM !<REST .FRM>) FORM>)
+ (ELSE <CHTYPE (.TEM !<REST .FRM>) SEGMENT>)>)
+ (ELSE .TEM)>)
+ (<TYPE? .PAT FORM SEGMENT>
+ <COND (<MEMQ <1 .PAT> '![OR AND NOT PRIMTYPE!]> <ACTORT .PAT .FRM>)
+ (ELSE
+ <COND (<AND <==? <LENGTH .PAT> 2> <TYPE? <2 .PAT> LIST>>
+ <WRDFX .PAT .FRM .RPAT>)
+ (<AND <G=? <LENGTH .PAT> 2> <TYPE? <2 .PAT> FIX>>
+ <BYTES-HACK .PAT .FRM .RPAT>)
+ (<AND <G=? <LENGTH .FRM> 2> <TYPE? <2 .FRM> FIX>>
+ <BYTES-HACK .FRM .PAT <1 .FRM>>)
+ (<AND .ORF
+ <ASSIGNED? EX>
+ <NOT <CTMATCH .RPAT .FRM <> <> T>>>
+ <ORSORT <FORM OR .RPAT .FRM>>)
+ (<AND .ORF <NOT <CTMATCH .PAT .FRM <> <> T>>>
+ <ORSORT <FORM OR .PAT .FRM>>)
+ (ELSE
+ <SET TEM <ELETYPE .PAT .FRM .RPAT>>
+ <AND <ASSIGNED? EX>
+ <TYPE? .TEM FORM SEGMENT>
+ <G? <LENGTH .TEM> 1>
+ <==? <1 .TEM> OR>
+ <MAPR <>
+ <FUNCTION (EL)
+ <AND <=? <1 .EL> .EX>
+ <PUT .EL 1 .RPAT>
+ <MAPLEAVE>>>
+ <REST .TEM>>>
+ .TEM)>)>)>)>>
+
+"\f"
+
+<DEFINE BYTES-HACK (F1 F2 RPAT "AUX" FST TL TEM SEGF MLF1 MLF2)
+ #DECL ((F1 F2) <OR FORM SEGMENT> (MLF1 MLF2) FIX)
+ <SET SEGF <SEGANDOR .F1 .F2 .ORF>>
+ <COND (<OR <EMPTY? .F1> <EMPTY? .F2>> #FALSE (EMPTY-FORM-IN-DECL!-ERRORS))>
+ <SET FST
+ <COND (<TYPE? .RPAT ATOM>
+ <COND (<TYPE? <1 .F2> ATOM> <TYPMAT <1 .F2> .RPAT>)
+ (<TYPE? <1 .F2> FORM> <ACTORT <1 .F2> .RPAT>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
+ (<TYPE? .RPAT FORM> <ACTORT .RPAT <1 .F2>>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
+ <COND
+ (<NOT .FST> .FST)
+ (ELSE
+ <COND
+ (<CTMATCH .RPAT '<PRIMTYPE BYTES> <> <> <>>
+ <SET MLF1 <MINL .F1>>
+ <SET MLF2 <MINL .F2>>
+ <COND (<AND <G=? <LENGTH .F2> 2> <TYPE? <2 .F2> FIX>>
+ <COND (<CTMATCH <1 .F2> '<PRIMTYPE BYTES> <> <> <>>
+ <COND (.ORF
+ <COND (<==? <2 .F2> <2 .F1>>
+ <FOSE .SEGF .FST <2 .F1> <MIN .MLF1 .MLF2>>)
+ (ELSE <ORSORT <FORM OR .F1 .F2>>)>)
+ (<AND <==? <2 .F2> <2 .F1>>
+ <NOT <AND <TYPE? .F1 SEGMENT>
+ <TYPE? .F2 SEGMENT>
+ <N==? <2 .F1> <2 .F2>>>>>
+ <FOSE .SEGF .FST <2 .F1> <MAX .MLF1 .MLF2>>)>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
+ (<TMATCH .F2 '<PRIMTYPE BYTES>>
+ <COND (.ORF
+ <COND (<TMATCH .F2
+ <SET TEM
+ <COND (<0? .MLF1>
+ <FOSE .SEGF
+ <1 .F1>
+ '[REST FIX]>)
+ (ELSE
+ <FOSE .SEGF
+ <1 .F1>
+ [.MLF1 FIX]
+ '[REST FIX]>)>>>
+ <TYPE-MERGE .TEM .F2>)
+ (ELSE <ORSORT <FORM .F1 .F2>>)>)
+ (<TMATCH .F2
+ <COND (<0? .MLF1>
+ <FOSE .SEGF STRUCTURED '[REST FIX]>)
+ (ELSE
+ <FOSE .SEGF
+ STRUCTURED
+ [.MLF1 FIX]
+ '[REST FIX]>)>>
+ <FOSE .SEGF .FST <2 .F1> <MAX .MLF2 .MLF1>>)>)
+ (ELSE <COND (.ORF <ORSORT <FORM OR .F1 .F2>>) (ELSE <>)>)>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)>>
+
+<DEFINE FOSE ("TUPLE" TUP "AUX" (FLG <1 .TUP>))
+ <COND (.FLG <CHTYPE (!<REST .TUP>) SEGMENT>)
+ (ELSE <CHTYPE (!<REST .TUP>) FORM>)>>
+
+<DEFINE SEGANDOR (F1 F2 ORF)
+ <COND (.ORF <AND <TYPE? .F1 SEGMENT> <TYPE? .F2 SEGMENT>>)
+ (ELSE <OR <TYPE? .F1 SEGMENT> <TYPE? .F2 SEGMENT>>)>>
+
+<DEFINE WRDFX (F1 F2 RPAT "AUX" FST TL)
+ #DECL ((F1 F2) <OR FORM SEGMENT>)
+ <COND (<OR <EMPTY? <SET F1 <CHTYPE .F1 FORM>>>
+ <EMPTY? <SET F2 <CHTYPE .F2 FORM>>>>
+ #FALSE (EMPTY-FORM-IN-DECL!-ERRORS))>
+ <SET FST
+ <COND (<TYPE? .RPAT ATOM>
+ <COND (<TYPE? <1 .F2> ATOM> <TYPMAT <1 .F2> .RPAT>)
+ (<TYPE? <1 .F2> FORM> <ACTORT <1 .F2> .RPAT>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
+ (<TYPE? .RPAT FORM> <ACTORT .RPAT <1 .F2>>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
+ <COND
+ (<NOT .FST> .FST)
+ (ELSE
+ <COND (<CTMATCH .RPAT ,ALLWORDS <> <> <>>
+ <COND (<AND <LENGTH? .F2 2> <TYPE? <2 .F2> LIST>>
+ <COND (<CTMATCH <1 .F2> ,ALLWORDS <> <><>>
+ <COND (.ORF
+ <SET TL <MAP-MERGE !<2 .F1> !<2 .F2>>>
+ <COND (<EMPTY? .TL> .FST)
+ (ELSE <FORM .FST .TL>)>)
+ (<SET TL <AND-MERGE <2 .F1> <2 .F2>>>
+ <FORM .FST .TL>)>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
+ (ELSE <COND (.ORF <ORSORT <FORM OR .F1 .F2>>) (ELSE <>)>)>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)>>
+
+<DEFINE MAP-MERGE ("TUPLE" PAIRS "AUX" (HIGH <2 .PAIRS>) (LOW <1 .PAIRS>))
+ #DECL ((PAIRS) <TUPLE [REST FIX]> (HIGH LOW) FIX)
+ <REPEAT ()
+ <COND (<EMPTY? <SET PAIRS <REST .PAIRS 2>>> <RETURN>)>
+ <SET HIGH <MAX .HIGH <2 .PAIRS>>>
+ <SET LOW <MIN .LOW <1 .PAIRS>>>>
+ <COND (<AND <==? .HIGH <CHTYPE <MIN> FIX>>
+ <==? .LOW <CHTYPE <MAX> FIX>>>
+ ())
+ (ELSE (.LOW .HIGH))>>
+
+
+<DEFINE AND-MERGE (L1 L2 "AUX" (FLG <>) HIGH LOW TEM (L (0)) (LL .L))
+ #DECL ((L LL L1 L2) <LIST [REST FIX]> (HIGH LOW) FIX)
+ <COND (<G? <LENGTH .L1> <LENGTH .L2>>
+ <SET TEM .L1>
+ <SET L1 .L2>
+ <SET L2 .TEM>)>
+ <REPEAT ()
+ <SET LOW <1 .L2>>
+ <SET HIGH <2 .L2>>
+ <REPEAT ((L1 .L1) LO HI)
+ #DECL ((L1) <LIST [REST FIX]> (LO HI) FIX)
+ <COND (<EMPTY? .L1> <RETURN>)>
+ <SET HI <2 .L1>>
+ <COND (<OR <AND <G=? <SET LO <1 .L1>> .LOW>
+ <L=? .LO .HIGH>>
+ <AND <L=? .HI .HIGH> <G=? .HI .LOW>>
+ <AND <G=? .LOW .LO> <L=? .LOW .HI>>
+ <AND <L=? .HIGH .HI> <G=? .HIGH .LO>>>
+ <SET LOW <MAX .LOW .LO>>
+ <SET HIGH <MIN .HIGH .HI>>
+ <SET L <REST <PUTREST .L (.LOW .HIGH)> 2>>
+ <SET FLG T>
+ <RETURN>)>
+ <SET L1 <REST .L1 2>>>
+ <COND (<EMPTY? <SET L2 <REST .L2 2>>>
+ <RETURN <COND (.FLG <REST .LL>) (ELSE <>)>>)>>>
+
+"\f"
+
+<DEFINE GET-RANGE (L1 "AUX" TT)
+ <COND (<AND <TYPE? .L1 FORM>
+ <TMATCH .L1 ,ALLWORDS>
+ <TYPE? <2 .L1> LIST>>
+ <COND (<NOT <EMPTY? <SET TT <MAP-MERGE !<2 .L1>>>>> .TT)>)>>
+
+"\f"
+
+<DEFINE ELETYPE (F1 F2 RTYP
+ "AUX" (S1 <VECTOR .F1 <> 0 <> <> '[]>) (FAIL <>) (INOPT <>)
+ (S2 <VECTOR .F2 <> 0 <> <> '[]>) (FL ()) (FP '<>) FSTL
+ SEGF RTEM)
+ #DECL ((S1 S2) <VECTOR <PRIMTYPE LIST> ANY FIX ANY ANY ANY>
+ (F1 F2) <PRIMTYPE LIST> (FP) <OR FORM SEGMENT> (FL) LIST)
+ <SET SEGF <SEGANDOR .F1 .F2 .ORF>>
+ <COND
+ (<OR <EMPTY? .F1> <EMPTY? .F2>> #FALSE (EMPTY-FORM-IN-DECL!-ERRORS))
+ (<AND .ANDF .ORF <NOT <TMATCH <1 .F2> .RTYP>>> <ORSORT <FORM OR .F1 .F2>>)
+ (ELSE
+ <COND
+ (<SET FSTL
+ <COND (<TYPE? .RTYP ATOM>
+ <COND (<TYPE? <1 .F2> ATOM> <TYPMAT .RTYP <1 .F2>>)
+ (<TYPE? <1 .F2> FORM> <ACTORT <1 .F2> .RTYP>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
+ (<TYPE? .RTYP FORM> <ACTORT .RTYP <1 .F2>>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
+ <COND (.ANDF
+ <SET FL
+ <CHTYPE <SET FP
+ <COND (.SEGF <CHTYPE (.FSTL) SEGMENT>)
+ (ELSE <FORM .FSTL>)>>
+ LIST>>)>
+ <PUT .S1 ,DECL-RESTED <REST .F1>>
+ <PUT .S2 ,DECL-RESTED <REST .F2>>
+ <REPEAT ((TEM1 <>) (TEM2 <>) T1 T2 TEM TT)
+ #DECL ((TT) <VECTOR FIX ANY>)
+ <SET T1 <SET T2 <>>>
+ <COND
+ (<AND <OR <AND <SET TEM1 <NEXTP .S1>> <SET T1 <DECL-ELEMENT .S1>>>
+ <AND <EMPTY? .TEM1> <SET T1 ANY>>>
+ <OR <AND <SET TEM2 <NEXTP .S2>> <SET T2 <DECL-ELEMENT .S2>>>
+ <AND .TEM1 <EMPTY? .TEM2> <SET T2 ANY>>>>
+ <COND (<AND .ORF <OR <NOT .TEM1> <NOT .TEM2>>>
+ <RETURN <COND (<LENGTH? .FP 1> <1 .FP>) (ELSE .FP)>>)>
+ <OR <SET RTEM
+ <SET TEM
+ <COND (<NOT .TEM1>
+ <COND (<OR <TYPE? .F1 FORM> <DECL-IN-REST .S2>>
+ .T2)
+ (ELSE <SET FAIL T> <>)>)
+ (<NOT .TEM2>
+ <COND (<OR <TYPE? .F2 FORM> <DECL-IN-REST .S1>>
+ .T1)
+ (ELSE <SET FAIL T> <>)>)
+ (ELSE <DTMATCH .T1 .T2>)>>>
+ <COND (.ORF <SET TEM <ORSORT <FORM OR .T1 .T2>>>)
+ (.MAYBEF <COND (.FAIL <RETURN <>>) (ELSE <SET FAIL T>)>)
+ (ELSE <RETURN <>>)>>
+ <COND (<AND <NOT .INOPT>
+ <OR <AND .ORF
+ <OR <DECL-IN-COUNT-VEC .S1>
+ <DECL-IN-COUNT-VEC .S2>>>
+ <AND .ANDF
+ <NOT .ORF>
+ <DECL-IN-COUNT-VEC .S1>
+ <DECL-IN-COUNT-VEC .S2>>>>
+ <SET INOPT <COND (.ANDF (OPTIONAL .TEM)) (ELSE ())>>)
+ (<AND .INOPT .ANDF>
+ <PUTREST <REST .INOPT <- <LENGTH .INOPT> 1>> (.TEM)>)>
+ <COND (<AND .INOPT
+ <OR <AND .ORF
+ <OR <0? <DECL-ITEM-COUNT .S1>>
+ <0? <DECL-ITEM-COUNT .S2>>>>
+ <AND .ANDF
+ <0? <DECL-ITEM-COUNT .S1>>
+ <0? <DECL-ITEM-COUNT .S2>>>>>
+ <AND .ANDF <SET TEM [!.INOPT]>>
+ <SET INOPT <>>)>
+ <COND
+ (<OR <AND .ORF
+ <OR <AND <DECL-IN-REST .S1> <EMPTY? <DECL-RESTED .S2>>>
+ <AND <DECL-IN-REST .S2> <EMPTY? <DECL-RESTED .S1>>>>>
+ <AND <OR <DECL-IN-REST .S1>
+ <AND .ANDF <OR <NOT .TEM1> <DECL-IN-COUNT-VEC .S1>>>>
+ <OR <DECL-IN-REST .S2>
+ <AND .ANDF
+ <OR <NOT .TEM2> <DECL-IN-COUNT-VEC .S2>>>>>>
+ <COND
+ (<OR .ORF .ANDF>
+ <COND (<N==? 0
+ <SET T1
+ <RESTER? .S1
+ .S2
+ .FL
+ .RTEM
+ <TYPE? .F2 SEGMENT>>>>
+ <COND (<==? .T1 T>
+ <RETURN <COND (<LENGTH? .FP 1> <1 .FP>)
+ (ELSE .FP)>>)
+ (ELSE
+ <RETURN <COND (<AND <TYPE? .T1 FORM SEGMENT>
+ <LENGTH? .FP 1>>
+ <1 .T1>)
+ (ELSE .T1)>>)>)
+ (<N==? 0
+ <SET T1
+ <RESTER? .S2
+ .S1
+ .FL
+ .RTEM
+ <TYPE? .F1 SEGMENT>>>>
+ <COND (<==? .T1 T>
+ <RETURN <COND (<LENGTH? .FP 1> <1 .FP>)
+ (ELSE .FP)>>)
+ (ELSE
+ <RETURN <COND (<AND <TYPE? .T1 FORM SEGMENT>
+ <LENGTH? .FP 1>>
+ <1 .T1>)
+ (ELSE .T1)>>)>)>)
+ (ELSE <RETURN T>)>)
+ (<AND <NOT .ANDF>
+ <OR <DECL-IN-REST .S1> <NOT .TEM1>>
+ <OR <DECL-IN-REST .S2> <NOT .TEM2>>>
+ <RETURN T>)>
+ <COND (<AND <NOT .INOPT>
+ .ANDF
+ <OR <NOT .ORF>
+ <NOT <OR <DECL-IN-REST .S1> <DECL-IN-REST .S2>>>>>
+ <COND (<AND <TYPE? <1 .FL> VECTOR>
+ <=? <2 <SET TT <1 .FL>>> .TEM>>
+ <PUT .TT 1 <+ <1 .TT> 1>>)
+ (<AND <N==? <CHTYPE .FP LIST> .FL> <=? .TEM <1 .FL>>>
+ <PUT .FL 1 [2 .TEM]>)
+ (ELSE <SET FL <REST <PUTREST .FL (.TEM)>>>)>)>)
+ (ELSE
+ <COND (<AND <EMPTY? .TEM1> <EMPTY? <SET TEM1 .TEM2>>>
+ <COND (.ANDF
+ <RETURN <COND (<LENGTH? .FP 1> <1 .FP>) (ELSE .FP)>>)
+ (ELSE <RETURN T>)>)
+ (ELSE <RETURN .TEM1>)>)>>)>)>>
+
+"\f"
+
+<DEFINE RESTER? (S1 S2 FL FST SEGF
+ "AUX" (TT <DECL-REST-VEC .S1>) (TEM1 T) (TEM2 T) (OPTIT <>))
+ #DECL ((S1 S2) <VECTOR ANY ANY ANY ANY ANY VECTOR> (FL) <LIST ANY>
+ (TT) VECTOR)
+ <COND (<AND <OR .ORF <DECL-IN-COUNT-VEC .S2>>
+ <EMPTY? <DECL-RESTED .S2>> <NOT <DECL-IN-REST .S2>>>
+ <SET OPTIT T>)>
+ <COND
+ (<AND .SEGF <NOT .ORF> <OR <NOT <DECL-IN-REST .S1>>
+ <NOT <DECL-IN-REST .S2>>>> T)
+ (<AND <NOT <EMPTY? .TT>>
+ <OR <NOT <DECL-IN-REST .S2>> <G=? <LENGTH .TT>
+ <LENGTH <REST <TOP <DECL-REST-VEC .S2>>>>>>>
+ <SET TT <REST <TOP .TT>>>
+ <MAPR <>
+ <FUNCTION (SO "AUX" T1)
+ #DECL ((SO) <VECTOR ANY>)
+ <SET T1
+ <OR <AND <SET TEM1 <NEXTP .S2>> <DECL-ELEMENT .S2>>
+ <AND <EMPTY? .TEM1>
+ <COND (.ORF <MAPLEAVE>) (ELSE ANY)>>>>
+ <AND <OR .ORF <DECL-IN-COUNT-VEC .S2>>
+ <EMPTY? <DECL-RESTED .S2>>
+ <NOT <DECL-IN-REST .S2>>
+ <SET OPTIT T>>
+ <COND (<NOT .TEM1> <AND <EMPTY? .TEM1> <SET TEM1 T>>)>
+ <COND (.T1
+ <PUT .SO
+ 1
+ <SET TEM2
+ <DTMATCH <AND <NEXTP .S1>
+ <DECL-ELEMENT .S1>> .T1>>>)>
+ <AND <OR <NOT .T1> <NOT .TEM2>> <MAPLEAVE>>>
+ <REST <SET TT [REST .FST !<REST .TT>]> 2>>
+ <COND (.OPTIT <PUT .TT 1 OPTIONAL>)
+ (ELSE <SET TT <UNIQUE-VECTOR-CHECK .TT>>)>
+ <COND (<AND .TEM1 .TEM2> <PUTREST .FL (.TT)> T)
+ (<AND <NOT .TEM1> <NOT <EMPTY? .TEM1>>> .TEM1)
+ (ELSE .TEM2)>)
+ (ELSE 0)>>
+
+<DEFINE UNIQUE-VECTOR-CHECK (V "AUX" (FRST <2 .V>))
+ #DECL ((V) <VECTOR [2 ANY]>)
+ <COND (<MAPF <>
+ <FUNCTION (X) <COND (<N=? .X .FRST> <MAPLEAVE .V>)>>
+ <REST .V 2>>)
+ (ELSE [REST .FRST])>>
+
+
+<DEFINE NEXTP (S "AUX" TEM TT N)
+ #DECL ((S) <VECTOR <PRIMTYPE LIST> ANY FIX ANY ANY ANY> (N) FIX
+ (TT) VECTOR)
+ <COND (<0? <DECL-ITEM-COUNT .S>> <PUT .S ,DECL-IN-COUNT-VEC <>>)>
+ <COND (<DECL-IN-REST .S> <NTHREST .S>)
+ (<NOT <0? <DECL-ITEM-COUNT .S>>>
+ <PUT .S ,DECL-ITEM-COUNT <- <DECL-ITEM-COUNT .S> 1>>
+ <NTHREST .S>)
+ (<EMPTY? <SET TEM <DECL-RESTED .S>>> <>)
+ (<TYPE? <1 .TEM> ATOM FORM SEGMENT>
+ <SET TEM <1 .TEM>>
+ <PUT .S ,DECL-RESTED <REST <DECL-RESTED .S>>>
+ <PUT .S ,DECL-ELEMENT .TEM>)
+ (<TYPE? <1 .TEM> VECTOR>
+ <SET TT <1 .TEM>>
+ <PUT .S ,DECL-RESTED <REST <DECL-RESTED .S>>>
+ <PUT .S ,DECL-REST-VEC <REST .TT>>
+ <COND (<G? <LENGTH .TT> 1>
+ <COND (<==? <1 .TT> REST>
+ <COND (<AND <==? <LENGTH .TT> 2>
+ <==? <2 .TT> ANY>>
+ <>)
+ (ELSE
+ <PUT .S ,DECL-IN-REST T>
+ <PUT .S
+ ,DECL-ELEMENT
+ <DECL-ELEMENT .TT>>)>)
+ (<OR <AND <TYPE? <1 .TT> FIX> <SET N <1 .TT>>>
+ <AND <MEMQ <1 .TT> '![OPT OPTIONAL!]>
+ <SET N 1>>>
+ <OR <TYPE? <1 .TT> FIX>
+ <PUT .S ,DECL-IN-COUNT-VEC T>>
+ <PUT .S
+ ,DECL-ITEM-COUNT
+ <- <* .N <- <LENGTH .TT> 1>> 1>>
+ <PUT .S ,DECL-ELEMENT <2 .TT>>
+ <COND (<L=? .N 0> <>) (ELSE .S)>)
+ (#FALSE (BAD-VECTOR-SYNTAX!-ERRORS))>)
+ (ELSE #FALSE (BAD-FORM-SYNTAX!-ERRORS))>)
+ (ELSE #FALSE (BAD-FORM-SYNTAX!-ERRORS))>>
+
+"\f"
+
+<DEFINE NTHREST (S "AUX" (TEM <REST <DECL-REST-VEC .S>>))
+ #DECL ((S) <VECTOR ANY ANY ANY ANY ANY VECTOR> (TEM) VECTOR)
+ <COND (<EMPTY? .TEM> <SET TEM <REST <TOP .TEM>>>)>
+ <PUT .S ,DECL-REST-VEC .TEM>
+ <PUT .S ,DECL-ELEMENT <1 .TEM>>>
+"\f"
+
+<DEFINE GET-ELE-TYPE (DCL2 NN
+ "OPTIONAL" (RST <>) (PT <>)
+ "AUX" (LN 0) (CNT 0) ITYP DC SDC DCL (N 0) DC1 (QOK <>)
+ (FMOK <>) STRU (GD '<>) (GP ()) (K 0) (DCL1 .DCL2)
+ (SEGF <>) TEM)
+ #DECL ((LN CNT K N) FIX (DCL) <PRIMTYPE LIST> (SDC DC) VECTOR
+ (GD) <OR FORM SEGMENT> (GP) LIST)
+ <PROG ()
+ <COND (<AND .PT <SET TEM <ISTYPE? .DCL1>>>
+ <SET PT <TYPE-AND <GET-ELE-TYPE .TEM .NN> .PT>>)>
+ <AND <TYPE? .DCL1 ATOM> <SET DCL1 <GET .DCL1 DECL '.DCL1>>>
+ <COND (<TYPE? .DCL1 SEGMENT> <SET SEGF T>)>
+ <COND (<==? <STRUCTYP .DCL2> BYTES>
+ <RETURN <GET-ELE-BYTE .DCL2 .NN .RST .PT>>)>
+ <COND (.RST <SET STRU <COND (<STRUCTYP .DCL1>) (ELSE STRUCTURED)>>)
+ (.PT
+ <SET STRU
+ <COND (<ISTYPE? .DCL2>)
+ (<SET STRU <STRUCTYP .DCL1>> <FORM PRIMTYPE .STRU>)
+ (ELSE STRUCTURED)>>)>
+ <COND
+ (<AND <TYPE? .DCL1 FORM SEGMENT>
+ <SET DCL .DCL1>
+ <G? <SET LN <LENGTH .DCL>> 1>
+ <NOT <SET FMOK <MEMQ <1 .DCL> '![OR AND NOT!]>>>
+ <NOT <SET QOK <==? <1 .DCL> QUOTE>>>
+ <NOT <==? <1 .DCL> PRIMTYPE>>>
+ <COND
+ (<==? .NN ALL>
+ <AND .PT <SET GP <CHTYPE <SET GD <FOSE .SEGF .STRU>> LIST>>>
+ <OR
+ <AND <TYPE? <SET DC1 <2 .DCL>> VECTOR>
+ <SET DC .DC1>
+ <G=? <LENGTH .DC> 2>
+ <==? <1 .DC> REST>
+ <COND (<==? <LENGTH .DC> 2>
+ <COND (.RST <FORM .STRU [REST <2 .DC>]>)
+ (.PT <FORM .STRU [REST <TYPE-MERGE <2 .DC> .PT>]>)
+ (ELSE <2 .DC>)>)
+ (.RST <FORM .STRU [REST <TYPE-MERGE !<REST .DC>>]>)
+ (.PT
+ <FORM .STRU
+ [REST
+ <MAPF ,TYPE-MERGE
+ <FUNCTION (D) <TYPE-MERGE .D .PT>>
+ <REST .DC>>]>)
+ (ELSE <TYPE-MERGE !<REST .DC>>)>>
+ <REPEAT (TT (CK <DCX <SET TT <2 .DCL>>>) (D .DCL) TEM)
+ #DECL ((D) <PRIMTYPE LIST>)
+ <COND (<EMPTY? <SET D <REST .D>>>
+ <SET TEM
+ <OR .SEGF
+ <AND <TYPE? .TT VECTOR> <==? <1 .TT> REST>>>>
+ <RETURN <COND (.TEM
+ <COND (.RST <FORM .STRU [REST .CK]>)
+ (.PT .GD)
+ (ELSE .CK)>)
+ (.PT .GD)
+ (.RST .STRU)
+ (ELSE ANY)>>)>
+ <SET CK <TYPE-MERGE .CK <DCX <SET TT <1 .D>>>>>
+ <AND .PT
+ <SET GP
+ <REST
+ <PUTREST .GP
+ (<COND (<TYPE? .TT VECTOR>
+ [<1 .TT>
+ !<MAPF ,LIST
+ <FUNCTION (X)
+ <TYPE-MERGE .X .PT>>
+ <REST .TT>>])
+ (ELSE
+ <TYPE-MERGE .PT .TT>)>)>>>>>>)
+ (ELSE
+ <SET N .NN>
+ <AND .PT <SET GP <CHTYPE <SET GD <FOSE .SEGF .STRU>> LIST>>>
+ <AND .RST <SET N <+ .N 1>>>
+ <COND (<EMPTY? <SET DCL <REST .DCL>>>
+ <RETURN <COND (.RST .STRU)
+ (.PT <FOSE .SEGF .STRU !<ANY-PAT <- .N 1>> .PT>)
+ (ELSE ANY)>>)>
+ <REPEAT ()
+ <COND
+ (<NOT <0? .CNT>>
+ <COND
+ (<EMPTY? <SET SDC <REST .SDC>>>
+ <SET SDC <REST .DC>>
+ <AND
+ <0? <SET CNT <- .CNT 1>>>
+ <COND (<EMPTY? <SET DCL <REST .DCL>>>
+ <RETURN <COND (.RST .STRU)
+ (.PT
+ <PUTREST .GP (!<ANY-PAT <- .N 1>> .PT)>
+ .GD)
+ (ELSE ANY)>>)
+ (ELSE <AGAIN>)>>)>
+ <SET ITYP <1 .SDC>>)
+ (<TYPE? <1 .DCL> ATOM FORM SEGMENT>
+ <SET ITYP <1 .DCL>>
+ <SET DCL <REST .DCL>>)
+ (<TYPE? <SET DC1 <1 .DCL>> VECTOR>
+ <SET DC .DC1>
+ <COND
+ (<==? <1 .DC> REST>
+ <AND <OR <AND .RST <NOT <1? .N>>> .PT>
+ <==? 2 <LENGTH .DC>>
+ <=? <2 .DC> '<NOT ANY>>
+ <RETURN <>>>
+ <SET K <MOD <- .N 1> <- <LENGTH .DC> 1>>>
+ <SET N </ <- .N 1> <- <LENGTH .DC> 1>>>
+ <RETURN
+ <COND
+ (.RST
+ <FOSE .SEGF
+ .STRU
+ <COND (<0? .K> .DC)
+ (ELSE [REST <TYPE-MERGE !<REST .DC>>])>>)
+ (.PT
+ <PUTREST
+ .GP
+ (!<COND (<L=? .N 0> ())
+ (<1? .N> (!<REST .DC>))
+ (ELSE ([.N !<REST .DC>]))>
+ !<MAPF ,LIST
+ <FUNCTION (O)
+ <COND (<==? <SET K <- .K 1>> -1> .PT)
+ (ELSE .O)>>
+ <REST .DC>>
+ .DC)>
+ .GD)
+ (ELSE <NTH .DC <+ .K 2>>)>>)
+ (<OR <TYPE? <1 .DC> FIX> <==? <1 .DC> OPT> <==? <1 .DC> OPTIONAL>>
+ <SET CNT <COND (<TYPE? <1 .DC> FIX> <1 .DC>) (ELSE 1)>>
+ <SET SDC .DC>
+ <AGAIN>)>)>
+ <AND
+ <0? <SET N <- .N 1>>>
+ <RETURN
+ <COND
+ (.RST
+ <COND (<AND <EMPTY? .DCL> <0? .CNT>> .STRU)
+ (<FOSE .SEGF
+ .STRU
+ !<COND (<0? .CNT> (.ITYP !.DCL))
+ (<N==? .SDC <REST .DC>>
+ <COND (<0? <SET CNT <- .CNT 1>>>
+ (!.SDC !<REST .DCL>))
+ (ELSE
+ (!.SDC
+ [.CNT !<REST .DC>]
+ !<REST .DCL>))>)
+ (ELSE ([.CNT !.SDC] !<REST .DCL>))>>)>)
+ (.PT
+ <SET GP <REST <PUTREST .GP (.PT)>>>
+ <AND <ASSIGNED? SDC> <SET SDC <REST .SDC>>>
+ <COND (<AND <EMPTY? .DCL> <0? .CNT>> .GD)
+ (<PUTREST .GP
+ <COND (<OR <0? .CNT>
+ <AND <1? .CNT> <==? .SDC <REST .DC>>>>
+ .DCL)
+ (<==? .SDC <REST .DC>>
+ ([.CNT !<REST .DC>] !<REST .DCL>))
+ (<L=? <SET CNT <- .CNT 1>> 0>
+ (!.SDC !<REST .DCL>))
+ (ELSE
+ (!.SDC
+ [.CNT !<REST .DC>]
+ !<REST .DCL>))>>
+ .GD)>)
+ (ELSE .ITYP)>>>
+ <AND <OR .PT .RST> <=? .ITYP '<NOT ANY>> <RETURN <>>>
+ <AND .PT <SET GP <REST <PUTREST .GP (.ITYP)>>>>
+ <COND (<EMPTY? .DCL>
+ <RETURN <COND (.RST .STRU)
+ (.PT
+ <PUTREST .GP (!<ANY-PAT <- .N 1>> .PT)>
+ .GD)
+ (ELSE ANY)>>)>>)>)
+ (.QOK <SET DCL1 <GEN-DECL <2 .DCL>>> <AGAIN>)
+ (<AND .FMOK <==? <1 .FMOK> OR>>
+ <MAPF ,TYPE-MERGE
+ <FUNCTION (D "AUX" IT)
+ <COND (<SET IT <GET-ELE-TYPE .D .NN .RST .PT>>
+ <AND <==? .IT ANY> <MAPLEAVE ANY>>
+ .IT)
+ (ELSE <MAPRET>)>>
+ <REST .DCL>>)
+ (<AND .FMOK <==? <1 .FMOK> AND>>
+ <SET ITYP ANY>
+ <MAPF <>
+ <FUNCTION (D)
+ <SET ITYP <TYPE-OK? .ITYP <GET-ELE-TYPE .D .NN .RST>>>>
+ <REST .DCL>>
+ .ITYP)
+ (.RST <COND (<STRUCTYP .DCL1>) (ELSE STRUCTURED)>)
+ (.PT
+ <COND (<==? .NN ALL> .DCL1)
+ (ELSE <FOSE .SEGF .DCL1 !<ANY-PAT <- .NN 1>> .PT>)>)
+ (ELSE ANY)>>>
+
+"\f"
+
+<DEFINE GET-ELE-BYTE (DCL N RST PT "AUX" SIZ)
+ #DECL ((N) <OR ATOM FIX>)
+ <COND (.PT
+ <COND (<==? .N ALL> .DCL)
+ (<TYPE-AND .DCL <FORM STRUCTURED [.N FIX] [REST FIX]>>)>)
+ (.RST
+ <COND (<==? .N ALL> <SET N <MINL .DCL>>)
+ (<G? .N <MINL .DCL>> <SET N 0>)
+ (ELSE <SET N <- <MINL .DCL> .N>>)>
+ <COND (<SET SIZ <GETBSYZ .DCL>> <FORM BYTES .SIZ .N>)
+ (ELSE BYTES)>)
+ (ELSE FIX)>>
+
+<DEFINE GETBSYZ (DCL "AUX" TEM)
+ <COND (<==? <SET TEM <STRUCTYP .DCL>> STRING> 7)
+ (<AND <==? .TEM BYTES> <TYPE? .DCL FORM SEGMENT> <G=? <LENGTH .DCL> 2>
+ <TYPE? <SET TEM <2 .DCL>> FIX>>
+ .TEM)>>
+
+<DEFINE MINL (DCL "AUX" (N 0) DD D DC (LN 0) (QOK <>) (ANDOK <>) TT (OROK <>))
+ #DECL ((N VALUE LN) FIX (DC) <PRIMTYPE LIST> (D) VECTOR)
+ <AND <TYPE? .DCL ATOM> <SET DCL <GET .DCL DECL '.DCL>>>
+ <COND
+ (<AND <TYPE? .DCL FORM SEGMENT>
+ <SET DC .DCL>
+ <G? <LENGTH .DC> 1>
+ <N==? <SET TT <1 .DC>> PRIMTYPE>
+ <NOT <SET OROK <==? .TT OR>>>
+ <NOT <SET QOK <==? .TT QUOTE>>>
+ <NOT <SET ANDOK <==? .TT AND>>>
+ <N==? .TT NOT>>
+ <SET DC <REST .DC>>
+ <COND (<AND <NOT <EMPTY? .DC>> <TYPE? <1 .DC> FIX>>
+ <OR <TMATCH .TT '<PRIMTYPE BYTES>>
+ <MESSAGE ERROR "BAD-DECL-SYNTAX" .DCL>>
+ <COND (<AND <==? <LENGTH .DC> 2> <TYPE? <2 .DC> FIX>>
+ <2 .DC>)
+ (ELSE 0)>)
+ (ELSE
+ <REPEAT ()
+ #DECL ((VALUE) FIX)
+ <COND (<AND <TYPE? <SET DD <1 .DC>> VECTOR>
+ <SET D .DD>
+ <G? <LENGTH .D> 1>>
+ <COND (<MEMQ <1 .D> '[REST OPT OPTIONAL]> <RETURN .N>)
+ (<TYPE? <1 .D> FIX>
+ <SET LN <1 .D>>
+ <SET N <+ .N <* .LN <- <LENGTH .D> 1>>>>)
+ (ELSE <MESSAGE ERROR "BAD DECL " .DCL>)>)
+ (<TYPE? .DD ATOM FORM SEGMENT> <SET N <+ .N 1>>)
+ (ELSE <MESSAGE ERROR "BAD DECL " .DCL>)>
+ <AND <EMPTY? <SET DC <REST .DC>>> <RETURN .N>>>)>)
+ (<OR .OROK .ANDOK> <CHTYPE <MAPF <COND (.OROK ,MIN) (ELSE ,MAX)> ,MINL <REST .DC>>
+ FIX>)
+ (.QOK <COND (<STRUCTURED? <2 .DC>> <LENGTH <2 .DC>>) (ELSE 0)>)
+ (<TYPE? .DCL ATOM FALSE FORM SEGMENT> 0)
+ (ELSE <MESSAGE "BAD DECL " .DCL>)>>
+
+<DEFINE STRUCTYP (DCL)
+ <SET DCL <TYPE-AND .DCL STRUCTURED>>
+ <COND (<TYPE? .DCL ATOM>
+ <AND <VALID-TYPE? .DCL> <TYPEPRIM .DCL>>)
+ (<TYPE? .DCL FORM SEGMENT>
+ <COND (<PRIMHK .DCL T>)
+ (<TYPE? <1 .DCL> FORM> <PRIMHK <1 .DCL> <>>)>)>>
+
+<DEFINE PRIMHK (FRM FLG "AUX" TEM (LN <LENGTH .FRM>))
+ #DECL ((FRM) <OR FORM SEGMENT> (LN) FIX)
+ <COND (<AND <==? .LN 2>
+ <COND (<==? <SET TEM <1 .FRM>> PRIMTYPE>
+ <AND <TYPE? <SET TEM <2 .FRM>> ATOM>
+ <VALID-TYPE? .TEM>
+ <STRUCTYP <2 .FRM>>>)
+ (<==? .TEM QUOTE> <PRIMTYPE <2 .FRM>>)
+ (<==? .TEM NOT> <>)>>)
+ (<NOT <0? .LN>>
+ <COND (<==? <SET TEM <1 .FRM>> OR>
+ <SET TEM NO-RETURN>
+ <MAPF <>
+ <FUNCTION (D)
+ <SET TEM <TYPE-MERGE <STRUCTYP .D> .TEM>>> <REST .FRM>>
+ <COND (<AND <TYPE? .TEM ATOM> <VALID-TYPE? .TEM>> .TEM)>)
+ (<==? .TEM AND>
+ <MAPF <>
+ <FUNCTION (D)
+ <COND (<SET TEM <STRUCTYP .D>> <MAPLEAVE>)>>
+ <REST .FRM>>
+ .TEM)
+ (<AND <TYPE? .TEM ATOM> <VALID-TYPE? .TEM>>
+ <TYPEPRIM .TEM>)>)>>
+
+"\f"
+
+<DEFINE TYPESAME (T1 T2)
+ <AND <SET T1 <ISTYPE? .T1>>
+ <==? .T1 <ISTYPE? .T2>>>>
+
+<DEFINE ISTYPE-GOOD? (TYP "OPTIONAL" (STRICT <>))
+ <AND <SET TYP <ISTYPE? .TYP .STRICT>>
+ <NOT <MEMQ <TYPEPRIM .TYP> '![BYTES STRING LOCD TUPLE FRAME!]>>
+ .TYP>>
+
+<DEFINE TOP-TYPE (TYP "AUX" TT)
+ <COND (<AND <TYPE? .TYP ATOM> <NOT <VALID-TYPE? .TYP>>
+ <NOT <MEMQ .TYP '![STRUCTURED APPLICABLE ANY LOCATIVE]>>>
+ <SET TYP <GET .TYP DECL '.TYP>>)>
+ <COND (<TYPE? .TYP ATOM> .TYP)
+ (<AND <TYPE? .TYP FORM SEGMENT> <NOT <LENGTH? .TYP 1>>>
+ <COND (<==? <SET TT <1 .TYP>> OR>
+ <MAPF ,TYPE-MERGE ,TOP-TYPE <REST .TYP>>)
+ (<==? .TT NOT> ANY)
+ (<==? .TT QUOTE> <TYPE <2 .TYP>>)
+ (<==? .TT PRIMTYPE> .TYP)
+ (ELSE .TT)>)>>
+
+<DEFINE ISTYPE? (TYP "OPTIONAL" (STRICT <>) "AUX" TY)
+ <PROG ()
+ <OR .STRICT <TYPE? .TYP ATOM> <SET TYP <TYPE-AND .TYP '<NOT
+ UNBOUND>>>>
+ <COND
+ (<TYPE? .TYP FORM SEGMENT>
+ <COND (<AND <==? <LENGTH .TYP> 2> <==? <1 .TYP> QUOTE>>
+ <SET TYP <TYPE <2 .TYP>>>)
+ (<==? <1 .TYP> OR>
+ <SET TYP <ISTYPE? <2 <SET TY .TYP>>>>
+ <MAPF <>
+ <FUNCTION (Z)
+ <COND (<N==? .TYP <ISTYPE? .Z>>
+ <MAPLEAVE <SET TYP <>>>)>>
+ <REST .TY 2>>)
+ (ELSE <SET TYP <1 .TYP>>)>)>
+ <AND <TYPE? .TYP ATOM>
+ <COND (<VALID-TYPE? .TYP> .TYP)
+ (<SET TYP <GET .TYP DECL>> <AGAIN>)>>>>
+
+
+<DEFINE DCX (IT "AUX" TT LN)
+ #DECL ((TT) VECTOR (LN) FIX)
+ <COND (<AND <TYPE? .IT VECTOR>
+ <G=? <SET LN <LENGTH <SET TT .IT>>> 2>
+ <COND (<==? .LN 2> <2 .TT>)
+ (ELSE <TYPE-MERGE !<REST .TT>>)>>)
+ (ELSE .IT)>>
+
+"DETERMINE IF A TYPE PATTERN REQUIRES DEFERMENT 0=> NO 1=> YES 2=> DONT KNOW "
+
+"\f"
+
+<DEFINE DEFERN (PAT "AUX" STATE TEM)
+ #DECL ((STATE) FIX)
+ <PROG ()
+ <COND
+ (<TYPE? .PAT ATOM>
+ <COND (<VALID-TYPE? .PAT>
+ <COND (<MEMQ <SET PAT <TYPEPRIM .PAT>>
+ '![STRING TUPLE LOCD FRAME BYTES!]>
+ 1)
+ (ELSE 0)>)
+ (<SET PAT <GET .PAT DECL>> <AGAIN>)
+ (ELSE 2)>)
+ (<AND <TYPE? .PAT FORM SEGMENT> <NOT <EMPTY? .PAT>>>
+ <COND (<==? <SET TEM <1 .PAT>> QUOTE> <DEFERN <TYPE <2 .PAT>>>)
+ (<==? .TEM PRIMTYPE> <DEFERN <2 .PAT>>)
+ (<AND <==? .TEM OR> <NOT <EMPTY? <REST .PAT>>>>
+ <SET STATE <DEFERN <2 .PAT>>>
+ <MAPF <>
+ <FUNCTION (P)
+ <OR <==? <DEFERN .P> .STATE> <SET STATE 2>>>
+ <REST .PAT 2>>
+ .STATE)
+ (<==? .TEM NOT> 2)
+ (<==? .TEM AND>
+ <SET STATE 2>
+ <MAPF <>
+ <FUNCTION (P)
+ <COND (<L? <SET STATE <DEFERN .P>> 2>
+ <MAPLEAVE>)>>
+ <REST .PAT>>
+ .STATE)
+ (ELSE <DEFERN <1 .PAT>>)>)
+ (ELSE 2)>>>
+
+" Define a decl for a given quoted object for maximum winnage."
+
+"\f"
+
+<DEFINE GEN-DECL (OBJ)
+ <COND
+ (<OR <MONAD? .OBJ> <APPLICABLE? .OBJ> <TYPE? .OBJ STRING>> <TYPE .OBJ>)
+ (<==? <PRIMTYPE .OBJ> BYTES>
+ <CHTYPE (<TYPE .OBJ> <BYTE-SIZE .OBJ> <LENGTH .OBJ>) SEGMENT>)
+ (ELSE
+ <REPEAT ((DC <GEN-DECL <1 .OBJ>>) (CNT 1)
+ (FRM <CHTYPE (<TYPE .OBJ>) SEGMENT>) (FRME .FRM) TT T1)
+ #DECL ((CNT) FIX (FRME) <<PRIMTYPE LIST> ANY>)
+ <COND (<EMPTY? <SET OBJ <REST .OBJ>>>
+ <COND (<G? .CNT 1>
+ <SET FRME <REST <PUTREST .FRME ([.CNT .DC])>>>)
+ (ELSE <SET FRME <REST <PUTREST .FRME (.DC)>>>)>
+ <RETURN .FRM>)
+ (<AND <=? <SET TT <GEN-DECL <1 .OBJ>>> .DC> .DC>
+ <SET CNT <+ .CNT 1>>)
+ (ELSE
+ <COND (<G? .CNT 1>
+ <SET FRME <REST <PUTREST .FRME ([.CNT .DC])>>>)
+ (ELSE <SET FRME <REST <PUTREST .FRME (.DC)>>>)>
+ <SET DC .TT>
+ <SET CNT 1>)>>)>>
+
+"\f"
+
+<DEFINE REST-DECL (DC N "AUX" TT TEM)
+ #DECL ((N) FIX)
+ <COND
+ (<TYPE? .DC FORM SEGMENT>
+ <COND
+ (<OR <==? <SET TT <1 .DC>> OR> <==? .TT AND>>
+ <SET TT
+ <CHTYPE (.TT
+ !<MAPF ,LIST
+ <FUNCTION (D "AUX" (IT <REST-DECL .D .N>))
+ <COND (<==? .IT ANY>
+ <COND (<==? .TT OR> <MAPLEAVE (ANY)>)
+ (ELSE <MAPRET>)>)
+ (ELSE .IT)>>
+ <REST .DC>>)
+ FORM>>
+ <COND (<EMPTY? <REST .TT>> ANY)
+ (<EMPTY? <REST .TT 2>> <2 .TT>)
+ (ELSE .TT)>)
+ (<==? .TT NOT> ANY)
+ (<==? <STRUCTYP .DC> BYTES>
+ <COND (<==? .TT PRIMTYPE>
+ .DC)
+ (<==? <LENGTH .DC> 2>
+ <CHTYPE (!.DC .N) FORM>)
+ (<FORM .TT <2 .DC> <+ <CHTYPE <3 .DC> FIX> .N>>)>)
+ (<==? .TT PRIMTYPE>
+ <COND (<0? .N> .DC)
+ (ELSE <CHTYPE (.DC !<ANY-PAT .N>) FORM>)>)
+ (ELSE
+ <FOSE <TYPE? .DC SEGMENT> <COND (<SET TEM <STRUCTYP .TT>> <FORM PRIMTYPE .TEM>)
+ (ELSE STRUCTURED)>
+ !<ANY-PAT .N>
+ !<REST .DC>>)>)
+ (<SET TEM <STRUCTYP .DC>>
+ <COND (<OR <0? .N>
+ <==? .TEM BYTES>> <FORM PRIMTYPE .TEM>)
+ (ELSE <CHTYPE (<FORM PRIMTYPE .TEM> !<ANY-PAT .N>) FORM>)>)
+ (ELSE
+ <COND (<0? .N> STRUCTURED)
+ (ELSE <CHTYPE (STRUCTURED !<ANY-PAT .N>) FORM>)>)>>
+
+<DEFINE ANY-PAT (N)
+ #DECL ((N) FIX)
+ <COND (<L=? .N 0> ()) (<1? .N> (ANY)) (ELSE ([.N ANY]))>>
+
+" TYPE-OK? are two type patterns compatible. If the patterns
+ don't parse, send user a message."
+
+<DEFINE TYPE-OK? (P1 P2 "AUX" TEM)
+ <COND (<OR <==? .P1 NO-RETURN> <==? .P2 NO-RETURN>> NO-RETURN)
+ (<SET TEM <TYPE-AND .P1 .P2>> .TEM)
+ (<EMPTY? .TEM> .TEM)
+ (ELSE <MESSAGE ERROR " " <1 .TEM> " " .P1 " " .P2>)>>
+
+" TYPE-ATOM-OK? does an atom's initial value agree with its DECL?"
+
+<DEFINE TYPE-ATOM-OK? (P1 P2 ATM)
+ #DECL ((ATM) ATOM)
+ <OR <TYPE-OK? .P1 .P2>
+ <MESSAGE ERROR "TYPE MISUSE " .ATM>>>
+
+" Merge a group of type specs into an OR."
+
+"\f"
+
+<DEFINE TYPE-MERGE ("TUPLE" TYPS)
+ #DECL ((TYPS) TUPLE (FTYP) FORM (LN) FIX)
+ <COND (<EMPTY? .TYPS> <>)
+ (ELSE
+ <REPEAT ((ORS <1 .TYPS>))
+ <COND (<EMPTY? <SET TYPS <REST .TYPS>>> <RETURN .ORS>)>
+ <SET ORS
+ <COND (<==? <1 .TYPS> NO-RETURN> .ORS)
+ (<==? .ORS NO-RETURN> <1 .TYPS>)
+ (ELSE <TMERGE .ORS <1 .TYPS>>)>>>)>>
+
+<DEFINE PUT-IN (LST ELE)
+ #DECL ((LST) <PRIMTYPE LIST> (VALUE) LIST)
+ <COND (<AND <TYPE? .ELE FORM SEGMENT>
+ <NOT <EMPTY? .ELE>>
+ <==? <1 .ELE> OR>>
+ <SET ELE <LIST !<REST .ELE>>>)
+ (ELSE <SET ELE (.ELE)>)>
+ <SET LST
+ <MAPF ,LIST
+ <FUNCTION (L1 "AUX" TT)
+ <COND (<EMPTY? .ELE> .L1)
+ (<REPEAT ((A .ELE) B)
+ #DECL ((A B) LIST)
+ <COND (<TMATCH <1 .A> .L1>
+ <SET TT <TMERGE <1 .A> .L1>>
+ <COND (<==? .A .ELE> <SET ELE <REST .ELE>>)
+ (ELSE <PUTREST .B <REST .A>>)>
+ <RETURN T>)>
+ <AND <EMPTY? <SET A <REST <SET B .A>>>>
+ <RETURN <>>>>
+ .TT)
+ (ELSE .L1)>>
+ .LST>>
+ <LSORT <COND (<EMPTY? .ELE> .LST)
+ (ELSE <PUTREST <REST .ELE <- <LENGTH .ELE> 1>> .LST> .ELE)>>>
+
+<DEFINE ORSORT (F) #DECL ((F) <FORM ANY ANY>) <PUTREST .F <LSORT <REST .F>>>>
+
+<DEFINE LSORT (L "AUX" (M ()) (B ()) (TMP ()) (IT ()) (N 0) A1 A2)
+ #DECL ((L M B TMP IT VALUE) LIST (N) FIX (CMPRSN) <OR FALSE APPLICABLE>)
+ <PROG ()
+ <COND (<L? <SET N <LENGTH .L>> 2> <RETURN .L>)>
+ <SET B <REST <SET TMP <REST .L <- </ .N 2> 1>>>>>
+ <PUTREST .TMP ()>
+ <SET L <LSORT .L>>
+ <SET B <LSORT .B>>
+ <SET TMP ()>
+ <REPEAT ()
+ <COND (<EMPTY? .L>
+ <COND (<EMPTY? .TMP> <RETURN .B>)
+ (ELSE <PUTREST .TMP .B> <RETURN .M>)>)
+ (<EMPTY? .B>
+ <COND (<EMPTY? .TMP> <RETURN .L>)
+ (ELSE <PUTREST .TMP .L> <RETURN .M>)>)
+ (ELSE
+ <SET A1 <1 .L>>
+ <SET A2 <1 .B>>
+ <COND (<COND (<AND <TYPE? .A1 ATOM> <TYPE? .A2 ATOM>>
+ <L? <STRCOMP .A1 .A2> 0>)
+ (<TYPE? .A1 ATOM> T)
+ (<TYPE? .A2 ATOM> <>)
+ (ELSE <FCOMPARE .A1 .A2>)>
+ <SET L <REST <SET IT .L>>>)
+ (ELSE <SET B <REST <SET IT .B>>>)>
+ <PUTREST .IT ()>
+ <COND (<EMPTY? .M> <SET M <SET TMP .IT>>)
+ (ELSE <SET TMP <REST <PUTREST .TMP .IT>>>)>)>>>>
+"\f"
+
+<DEFINE FCOMPARE (F1 F2 "AUX" (L1 <LENGTH .F1>) (L2 <LENGTH .F2>))
+ #DECL ((F1 F2) <PRIMTYPE LIST> (L1 L2) FIX)
+ <COND (<==? .L1 .L2>
+ <L? <STRCOMP <UNPARSE .F1> <UNPARSE .F2>> 0>)
+ (<L? .L1 .L2>)>>
+
+
+<DEFINE CANONICAL-DECL (D)
+ <SET D <VTS .D>>
+ <COND (<AND <TYPE? .D FORM SEGMENT> <NOT <EMPTY? .D>>>
+ <COND (<==? <1 .D> OR>
+ <ORSORT <FORM OR !<CAN-ELE <REST .D>>>>)
+ (<==? <1 .D> QUOTE> <CANONICAL-DECL <GEN-DECL <2 .D>>>)
+ (ELSE <CAN-ELE .D>)>)
+ (ELSE .D)>>
+
+
+<DEFINE CAN-ELE (L "AUX" (SAME <>) SAMCNT TT TEM)
+ #DECL ((L) <PRIMTYPE LIST> (SAMCNT) FIX)
+ <CHTYPE
+ (<CANONICAL-DECL <1 .L>>
+ !<MAPR ,LIST
+ <FUNCTION (EL "AUX" (ELE <1 .EL>) (LAST <EMPTY? <REST .EL>>))
+ <COND
+ (<TYPE? .ELE VECTOR>
+ <COND
+ (<AND <==? <LENGTH .ELE> 2> <TYPE? <1 .ELE> FIX>>
+ <SET TT <CANONICAL-DECL <2 .ELE>>>
+ <COND (<AND .SAME <=? .SAME .TT>>
+ <SET SAMCNT <+ .SAMCNT <1 .ELE>>>
+ <COND (.LAST [.SAMCNT .TT]) (ELSE <MAPRET>)>)
+ (ELSE
+ <COND (.SAME <SET TEM <GR-RET .SAME .SAMCNT>>)
+ (ELSE <SET TEM <>>)>
+ <SET SAME .TT>
+ <SET SAMCNT <1 .ELE>>
+ <COND (.LAST
+ <COND (.TEM <MAPRET .TEM <GR-RET .TT .SAMCNT>>)
+ (ELSE <GR-RET .TT .SAMCNT>)>)
+ (.TEM)
+ (ELSE <MAPRET>)>)>)
+ (<AND <==? <1 .ELE> REST>
+ <==? <LENGTH .ELE> 2>
+ <==? <2 .ELE> ANY>>
+ <COND (.SAME
+ <SET TEM <GR-RET .SAME .SAMCNT>>
+ <SET SAME <>>
+ <MAPRET .TEM>)
+ (ELSE <MAPRET>)>)
+ (ELSE
+ <COND (.SAME <SET TEM <GR-RET .SAME .SAMCNT>>)
+ (ELSE <SET TEM <>>)>
+ <SET TT <IVECTOR <LENGTH .ELE>>>
+ <PUT .TT 1 <COND (<==? <1 .ELE> OPT> OPTIONAL) (ELSE <1 .ELE>)>>
+ <MAPR <>
+ <FUNCTION (X Y) <PUT .X 1 <CANONICAL-DECL <1 .Y>>>>
+ <REST .TT>
+ <REST .ELE>>
+ <SET SAME <>>
+ <COND (.TEM <MAPRET .TEM .TT>) (ELSE .TT)>)>)
+ (ELSE
+ <SET ELE <CANONICAL-DECL .ELE>>
+ <COND (<AND .SAME <=? .SAME .ELE>>
+ <SET SAMCNT <+ .SAMCNT 1>>
+ <COND (.LAST <GR-RET .ELE .SAMCNT>) (ELSE <MAPRET>)>)
+ (ELSE
+ <COND (.SAME <SET TEM <GR-RET .SAME .SAMCNT>>)
+ (ELSE <SET TEM <>>)>
+ <SET SAME .ELE>
+ <SET SAMCNT 1>
+ <COND (.LAST <COND (.TEM <MAPRET .TEM .ELE>) (ELSE .ELE)>)
+ (.TEM)
+ (ELSE <MAPRET>)>)>)>>
+ <REST .L>>)
+ FORM>>
+
+<DEFINE GR-RET (X N) #DECL ((N) FIX)
+ <COND (<1? .N> .X)(ELSE [.N .X])>>
+
+<ENDPACKAGE>
--- /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">
+
+<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>)>>
+
+<ENDPACKAGE>
--- /dev/null
+<PACKAGE "CODGEN">
+
+<ENTRY GEN CODE-GEN STB SEQ-GEN MERGE-STATES FRMS LVAL-UP GOOD-TUPLE
+ UPDATE-WHERE NSLOTS NTSLOTS STFIXIT STK GET-TMPS PRE
+ STACK:L NO-KILL DELAY-KILL BSTB TOT-SPEC BASEF AC-HACK BINDUP SPECD LADDR
+ ADD:STACK GENERATORS GOODACS FRMID RES-FLS STORE-SET TRUE-FALSE ACFIX
+ SUBR-GEN BIND-CODE SPEC-LIST BTP NPRUNE REG? ARG? ARGS-TO-ACS>
+
+<USE "CACS" "CHKDCL" "COMCOD" "COMPDEC" "STRGEN" "MAPGEN" "MMQGEN" "BUILDL" "BITSGEN"
+ "LNQGEN" "ISTRUC" "CARGEN" "NOTGEN" "COMSUB" "BITTST" "CBACK" "ALLR"
+ "CUP" "SUBRTY" "NEWREP" "CPRINT" "INFCMP" "CASE" "SPCGEN">
+
+<SETG FUDGE <>>
+
+;"DISABLE FUNNY COND./BOOL FEATURE"
+
+" This file contains the major general codde generators. These include
+ variable access functions (LVAL, SETG etc.), FSUBRs (COND, AND, REPEAT)
+ and a few assorted others."
+
+" All generators are called with a node and a destination for the
+ result. The destinations are either DATUMs (lists of ACs or types)
+ or the special atoms DONT-CARE or FLUSHED. Generators for
+ SUBRs that can be predicates may have additional arguments when they
+ are being invoked for their branching effect."
+
+" The atom STK always points to a list that specifies the model
+ of the TP stack."
+
+" Main generator, dispatches to specific code generators. "
+
+<SETG OTBSAV
+ <PROG (TEM)
+ <COND (<AND <SET TEM <LOOKUP "OTBSAV" <GET MUDDLE OBLIST>>>
+ <GASSIGNED? .TEM>>
+ ,.TEM)
+ (ELSE <SQUOTA |OTBSAV >)>>>
+
+<GDECL (OTBSAV) FIX>
+
+<DEFINE GEN (NOD WHERE "AUX" TEMP)
+ #DECL ((NOD) NODE (WHERE) <OR ATOM DATUM>)
+ <SET TEMP <APPLY <NTH ,GENERATORS <NODE-TYPE .NOD>> .NOD .WHERE>>
+ <OR <ASSIGNED? NPRUNE> <PUT .NOD ,KIDS ()>>
+ .TEMP>
+
+" Generate a sequence of nodes flushing all values except the ladt."
+
+<DEFINE SEQ-GEN (L WHERE "OPTIONAL" (INPROG <>) (SINPROG <>) (INCODE-GEN <>))
+ #DECL ((L) <LIST [REST NODE]> (WHERE) <OR ATOM DATUM>)
+ <MAPR <>
+ <FUNCTION (N "AUX" (ND <1 .N>))
+ #DECL ((N) <LIST NODE> (ND) NODE)
+ <COND (<AND .INPROG
+ <==? <NODE-TYPE .ND> ,QUOTE-CODE>
+ <==? <RESULT-TYPE .ND> ATOM>
+ <OR <NOT <EMPTY? <REST .N>>>
+ <ISTAG? <NODE-NAME .ND>>>>
+ <MESSAGE WARNING " TAG SEEN IN PROG/REPEAT " .ND>
+ <REGSTO T>
+ <LABEL:TAG <UNIQUE:TAG <NODE-NAME .ND> T>>
+ <COND (<EMPTY? <REST .N>>
+ <SET WHERE
+ <GEN .ND
+ <COND (<TYPE? .WHERE DATUM> <DATUM !.WHERE>)
+ (ELSE .WHERE)>>>)>)
+ (<EMPTY? <REST .N>>
+ <SET WHERE
+ <GEN .ND
+ <COND (<AND .INPROG <TYPE? .WHERE DATUM>>
+ <DATUM !.WHERE>)
+ (ELSE .WHERE)>>>)
+ (ELSE <RET-TMP-AC <GEN .ND FLUSHED>>)>>
+ .L>
+ <COND (<AND <NOT .INPROG> <NOT .INCODE-GEN>> <VAR-STORE>)>
+ .WHERE>
+
+" The main code generation entry (called from CDRIVE). Sets up initial
+ stack model, calls to generate code for the bindings and generates code for
+ the function's body."
+
+<DEFINE CODE-GEN (BASEF
+ "AUX" (TOT-SPEC 0) (NTSLOTS (<FORM GVAL <TMPLS .BASEF>>))
+ (IDT 0) XX (STB (0)) (STK (0 !.STB)) (PRE <>) (FRMID 1)
+ BTP (FRMS (1 .STK .BASEF 0 .NTSLOTS)) (BSTB .STB)
+ (SPECD <>)
+ (TMPS <COND (<ACTIVATED .BASEF> (2)) (ELSE (0))>)
+ START:TAG (AC-HACK <ACS .BASEF>) (K <KIDS .BASEF>)
+ (CD <>)
+ (DEST
+ <COND (<ACTIVATED .BASEF> <FUNCTION:VALUE>)
+ (ELSE <GOODACS .BASEF <FUNCTION:VALUE>>)>)
+ (ATAG <MAKE:TAG "AGAIN">) (RTAG <MAKE:TAG "EXIT">)
+ (SPEC-LIST ()) (RET <>) (NO-KILL ()) (KILL-LIST ()))
+ #DECL ((TOT-SPEC IDT) <SPECIAL FIX> (BASEF) <SPECIAL NODE>
+ (SPEC-LIST KILL-LIST STK BSTB NTSLOTS) <SPECIAL LIST>
+ (PRE SPECD) <SPECIAL ANY> (FRMID TMPS) <SPECIAL ANY>
+ (START:TAG) <SPECIAL ATOM> (AC-HACK) <SPECIAL <PRIMTYPE LIST>>
+ (FRMS NO-KILL) <SPECIAL LIST> (K) <LIST [REST NODE]> (BTP) LIST
+ (CD) <OR DATUM FALSE>)
+ <BEGIN-FRAME <TMPLS .BASEF>
+ <ACTIVATED .BASEF>
+ <PRE-ALLOC .BASEF>>
+ <PUT .BASEF ,STK-B .STB>
+ <BIND-CODE .BASEF .AC-HACK>
+ <VAR-STORE>
+ <LABEL:TAG .ATAG>
+ <SET SPEC-LIST (.BASEF .SPECD <SPECS-START .BASEF>)>
+ <SET STK (0 !<SET BTP .STK!>)>
+ <COND (.AC-HACK <EMIT '<INTGO!-OP!-PACKAGE>>)>
+ <PUT .BASEF ,ATAG .ATAG>
+ <PUT .BASEF ,RTAG .RTAG>
+ <PUT .BASEF ,BTP-B .BTP>
+ <PUT .BASEF ,DST .DEST>
+ <PUT .BASEF ,PRE-ALLOC .PRE>
+ <PUT .BASEF ,SPCS-X .SPECD>
+ <COND (<N==? <SET CD
+ <SEQ-GEN .K
+ <COND (<TYPE? .DEST DATUM> <DATUM !.DEST>)
+ (ELSE .DEST)>
+ <>
+ <>
+ T>>
+ ,NO-DATUM>
+ <SET RET T>
+ <ACFIX .DEST .CD>)
+ (ELSE <SET CD <CDST .BASEF>>)>
+ <COND (<AND <TYPE? .DEST DATUM>
+ .CD
+ <ISTYPE? <DATTYP .DEST>>
+ <TYPE? <DATTYP .CD> AC>>
+ <RET-TMP-AC <DATTYP .CD> .CD>)>
+ <COND (<AND .RET .AC-HACK>
+ <UNBIND:LOCS .STK .STB <=? .AC-HACK '(FUNNY-STACK)>>)>
+ <LABEL:TAG .RTAG>
+ <COND (.CD
+ <AND <TYPE? <DATTYP .DEST> AC>
+ <FIX-ACLINK <DATTYP .DEST> .DEST .CD>>
+ <AND <TYPE? <DATVAL .DEST> AC>
+ <FIX-ACLINK <DATVAL .DEST> .DEST .CD>>)>
+ <MAPF <>
+ <FUNCTION (AC)
+ #DECL ((AC) AC)
+ <MAPF <>
+ <FUNCTION (ITEM)
+ <COND (<TYPE? .ITEM SYMTAB>
+ <PUT .ITEM ,STORED T>)>>
+ <ACRESIDUE .AC>>>
+ ,ALLACS>
+ <SET XX <RET-TMP-AC <MOVE:ARG .DEST <FUNCTION:VALUE>>>>
+ <END-FRAME>
+ .XX>
+
+
+" Update ACs with respect to their datums."
+
+<DEFINE ACFIX (OLD1 NEW1 "AUX" OLD NEW)
+ #DECL ((OLD NEW) DATUM)
+ <COND (<TYPE? .OLD1 DATUM>
+ <SET NEW .NEW1>
+ <SET OLD .OLD1>
+ <COND (<==? <DATTYP .OLD> ANY-AC>
+ <PUT .OLD ,DATTYP <DATTYP .NEW>>)>
+ <COND (<==? <DATVAL .OLD> ANY-AC>
+ <PUT .OLD ,DATVAL <DATVAL .NEW>>)>)>
+ T>
+
+" Generate code for setting up and binding agruments."
+
+<DEFINE BIND-CODE (NOD
+ "OPTIONAL" (FLG <>)
+ "AUX" (BST <BINDING-STRUCTURE .NOD>) B (NPRUNE T)
+ (NSLOTS <SSLOTS .NOD>) (TSLOTS <TMPLS .NOD>) (LARG <>)
+ INAME GOOD-OPTS
+ (SFLG
+ <AND .FLG <MEMBER .FLG '![(STACK) (FUNNY-STACK)!]>>)
+ (STB <STK-B .NOD>))
+ #DECL ((NOD) NODE (BST B) <LIST [REST SYMTAB]> (NPRUNE) <SPECIAL ANY>
+ (NSLOTS) <SPECIAL FIX> (TSLOTS) ATOM (INAME) <UVECTOR [REST ATOM]>
+ (FRMS) <LIST [5 ANY]> (TOT-SPEC) FIX (BASEF) NODE)
+ <AND <ACTIVATED .NOD> <ACT:INITIAL> <ADD:STACK 2>>
+ <OR .PRE .FLG <PROG ()
+ <SALLOC:SLOTS .TSLOTS>
+ <ADD:STACK .TSLOTS>>>
+ <AND .FLG <SET INAME <NODE-NAME .NOD>>>
+ <COND
+ (<AND .SFLG <L? <TOTARGS .NOD> 0>>
+ <EMIT <INSTRUCTION INTERNAL-ENTRY!-OP!-PACKAGE <1 .INAME> -1>>
+ <EMIT '<`SUBM `M* `(P) >>
+ <ADD:STACK PSTACK>
+ <ADD:STACK 4>
+ <PUT .FRMS 2 <SET BSTB <SET STB <SET STK (0 !.STK)>>>>
+ <TUPLE1-B <1 .BST>>
+ <PUT <1 .BST> ,POTLV <>>
+ <SET BST <REST .BST>>)
+ (.SFLG
+ <SET GOOD-OPTS
+ <OPT-CHECK <REST .BST <REQARGS .NOD>>
+ <- <TOTARGS .NOD> <REQARGS .NOD>>
+ .INAME>>
+ <ADD:STACK <* 2 <TOTARGS .NOD>>>
+ <SET TMPS <STACK:L .STK .STB>>
+ <ADD:STACK .TSLOTS>
+ <REPEAT ((I (.TSLOTS 0)) (TG <MAKE:TAG>) (TRG <TOTARGS .NOD>) (OPS 0)
+ (OSTK .STK))
+ #DECL ((TG) ATOM (OPS TRG) FIX (STK OSTK) LIST)
+ <EMIT <INSTRUCTION INTERNAL-ENTRY!-OP!-PACKAGE <1 .INAME> .TRG>>
+ <SET STK (0 !.STK)>
+ <EMIT '<`SUBM `M* `(P) >>
+ <SALLOC:SLOTS <2 .I>>
+ <ALLOC:SLOTS <1 .I>>
+ <SET B .BST>
+ <REPEAT ((TRG .TRG) (OPS .OPS) SYM T1)
+ #DECL ((TRG OPS) FIX (SYM) SYMTAB (T1) ADDRESS:C)
+ <COND (<EMPTY? .B> <RETURN>) (ELSE <SET SYM <1 .B>>)>
+ <PUT .SYM ,POTLV <>>
+ <COND (<OR <==? <CODE-SYM .SYM> 7>
+ <==? <CODE-SYM .SYM> 8>
+ <==? <CODE-SYM .SYM> 9>>
+ <TUPCHK <INIT-SYM .SYM> T>)>
+ <COND
+ (<NOT <0? .TRG>>
+ <AND
+ <SPEC-SYM .SYM>
+ <PUSH:BIND
+ <NAME-SYM .SYM>
+ <DATUM
+ <COND (<=? .AC-HACK '(FUNNY-STACK)>
+ <SET T1
+ <ADDRESS:C <- -3
+ <* 2
+ <- <TOTARGS .NOD>
+ <ARGNUM-SYM .SYM>>>>
+ `(FRM) >>)
+ (<SET T1
+ <ADDRESS:C <FORM -
+ <* 2 <ARGNUM-SYM .SYM>>
+ !<STACK:L .STK .BSTB>
+ 3>
+ `(TP) >>)>
+ .T1>
+ <DECL-SYM .SYM>>
+ <ADD:STACK 6>
+ <VAR-STORE>
+ <BIND:END>
+ <SET SPECD T>
+ <SET TOT-SPEC <+ .TOT-SPEC 6>>>
+ <SET TRG <- .TRG 1>>)
+ (<NOT <0? .OPS>>
+ <COND (<L=? <CODE-SYM .SYM> 7>
+ <COND (<SPEC-SYM .SYM> <AUX1-B .SYM>)
+ (ELSE <GEN <INIT-SYM .SYM> <LADDR .SYM T <>>>)>)
+ (ELSE
+ <COND (<SPEC-SYM .SYM> <AUX2-B .SYM>)
+ (ELSE
+ <MOVE:ARG <REFERENCE:UNBOUND> <LADDR .SYM T <>>>)>)>
+ <VAR-STORE>
+ <SET OPS <- .OPS 1>>)
+ (ELSE <RETURN>)>
+ <AND <OR .GOOD-OPTS <1? <LENGTH .INAME>>>
+ <SPEC-SYM .SYM>
+ <PUT .SYM ,ARGNUM-SYM <TMPLS .BASEF>>>
+ <SET B <REST .B>>>
+ <PUT .I 2 <+ <CHTYPE <2 .I> FIX> 2>>
+ <SET TRG <- .TRG 1>>
+ <SET OPS <+ .OPS 1>>
+ <COND (<OR .GOOD-OPTS <EMPTY? <SET INAME <REST .INAME>>>>
+ <LABEL:TAG .TG>
+ <SET BST .B>
+ <RETURN>)
+ (ELSE <SET STK .OSTK> <BRANCH:TAG .TG>)>>
+ <SET LARG T>)
+ (.FLG <LABEL:TAG <1 .INAME>> <EMIT '<`SUBM `M* `(P) >>)>
+ <REPEAT ((COD 0) SYM)
+ #DECL ((COD) FIX (SYM) SYMTAB)
+ <COND (<EMPTY? .BST>
+ <COND (<AND .FLG
+ <NOT .LARG>
+ <COND (.SPECD <VAR-STORE> <BIND:END> T) (ELSE T)>>
+ <SALLOC:SLOTS .TSLOTS>
+ <SET TMPS <STACK:L .STK .STB>>
+ <ADD:STACK .TSLOTS>)>
+ <OR .PRE
+ <0? .NSLOTS>
+ <PROG ()
+ <COND (<G? .NSLOTS 0>
+ <SALLOC:SLOTS <- .NSLOTS .TOT-SPEC>>
+ <ADD:STACK <- .NSLOTS .TOT-SPEC>>)>
+ <SET PRE T>
+ <EMIT-PRE T>>>
+ <AND <ACTIVATED .NOD> <ACT:FINAL>>
+ <RETURN>)>
+ <SET COD <CODE-SYM <SET SYM <1 .BST>>>>
+ <PUT .SYM ,POTLV <>>
+ <COND (<L? .COD 0>
+ <PUT .SYM ,CODE-SYM <SET COD <- .COD>>>
+ <COND (<G? .NSLOTS 0>
+ <SALLOC:SLOTS <- .NSLOTS .TOT-SPEC>>
+ <ADD:STACK <- .NSLOTS .TOT-SPEC>>)>
+ <SET PRE T>
+ <EMIT-PRE T>)>
+ <COND (<AND .FLG
+ <NOT .LARG>
+ <0? <NTH '![0 0 0 0 1 0 0 0 0 1 0 1 1!] .COD>>
+ <SET LARG T>
+ <COND (.SPECD <VAR-STORE> <BIND:END> T) (ELSE T)>>
+ <SET TMPS <STACK:L .STK .STB>>
+ <SALLOC:SLOTS .TSLOTS>
+ <ADD:STACK .TSLOTS>)>
+ <APPLY <NTH ,BINDERS .COD> .SYM>
+ <OR .PRE <PUT .SYM ,SPEC-SYM FUDGE>>
+ <SET BST <REST .BST>>>
+ .TOT-SPEC>
+
+<DEFINE OPT-CHECK (B NUM LBLS "AUX" (N .NUM) (RQ <REQARGS .BASEF>) NOD S)
+ #DECL ((B) <LIST [REST SYMTAB]> (N NUM RQ) FIX (LBLS) <UVECTOR [REST ATOM]>
+ (NOD BASEF) NODE (S) SYMTAB)
+ <COND
+ (<AND
+ <NOT <0? .NUM>>
+ <MAPF <>
+ <FUNCTION (S)
+ #DECL ((S) SYMTAB)
+ <PUT .S ,POTLV <>>
+ <COND (<L? <SET N <- .N 1>> 0> <MAPLEAVE>)>
+ <COND (<AND <OR <==? <CODE-SYM .S> 6> <==? <CODE-SYM .S> 7>>
+ <NOT <MEMQ <NODE-TYPE <CHTYPE <INIT-SYM .S> NODE>> ,SNODES>>>
+ <MAPLEAVE <>>)
+ (ELSE T)>>
+ .B>>
+ <REPEAT (ADDR OFFS)
+ #DECL ((OFFS) FIX)
+ <SET S <1 .B>>
+ <SET B <REST .B>>
+ <EMIT <INSTRUCTION INTERNAL-ENTRY!-OP!-PACKAGE
+ <NTH .LBLS <+ .NUM 1>>
+ .RQ>>
+ <COND (<OR <==? <CODE-SYM .S> 6> <==? <CODE-SYM .S> 7>>
+ <COND (<==? <NODE-TYPE <SET NOD <INIT-SYM .S>>> ,LVAL-CODE>
+ <SET OFFS <* <- .RQ
+ <ARGNUM-SYM <CHTYPE <NODE-NAME .NOD> SYMTAB>>> 2>>
+ <SET ADDR <ADDRESS:C <- -1 .OFFS> `(TP) >>
+ <SET ADDR <DATUM .ADDR .ADDR>>)
+ (ELSE <SET ADDR <GEN .NOD DONT-CARE>>)>)
+ (ELSE <SET ADDR <REFERENCE:UNBOUND>>)>
+ <STACK:ARGUMENT .ADDR>
+ <COND (<L=? <SET NUM <- .NUM 1>> 0> <RETURN>)>
+ <SET RQ <+ .RQ 1>>>)>>
+
+" Generate \"BIND\" binding code."
+
+<DEFINE BIND-B (SYM) #DECL ((SYM) SYMTAB) <BINDUP .SYM <MAKE:ENV>>>
+
+" Do code generation for normal arguments."
+
+<DEFINE NORM-B (SYM)
+ #DECL ((SYM) SYMTAB (AC-HACK) <PRIMTYPE LIST>)
+ <COND (.AC-HACK
+ <BINDUP .SYM <DATUM !<NTH .AC-HACK <ARGNUM-SYM .SYM>>> <>>)
+ (<TYPE? <ADDR-SYM .SYM> DATUM>)
+ (ELSE <BINDUP .SYM <REFERENCE:ARG <ARGNUM-SYM .SYM>>>)>>
+
+" Initialized optional argument binder."
+
+<DEFINE OPT1-B (SYM)
+ #DECL ((SYM) SYMTAB)
+ <TUPCHK <INIT-SYM .SYM>>
+ <OPTBIND .SYM <INIT-SYM .SYM>>>
+
+" Uninitialized optional argument binder."
+
+<DEFINE OPT2-B (SYM) #DECL ((SYM) SYMTAB) <OPTBIND .SYM>>
+
+" Create a binding either by pushing or moving if slots PRE created."
+
+<DEFINE BINDUP (SYM SRC "OPTIONAL" (SPCB T))
+ #DECL ((SYM) SYMTAB (SRC) DATUM (TOT-SPEC) FIX)
+ <COND (<SPEC-SYM .SYM>
+ <SET SPECD T>
+ <COND (.PRE
+ <PUT .SYM ,ADDR-SYM <- <CHTYPE <ADDR-SYM .SYM> FIX> .TOT-SPEC>>
+ <STORE:BIND .SYM .SRC>)
+ (ELSE
+ <PUSH:BIND <NAME-SYM .SYM> .SRC <DECL-SYM .SYM>>
+ <SET TOT-SPEC <+ .TOT-SPEC 6>>
+ <ADD:STACK 6>
+ <AND .SPCB <VAR-STORE> <BIND:END>>)>)
+ (ELSE <CLOB:PAIR .SYM .PRE .SRC>)>
+ <RET-TMP-AC .SRC>>
+
+" Push or store a non special argument."
+
+<DEFINE CLOB:PAIR (SYM PRE SRC)
+ #DECL ((SYM) SYMTAB (SRC) DATUM (TOT-SPEC) FIX)
+ <COND (.PRE
+ <PUT .SYM ,ADDR-SYM <- <CHTYPE <ADDR-SYM .SYM> FIX> .TOT-SPEC>>
+ <STORE:PAIR .SYM .SRC>)
+ (ELSE <PUSH:PAIR .SRC> <ADD:STACK 2>)>>
+
+" Create a binding for either intitialized or unitialized optional."
+
+<DEFINE OPTBIND (SYM
+ "OPTIONAL" DVAL
+ "AUX" (GIVE <MAKE:TAG>) (DEF <MAKE:TAG>) DV (LPRE .PRE))
+ #DECL ((SYM) SYMTAB (BASEF DVAL) NODE (GIVE DEF) ATOM (DV) DATUM (TOT-SPEC) FIX)
+ <COND (<SPEC-SYM .SYM>
+ <SET SPECD T>
+ <OR .LPRE <PUSH:ATB <NAME-SYM .SYM>>>)>
+ <TEST:ARG <ARGNUM-SYM .SYM> .DEF>
+ <COND
+ (.LPRE
+ <COND
+ (<SPEC-SYM .SYM>
+ <MOVE:ARG <REFERENCE:ARG <ARGNUM-SYM .SYM>>
+ <FUNCTION:VALUE>>)
+ (ELSE
+ <MOVE:ARG
+ <REFERENCE:ARG <ARGNUM-SYM .SYM>>
+ <REFERENCE:STACK
+ (<ADDR-SYM .SYM>
+ <COND (<TYPE? <ARGNUM-SYM .SYM> ATOM>
+ <FORM GVAL <ARGNUM-SYM .SYM>>)
+ (ELSE 0)>)>>)>)
+ (ELSE <PUSH:PAIR <REFERENCE:ARG <ARGNUM-SYM .SYM>>>)>
+ <BRANCH:TAG .GIVE>
+ <LABEL:TAG .DEF>
+ <SET DV
+ <COND (<ASSIGNED? DVAL>
+ <GEN .DVAL <COND (.LPRE <FUNCTION:VALUE>) (ELSE DONT-CARE)>>)
+ (ELSE <REFERENCE:UNBOUND>)>>
+ <AND <OR <NOT .LPRE> <NOT <SPEC-SYM .SYM>>>
+ <CLOB:PAIR .SYM .LPRE .DV>>
+ <LABEL:TAG .GIVE>
+ <AND <SPEC-SYM .SYM>
+ <COND (.LPRE <STORE:BIND .SYM .DV>)
+ (ELSE
+ <PUSH:PAIR <REFERENCE <DECL-SYM .SYM>>>
+ <ADD:STACK 4>
+ <VAR-STORE>
+ <BIND:END>)>>
+ <VAR-STORE>
+ <COND (<AND <NOT .LPRE> <SPEC-SYM .SYM>>
+ <SET TOT-SPEC <+ .TOT-SPEC 6>>)>
+ <RET-TMP-AC .DV>>
+
+" Do a binding for a named activation."
+
+<DEFINE ACT-B (SYM)
+ #DECL ((SYM) SYMTAB)
+ <AND <ASSIGNED? START:TAG> <BINDUP .SYM <MAKE:ACT>>>>
+
+" Bind an \"AUX\" variable."
+
+<DEFINE AUX1-B (SYM "AUX" TT TEM TY)
+ #DECL ((SYM) SYMTAB (TT) DATUM (FCN) NODE (TOT-SPEC) FIX)
+ <PUT .SYM ,POTLV <>>
+ <TUPCHK <INIT-SYM .SYM>>
+ <COND
+ (<AND <NOT .PRE> <SPEC-SYM .SYM>>
+ <PUSH:ATB <NAME-SYM .SYM>>
+ <ADD:STACK 2>
+ <PUSH:PAIR <SET TT <GEN <INIT-SYM .SYM> DONT-CARE>>>
+ <PUSH:PAIR <REFERENCE <DECL-SYM .SYM>>>
+ <SET SPECD T>
+ <ADD:STACK 4>
+ <VAR-STORE>
+ <BIND:END>
+ <SET TOT-SPEC <+ .TOT-SPEC 6>>
+ <RET-TMP-AC .TT>)
+ (<TYPE? <ADDR-SYM .SYM> TEMPV>
+ <SET TY <CREATE-TMP <SET TEM <ISTYPE-GOOD? <1 <DECL-SYM .SYM>>>>>>
+ <PUT .SYM
+ ,ADDR-SYM
+ <CHTYPE (.BSTB
+ .TY
+ <COND (<=? .AC-HACK '(FUNNY-STACK)> <* <TOTARGS .FCN> -2>)
+ (ELSE 0)>
+ !.TMPS)
+ TEMPV>>
+ <SET TT
+ <GEN
+ <INIT-SYM .SYM>
+ <DATUM <COND (<OR <ISTYPE-GOOD? <RESULT-TYPE <INIT-SYM .SYM>>> .TEM>)
+ (ELSE ANY-AC)>
+ ANY-AC>>>
+ <SMASH-INACS .SYM .TT>
+ <PUT .SYM ,STORED <>>
+ <PUT <SET TEM <CHTYPE <DATVAL .TT> AC>> ,ACRESIDUE (.SYM !<ACRESIDUE .TEM>)>
+ <COND (<TYPE? <SET TEM <DATTYP .TT>> AC>
+ <PUT .TEM ,ACRESIDUE (.SYM !<ACRESIDUE .TEM>)>)>
+ <RET-TMP-AC .TT>)
+ (ELSE <BINDUP .SYM <GEN <INIT-SYM .SYM> DONT-CARE>>)>>
+
+" Do a binding for an uninitialized \"AUX\" "
+
+<DEFINE AUX2-B (SYM "AUX" ADR TY)
+ #DECL ((SYM) SYMTAB (FCN) NODE)
+ <PUT .SYM ,POTLV <>>
+ <TUPCHK <INIT-SYM .SYM>>
+ <COND (<TYPE? <ADDR-SYM .SYM> TEMPV>
+ <SET TY <CREATE-TMP <ISTYPE-GOOD? <1 <DECL-SYM .SYM>>>>>
+ <COND (<ISTYPE-GOOD? <1 <DECL-SYM .SYM>>>
+ <PUT .SYM ,INIT-SYM T>)>
+ <PUT .SYM
+ ,ADDR-SYM
+ <CHTYPE (.BSTB
+ .TY
+ <COND (<=? .AC-HACK '(FUNNY-STACK)>
+ <* <TOTARGS .FCN> -2>)
+ (ELSE 0)>
+ !.TMPS)
+ TEMPV>>)
+ (<AND <SET TY <ISTYPE-GOOD? <1 <DECL-SYM .SYM>>>>
+ <NOT <ASS? .SYM>>
+ <NOT <SPEC-SYM .SYM>>>
+ <SET ADR <ADDRESS:PAIR <FORM TYPE-WORD!-OP!-PACKAGE .TY> '[0]>>
+ <PUT .SYM ,INIT-SYM T>
+ <BINDUP .SYM <DATUM .ADR .ADR>>)
+ (ELSE <BINDUP .SYM <REFERENCE:UNBOUND>>)>>
+
+<DEFINE TUPCHK (TUP "OPTIONAL" (OPT <>) "AUX" (NS .NSLOTS) (TS .TOT-SPEC))
+ #DECL ((TUP) <OR FALSE NODE> (NS TS) FIX)
+ <OR .PRE
+ <COND (<AND <TYPE? .TUP NODE>
+ <OR <==? <NODE-NAME .TUP> ITUPLE>
+ <==? <NODE-NAME .TUP> TUPLE>>>
+ <COND (<OR .OPT
+ <==? <NODE-TYPE .TUP> ,ISTRUC-CODE>
+ <NOT <GOOD-TUPLE .TUP>>>
+ <COND (<G? .NS 0>
+ <SALLOC:SLOTS <- .NS .TS>>
+ <ADD:STACK <- .NS .TS>>)>
+ <EMIT-PRE <SET PRE T>>)>)>>>
+
+<DEFINE GOOD-TUPLE (TUP "AUX" (K <KIDS .TUP>) NT (WD 0))
+ #DECL ((NT) FIX (TUP) NODE (K) <LIST [REST NODE]>)
+ <AND <NOT <==? <NODE-TYPE .TUP> ,ISTRUC-CODE>>
+ <COND (<==? <NODE-SUBR .TUP> ,ITUPLE>
+ <AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
+ <OR <==? <SET NT <NODE-TYPE <2 .K>>> ,QUOTE-CODE>
+ <==? .NT ,FLVAL-CODE>
+ <==? .NT ,FGVAL-CODE>
+ <==? .NT ,GVAL-CODE>
+ <==? .NT ,LVAL-CODE>>
+ <* <NODE-NAME <1 .K>> 2>>)
+ (ELSE
+ <MAPF <>
+ <FUNCTION (K)
+ <COND (<==? <NODE-TYPE .K> ,SEGMENT-CODE>
+ <MAPLEAVE <>>)
+ (ELSE <SET WD <+ .WD 2>>)>>
+ .K>)>>>
+
+" Do a \"TUPLE\" binding."
+
+<DEFINE TUPLE1-B (SYM)
+ #DECL ((SYM) SYMTAB)
+ <EMIT '<`PUSH `P* `A >>
+ <EMIT '<`PUSHJ `P* |MAKTU2 >>
+ <COND (<SPEC-SYM .SYM>
+ <EMIT '<`POP `TP* `B >>
+ <EMIT '<`POP `TP* `A >>
+ <BINDUP .SYM <FUNCTION:VALUE T>>)>>
+
+<DEFINE TUPL-B (SYM "AUX" (SK <* 2 <- <ARGNUM-SYM .SYM> 1>>))
+ #DECL ((SYM) SYMTAB (SK) FIX)
+ <EMIT '<`MOVE `B* `AB >>
+ <OR <L=? .SK 0>
+ <EMIT <INSTRUCTION `ADD `B* [<FORM .SK (.SK)>]>>>
+ <EMIT '<`HLRZ `A* |OTBSAV `(TB) >>
+ <EMIT '<`HRLI `A* <TYPE-CODE!-OP!-PACKAGE TUPLE>>>
+ <BINDUP .SYM <FUNCTION:VALUE T>>>
+
+" Generate the code to actually build a TUPLE."
+
+<DEFINE BUILD:TUPLE (NUM "AUX" (STAG <MAKE:TAG>) (ETAG <MAKE:TAG>))
+ #DECL ((NUM) FIX (STAG ETAG) ATOM)
+ <COPY:ARGPNTR>
+ <AND <NOT <1? .NUM>> <BUMP:ARGPNTR <- .NUM 1>>>
+ <LABEL:TAG .STAG>
+ <TEST:ARGPNTR .ETAG>
+ <STACK:ARGUMENT <REFERENCE:ARGPNTR>>
+ <BUMP:ARGPNTR>
+ <BUMP:CNTR>
+ <BRANCH:TAG .STAG>
+ <LABEL:TAG .ETAG>
+ <TUPLE:FINAL>>
+
+" Dispatch table for binding generation code."
+
+<SETG BINDERS
+ ![,ACT-B ,AUX1-B ,AUX2-B ,TUPL-B ,NORM-B ,OPT1-B ,OPT1-B ,OPT2-B ,OPT2-B
+ ,NORM-B ,BIND-B ,NORM-B ,NORM-B!]>
+
+<DEFINE MENTROPY (N R) T>
+
+<COND (<GASSIGNED? NOTIMP>
+ <SETG MBINDERS
+ [,ACT-B
+ ,AUX1-B
+ ,AUX2-B
+ ,NOTIMP
+ ,MENTROPY
+ ,MOPTG
+ ,MOPTG
+ ,MOPTG2
+ ,MOPTG2
+ ,MENTROPY
+ ,BIND-B
+ ,MENTROPY
+ ,MENTROPY]>)>
+
+" Appliacation of a form could still be an NTH."
+
+<DEFINE FORM-F-GEN (NOD WHERE "AUX" (K <KIDS .NOD>) TY)
+ #DECL ((NOD) NODE)
+ <COND (<==? <ISTYPE? <SET TY <RESULT-TYPE <1 .K>>>> FIX>
+ <PUT .NOD ,NODE-NAME INTH>
+ <PUT .NOD ,NODE-TYPE <NODE-SUBR .NOD>>
+ <PUT .NOD ,NODE-SUBR ,NTH>
+ <COND (<OR <==? <NODE-TYPE .NOD> ,ALL-REST-CODE>
+ <==? <NODE-TYPE .NOD> ,NTH-CODE>>
+ <SET K (<2 .K> <1 .K>)>)>
+ <PUT .NOD ,KIDS .K>
+ <GEN .NOD .WHERE>)
+ (.TY <FORM-GEN .NOD .WHERE>)
+ (ELSE
+ <MESSAGE ERROR
+ " NON APPLICABLE OBJECT "
+ <NODE-NAME .NOD>
+ .NOD>)>>
+
+" Generate a call to EVAL for uncompilable FORM."
+
+<DEFINE FORM-GEN (NOD WHERE "AUX" (SSTK .STK) TEM (STK (0 !.STK)))
+ #DECL ((NOD) NODE (WHERE) <OR ATOM DATUM> (TEM) DATUM
+ (STK) <SPECIAL LIST> (SSTK) LIST)
+ <RET-TMP-AC <STACK:ARGUMENT <REFERENCE <NODE-NAME .NOD>>>>
+ <ADD:STACK 2>
+ <REGSTO T>
+ <SET TEM <FUNCTION:VALUE T>>
+ <SUBR:CALL EVAL 1>
+ <SET STK .SSTK>
+ <MOVE:ARG .TEM .WHERE>>
+
+" Generate code for LIST/VECTOR etc. evaluation."
+
+<GDECL (COPIERS) <UVECTOR [REST ATOM]>>
+
+<DEFINE COPY-GEN (NOD WHERE
+ "AUX" GT RES (I 0) (ARGS <KIDS .NOD>) (UNK <>)
+ (TYP <ISTYPE? <RESULT-TYPE .NOD>>)
+ (INAME
+ <NTH
+ '[|IILIST |CIVEC |CIUVEC TUPLE]
+ <LENGTH <CHTYPE <MEMQ .TYP ,COPIERS> UVECTOR>>>))
+ #DECL ((GT) <OR FALSE FIX> (NOD) NODE (WHERE) <OR ATOM DATUM>
+ (ARGS) <LIST [REST NODE]> (I) FIX (VALUE RES) DATUM)
+ <PROG ((STK (0 !.STK)))
+ #DECL ((STK) <SPECIAL LIST>)
+ <COND
+ (<REPEAT ()
+ <AND <EMPTY? .ARGS> <RETURN>>
+ <COND (<==? <NODE-TYPE <1 .ARGS>> ,SEGMENT-CODE>
+ <RET-TMP-AC <GEN <1 <KIDS <1 .ARGS>>> <FUNCTION:VALUE>>>
+ <COND (<AND <==? <NODE-NAME .NOD> LIST>
+ <EMPTY? <REST .ARGS>>>
+ <REGSTO T>
+ <SEGMENT:LIST .I .UNK>
+ <SET RES <FUNCTION:VALUE T>>
+ <RETURN <>>)
+ (ELSE
+ <REGSTO T>
+ <SEGMENT:STACK </ <STACKS .NOD> 2> .UNK>
+ <ADD:STACK <- <STACKS .NOD>>>
+ <ADD:STACK PSTACK>
+ <SET UNK T>)>)
+ (ELSE
+ <RET-TMP-AC <STACK:ARGUMENT <GEN <1 .ARGS> DONT-CARE>>>
+ <ADD:STACK 2>
+ <SET I <+ .I 1>>)>
+ <SET ARGS <REST .ARGS>>>
+ <REGSTO T>
+ <SET RES <FUNCTION:VALUE T>>
+ <COND (.UNK
+ <AND <NOT <==? .INAME TUPLE>>
+ <EMIT <INSTRUCTION `POP
+ `P*
+ <COND (<==? .INAME TUPLE> `D )
+ (ELSE `A )>>>>)
+ (ELSE
+ <EMIT <INSTRUCTION `MOVEI
+ <COND (<==? .INAME TUPLE> `D* ) (ELSE `A* )>
+ <COND (<==? .INAME TUPLE> <+ .I .I>)
+ (ELSE .I)>>>)>
+ <COND (<==? .INAME TUPLE>
+ <COND (.UNK
+ <EMIT <INSTRUCTION `MOVE `D* `(P) >>
+ <EMIT <INSTRUCTION `ASH `D* 1>>)>
+ <EMIT <INSTRUCTION `PUSHJ `P* |MAKTUP >>)
+ (ELSE <EMIT <INSTRUCTION `PUSHJ `P* .INAME>>)>)>>
+ <COND (<==? .INAME TUPLE>
+ <COND (<SET GT <GOOD-TUPLE .NOD>> <ADD:STACK <+ 2 .GT>>)
+ (ELSE <EMIT <INSTRUCTION `AOS `(P) >> <ADD:STACK PSTACK>)>)>
+ <MOVE:ARG .RES .WHERE>>
+
+<SETG COPIERS ![TUPLE UVECTOR VECTOR LIST!]>
+
+"Generate code for a call to a SUBR."
+
+<DEFINE SUBR-GEN (NOD WHERE)
+ #DECL ((WHERE) <OR ATOM DATUM> (NOD) NODE)
+ <COMP:SUBR:CALL <NODE-NAME .NOD>
+ <KIDS .NOD>
+ <STACKS .NOD>
+ .WHERE>>
+
+" Compile call to a SUBR that doesn't compile or PUSHJ."
+
+<DEFINE COMP:SUBR:CALL (SUBR OBJ STA W
+ "AUX" RES (I 0) (UNK <>) (OS .STK) (STK (0 !.STK)))
+ #DECL ((STA I) FIX (OBJ) <LIST [REST NODE]> (UNK) <OR FALSE ATOM>
+ (STK) <SPECIAL LIST> (OS) LIST (RES) DATUM)
+ <MAPF <>
+ <FUNCTION (OB)
+ #DECL ((OB) NODE (I STA) FIX)
+ <COND (<==? <NODE-TYPE .OB> ,SEGMENT-CODE>
+ <RET-TMP-AC <GEN <1 <KIDS .OB>> <FUNCTION:VALUE>>>
+ <REGSTO T>
+ <SEGMENT:STACK </ .STA 2> .UNK>
+ <ADD:STACK <- .STA>>
+ <ADD:STACK PSTACK>
+ <SET UNK T>)
+ (ELSE
+ <RET-TMP-AC <STACK:ARGUMENT <GEN .OB DONT-CARE>>>
+ <ADD:STACK 2>
+ <SET I <+ .I 1>>)>>
+ .OBJ>
+ <REGSTO T>
+ <SET RES <FUNCTION:VALUE T>>
+ <COND (.UNK <SEGMENT:FINAL .SUBR>)
+ (ELSE <SUBR:CALL .SUBR .I>)>
+ <SET STK .OS>
+ <MOVE:ARG .RES .W>>
+
+
+<GDECL (SUBRS TEMPLATES) UVECTOR>
+
+<DEFINE GET-TMPS (SUB "AUX" (LS <MEMQ .SUB ,SUBRS>))
+ #DECL ((VALUE) <LIST ANY ANY> (LS) <OR FALSE UVECTOR>)
+ <COND (.LS <NTH ,TEMPLATES <LENGTH .LS>>)
+ (ELSE '(ANY ANY))>>
+
+" Generate calls to SUBRs using the internal PUSHJ feature."
+
+<DEFINE ISUBR-GEN (NOD WHERE
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
+ "AUX" (TMPL <GET-TMPS <NODE-SUBR .NOD>>) W (SDIR .DIR) B2
+ (OS .STK) (STK (0 !.STK)) W2 (TP <4 .TMPL>))
+ #DECL ((NOD) NODE (WHERE W2) <OR ATOM DATUM> (W) DATUM
+ (TMPL) <LIST ANY ANY ANY ANY ANY ANY> (UNK) <OR FALSE ATOM>
+ (STA ARGS) FIX (STK) <SPECIAL LIST> (OS) LIST)
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <COND (<==? <NODE-NAME .NOD> INTH> <SET TP (<2 <CHTYPE .TP LIST>>
+ <1 <CHTYPE .TP LIST>>)>)>
+ <COND (<=? .TP STACK> <STACK-ARGS .NOD T>)
+ (<NOT <AC-ARGS .NOD .TP>> <AC-SEG-CALL .TP>)>
+ <REGSTO T>
+ <EMIT <INSTRUCTION `PUSHJ `P* <6 .TMPL>>>
+ <SET STK .OS>
+ <COND (<AND .BRANCH <5 .TMPL>>
+ <COND (<==? .WHERE FLUSHED>
+ <COND (.DIR <EMIT '<`SKIPA >> <BRANCH:TAG .BRANCH>)
+ (ELSE <BRANCH:TAG .BRANCH>)>)
+ (ELSE
+ <COND (.DIR <BRANCH:TAG <SET B2 <MAKE:TAG>>>)
+ (<OR .NOTF
+ <NOT <OR <==? .WHERE DONT-CARE>
+ <AND <TYPE? .WHERE DATUM>
+ <SET W .WHERE>
+ <==? <LENGTH .W> 2>
+ <OR <==? <DATTYP .W> ANY-AC>
+ <==? <DATTYP .W> ,AC-A>>
+ <OR <==? <DATVAL .W> ANY-AC>
+ <==? <DATVAL .W> ,AC-B>>>>>>
+ <EMIT '<`SKIPA >>
+ <BRANCH:TAG <SET B2 <MAKE:TAG>>>)>
+ <SET WHERE
+ <MOVE:ARG <COND (.NOTF <REFERENCE .SDIR>)
+ (ELSE <FUNCTION:VALUE T>)>
+ .WHERE>>
+ <BRANCH:TAG .BRANCH>
+ <COND (<ASSIGNED? B2> <LABEL:TAG .B2>)>
+ .WHERE)>)
+ (.BRANCH
+ <OR <==? .WHERE FLUSHED> <SET DIR <NOT .DIR>>>
+ <D:B:TAG <COND (<==? .WHERE FLUSHED> .BRANCH)
+ (ELSE <SET B2 <MAKE:TAG>>)>
+ <FUNCTION:VALUE>
+ .DIR
+ <RESULT-TYPE .NOD>>
+ <SET W2
+ <MOVE:ARG <COND (.NOTF <REFERENCE .SDIR>)
+ (ELSE <FUNCTION:VALUE T>)>
+ .WHERE>>
+ <COND (<N==? .WHERE FLUSHED>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B2>)>
+ .W2)
+ (<5 .TMPL>
+ <GEN:FALSE>
+ <MOVE:ARG <FUNCTION:VALUE T> .WHERE>)
+ (ELSE <MOVE:ARG <FUNCTION:VALUE T> .WHERE>)>>
+
+<DEFINE STACK-ARGS (NOD PASN
+ "AUX" (UNK <>) (ARGS 0) (STA <STACKS .NOD>) N
+ (K <KIDS .NOD>))
+ #DECL ((NOD N) NODE (ARGS STA) FIX (K) <LIST [REST NODE]>)
+ <REPEAT ()
+ <AND <EMPTY? .K> <RETURN>>
+ <COND (<==? <NODE-TYPE <SET N <1 .K>>> ,SEGMENT-CODE>
+ <RET-TMP-AC <GEN <1 <KIDS .N>> <FUNCTION:VALUE>>>
+ <REGSTO T>
+ <SEGMENT:STACK </ .STA 2> .UNK>
+ <ADD:STACK <- .STA>>
+ <ADD:STACK PSTACK>
+ <SET UNK T>)
+ (ELSE
+ <RET-TMP-AC <STACK:ARGUMENT <GEN .N DONT-CARE>>>
+ <ADD:STACK 2>
+ <SET ARGS <+ .ARGS 1>>)>
+ <SET K <REST .K>>>
+ <REGSTO T>
+ <COND (.UNK <EMIT '<`POP `P* `A >>)
+ (.PASN <EMIT <INSTRUCTION `MOVEI `A* .ARGS>>)>
+ <COND (<NOT .UNK> .ARGS)>>
+
+" Get a bunch of goodies into ACs for a PUSHJ call."
+
+<DEFINE AC-ARGS (NOD ACTMP "AUX" WHS)
+ #DECL ((WHS) <LIST [REST DATUM]> (NOD) NODE (ACTMP) LIST)
+ <COND
+ (<SEGS .NOD> <STACK-ARGS .NOD <>>)
+ (<SET WHS
+ <MAPR ,LIST
+ <FUNCTION (NL WL
+ "AUX" (N <1 .NL>) (W <1 .WL>) (SD <SIDES <REST .NL>>)
+ (RT <ISTYPE-GOOD? <DATTYP .W>>))
+ #DECL ((N) NODE (W) <OR DATUM LIST> (RT) <OR ATOM FALSE>)
+ <SET W
+ <GEN .N
+ <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE> DONT-CARE)
+ (.SD
+ <DATUM <COND (<ISTYPE-GOOD? <RESULT-TYPE .N>>)
+ (ELSE ANY-AC)>
+ ANY-AC>)
+ (ELSE <DATUM !.W>)>>>
+ <AND .SD <REGSTO <>>>
+ <COND (.RT <DATTYP-FLUSH .W> <PUT .W ,DATTYP .RT>)>
+ .W>
+ <KIDS .NOD>
+ .ACTMP>>
+ <SET WHS
+ <MAPF ,LIST
+ <FUNCTION (W1 W2)
+ #DECL ((W1) DATUM (W2) LIST)
+ <MOVE:ARG .W1 <DATUM !.W2>>>
+ .WHS
+ .ACTMP>>
+ <MAPF <> ,RET-TMP-AC .WHS>
+ T)>>
+
+<DEFINE SIDES (L)
+ #DECL ((L) <LIST [REST NODE]>)
+ <MAPF <>
+ <FUNCTION (N)
+ <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE> <>)
+ (<OR <==? <NODE-TYPE .N> ,ISUBR-CODE>
+ <MEMQ ALL <SIDE-EFFECTS .N>>>
+ <MAPLEAVE T>)>>
+ .L>>
+
+" Generate code for a call to an RSUBR (maybe PUSHJ)."
+
+<DEFINE RSUBR-GEN (N W
+ "AUX" (IT <NODE-NAME .N>) ACST RN KNWN (OS .STK)
+ (STK (0 !.STK)))
+ #DECL ((N RN) NODE (W) <OR ATOM DATUM> (STK) <SPECIAL LIST> (OS) LIST)
+ <MAPF <>
+ <FUNCTION (ARG)
+ #DECL ((ARG) NODE)
+ <OR <RESULT-TYPE .ARG>
+ <==? <NODE-TYPE .ARG> ,SEGMENT-CODE>
+ <MESSAGE ERROR "BAD ARG TO " <NODE-NAME .N> .ARG>>>
+ <KIDS .N>>
+ <COND (<AND <TYPE? <NODE-SUBR .N> FUNCTION>
+ <SET ACST <ACS <SET RN <GET .IT .IND>>>>
+ <OR <ASSIGNED? GROUP-NAME> <==? .FCN .RN>>>
+ <COND (<OR <=? .ACST '(STACK)> <=? .ACST '(FUNNY-STACK)>>
+ <SET KNWN <STACK-ARGS .N <>>>
+ <REGSTO T>
+ <SET STK .OS>
+ <STACK-CALL <REQARGS .RN>
+ <TOTARGS .RN>
+ <NODE-NAME .RN>
+ .KNWN <>>)
+ (ELSE
+ <OR <AC-ARGS .N .ACST> <AC-SEG-CALL .ACST>>
+ <REGSTO T>
+ <SET STK .OS>
+ <EMIT <INSTRUCTION `PUSHJ `P* <1 <CHTYPE <NODE-NAME .RN>
+ UVECTOR>>>>)>
+ <MOVE:ARG <FUNCTION:VALUE T> .W>)
+ (ELSE <SUBR-GEN .N .W>)>>
+
+" Generate a call to an internal compiled goodies using a PUSHJ."
+
+<DEFINE IRSUBR-GEN (NOD WHERE
+ "AUX" KNWN (N <NODE-SUBR .NOD>) (AN <2 .N>) (OS .STK)
+ (STK (0 !.STK)))
+ #DECL ((NOD) NODE (WHERE) <OR ATOM DATUM> (STK) <SPECIAL LIST> (OS) LIST
+ (N) <IRSUBR ANY <LIST [REST FIX]>> (AN) <LIST [REST FIX]>)
+ <REGSTO T>
+ <SET KNWN <STACK-ARGS .NOD <>>>
+ <STACK-CALL <MIN !.AN>
+ <MAX !.AN>
+ '![!]
+ .KNWN
+ <NODE-NAME .NOD>>
+ <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>
+
+" Get the arguemnts to a FUNCTION into the ACs."
+
+<DEFINE ARGS-TO-ACS (NOD
+ "AUX" (RQRG <REQARGS .NOD>) (INAME <NODE-NAME .NOD>) (N 1)
+ (ACST <ACS .NOD>) TG1 TG2 TG)
+ #DECL ((N RQRG) FIX (INAME) <UVECTOR [REST ATOM]> (ACST) LIST (NOD) NODE)
+ <COND
+ (<MEMBER .ACST '![(STACK) (FUNNY-STACK)!]>
+ <COND (<AND <EMPTY? <REST .INAME>> <NOT <L? .RQRG 0>>>
+ <REPEAT ()
+ <AND <G? .N .RQRG> <RETURN>>
+ <STACK:ARGUMENT <REFERENCE:ARG .N>>
+ <SET N <+ .N 1>>>
+ <EMIT <INSTRUCTION `PUSHJ `P* <1 .INAME>>>
+ <EMIT '<`JRST |FINIS >>)
+ (ELSE
+ <EMIT '<`MOVE `A* `AB >>
+ <AND <L=? .RQRG 0>
+ <EMIT <INSTRUCTION `JUMPGE `AB* <SET TG1 <MAKE:TAG>>>>>
+ <LABEL:TAG <SET TG2 <MAKE:TAG>>>
+ <AND <L? .RQRG 0> <EMIT '<INTGO!-OP>>>
+ <STACK:ARGUMENT <REFERENCE:ARG 1>>
+ <EMIT <INSTRUCTION `ADD `AB* '[<2 (2)>]>>
+ <EMIT <INSTRUCTION `JUMPL `AB* .TG2>>
+ <AND <L=? .RQRG 0> <LABEL:TAG .TG1>>
+ <EMIT '<`HLRES `A >>
+ <EMIT '<`ASH `A* -1>>
+ <COND (<G=? .RQRG 0>
+ <EMIT <INSTRUCTION `ADDI `A* <SET TG <MAKE:TAG>>>>
+ <EMIT <INSTRUCTION `PUSHJ `P* `@ .RQRG '`(A) >>)
+ (ELSE
+ <EMIT '<`MOVMS `A >>
+ <EMIT <INSTRUCTION `PUSHJ `P* <1 .INAME>>>)>
+ <EMIT '<`JRST |FINIS >>
+ <COND (<G=? .RQRG 0>
+ <REPEAT ()
+ <AND <EMPTY? <REST .INAME>> <LABEL:TAG .TG>>
+ <EMIT <INSTRUCTION `SETZ <1 .INAME>>>
+ <AND <EMPTY? <SET INAME <REST .INAME>>>
+ <RETURN>>>)>)>)
+ (ELSE
+ <REPEAT ()
+ <AND <EMPTY? .ACST> <RETURN>>
+ <RET-TMP-AC <MOVE:ARG <REFERENCE:ARG .N> <DATUM !<1 .ACST>>>>
+ <SET N <+ .N 1>>
+ <SET ACST <REST .ACST>>>
+ <EMIT <INSTRUCTION `PUSHJ `P* <1 .INAME>>>
+ <EMIT '<`JRST |FINIS >>)>>
+
+" Push the args supplied in ACs onto the stack."
+
+<DEFINE ACS-TO-STACK (ACST "AUX" (N 0))
+ #DECL ((N) FIX (ACST) LIST (VALUE) FIX)
+ <MAPF <>
+ <FUNCTION (W)
+ #DECL ((N) FIX)
+ <STACK:ARGUMENT <DATUM !.W>>
+ <SET N <+ .N 1>>>
+ .ACST>
+ .N>
+
+<DEFINE AC-SEG-CALL (ACS "AUX" (NARG <LENGTH .ACS>) TT OFFS)
+ #DECL ((OFFS NARG) FIX (ACS) LIST (TT) ADDRESS:C)
+ <COND (.CAREFUL
+ <EMIT <INSTRUCTION `CAIE `A* .NARG>>
+ <EMIT '<`JRST |COMPER >>)>
+ <SET OFFS <- 1 <SET NARG <* .NARG 2>>>>
+ <MAPF <>
+ <FUNCTION (X)
+ #DECL ((X) LIST)
+ <SET TT <ADDRESS:C .OFFS '`(TP) >>
+ <SET OFFS <+ .OFFS 2>>
+ <RET-TMP-AC <MOVE:ARG <DATUM .TT .TT> <DATUM !.X>>>>
+ .ACS>
+ <EMIT <INSTRUCTION `SUB `TP* [<FORM .NARG (.NARG)>]>>>
+
+" Generate PUSHJ in stack arg case (may go different places)"
+
+<DEFINE STACK-CALL (RQRG TRG INAME KNWN INT)
+ #DECL ((TRG RQRG) FIX (INAME) <UVECTOR [REST ATOM]> (KNWN) <OR FIX FALSE>
+ (INT) <OR ATOM FALSE>)
+ <COND
+ (<L? .TRG 0> ;"TUPLE?"
+ <COND (.KNWN <EMIT <INSTRUCTION `MOVEI `A* .KNWN>>)>
+ <EMIT <COND (.INT
+ <INSTRUCTION `PUSHJ
+ `P*
+ `@
+ <FORM MQUOTE!-OP!-PACKAGE
+ <INTERNAL-RSUBR .INT -1 T>>>)
+ (ELSE <INSTRUCTION `PUSHJ `P* <1 .INAME>>)>>)
+ (ELSE
+ <COND
+ (<NOT .KNWN>
+ <COND
+ (<==? .RQRG .TRG>
+ <COND (.CAREFUL
+ <EMIT <INSTRUCTION `CAIE `A* .RQRG>>
+ <EMIT '<`JRST |COMPER >>)>
+ <EMIT <COND (.INT
+ <INSTRUCTION `PUSHJ
+ `P*
+ `@
+ <FORM MQUOTE!-OP!-PACKAGE
+ <INTERNAL-RSUBR .INT .RQRG T>>>)
+ (ELSE <INSTRUCTION `PUSHJ `P* <1 .INAME>>)>>)
+ (ELSE
+ <COND (.CAREFUL
+ <EMIT <INSTRUCTION `CAIG `A* .TRG>>
+ <EMIT <INSTRUCTION `CAIGE `A* .RQRG>>
+ <EMIT '<`JRST |COMPER >>)>
+ <EMIT
+ <INSTRUCTION
+ `ADDI
+ `A*
+ <PROG ((I <+ <- .TRG .RQRG> 2>))
+ #DECL ((I) FIX)
+ <IVECTOR
+ <- .I 1>
+ '<COND
+ (.INT
+ <FORM `@
+ <FORM MQUOTE!-OP!-PACKAGE
+ <INTERNAL-RSUBR .INT
+ <- .TRG <SET I <- .I 1>>>
+ T>>>)
+ (ELSE <FORM <NTH .INAME <SET I <- .I 1>>>>)>>>>>
+ <EMIT <INSTRUCTION `PUSHJ `P* `@ <- .RQRG> `(A) >>)>)
+ (ELSE
+ <EMIT <COND (.INT
+ <INSTRUCTION `PUSHJ
+ `P*
+ `@
+ <FORM MQUOTE!-OP!-PACKAGE
+ <INTERNAL-RSUBR .INT .KNWN T>>>)
+ (ELSE
+ <INSTRUCTION `PUSHJ
+ `P*
+ <NTH .INAME <- .TRG .KNWN -1>>>)>>)>)>>
+
+
+" Generate code for a stackform."
+
+<DEFINE STACKFORM-GEN (NOD WHERE
+ "AUX" (K <KIDS .NOD>) TT T1 T2 TTT (PRE T) (OS .STK)
+ (STK (0 !.STK))
+ (SUBRC
+ <AND
+ <==? <NODE-TYPE <SET TT <1 .K>>> ,FGVAL-CODE>
+ <==? <NODE-TYPE <SET TT <1 <KIDS .TT>>>>
+ ,QUOTE-CODE>
+ <GASSIGNED? <SET TTT <NODE-NAME .TT>>>
+ <TYPE? ,.TTT SUBR>
+ .TTT>))
+ #DECL ((NOD TT) NODE (K) <LIST [REST NODE]> (PRE) <SPECIAL ANY>
+ (WHERE) <OR ATOM DATUM> (STK) <SPECIAL LIST> (OS) LIST)
+ <REGSTO T>
+ <COND (<NOT .SUBRC>
+ <RET-TMP-AC <STACK:ARGUMENT <GEN <1 .K> DONT-CARE>>>)>
+ <PCOUNTER <COND (.SUBRC 0) (ELSE 1)>>
+ <ADD:STACK PSTACK>
+ <LABEL:TAG <SET T1 <MAKE:TAG>>>
+ <PRED:BRANCH:GEN <SET T2 <MAKE:TAG>> <3 .K> <>>
+ <RET-TMP-AC <STACK:ARGUMENT <GEN <2 .K> DONT-CARE>>>
+ <COUNTP>
+ <BRANCH:TAG .T1>
+ <LABEL:TAG .T2>
+ <SEGMENT:FINAL <COND (.SUBRC .SUBRC) (ELSE APPLY)>>
+ <SET STK .OS>
+ <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>
+
+" Generate code for a COND."
+
+<DEFINE COND-GEN (NOD WHERE
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
+ "AUX" SACS NWHERE (ALLSTATES ()) (SSTATE #SAVED-STATE ())
+ (RW .WHERE) LOCN (COND <MAKE:TAG "COND">) W2
+ (KK <CLAUSES .NOD>) (SDIR .DIR) (SACS-OK T)
+ (SNUMSYM ()))
+ #DECL ((NOD) NODE (WHERE RW) <OR ATOM DATUM> (COND) ATOM (W2) DATUM
+ (KK) <LIST [REST NODE]> (ALLSTATES) <LIST [REST SAVED-STATE]>
+ (SSTATE) SAVED-STATE (LOCN) DATUM)
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <COND (<AND ,FUDGE .BRANCH> <VAR-STORE>) (ELSE <SET SACS <SAVE:RES>> <REGSTO <>>)>
+ <PREFER-DATUM .WHERE>
+ <SET WHERE <GOODACS .NOD .WHERE>>
+ <COND (<AND <TYPE? .WHERE DATUM>
+ <SET W2 .WHERE>
+ <OR <==? <ISTYPE? <RESULT-TYPE .NOD>> FALSE>
+ <==? <ISTYPE? <DATTYP .W2>> FALSE>>>
+ <SET WHERE <DATUM ANY-AC <DATVAL .W2>>>)>
+ <MAPR <>
+ <FUNCTION (BRN
+ "AUX" (LAST <EMPTY? <REST .BRN>>) (BR <1 .BRN>) NEXT
+ (K <CLAUSES .BR>) (PR <PREDIC .BR>) (NO-SEQ <>) (LEAVE <>)
+ (W
+ <COND (<TYPE? .WHERE DATUM> <DATUM !.WHERE>)
+ (ELSE .WHERE)>) FLG (BRNCHED <>))
+ #DECL ((PR BR) NODE (BRN) <LIST NODE> (K) <LIST [REST NODE]>)
+ <OR <AND ,FUDGE .BRANCH> <SET SNUMSYM <SAVE-NUM-SYM .SACS>>>
+ <RESTORE-STATE .SSTATE <AND <ASSIGNED? LOCN> <==? .LOCN ,NO-DATUM>>>
+ <COND
+ (<EMPTY? .K>
+ <COND
+ (<OR <SET FLG <NOT <TYPE-OK? <RESULT-TYPE .PR> FALSE>>> .LAST>
+ <OR .LAST <COND-COMPLAIN "NON REACHABLE COND CLAUSE(S) " <2 .BRN>>>
+ <COND (<AND .FLG .BRANCH>
+ <SET LOCN
+ <GEN .PR <COND (<==? .RW FLUSHED> FLUSHED) (ELSE .W)>>>
+ <COND (.DIR <BRANCH:TAG .BRANCH>)>)
+ (<AND .BRANCH .LAST>
+ <SET LOCN
+ <PRED:BRANCH:GEN .BRANCH
+ .PR
+ .SDIR
+ <COND (<==? .RW FLUSHED> FLUSHED)
+ (ELSE .W)>
+ .NOTF>>)
+ (ELSE
+ <SET LOCN
+ <GEN .PR <COND (<==? .RW FLUSHED> FLUSHED) (ELSE .W)>>>
+ <ACFIX .WHERE .W>
+ <VAR-STORE <>>)>
+ <COND (<==? .LOCN ,NO-DATUM>
+ <SET SACS-OK <SAVE-TYP .PR>>
+ <OR <AND ,FUDGE .BRANCH> <FIX-NUM-SYM .SNUMSYM .SACS>>)
+ (<NOT <AND ,FUDGE .BRANCH>><SET ALLSTATES (<SAVE-STATE> !.ALLSTATES)>)>
+ <MAPLEAVE>)
+ (<==? <ISTYPE? <RESULT-TYPE .PR>> FALSE> <GEN .PR FLUSHED>)
+ (<==? .RW FLUSHED>
+ <PRED:BRANCH:GEN <COND (<AND .BRANCH .SDIR> .BRANCH) (ELSE .COND)>
+ .PR
+ T
+ FLUSHED
+ .NOTF>)
+ (ELSE
+ <COND
+ (<AND .BRANCH .SDIR>
+ <RET-TMP-AC <PRED:BRANCH:GEN .BRANCH .PR T FLUSHED .NOTF>>)
+ (ELSE
+ <RET-TMP-AC
+ <PRED:BRANCH:GEN
+ .COND
+ .PR
+ T
+ <COND (<AND <TYPE? .W DATUM> <ISTYPE? <DATTYP .W>>>
+ <PUT .W ,DATTYP ANY-AC>
+ .W)
+ (ELSE .W)>
+ .NOTF>>)>)>
+ <SET SSTATE <SAVE-STATE>>
+ <OR <==? <RESULT-TYPE .PR> FLUSHED>
+ <AND ,FUDGE .BRANCH>
+ <SET ALLSTATES (.SSTATE !.ALLSTATES)>>
+ <VAR-STORE <>>)
+ (ELSE
+ <SET NEXT <MAKE:TAG "PHRASE">>
+ <COND (<==? <ISTYPE? <RESULT-TYPE .PR>> FALSE>
+ <COND (<AND .BRANCH .LAST <NOT .DIR>>
+ <SET LOCN <GEN .PR .W>>
+ <BRANCH:TAG .BRANCH>)
+ (ELSE
+ <COND (<AND .LAST <NOT <==? .RW FLUSHED>>>
+ <SET LOCN <GEN .PR .W>>)
+ (ELSE <SET LOCN <GEN .PR FLUSHED>>)>
+ <AND <N==? .LOCN ,NO-DATUM> <BRANCH:TAG .NEXT>>)>
+ <SET NO-SEQ T>
+ <OR <AND ,FUDGE .BRANCH> <SET ALLSTATES (<SAVE-STATE> !.ALLSTATES)>>
+ <COND-COMPLAIN "COND PREDICATE ALWAYS FALSE" .PR>)
+ (<TYPE-OK? FALSE <RESULT-TYPE .PR>>
+ <COND (<AND .LAST <NOT .DIR> .BRANCH>
+ <RET-TMP-AC <PRED:BRANCH:GEN .BRANCH .PR <> .W .NOTF>>)
+ (<AND .LAST .BRANCH>
+ <RET-TMP-AC <PRED:BRANCH:GEN .NEXT .PR <> FLUSHED>>)
+ (<AND .LAST <NOT <==? .RW FLUSHED>>>
+ <RET-TMP-AC <PRED:BRANCH:GEN .NEXT .PR <> .W>>)
+ (ELSE <PRED:BRANCH:GEN .NEXT .PR <> FLUSHED>)>
+ <COND (<AND .LAST <N==? <RESULT-TYPE .PR> NO-RETURN>>
+ <OR <AND ,FUDGE .BRANCH>
+ <SET ALLSTATES (<SAVE-STATE> !.ALLSTATES)>>)
+ (<==? <RESULT-TYPE .PR> NO-RETURN>
+ <SET SACS-OK <SAVE-TYP <NTH .K <LENGTH .K>>>>
+ <OR <AND ,FUDGE .BRANCH> <FIX-NUM-SYM .SNUMSYM .SACS>>)>)
+ (ELSE
+ <SET K (.PR !.K)>
+ <COND (<NOT .LAST>
+ <SET LEAVE T>
+ <COND-COMPLAIN "NON REACHABLE COND CLAUSE(S)"
+ <2 .BRN>>)>)>
+ <SET SSTATE <SAVE-STATE>>
+ <VAR-STORE <>>
+ <COND
+ (.BRANCH
+ <OR
+ .NO-SEQ
+ <COND
+ (<OR
+ <SET FLG
+ <NOT <TYPE-OK?
+ <RESULT-TYPE <SET PR <NTH .K <LENGTH .K>>>> FALSE>>>
+ <NOT <TYPE-OK? <RESULT-TYPE .PR> '<NOT FALSE>>>>
+ <COND (.NOTF
+ <SEQ-GEN .K FLUSHED>
+ <COND (<==? .RW FLUSHED> <SET LOCN ,NO-DATUM>)
+ (ELSE
+ <SET LOCN <MOVE:ARG <REFERENCE <NOT .FLG>> .W>>)>)
+ (<SET LOCN
+ <SEQ-GEN .K
+ <COND (<OR <==? .RW FLUSHED>
+ <N==? .SDIR .FLG>>
+ FLUSHED)
+ (ELSE .W)>>>)>
+ <AND <==? .FLG .SDIR> <SET BRNCHED T> <BRANCH:TAG .BRANCH>>)
+ (ELSE
+ <SET LOCN
+ <PSEQ-GEN .K
+ <COND (<==? .RW FLUSHED> FLUSHED) (ELSE .W)>
+ .BRANCH
+ .SDIR
+ .NOTF>>)>>
+ <AND .LAST .NO-SEQ <NOT .DIR> <BRANCH:TAG .BRANCH>>)
+ (<NOT .NO-SEQ>
+ <SET LOCN
+ <PSEQ-GEN .K
+ <COND (<==? .RW FLUSHED> FLUSHED) (ELSE .W)>
+ .BRANCH
+ .SDIR
+ .NOTF>>)>
+ <VAR-STORE <>>
+ <COND (<N==? .LOCN ,NO-DATUM>
+ <OR <AND ,FUDGE .BRANCH> <SET ALLSTATES (<SAVE-STATE> !.ALLSTATES)>>)
+ (ELSE
+ <SET SACS-OK <SAVE-TYP <NTH .K <LENGTH .K>>>>
+ <OR <AND ,FUDGE .BRANCH> <FIX-NUM-SYM .SNUMSYM .SACS>>
+ <RESTORE-STATE .SSTATE T>)>
+ <COND (<AND <NOT .LAST> <N==? .LOCN ,NO-DATUM>>
+ <OR .NO-SEQ <RET-TMP-AC .LOCN>>
+ <OR .BRNCHED <BRANCH:TAG .COND>>)>
+ <LABEL:TAG .NEXT>)>
+ <ACFIX .WHERE .W>
+ <OR <ASSIGNED? NPRUNE> <PUT .BR ,CLAUSES ()>>
+ <AND .LEAVE <MAPLEAVE>>>
+ .KK>
+ <OR <ASSIGNED? NPRUNE> <PUT .NOD ,CLAUSES ()>>
+ <COND (<AND <TYPE? .WHERE DATUM> <N==? <RESULT-TYPE .NOD> NO-RETURN>>
+ <SET W2 .WHERE>
+ <AND <ISTYPE? <DATTYP .W2>>
+ <TYPE? <DATTYP .LOCN> AC>
+ <NOT <==? <DATTYP .W2> <DATTYP .LOCN>>>
+ <RET-TMP-AC <DATTYP .LOCN> .LOCN>>
+ <AND <TYPE? <DATTYP .W2> AC> <FIX-ACLINK <DATTYP .W2> .W2 .LOCN>>
+ <AND <TYPE? <DATVAL .W2> AC> <FIX-ACLINK <DATVAL .W2> .W2 .LOCN>>)>
+ <LABEL:TAG .COND>
+ <SET NWHERE
+ <COND (<==? <RESULT-TYPE .NOD> NO-RETURN> ,NO-DATUM)
+ (ELSE <MOVE:ARG .WHERE .RW>)>>
+ <AND <N==? .NWHERE ,NO-DATUM> <NOT <AND ,FUDGE .BRANCH>> <MERGE-STATES .ALLSTATES>>
+ <OR .BRANCH <CHECK:VARS .SACS .SACS-OK>>
+ .NWHERE>
+
+<DEFINE PSEQ-GEN (L W B D N)
+ #DECL ((L) <LIST [REST NODE]>)
+ <REPEAT ()
+ <COND (<EMPTY? <REST .L>>
+ <RETURN <COND (.B <PRED:BRANCH:GEN .B <1 .L> .D .W .N>)
+ (ELSE <GEN <1 .L> .W>)>>)>
+ <RET-TMP-AC <GEN <1 .L> FLUSHED>>
+ <SET L <REST .L>>>>
+
+<DEFINE COND-COMPLAIN (MSG N1) #DECL ((N1) NODE) <MESSAGE NOTE .MSG .N1>>
+
+<DEFINE SAVE-TYP (NOD)
+ #DECL ((NOD) NODE)
+ <==? <NODE-TYPE .NOD> ,RETURN-CODE>>
+
+<DEFINE MERGE-STATES (ALLSTATES)
+ #DECL ((ALLSTATES) LIST)
+ <COND
+ (<EMPTY? .ALLSTATES>
+ <MAPF <>
+ <FUNCTION (AC "AUX" (NRES <ACRESIDUE .AC>))
+ <COND (.NRES
+ <MAPF <> <FUNCTION (X) <SMASH-INACS .X <>>> .NRES>)>
+ <PUT .AC ,ACRESIDUE <>>>
+ ,ALLACS>)
+ (ELSE <MAPF <> <FUNCTION (X) <MERGE-STATE .X>> .ALLSTATES>)>>
+
+" Fixup where its going better or something?"
+
+<DEFINE UPDATE-WHERE (NOD WHERE "AUX" TYP)
+ #DECL ((NOD) NODE (WHERE VALUE) <OR ATOM DATUM>)
+ <COND (<==? .WHERE FLUSHED> DONT-CARE)
+ (<SET TYP <ISTYPE? <RESULT-TYPE .NOD>>> <REG? .TYP .WHERE>)
+ (<==? .WHERE DONT-CARE> <DATUM ANY-AC ANY-AC>)
+ (ELSE .WHERE)>>
+
+" Generate code for OR use BOOL-GEN to do work."
+
+<DEFINE OR-GEN (NOD WHERE "OPTIONAL" (NF <>) (BR <>) (DIR T))
+ #DECL ((NOD) NODE)
+ <BOOL-GEN .NOD <CLAUSES .NOD> T .WHERE .NF .BR .DIR>>
+
+" Generate code for AND use BOOL-GEN to do work."
+
+<DEFINE AND-GEN (NOD WHERE "OPTIONAL" (NF <>) (BR <>) (DIR <>))
+ #DECL ((NOD) NODE)
+ <BOOL-GEN .NOD <CLAUSES .NOD> <> .WHERE .NF .BR .DIR>>
+
+<DEFINE BOOL-GEN (NOD PREDS RESULT WHERE NOTF BRANCH DIR
+ "AUX" SACS (SSTATE ()) (SS #SAVED-STATE ()) (RW .WHERE)
+ (BOOL <MAKE:TAG "BOOL">) (FLUSH <==? .RW FLUSHED>)
+ (FLS <AND <NOT .BRANCH> .FLUSH>) RTF SRES
+ (LOCN <DATUM ANY ANY>) FIN (SACS-OK T))
+ #DECL ((PREDS) <LIST [REST NODE]> (SSTATE) <LIST [REST SAVED-STATE]>
+ (SS) SAVED-STATE (NOTF DIR FLUSH FLS RTF) ANY (BOOL) ATOM
+ (BRANCH) <OR ATOM FALSE> (WHERE RW) <OR DATUM ATOM> (NOD) NODE
+ (LOCN) ANY (SRES RESULT) ANY)
+ <COND (<AND ,FUDGE .BRANCH> <VAR-STORE <>>) (ELSE <SET SACS <SAVE:RES>> <REGSTO <>>)>
+ <PREFER-DATUM .WHERE>
+ <AND .NOTF <SET RESULT <NOT .RESULT>>>
+ <SET SRES .RESULT>
+ <SET RTF
+ <AND <NOT .FLUSH> <==? .SRES .DIR> <TYPE-OK? <RESULT-TYPE .NOD> FALSE>>>
+ <AND .DIR <SET RESULT <NOT .RESULT>>>
+ <SET WHERE <GOODACS .NOD .WHERE>>
+ <COND
+ (<EMPTY? .PREDS> <SET LOCN <MOVE:ARG <REFERENCE .RESULT> .WHERE>>)
+ (ELSE
+ <MAPR <>
+ <FUNCTION (BRN
+ "AUX" (BR <1 .BRN>) (LAST <EMPTY? <REST .BRN>>)
+ (RT <RESULT-TYPE .BR>)
+ (W
+ <COND (<AND <TYPE? .WHERE DATUM>
+ <ISTYPE? <DATTYP .WHERE>>
+ <NOT .LAST>>
+ <GOODACS .BR <DATUM ANY-AC <DATVAL .WHERE>>>)
+ (<AND <OR <NOT .RTF> .LAST> <TYPE? .WHERE DATUM>>
+ <DATUM !.WHERE>)
+ (<==? .RW FLUSHED> FLUSHED)
+ (ELSE .WHERE)>) (RTFL <>))
+ #DECL ((BRN) <LIST NODE> (BR) NODE (W) <OR ATOM DATUM>)
+ <SET SS <SAVE-STATE>>
+ <COND
+ (<AND <TYPE-OK? .RT FALSE> <NOT <SET RTFL <==? <ISTYPE? .RT> FALSE>>>>
+ <COND
+ (<OR .BRANCH <AND .FLS <NOT .LAST>>>
+ <COND (.LAST
+ <SET LOCN
+ <PRED:BRANCH:GEN .BRANCH
+ .BR
+ .DIR
+ <COND (.FLUSH FLUSHED) (ELSE .W)>
+ .NOTF>>)
+ (ELSE
+ <RET-TMP-AC
+ <PRED:BRANCH:GEN <COND (.FLS .BOOL)
+ (.RESULT .BOOL)
+ (ELSE .BRANCH)>
+ .BR
+ .SRES
+ <COND (.RTF .W) (ELSE FLUSHED)>
+ .NOTF>>)>
+ <COND (<AND <NOT <AND ,FUDGE .BRANCH>> <N==? .RT NO-RETURN>>
+ <SET SSTATE (<SAVE-STATE> !.SSTATE)>)
+ (<==? .RT NO-RETURN>
+ <SET SACS-OK <SAVE-TYP .BR>>
+ <RESTORE-STATE .SS T>)>)
+ (.LAST
+ <SET LOCN <GEN .BR .W>>
+ <COND (<AND <NOT <AND ,FUDGE .BRANCH>> <N==? .RT NO-RETURN>>
+ <SET SSTATE (<SAVE-STATE> !.SSTATE)>)
+ (<==? .RT NO-RETURN>
+ <SET SACS-OK <SAVE-TYP .BR>>
+ <RESTORE-STATE .SS T>)>
+ .LOCN)
+ (ELSE
+ <SET LOCN <PRED:BRANCH:GEN .BOOL .BR .DIR .W .NOTF>>
+ <COND (<AND <NOT <AND ,FUDGE .BRANCH>> <N==? .RT NO-RETURN>>
+ <SET SSTATE (<SAVE-STATE> !.SSTATE)>)
+ (<==? .RT NO-RETURN>
+ <SET SACS-OK <SAVE-TYP .BR>>
+ <RESTORE-STATE .SS T>)>
+ <RET-TMP-AC .LOCN>)>)
+ (<OR <N==? .SRES <COND (.NOTF <SET RTFL <NOT .RTFL>>) (ELSE .RTFL)>>
+ .LAST>
+ <OR .LAST <MESSAGE NOTE "NON REACHABLE AND/OR CLAUSE" <2 .BRN>>>
+ <COND (.BRANCH
+ <SET LOCN
+ <GEN .BR <COND (<N==? .DIR .RTFL> .W) (ELSE FLUSHED)>>>
+ <AND <N==? .DIR .RTFL>
+ <N==? .LOCN ,NO-DATUM>
+ <PROG ()
+ <VAR-STORE>
+ T>
+ <BRANCH:TAG .BRANCH>>)
+ (ELSE <SET LOCN <GEN .BR .W>>)>
+ <ACFIX .WHERE .W>
+ <VAR-STORE>
+ <MAPLEAVE>)
+ (ELSE <RET-TMP-AC <GEN .BR FLUSHED>>)>
+ <ACFIX .WHERE .W>
+ <VAR-STORE <>>>
+ .PREDS>)>
+ <OR <ASSIGNED? NPRUNE> <PUT .NOD ,CLAUSES ()>>
+ <COND (<AND <TYPE? .WHERE DATUM> <TYPE? .LOCN DATUM>>
+ <AND <NOT <==? <DATTYP .WHERE> <DATTYP .LOCN>>>
+ <ISTYPE? <DATTYP .WHERE>>
+ <TYPE? <DATTYP .LOCN> AC>
+ <RET-TMP-AC <DATTYP .LOCN> .LOCN>>
+ <AND <TYPE? <DATTYP .WHERE> AC>
+ <FIX-ACLINK <DATTYP .WHERE> .WHERE .LOCN>>
+ <AND <TYPE? <DATVAL .WHERE> AC>
+ <FIX-ACLINK <DATVAL .WHERE> .WHERE .LOCN>>)>
+ <OR <AND .BRANCH <NOT .RESULT>> <LABEL:TAG .BOOL>>
+ <SET FIN
+ <COND (<==? <RESULT-TYPE .NOD> NO-RETURN> ,NO-DATUM)
+ (ELSE <OR <AND ,FUDGE .BRANCH>
+ <MERGE-STATES .SSTATE>> <MOVE:ARG .WHERE .RW>)>>
+ <OR <AND ,FUDGE .BRANCH> <CHECK:VARS .SACS .SACS-OK>>
+ .FIN>
+
+" Get the best set of acs around for this guy."
+
+<DEFINE GOODACS (N W1 "AUX" W)
+ #DECL ((N) NODE (W) DATUM)
+ <COND (<==? .W1 FLUSHED> DONT-CARE)
+ (<TYPE? .W1 DATUM>
+ <SET W .W1>
+ <DATUM <COND (<OR <ISTYPE-GOOD? <DATTYP .W>>
+ <ISTYPE-GOOD? <RESULT-TYPE .N>>>)
+ (<TYPE? <DATTYP .W> AC> <DATTYP .W>)
+ (ELSE ANY-AC)>
+ <COND (<TYPE? <DATVAL .W> AC> <DATVAL .W>)
+ (ELSE ANY-AC)>>)
+ (ELSE
+ <DATUM <COND (<ISTYPE-GOOD? <RESULT-TYPE .N>>) (ELSE ANY-AC)>
+ ANY-AC>)>>
+
+" Generate code for ASSIGNED?"
+
+<DEFINE ASSIGNED?-GEN (N W
+ "OPTIONAL" (NF <>) (BR <>) (DIR <>)
+ "AUX" (A <LOCAL-ADDR .N <>>) (SDIR .DIR)
+ (FLS <==? .W FLUSHED>) B2)
+ #DECL ((A) DATUM (N) NODE)
+ <AND .NF <SET DIR <NOT .DIR>>>
+ <SET DIR
+ <COND (<AND .BR <NOT .FLS>> <NOT .DIR>) (ELSE .DIR)>>
+ <EMIT <INSTRUCTION GETYP!-OP `O* !<ADDR:TYPE .A>>>
+ <EMIT <INSTRUCTION <COND (.DIR `CAIE ) (ELSE `CAIN )>
+ `O*
+ '<TYPE-CODE!-OP!-PACKAGE UNBOUND>>>
+ <RET-TMP-AC .A>
+ <COND (<AND .BR .FLS> <BRANCH:TAG .BR> FLUSHED)
+ (.BR
+ <BRANCH:TAG <SET B2 <MAKE:TAG>>>
+ <SET W <MOVE:ARG <REFERENCE .SDIR> .W>>
+ <BRANCH:TAG .BR>
+ <LABEL:TAG .B2>
+ .W)
+ (ELSE
+ <BRANCH:TAG <SET BR <MAKE:TAG>>>
+ <TRUE-FALSE .N .BR .W>)>>
+
+<DEFINE TRUE-FALSE (N B W "OPTIONAL" (THIS T) "AUX" (RW .W) (B2 <MAKE:TAG>))
+ #DECL ((N) NODE (B2 B) ATOM (W) <OR DATUM ATOM>)
+ <SET W <UPDATE-WHERE .N .W>>
+ <MOVE:ARG <REFERENCE .THIS> .W>
+ <RET-TMP-AC .W>
+ <BRANCH:TAG .B2>
+ <LABEL:TAG .B>
+ <MOVE:ARG <REFERENCE <NOT .THIS>> .W>
+ <LABEL:TAG .B2>
+ <MOVE:ARG .W .RW>>
+
+" Generate code for LVAL."
+
+<DEFINE LVAL-GEN (NOD WHERE
+ "AUX" (SYM <NODE-NAME .NOD>) (TAC <>) (VAC <>) TT ADDR
+ (LIVE
+ <COND (<==? <LENGTH <SET TT <TYPE-INFO .NOD>>> 2>
+ <2 .TT>)
+ (ELSE T)>))
+ #DECL ((NOD) NODE (SYM) SYMTAB (ADDR) <OR FALSE DATUM>
+ (TAC VAC) <OR FALSE AC> (NO-KILL) LIST)
+ <LVAL-UP .SYM>
+ <COND (<SET ADDR <INACS .SYM>>
+ <AND <TYPE? <DATTYP <SET ADDR <DATUM !.ADDR>>> AC>
+ <PUT <SET TAC <DATTYP .ADDR>>
+ ,ACLINK
+ (.ADDR !<ACLINK .TAC>)>>
+ <AND <TYPE? <DATVAL .ADDR> AC>
+ <PUT <SET VAC <DATVAL .ADDR>>
+ ,ACLINK
+ (.ADDR !<ACLINK .VAC>)>>
+ <SET ADDR <MOVE:ARG .ADDR .WHERE>>)
+ (ELSE
+ <SET ADDR <MOVE:ARG <LADDR .SYM <> <>> .WHERE>>
+ <COND (<AND <TYPE? <SET TT <DATVAL .ADDR>> AC> <SET VAC .TT>>
+ <AND <TYPE? <SET TT <DATTYP .ADDR>> AC> <SET TAC .TT>>
+ <COND (<N==? <DATTYP .ADDR> DONT-CARE>
+ <SMASH-INACS .SYM <DATUM !.ADDR>>
+ <AND .TAC <PUT .TAC ,ACRESIDUE (.SYM)>>
+ <AND .VAC <PUT .VAC ,ACRESIDUE (.SYM)>>)>)>)>
+ <COND (<AND ,DEATH
+ <NOT .LIVE>
+ <NOT <MAPF <>
+ <FUNCTION (LL)
+ #DECL ((LL) LIST)
+ <AND <==? <1 .LL> .SYM>
+ <PUT .LL 2 T>
+ <MAPLEAVE>>>
+ .NO-KILL>>>
+ <OR <STORED .SYM> <EMIT <MAKE:TAG <SPNAME <NAME-SYM .SYM>>>>>
+ <SMASH-INACS .SYM <> <>>
+ <AND .TAC
+ <ACRESIDUE .TAC>
+ <PUT .TAC ,ACRESIDUE <RES-FLS <ACRESIDUE .TAC> .SYM>>>
+ <AND .VAC
+ <ACRESIDUE .VAC>
+ <PUT .VAC ,ACRESIDUE <RES-FLS <ACRESIDUE .VAC> .SYM>>>)>
+ .ADDR>
+
+<DEFINE DELAY-KILL (L1 L2 "AUX" TT TAC SYM)
+ #DECL ((L1 L2) <LIST [REST !<LIST SYMTAB <OR ATOM FALSE>>]> (SYM) SYMTAB)
+ <REPEAT ()
+ <COND (<OR <==? .L1 .L2> <NOT ,DEATH>> <RETURN>)>
+ <COND (<2 <SET TT <1 .L1>>>
+ <OR <STORED <SET SYM <1 .TT>>>
+ <EMIT <MAKE:TAG <SPNAME <NAME-SYM .SYM>>>>>
+ <COND (<SET TT <INACS .SYM>>
+ <AND <TYPE? <SET TAC <DATTYP .TT>> AC>
+ <ACRESIDUE .TAC>
+ <PUT .TAC
+ ,ACRESIDUE
+ <RES-FLS <ACRESIDUE .TAC> .SYM>>>
+ <AND <TYPE? <SET TAC <DATVAL .TT>> AC>
+ <ACRESIDUE .TAC>
+ <PUT .TAC
+ ,ACRESIDUE
+ <RES-FLS <ACRESIDUE .TAC> .SYM>>>
+ <SMASH-INACS .SYM <>>)>)>
+ <SET L1 <REST .L1>>>>
+
+<DEFINE RES-FLS (L S)
+ #DECL ((L) <LIST [REST <OR TEMP SYMTAB COMMON>]> (S) SYMBOL)
+ <COND
+ (<EMPTY? .L> <>)
+ (ELSE
+ <REPEAT ((L1 .L) (LL .L))
+ #DECL ((LL L1) <LIST [REST <OR TEMP SYMTAB COMMON>]>)
+ <COND (<==? <1 .LL> .S>
+ <COND (<==? .LL .L>
+ <RETURN <COND (<NOT <EMPTY? <SET L <REST .L>>>> .L)>>)
+ (ELSE <PUTREST .L <REST .LL>> <RETURN .L1>)>)>
+ <AND <EMPTY? <SET LL <REST <SET L .LL>>>> <RETURN .L1>>>)>>
+
+" Generate LVAL for free variable."
+
+<DEFINE FLVAL-GEN (NOD WHERE "AUX" T2 T1 TT)
+ #DECL ((NOD) NODE (TT) SYMTAB (T2) DATUM)
+ <REGSTO T>
+ <COND (<TYPE? <SET T1 <NODE-NAME .NOD>> SYMTAB>
+ <SET TT .T1>
+ <MOVE:ARG <REFERENCE <NAME-SYM .TT>>
+ <SET T2 <DATUM ATOM <2 ,ALLACS>>>>)
+ (ELSE <SET T2 <GEN <1 <KIDS .NOD>> <DATUM ATOM <2 ,ALLACS>>>>)>
+ <FAST:VAL>
+ <RET-TMP-AC .T2>
+ <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>
+
+<DEFINE FSET-GEN (NOD WHERE "AUX" TT TEM T1 T2)
+ #DECL ((NOD TEM) NODE (T1) SYMTAB (T2) DATUM)
+ <REGSTO T>
+ <COND (<TYPE? <SET TT <NODE-NAME .NOD>> SYMTAB>
+ <SET T1 .TT>
+ <SET T2 <MOVE:ARG <REFERENCE <NAME-SYM .T1>> DONT-CARE>>
+ <SET TEM <2 <KIDS .NOD>>>)
+ (ELSE
+ <SET T2 <GEN <1 <KIDS .NOD>> DONT-CARE>>
+ <SET TEM <2 <KIDS .NOD>>>)>
+ <SET TT <GEN .TEM <FUNCTION:VALUE>>>
+ <SET T2 <MOVE:ARG .T2 <DATUM ATOM <3 ,ALLACS>>>>
+ <FAST:SET>
+ <RET-TMP-AC .T2>
+ <MOVE:ARG .TT .WHERE>>
+
+" Generate code for an internal SET."
+
+<DEFINE SET-GEN (NOD WHERE
+ "AUX" (SYM <NODE-NAME .NOD>)
+ (TY <ISTYPE-GOOD? <1 <TYPE-INFO .NOD>>>) TEM
+ (TYAC ANY-AC) (STORE-SET <>) (VAC ANY-AC) DAT1 (TT <>))
+ #DECL ((NOD) NODE (ADDR TEM) DATUM (SYM) SYMTAB
+ (STORE-SET) <SPECIAL ANY>)
+ <COND (<TYPE? .WHERE DATUM>
+ <AND <==? <DATVAL .WHERE> DONT-CARE> <PUT .WHERE ,DATVAL ANY-AC>>
+ <AND <==? <DATTYP .WHERE> DONT-CARE> <PUT .WHERE ,DATTYP ANY-AC>>
+ <AND <TYPE? <DATTYP .WHERE> AC> <SET TYAC <DATTYP .WHERE>>>
+ <AND <TYPE? <DATVAL .WHERE> AC> <SET VAC <DATVAL .WHERE>>>)>
+ <COND (<TYPE? .TYAC AC>
+ <COND (<MEMQ .SYM <ACRESIDUE .TYAC>>
+ <MAPF <>
+ <FUNCTION (S)
+ #DECL ((S) SYMTAB)
+ <OR <==? .S .SYM> <STOREV .SYM>>>
+ <ACRESIDUE .TYAC>>
+ <PUT .TYAC ,ACRESIDUE (.SYM)>)
+ (ELSE <MUNG-AC .TYAC .WHERE>)>)>
+ <COND (<TYPE? .VAC AC>
+ <COND (<MEMQ .SYM <ACRESIDUE .VAC>>
+ <MAPF <>
+ <FUNCTION (S)
+ #DECL ((S) SYMTAB)
+ <OR <==? .S .SYM> <STOREV .SYM>>>
+ <CHTYPE <ACRESIDUE .VAC> LIST>>
+ <PUT .VAC ,ACRESIDUE (.SYM)>)
+ (ELSE <MUNG-AC .VAC .WHERE>)>)>
+ <OR .TY
+ <AND <OR <==? <SPEC-SYM .SYM> FUDGE> <NOT <SPEC-SYM .SYM>>>
+ <OR <ARG? .SYM> <INIT-SYM .SYM>>
+ <SET TY <ISTYPE-GOOD? <1 <DECL-SYM .SYM>>>>>>
+ '<COND (<AND <SET TT <INACS .SYM>>
+ <==? .TYAC ANY-AC>
+ <==? .VAC ANY-AC>
+ <PROG-AC .SYM>
+ <MEMQ .SYM <LOOP-VARS <1 <PROG-AC .SYM>>>>
+ <OR <==? .TY <DATTYP .TT>>
+ <AND <NOT .TY>
+ <TYPE? <DATTYP .TT> AC>
+ <SET TYAC <DATTYP .TT>>>>>
+ <SET VAC <DATVAL .TT>>)>
+ <SET TEM
+ <GEN <2 <KIDS .NOD>>
+ <COND (.TY <DATUM .TY .VAC>)
+ (ELSE <SET TY <>> <DATUM .TYAC .VAC>)>>>
+ <REPEAT ((TT .TEM) AC)
+ #DECL ((TT) <PRIMTYPE LIST> (AC) AC)
+ <COND (<EMPTY? .TT> <RETURN>)
+ (<TYPE? <1 .TT> AC>
+ <OR <MEMQ .TEM <ACLINK <SET AC <1 .TT>>>>
+ <PUT .AC ,ACLINK (.TEM !<ACLINK .AC>)>>
+ <OR <MEMQ .SYM <ACRESIDUE .AC>>
+ <PUT .AC ,ACRESIDUE (.SYM !<ACRESIDUE .AC>)>>)>
+ <SET TT <REST .TT>>>
+ <COND (<SET DAT1 <INACS .SYM>>
+ <COND (<TYPE? <DATTYP .DAT1> AC>
+ <OR <MEMQ <DATTYP .DAT1> .TEM>
+ <FLUSH-RESIDUE <DATTYP .DAT1> .SYM>>)>
+ <COND (<TYPE? <DATVAL .DAT1> AC>
+ <OR <MEMQ <DATVAL .DAT1> .TEM>
+ <FLUSH-RESIDUE <DATVAL .DAT1> .SYM>>)>)>
+ <COND (<TYPE? <DATVAL .TEM> AC> <SMASH-INACS .SYM <DATUM !.TEM>>)>
+ <PUT .SYM ,STORED .STORE-SET>
+ <KILL-LOOP-AC .SYM>
+ <FLUSH-COMMON-SYMT .SYM>
+ <MOVE:ARG .TEM .WHERE>>
+
+
+<DEFINE ARG? (SYM) #DECL ((SYM) SYMTAB) <1? <NTH ,ARGTBL <CODE-SYM .SYM>>>>
+
+<SETG ARGTBL ![0 0 0 0 1 0 0 0 0 1 0 1 1!]>
+
+<GDECL (ARGTBL) <UVECTOR [REST FIX]>>
+
+" Update the stack model with a FIX or an ATOM."
+
+<DEFINE ADD:STACK (THING)
+ #DECL ((STK) <LIST FIX>)
+ <COND (<TYPE? .THING FIX> <PUT .STK 1 <+ <1 .STK> .THING>>)
+ (<OR <==? .THING PSLOT> <==? .THING PSTACK>>
+ <SET STK (0 .THING !.STK)>)
+ (<TYPE? .THING ATOM>
+ <SET STK (0 <FORM GVAL .THING> !.STK)>)
+ (ELSE <MESSAGE INCONSISTENCY "BAD CALL TO ADD:STACK ">)>>
+
+" Return the current distance between two stack places."
+
+<DEFINE STACK:L (FROM TO "AUX" (LN 0) (TF 0) (LF ()))
+ #DECL ((LN TF) FIX (FROM TO) LIST (VALUE) <OR FALSE LIST>)
+ <REPEAT (T)
+ <AND <==? <SET T <1 .FROM>> PSTACK> <RETURN <>>>
+ <COND (<N==? .T PSLOT>
+ <COND (<NOT <TYPE? .T FIX>> <SET LF (.T !.LF)>)
+ (ELSE <SET TF .T> <SET LN <+ .LN .TF>>)>)>
+ <AND <==? .TO .FROM> <RETURN (.LN !.LF)>>
+ <SET FROM <REST .FROM>>>>
+
+" Compute the address of a local variable using the stack model."
+
+<DEFINE LOCAL-ADDR (NOD STYP "AUX" (S <NODE-NAME .NOD>))
+ #DECL ((NOD) NODE (S) SYMTAB)
+ <LADDR .S <> .STYP>>
+
+<DEFINE LADDR (S LOSER STYP
+ "OPTIONAL" (NOSTORE T)
+ "AUX" TEM T2 T3 T4 (FRMS .FRMS) (AC-HACK .AC-HACK)
+ (NTSLOTS .NTSLOTS))
+ #DECL ((S) SYMTAB (T4) ADDRESS:C (VALUE TEM) DATUM (FRMS NTSLOTS) LIST)
+ <SET TEM
+ <COND
+ (<SET T2 <INACS .S>>
+ <COND (<TYPE? <DATTYP <SET T2 <DATUM !.T2>>> AC>
+ <PUT <DATTYP .T2> ,ACLINK (.T2 !<ACLINK <DATTYP .T2>>)>)>
+ <COND (<TYPE? <DATVAL .T2> AC>
+ <PUT <DATVAL .T2> ,ACLINK (.T2 !<ACLINK <DATVAL .T2>>)>)>
+ <SET LOSER T>
+ .T2)
+ (ELSE
+ <COND (<AND .NOSTORE <TYPE? <NUM-SYM .S> LIST> <1 <NUM-SYM .S>>>
+ <PUT <NUM-SYM .S> 1 <>>)>
+ <COND
+ (<AND <TYPE? <ADDR-SYM .S> TEMPV> <==? <1 .FRMS> <FRMNO .S>>>
+ <COND
+ (<=? .AC-HACK '(STACK)>
+ <SET T4
+ <ADDRESS:C
+ !<FIX:ADDR (-1 !<STACK:L .STK <1 <ADDR-SYM .S>>>)
+ <REST <ADDR-SYM .S>>>
+ `(TP) >>)
+ (<SET T4
+ <ADDRESS:C !<REST <ADDR-SYM .S>>
+ <COND (<=? .AC-HACK '(FUNNY-STACK)> `(FRM) )
+ (ELSE `(TB) )>
+ <COND (<=? .AC-HACK '(FUNNY-STACK)> 1) (ELSE 0)>>>)>
+ <DATUM .T4 .T4>)
+ (<TYPE? <ADDR-SYM .S> DATUM> <DATUM !<ADDR-SYM .S>>)
+ (<TYPE? <ADDR-SYM .S> FIX TEMPV>
+ <COND
+ (<AND .AC-HACK <=? .AC-HACK '(STACK)> <==? <1 .FRMS> <FRMNO .S>>>
+ <SET T4
+ <ADDRESS:C
+ !<FIX:ADDR (-1 !<STACK:L .STK .BSTB>)
+ (<ADDR-SYM .S>
+ !<COND (<TYPE? <ARGNUM-SYM .S> ATOM>
+ <MEMBER <FORM GVAL <ARGNUM-SYM .S>> .NTSLOTS>)
+ (ELSE (0))>)>
+ `(TP) >>
+ <DATUM .T4 .T4>)
+ (<==? <1 .FRMS> <FRMNO .S>>
+ <SPEC:REFERENCE:STACK
+ .AC-HACK
+ (<ADDR-SYM .S>
+ !<COND (<TYPE? <ARGNUM-SYM .S> FIX>
+ <COND (<NOT .AC-HACK>
+ <REST .NTSLOTS <- <LENGTH .NTSLOTS> 1>>)
+ (ELSE '(-2))>)
+ (<AND .PRE <NOT <SPEC-SYM .S>>> .NTSLOTS)
+ (ELSE <MEMBER <FORM GVAL <ARGNUM-SYM .S>> .NTSLOTS>)>)>)
+ (<REPEAT ((FRMS .FRMS) NNTSLTS (LB <>) (OFFS (0 ())) (CURR <>))
+ #DECL ((FRMS NNTSLTSJ) LIST (OFFS) <LIST [2 <OR FIX LIST>]>)
+ <COND
+ (<SET CURR <==? <4 .FRMS> FUZZ>>
+ <COND (.LB
+ <SET T3
+ <SPEC-OFFPTR
+ <- ,OTBSAV <1 .OFFS> 1>
+ <DATUM <ADDRESS:PAIR |$TTB > .T3>
+ VECTOR
+ (<FORM - 0 !<2 .OFFS>>)>>
+ <SET OFFS (0 ())>)
+ (ELSE
+ <SET LB T>
+ <SET T3
+ <SPEC-OFFPTR
+ <- ,OTBSAV <1 .OFFS> 1>
+ <DATUM <ADDRESS:PAIR |$TTB >
+ <ADDRESS:PAIR |$TTB `TB >>
+ VECTOR
+ (<FORM - 0 !<2 .OFFS>>)>>
+ <SET OFFS (0 ())>)>)
+ (ELSE <SET OFFS <STFIXIT .OFFS <4 .FRMS>>>)>
+ <AND <EMPTY? <SET FRMS <REST .FRMS 5>>>
+ <MESSAGE INCONSISTANCY "BAD FRAME MODEL ">>
+ <AND
+ <==? <FRMNO .S> <1 .FRMS>>
+ <SET OFFS
+ (<COND (<TYPE? <ADDR-SYM .S> FIX>
+ (<+ <ADDR-SYM .S> <- <1 .OFFS>>>))
+ (ELSE
+ <FIX:ADDR (<1 .OFFS>)
+ <REST <CHTYPE <ADDR-SYM .S> LIST>>>)>
+ (<FORM - 0 !<2 .OFFS>>))>
+ <SET NNTSLTS <5 .FRMS>>
+ <RETURN
+ <COND
+ (.LB
+ <SET T3
+ <SPEC-OFFPTR
+ !<1 .OFFS>
+ <DATUM <ADDRESS:PAIR |$TTB > .T3>
+ VECTOR
+ (!<2 .OFFS>
+ !<COND (<TYPE? <ARGNUM-SYM .S> ATOM>
+ <MEMBER <FORM GVAL <ARGNUM-SYM .S>> .NNTSLTS>)
+ (ELSE <REST .NNTSLTS <- <LENGTH .NNTSLTS> 1>>)>)>>
+ <DATUM .T3 .T3>)
+ (ELSE
+ <REFERENCE:STACK
+ (!<1 .OFFS>
+ !<COND (<TYPE? <ARGNUM-SYM .S> ATOM>
+ <MEMBER <FORM GVAL <ARGNUM-SYM .S>> .NNTSLTS>)
+ (<AND <TYPE? <ADDR-SYM .S> FIX>
+ <G=? <CODE-SYM .S> 6>
+ <L=? <CODE-SYM .S> 9>
+ <N=? <ACS <3 .FRMS>> '(STACK)>>
+ <REST .NNTSLTS <- <LENGTH .NNTSLTS> 1>>)
+ (ELSE '(0))>
+ !<2 .OFFS>)>)>>>>)>)
+ (ELSE <MESSAGE INCONSISTENCY "BAD VARIABLE ADDRESS ">)>)>>
+ <COND (<AND <NOT .LOSER>
+ <NOT <SPEC-SYM .S>>
+ <OR <ARG? .S> <INIT-SYM .S>>
+ <SET T2 <ISTYPE-GOOD? <1 <DECL-SYM .S>>>>>
+ <DATUM .T2 <DATVAL .TEM>>)
+ (<AND <NOT .LOSER> .STYP <SET T2 <ISTYPE-GOOD? .STYP>>>
+ <DATUM .T2 <DATVAL .TEM>>)
+ (ELSE .TEM)>>
+
+<DEFINE STFIXIT (OFF FRM "AUX" (NF 0) (NX ()))
+ #DECL ((NF) FIX (NX) LIST (OFF) <LIST FIX LIST> (FRM) LIST)
+ <MAPF <>
+ <FUNCTION (IT)
+ <COND (<TYPE? .IT FIX> <SET NF <+ .NF .IT>>)
+ (ELSE <SET NX (.IT !.NX)>)>>
+ .FRM>
+ (<+ <1 .OFF> .NF> (!.NX !<2 .OFF>))>
+
+" Generate obscure stuff."
+
+<DEFINE DEFAULT-GEN (NOD WHERE)
+ #DECL ((NOD) NODE)
+ <MOVE:ARG <REFERENCE <NODE-NAME .NOD>> .WHERE>>
+
+" Do GVAL using direct locative reference."
+
+<DEFINE GVAL-GEN (N W
+ "AUX" (GD <GLOC? <NODE-NAME <1 <KIDS .N>>>>)
+ (RT <ISTYPE-GOOD? <RESULT-TYPE .N>>))
+ #DECL ((N) NODE)
+ <SET GD <OFFPTR 0 .GD VECTOR>>
+ <MOVE:ARG <DATUM <COND (.RT) (ELSE .GD)> .GD> .W>>
+
+" Do SETG using direct locative reference."
+
+<DEFINE SETG-GEN (N W
+ "AUX" GD DD (NN <2 <KIDS .N>>) (FA <FREE-ACS T>)
+ (RT <ISTYPE-GOOD? <RESULT-TYPE .N>>)
+ (D
+ <GEN
+ .NN
+ <COND (<==? .W FLUSHED> DONT-CARE)
+ (<G=? .FA 3>
+ <SET DD <GOODACS .N .W>>
+ <COND (<NOT <TYPE? <DATTYP .DD> AC>>
+ <PUT .DD ,DATTYP ANY-AC>)>
+ .DD)
+ (<AND .RT <G=? .FA 2>> <GOODACS .N .W>)
+ (ELSE DONT-CARE)>>))
+ #DECL ((N NN) NODE (D) DATUM (FA) FIX)
+ <SET GD <OFFPTR 0 <SET GD <GLOC? <NODE-NAME <1 <KIDS .N>>>>> VECTOR>>
+ <MOVE:ARG .D <SET GD <DATUM .GD .GD>> T>
+ <COND (<AND <OR <AND <TYPE? <DATTYP .D> ATOM>
+ <ISTYPE-GOOD? <DATTYP .D>>>
+ <TYPE? <DATTYP .D> AC>>
+ <TYPE? <DATVAL .D> AC>>
+ <RET-TMP-AC .GD>
+ <MOVE:ARG .D .W>)
+ (ELSE <RET-TMP-AC .D> <MOVE:ARG .GD .W>)>>
+
+<BLOCK (<ROOT>)>
+
+RGLOC
+
+<ENDBLOCK>
+
+<DEFINE GLOC? (ATM "AUX" GL)
+ #DECL ((GL) DATUM)
+ <COND (.GLUE
+ <SET GL
+ <MOVE:ARG <REFERENCE <RGLOC .ATM T>> <DATUM LOCR ANY-AC>>>
+ <EMIT <INSTRUCTION `ADD
+ <ACSYM <CHTYPE <DATVAL .GL> AC>>
+ |GLOTOP
+ 1 >>
+ <RET-TMP-AC <DATTYP .GL> .GL>
+ <PUT .GL ,DATTYP VECTOR>
+ .GL)
+ (ELSE <REFERENCE <GLOC .ATM T>>)>>
+
+<SETG USE-RGLOC T>
+
+" Generate GVAL calls."
+
+<DEFINE FGVAL-GEN (NOD WHERE)
+ #DECL ((NOD) NODE)
+ <RET-TMP-AC <GEN <1 <KIDS .NOD>> <DATUM ATOM ,AC-B>>>
+ <REGSTO T>
+ <FAST:GVAL>
+ <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>
+
+" Generate a SETG call."
+
+<DEFINE FSETG-GEN (NOD WHERE "AUX" TT TEM)
+ #DECL ((NOD) NODE (TT TEM) DATUM)
+ <SET TT <GEN <1 <KIDS .NOD>> DONT-CARE>>
+ <SET TEM <GEN <2 <KIDS .NOD>> <FUNCTION:VALUE>>>
+ <SET TT <MOVE:ARG .TT <DATUM ATOM <3 ,ALLACS>>>>
+ <PUT <3 ,ALLACS> ,ACPROT T>
+ <MOVE:ARG .TEM <SET TEM <FUNCTION:VALUE>>>
+ <PUT <3 ,ALLACS> ,ACPROT <>>
+ <RET-TMP-AC .TT>
+ <REGSTO T>
+ <FAST:SETG>
+ <MOVE:ARG .TEM .WHERE>>
+
+<DEFINE CHTYPE-GEN (NOD WHERE
+ "AUX" (TYP <ISTYPE? <RESULT-TYPE .NOD>>) (N <1 <KIDS .NOD>>)
+ TEM
+ (ITYP
+ <COND (<ISTYPE? <RESULT-TYPE .N>>)
+ (<MEMQ <NODE-TYPE .N> ,SNODES> DONT-CARE)
+ (ELSE ANY-AC)>))
+ #DECL ((NOD N) NODE (TEM) DATUM (WHERE) <OR ATOM DATUM>)
+ <COND (<TYPE? .WHERE ATOM>
+ <COND (<ISTYPE-GOOD? .TYP>
+ <SET TEM <GEN .N DONT-CARE>>
+ <DATTYP-FLUSH .TEM>
+ <PUT .TEM ,DATTYP .TYP>)
+ (ELSE
+ <SET TEM <GEN .N <DATUM ANY-AC ANY-AC>>>
+ <MUNG-AC <DATTYP .TEM> .TEM>
+ <EMIT <INSTRUCTION `HRLI
+ <ACSYM <CHTYPE <DATTYP .TEM> AC>>
+ <FORM TYPE-CODE!-OP!-PACKAGE .TYP>>>
+ <MOVE:ARG .TEM .WHERE>)>)
+ (<ISTYPE-GOOD? .TYP>
+ <COND (<AND <==? <LENGTH .WHERE> 2> <TYPE? <DATVAL .WHERE> AC>>
+ <DATTYP-FLUSH <SET TEM <GEN .N <DATUM .ITYP <DATVAL .WHERE>>>>>
+ <PUT .TEM ,DATTYP .TYP>
+ <MOVE:ARG .TEM .WHERE>)
+ (ELSE
+ <DATTYP-FLUSH <SET TEM <GEN .N <DATUM .ITYP ANY-AC>>>>
+ <PUT .TEM ,DATTYP .TYP>
+ <MOVE:ARG .TEM .WHERE>)>)
+ (ELSE
+ <SET TEM <GEN .N <DATUM ANY-AC ANY-AC>>>
+ <MUNG-AC <DATTYP .TEM> .TEM>
+ <EMIT <INSTRUCTION `HRLI
+ <ACSYM <CHTYPE <DATTYP .TEM> AC>>
+ <FORM TYPE-CODE!-OP!-PACKAGE .TYP>>>
+ <MOVE:ARG .TEM .WHERE>)>>
+
+" Generate do-nothing piece of code."
+
+<DEFINE ID-GEN (N W) #DECL ((N) NODE) <GEN <1 <KIDS .N>> .W>>
+
+<DEFINE UNWIND-GEN (N W
+ "AUX" (OSTK .STK) (STK (0 !.STK)) (UNBRANCH <MAKE:TAG>)
+ (NOUNWIND <MAKE:TAG>) W1)
+ #DECL ((N) NODE (STK) <SPECIAL LIST> (OSTK) LIST (W1) DATUM)
+ <SGETREG ,AC-C <>>
+ <EMIT <INSTRUCTION `MOVEI `C* .UNBRANCH>>
+ <EMIT <INSTRUCTION `SUBI `C* `(M) >>
+ <EMIT <INSTRUCTION `PUSHJ `P* |IUNWIN >>
+ <ADD:STACK 10>
+ <RET-TMP-AC <SET W1 <GEN <1 <KIDS .N>> <GOODACS .N .W>>>>
+ <VAR-STORE>
+ <SGETREG ,AC-E <>>
+ <EMIT '<`PUSHJ `P* |POPUNW>>
+ <BRANCH:TAG .NOUNWIND>
+ <LABEL:TAG .UNBRANCH>
+ <GEN <2 <KIDS .N>> FLUSHED>
+ <VAR-STORE>
+ <EMIT '<`JRST |UNWIN2 >>
+ <LABEL:TAG .NOUNWIND>
+ <AND <TYPE? <DATTYP .W1> AC> <SGETREG <DATTYP .W1> .W1>>
+ <AND <TYPE? <DATVAL .W1> AC> <SGETREG <DATVAL .W1> .W1>>
+ <POP:LOCS .STK .OSTK>
+ <SET STK .OSTK>
+ <MOVE:ARG .W1 .W>>
+
+" Generate call to READ etc. with eof condition."
+
+<DEFINE READ2-GEN (N W
+ "AUX" (OSTK .STK) (STK (0 !.STK)) (I 0) SPOB BRANCH
+ (PSJ <MEMQ <NODE-NAME .N> '![READCHR NEXTCHR!]>))
+ #DECL ((N) NODE (STK) <SPECIAL LIST> (OSTK) LIST (I) FIX (SPOB) NODE)
+ <MAPF <>
+ <FUNCTION (OB)
+ #DECL ((OB SPOB) NODE (I) FIX)
+ <COND (.PSJ
+ <COND (<==? <NODE-TYPE .OB> ,EOF-CODE> <SET SPOB .OB>)
+ (ELSE <RET-TMP-AC <GEN .OB <DATUM ,AC-A ,AC-B>>>)>)
+ (ELSE
+ <COND (<==? <NODE-TYPE .OB> ,EOF-CODE>
+ <SET SPOB .OB>
+ <ADD:STACK PSLOT>
+ <TIME:STACK>)
+ (ELSE <RET-TMP-AC <STACK:ARGUMENT <GEN .OB DONT-CARE>>>)>
+ <ADD:STACK 2>
+ <SET I <+ .I 1>>)>>
+ <KIDS .N>>
+ <REGSTO T>
+ <COND (.PSJ
+ <EMIT <INSTRUCTION `PUSHJ
+ `P*
+ <COND (<==? <NODE-NAME .N> READCHR> |CREADC )
+ (ELSE |CNXTCH )>>>
+ <EMIT '<`CAIA >>
+ <BRANCH:TAG <SET BRANCH <MAKE:TAG>>>)
+ (ELSE
+ <SUBR:CALL <NODE-NAME .N> .I>
+ <SET BRANCH <TIME:CHECK>>)>
+ <SET STK .OSTK>
+ <RET-TMP-AC <GEN .SPOB
+ <COND (<==? .W FLUSHED> .W) (ELSE <FUNCTION:VALUE>)>>>
+ <VAR-STORE>
+ <LABEL:TAG .BRANCH>
+ <MOVE:ARG <FUNCTION:VALUE T> .W>>
+
+<DEFINE GET-GEN (N W) <GETGET .N .W T>>
+
+<DEFINE GET2-GEN (N W) <GETGET .N .W <>>>
+
+<GDECL (GETTERS) UVECTOR>
+
+<DEFINE GETGET (N W REV
+ "AUX" (K <KIDS .N>) PITEM PINDIC (BR <MAKE:TAG>)
+ (INDX <LENGTH <CHTYPE <MEMQ <NODE-SUBR .N> ,GETTERS> UVECTOR>>)
+ (LN <LENGTH .K>))
+ #DECL ((N) NODE (K) <LIST NODE NODE [REST NODE]> (PITEM PINDIC) DATUM
+ (INDX LN) FIX)
+ <SET PITEM <GEN <1 .K> <DATUM ,AC-A ,AC-B>>>
+ <SET PINDIC <GEN <2 .K> <DATUM ,AC-C ,AC-D>>>
+ <SET PITEM <MOVE:ARG .PITEM <DATUM ,AC-A ,AC-B>>>
+ <RET-TMP-AC <MOVE:ARG .PINDIC <DATUM ,AC-C ,AC-D>>>
+ <RET-TMP-AC .PITEM>
+ <REGSTO T>
+ <EMIT <INSTRUCTION `PUSHJ
+ `P*
+ <NTH '![|CIGETP |CIGTPR |CIGETL |CIGET !] .INDX>>>
+ <COND (<==? .LN 2> <EMIT '<`JFCL >>)
+ (ELSE
+ <EMIT '<`SKIPA >>
+ <BRANCH:TAG .BR>
+ <COND (.REV
+ <RET-TMP-AC <STACK:ARGUMENT <GEN <3 .K> DONT-CARE>>>
+ <REGSTO T>
+ <SUBR:CALL EVAL 1>)
+ (ELSE <RET-TMP-AC <GEN <3 .K> <FUNCTION:VALUE>>>)>
+ <VAR-STORE>
+ <LABEL:TAG .BR>)>
+ <MOVE:ARG <FUNCTION:VALUE T> .W>>
+
+
+<DEFINE REG? (TYP TRY
+ "OPTIONAL" (GETIT <>)
+ "AUX" (FUNNY <MEMQ <TYPEPRIM .TYP> '![STRING BYTES FRAME TUPLE LOCD!]>)
+ (TRY1 .TRY))
+ #DECL ((TYP) ATOM)
+ <COND (<AND <TYPE? .TRY1 DATUM>
+ <REPEAT ()
+ <AND <EMPTY? .TRY1> <RETURN <>>>
+ <AND <TYPE? <DATVAL .TRY1> AC> <RETURN T>>
+ <SET TRY1 <REST .TRY1 2>>>>
+ <DATUM <COND (.FUNNY <DATTYP .TRY1>) (ELSE .TYP)>
+ <DATVAL .TRY1>>)
+ (.FUNNY
+ <COND (.GETIT <ANY2ACS>) (ELSE <DATUM ANY-AC ANY-AC>)>)
+ (ELSE
+ <DATUM .TYP <COND (.GETIT <GETREG <>>) (ELSE ANY-AC)>>)>>
+
+<SETG GETTERS ![,GET ,GETL ,GETPROP ,GETPL!]>
+
+<COND (<GASSIGNED? ARITH-GEN>
+<SETG GENERATORS
+ <DISPATCH ,DEFAULT-GEN
+ (,FORM-CODE ,FORM-GEN)
+ (,PROG-CODE ,PROG-REP-GEN)
+ (,SUBR-CODE ,SUBR-GEN)
+ (,COND-CODE ,COND-GEN)
+ (,LVAL-CODE ,LVAL-GEN)
+ (,SET-CODE ,SET-GEN)
+ (,OR-CODE ,OR-GEN)
+ (,AND-CODE ,AND-GEN)
+ (,RETURN-CODE ,RETURN-GEN)
+ (,COPY-CODE ,COPY-GEN)
+ (,AGAIN-CODE ,AGAIN-GEN)
+ (,GO-CODE ,GO-GEN)
+ (,ARITH-CODE ,ARITH-GEN)
+ (,RSUBR-CODE ,RSUBR-GEN)
+ (,0-TST-CODE ,0-TEST)
+ (,NOT-CODE ,NOT-GEN)
+ (,1?-CODE ,1?-GEN)
+ (,TEST-CODE ,TEST-GEN)
+ (,EQ-CODE ,==-GEN)
+ (,TY?-CODE ,TYPE?-GEN)
+ (,LNTH-CODE ,LNTH-GEN)
+ (,MT-CODE ,MT-GEN)
+ (,REST-CODE ,REST-GEN)
+ (,NTH-CODE ,NTH-GEN)
+ (,PUT-CODE ,PUT-GEN)
+ (,PUTR-CODE ,PUTREST-GEN)
+ (,FLVAL-CODE ,FLVAL-GEN)
+ (,FSET-CODE ,FSET-GEN)
+ (,FGVAL-CODE ,FGVAL-GEN)
+ (,FSETG-CODE ,FSETG-GEN)
+ (,STACKFORM-CODE ,STACKFORM-GEN)
+ (,MIN-MAX-CODE ,MIN-MAX)
+ (,CHTYPE-CODE ,CHTYPE-GEN)
+ (,FIX-CODE ,FIX-GEN)
+ (,FLOAT-CODE ,FLOAT-GEN)
+ (,ABS-CODE ,ABS-GEN)
+ (,MOD-CODE ,MOD-GEN)
+ (,ID-CODE ,ID-GEN)
+ (,ASSIGNED?-CODE ,ASSIGNED?-GEN)
+ (,ISTRUC-CODE ,ISTRUC-GEN)
+ (,ISTRUC2-CODE ,ISTRUC-GEN)
+ (,BITS-CODE ,BITS-GEN)
+ (,GETBITS-CODE ,GETBITS-GEN)
+ (,BITL-CODE ,BITLOG-GEN)
+ (,PUTBITS-CODE ,PUTBITS-GEN)
+ (,ISUBR-CODE ,ISUBR-GEN)
+ (,EOF-CODE ,ID-GEN)
+ (,READ-EOF2-CODE ,READ2-GEN)
+ (,READ-EOF-CODE ,SUBR-GEN)
+ (,IPUT-CODE ,IPUT-GEN)
+ (,IREMAS-CODE ,IREMAS-GEN)
+ (,GET-CODE ,GET-GEN)
+ (,GET2-CODE ,GET2-GEN)
+ (,IRSUBR-CODE ,IRSUBR-GEN)
+ (,MAP-CODE ,MAPFR-GEN)
+ (,MARGS-CODE ,MPARGS-GEN)
+ (,MAPLEAVE-CODE ,MAPLEAVE-GEN)
+ (,MAPRET-STOP-CODE ,MAPRET-STOP-GEN)
+ (,UNWIND-CODE ,UNWIND-GEN)
+ (,GVAL-CODE ,GVAL-GEN)
+ (,SETG-CODE ,SETG-GEN)
+ (,TAG-CODE ,TAG-GEN)
+ (,PRINT-CODE ,PRINT-GEN)
+ (,MEMQ-CODE ,MEMQ-GEN)
+ (,LENGTH?-CODE ,LENGTH?-GEN)
+ (,FORM-F-CODE ,FORM-F-GEN)
+ (,INFO-CODE ,INFO-GEN)
+ (,OBLIST?-CODE ,OBLIST?-GEN)
+ (,AS-NXT-CODE ,AS-NXT-GEN)
+ (,AS-IT-IND-VAL-CODE ,ASSOC-FIELD-GET)
+ (,ALL-REST-CODE ,ALL-REST-GEN)
+ (,COPY-LIST-CODE ,LIST-BUILD)
+ (,PUT-SAME-CODE ,SPEC-PUT-GEN)
+ (,BACK-CODE ,BACK-GEN)
+ (,TOP-CODE ,TOP-GEN)
+ (,SUBSTRUC-CODE ,SUBSTRUC-GEN)
+ (,ROT-CODE ,ROT-GEN)
+ (,LSH-CODE ,LSH-GEN)
+ (,BIT-TEST-CODE ,BIT-TEST-GEN)>>
+\f)>
+
+<ENDPACKAGE>
\ No newline at end of file
--- /dev/null
+<PACKAGE "COMCOD">
+
+<ENTRY MOVE:ARG ADDR:TYPE ADDR:VALUE MOVE:VALUE STEMP:ADDR MOVE:TYP EMIT
+ D:B:TAG SEGMENT:LIST TUPLE:FINAL STORE:BIND LOCAL-TAGS TEST:ARGPNTR
+ REFERENCE BRANCH:TAG PSLOT COPY:ARGPNTR BIND:END TIME:STACK
+ ACT:FINAL PUSH:BIND TIME:CHECK START:TAG ISTAG? FAST:GVAL
+ REFERENCE:ARGPNTR REFERENCE:ARG POP:LOCS SEGMENT:STACK PUSH:PAIR
+ MAKE:ENV LABEL:TAG FAST:SETG BUMP:CNTR MAKE:ACT REFERENCE:STACK
+ SPEC:REFERENCE:STACK ADDRESS:PAIR PCOUNTER STACK:ARGUMENT
+ SALLOC:SLOTS FAST:VAL GEN:FALSE SUBR:CALL STORE:PAIR FIX-ACLINK
+ BUMP:ARGPNTR COUNTP SEGMENT:FINAL TEST:ARG FUNCTION:VALUE
+ REFERENCE:UNBOUND ACT:INITIAL UNBIND:LOCS FIX:ADDR FAST:SET PUSH:ATB
+ UNIQUE:TAG ALLOC:SLOTS ADDR:TYPE1 PROG:END ADDR:VALUE1 FUNCTION:INITIAL
+ REFERENCE:ADR ALLOCATE:SLOTS GETUVT UNBIND:FUNNY LABEL:OFF IMCHK
+ CODE:PTR CODE:TOP BUILD:FRAME FRAMLN CHECK-LOCAL-TAGS GROUP:INITIAL
+ INT:LOSER:INITIAL INT:INITIAL SUB:INT:INITIAL FCN:INT:INITIAL
+ SUB:INITIAL FS:INT:INITIAL RDCL INT:FINAL FS:INT:FINAL FCNSUB:FINAL
+ ASSEM? TAG:COUNT>
+
+<USE "CACS" "COMPDEC" "NPRINT" "CODGEN" "PEEPH" "CODING" "CHKDCL" "CUP">
+
+<BLOCK (<ROOT>)>
+
+CSOURCE
+
+<ENDBLOCK>
+
+<BLOCK (!.OBLIST <GET PACKAGE OBLIST>)>
+
+
+
+"***** BEGINNING OF THE IMPLEMENTATION SECTION *****"
+
+<DEFINE EMIT (INSTR)
+ #DECL ((CODE:PTR) LIST)
+ <PUTREST .CODE:PTR (.INSTR)>
+ <SET CODE:PTR <REST .CODE:PTR>>>
+
+<SETG BIND-BEGIN [<FORM (<CHTYPE <TYPE-C ATOM> FIX>) -1>]>
+
+"Special datum meaning nothing returned."
+
+<SETG NO-DATUM <CHTYPE (FLUSHED FLUSHED) DATUM>>
+
+<NEWTYPE ADDRESS:C LIST>
+
+<DEFINE ADDRESS:C ("TUPLE" T) <CHTYPE (!.T) ADDRESS:C>>
+
+<NEWTYPE ADDRESS:PAIR LIST>
+
+<DEFINE ADDRESS:PAIR ("TUPLE" T) <CHTYPE (!.T) ADDRESS:PAIR>>
+
+<NEWTYPE TYPED:ADDRESS LIST>
+
+<DEFINE TYPED:ADDRESS (TYP ADR)
+ <CHTYPE (.TYP !<REFERENCE .ADR>) TYPED:ADDRESS>>
+
+<NEWTYPE IRSUBR LIST>
+
+;"FUNNY FUDGES "
+
+<OR <GASSIGNED? TDEFER!-OP> <SETG TDEFER!-OP <SQUOTA |TDEFER >>>
+
+<OR <GASSIGNED? TTP!-OP> <SETG TTP!-OP <SQUOTA |TTP >>>
+
+<OR <GASSIGNED? TTB!-OP> <SETG TTB!-OP <SQUOTA |TTB >>>
+
+<SETG FRAMACT 9>
+
+<SETG FRAMLN 7>
+
+<DEFINE MAKE:TAG ("OPTIONAL" (STR "TAG") ATM)
+ #DECL ((STR) STRING (ATM) ATOM (TAG:COUNT) FIX)
+ <SET STR <STRING .STR <UNPARSE .TAG:COUNT>>>
+ <SET TAG:COUNT <+ .TAG:COUNT 1>>
+ <GUNASSIGN <SET ATM
+ <OR <LOOKUP .STR ,TMP:OBL> <INSERT .STR ,TMP:OBL>>>>
+ .ATM>
+
+<DEFINE BRANCH:TAG (TAG) <EMIT <INSTRUCTION `JRST .TAG>>>
+
+<DEFINE LABEL:TAG (TAG) <EMIT .TAG>>
+
+<DEFINE ISTAG? (ATM)
+ #DECL ((LOCAL-TAGS) LIST)
+ <MAPF <>
+ <FUNCTION (LL)
+ #DECL ((LL) <LIST ATOM>)
+ <COND (<==? <1 .LL> .ATM> <MAPLEAVE T>)>>
+ .LOCAL-TAGS>>
+
+<DEFINE UNIQUE:TAG (ATM DEF?)
+ #DECL ((ATM) ATOM (DEF?) <OR ATOM FALSE> (LOCAL-TAGS) LIST)
+ <COND (<MAPF <>
+ <FUNCTION (L)
+ #DECL ((L) <LIST ATOM ATOM <OR FALSE ATOM>>)
+ <COND (<==? <1 .L> .ATM>
+ <COND (<AND .DEF? <3 .L>>
+ <MESSAGE ERROR
+ "MULTIPLY DEFINED TAG "
+ .ATM>)>
+ <AND .DEF? <PUT .L 3 T>>
+ <MAPLEAVE <2 .L>>)>>
+ .LOCAL-TAGS>)
+ (ELSE
+ <SET LOCAL-TAGS
+ ((.ATM <SET ATM <MAKE:TAG <PNAME .ATM>>> .DEF?)
+ !.LOCAL-TAGS)>
+ .ATM)>>
+
+<DEFINE CHECK-LOCAL-TAGS (L "AUX" (LOSERS ()))
+ #DECL ((L LOSERS) LIST)
+ <MAPF <>
+ <FUNCTION (LL)
+ #DECL ((LL) <LIST ATOM ATOM <OR ATOM FALSE>>)
+ <COND (<NOT <3 .LL>> <SET LOSERS (<1 .LL> !.LOSERS)>)>>
+ .L>
+ <COND (<NOT <EMPTY? .LOSERS>>
+ <MESSAGE ERROR " UNDEFINED LABEL (S) " .LOSERS>)>>
+
+<DEFINE LABEL:OFF (TAG)
+ <COND (.GLUE <LABEL:TAG .TAG>)
+ (<EMIT <INSTRUCTION
+ PSEUDO!-OP
+ <FORM SETG
+ .TAG
+ '<ANDB 262143 <CHTYPE .HERE!-OP FIX>>>>>)>>
+
+<DEFINE TRUE:BRANCH:TAG (TAG SRC) <D:B:TAG .TAG .SRC T <>>>
+
+<DEFINE FALSE:BRANCH:TAG (TAG SRC) <D:B:TAG .TAG .SRC <> <>>>
+
+<DEFINE D:B:TAG (TAG SRC DIR TYP "AUX" DT)
+ #DECL ((SRC) DATUM (DIR) <OR FALSE ATOM>)
+ <COND (<AND .TYP
+ <SET DT <ISTYPE? <TYPE-AND .TYP '<NOT FALSE>>>>
+ <OR <MEMQ .DT '![CHANNEL RSUBR ATOM!]>
+ <AND <MEMQ <TYPEPRIM .DT> '![UVECTOR VECTOR!]>
+ <G? <MINL .DT> 0>>>>
+ <COND (<TYPE? <SET DT <DATVAL .SRC>> AC>
+ <EMIT <INSTRUCTION <COND (.DIR `JUMPL ) (ELSE `JUMPGE )>
+ <ACSYM .DT>
+ .TAG>>)
+ (ELSE
+ <EMIT <INSTRUCTION <COND (.DIR `SKIPGE ) (ELSE `SKIPL )>
+ !<ADDR:VALUE .SRC>>>
+ <BRANCH:TAG .TAG>)>)
+ (ELSE
+ <EMIT <INSTRUCTION GETYP!-OP `O* !<ADDR:TYPE .SRC>>>
+ <EMIT <INSTRUCTION <COND (.DIR `CAIE ) (ELSE `CAIN )>
+ `O*
+ '<TYPE-CODE!-OP FALSE>>>
+ <BRANCH:TAG .TAG>)>>
+
+<DEFINE GEN:FALSE () <EMIT <INSTRUCTION `PUSHJ `P* |RTFALS >>>
+
+<DEFINE SUBR:CALL (ADR ARG-NUMBER)
+ <EMIT <INSTRUCTION MCALL!-OP .ARG-NUMBER .ADR>>>
+
+<DEFINE FUNCTION:VALUE ("OPTIONAL" (ALLOC <>) "AUX" (DAT <DATUM ,AC-A ,AC-B>))
+ <COND (.ALLOC
+ <SGETREG <DATTYP .DAT> .DAT>
+ <SGETREG <DATVAL .DAT> .DAT>)>
+ .DAT>
+
+<SETG TMP:OBL <MOBLIST <OR <LOOKUP "TMP" <ROOT>> <INSERT "TMP" <ROOT>>>>>
+
+<DEFINE ADDR:TYPE (DAT "AUX" (TYP <DATTYP .DAT>))
+ #DECL ((DAT) <DATUM ANY ANY>)
+ <ADDR:TYPE1 .TYP>>
+
+<DEFINE ADDR:TYPE1 (ADR "AUX" TT)
+ <COND (<TYPE? .ADR AC> (<ADDRSYM .ADR>))
+ (<TYPE? .ADR ATOM> (<TYPE:SYM .ADR>))
+ (<TYPE? .ADR TEMP> <TEMP:ADDR .ADR 0>)
+ (<TYPE? .ADR ADDRESS:C> .ADR)
+ (<TYPE? .ADR ADDRESS:PAIR> (<1 .ADR>))
+ (<TYPE? .ADR OFFPTR>
+ <COND (<=? <DATVAL <2 .ADR>> #ADDRESS:PAIR (|$TTB
+ `TB )>
+ (<1 .ADR> `(TB) ))
+ (ELSE
+ <TOACV <2 .ADR>> ;"FORCE INDEX INTO REG "
+ <COND (<AND <MEMQ <SET TT <3 .ADR>> <ALLTYPES>>
+ <MEMQ <TYPEPRIM .TT> '![STORAGE UVECTOR!]>>
+ (<GETUVT <DATVAL <2 .ADR>>>))
+ (ELSE
+ (<1 .ADR>
+ !<COND (<==? <LENGTH .ADR> 4> <4 .ADR>)
+ (ELSE (0))>
+ (<ADDRSYM <DATVAL <2 .ADR>>>)))>)>)>>
+
+<DEFINE GETUVT (AC "OPTIONAL" (TOAC ,ACO) (NS <>) "AUX" TAC (P <ACPROT .AC>))
+ #DECL ((AC TAC TOAC) AC)
+ <PUT .AC ,ACPROT T>
+ <EMIT <INSTRUCTION `HLRE
+ <ACSYM <SET TAC <GETREG <>>>>
+ <ADDRSYM .AC>>>
+ <EMIT <INSTRUCTION `SUBM <ACSYM .AC> <ADDRSYM .TAC>>>
+ <PUT .AC ,ACPROT .P>
+ <EMIT <INSTRUCTION GETYP!-OP <ACSYM .TOAC> (<ADDRSYM .TAC>)>>
+ <OR .NS <EMIT <INSTRUCTION `HRLZS <ADDRSYM .TOAC>>>>
+ <ADDRSYM .TOAC>>
+
+<DEFINE TYPE:SYM (NAME) <FORM TYPE-WORD!-OP .NAME>>
+
+<DEFINE ADDR:VALUE (DAT "AUX" (VAL <DATVAL .DAT>))
+ #DECL ((DAT) <DATUM ANY ANY>)
+ <ADDR:VALUE1 .VAL>>
+
+<DEFINE ADDR:VALUE1 (ADR)
+ <COND (<TYPE? .ADR ADDRESS:C> (!.ADR 1))
+ (<TYPE? .ADR ADDRESS:PAIR> <REST .ADR>)
+ (<TYPE? .ADR AC> (<ADDRSYM .ADR>))
+ (<TYPE? .ADR TEMP> <TEMP:ADDR .ADR 1>)
+ (<TYPE? .ADR OFFPTR>
+ <COND (<=? <DATVAL <2 .ADR>> #ADDRESS:PAIR (|$TTB
+ `TB )>
+ (<+ <1 .ADR> 1> `(TB) ))
+ (ELSE
+ <TOACV <2 .ADR>>
+ (!<COND (<==? <LENGTH .ADR> 4> <4 .ADR>) (ELSE (0))>
+ <+ 1 <1 .ADR>>
+ (<ADDRSYM <DATVAL <2 .ADR>>>)))>)
+ (ELSE <MESSAGE INCONSISTENCY "BAD ADDRESS "> ())>>
+
+
+<DEFINE TEMP:ADDR (TM OFF "AUX" DAT)
+ #DECL ((DAT) <OR FALSE DATUM> (TM) TEMP (OFF) FIX (FCN) NODE)
+ <COND (<SET DAT <TMPAC .TM>>
+ <COND (<0? .OFF> <ADDR:TYPE1 <DATTYP .DAT>>)
+ (<1? .OFF> <ADDR:VALUE1 <DATVAL .DAT>>)
+ (<MESSAGE "INCONSISTENCY" "TEMPORARY OFFSET BAD">)>)
+ (<COND (<=? .AC-HACK '(STACK)>
+ (!<FIX:ADDR (-1 <- .OFF> !<STACK:L .STK .BSTB>)
+ (<TMPNO .TM> !.TMPS)>
+ '`(TP) ))
+ (ELSE
+ <REFERENCE:STACK:ADR
+ (.OFF <TMPNO .TM>
+ <COND (<=? .AC-HACK '(FUNNY-STACK)>
+ <* <TOTARGS .FCN> -2>)
+ (ELSE 0)> !.TMPS) .AC-HACK>)>)>>
+
+<DEFINE STEMP:ADDR (TM "OPTIONAL" (OFF 0))
+ #DECL ((TM) TEMP (OFF) FIX (FCN) NODE)
+ <COND (<=? .AC-HACK '(STACK)>
+ (!<FIX:ADDR (-1 <- .OFF> !<STACK:L .STK .BSTB>)
+ (<TMPNO .TM> !.TMPS)>
+ '`(TP) ))
+ (ELSE
+ <REFERENCE:STACK:ADR
+ (.OFF <TMPNO .TM>
+ <COND (<=? .AC-HACK '(FUNNY-STACK)>
+ <* <TOTARGS .FCN> -2>)
+ (ELSE 0)> !.TMPS) .AC-HACK>)>>
+
+"FIX:ADDR TAKES TWO ARGUMENTS. THESE ARE A NEGATIVE AND POSITIVE OFFSETS ON THE STACK
+ AND BUILDS A COMPOSITE OFFSET ELIMINATING DUPLICATION"
+
+<DEFINE FIX:ADDR (NEGS OPOS
+ "AUX" (POS <LIST !.OPOS>) (NUM 0) (NPOS ()) (NNEGS ()) LN)
+ #DECL ((NEGS POS) LIST (NUM) FIX (NNEGS) LIST)
+ <MAPF <>
+ <FUNCTION (NEG1 "AUX" NEGX)
+ <COND (<TYPE? .NEG1 FIX> <SET NUM <- .NUM .NEG1>>)
+ (<AND <TYPE? .NEG1 FORM ATOM>
+ <SET NEGX <MEMBER .NEG1 .POS>>>
+ <SET LN <- <LENGTH .POS> <LENGTH .NEGX> -1>>
+ <SET POS <DEL .POS .LN>>)
+ (ELSE <SET NNEGS (.NEG1 !.NNEGS)>)>>
+ .NEGS>
+ <MAPF <>
+ <FUNCTION (NPOS1)
+ <COND (<TYPE? .NPOS1 FIX> <SET NUM <+ .NUM .NPOS1>>)
+ (<SET NPOS (.NPOS1 !.NPOS)>)>>
+ .POS>
+ <COND (<NOT <EMPTY? .NNEGS>> (<FORM - .NUM !.NNEGS> !.NPOS))
+ (ELSE (.NUM !.NPOS))>>
+
+<DEFINE DEL (IT NUM)
+ #DECL ((IT) <LIST ANY> (NUM) FIX)
+ <COND (<==? .NUM 1> <REST .IT>)
+ (ELSE <PUTREST <REST .IT <- .NUM 2>> <REST .IT .NUM>> .IT)>>
+
+<DEFINE REFERENCE:ADR (OBJECT "EXTRA" TTYPE)
+ <COND (<AND <==? <PRIMTYPE .OBJECT> WORD>
+ <SET TTYPE <FORM TYPE-WORD!-OP <TYPE .OBJECT>>>>
+ <ADDRESS:PAIR .TTYPE [.OBJECT]>)
+ (<AND <==? <PRIMTYPE .OBJECT> LIST> <EMPTY? .OBJECT>>
+ <ADDRESS:PAIR <FORM TYPE-WORD!-OP <TYPE .OBJECT>> '[0]>)
+ (ELSE
+ <ADDRESS:C <FORM MQUOTE!-OP <FORM QUOTE .OBJECT>> -1>)>>
+
+<DEFINE REFERENCE (OBJ "AUX" ADR)
+ #DECL ((VALUE) <DATUM ANY ANY>)
+ <SET ADR <REFERENCE:ADR .OBJ>>
+ <DATUM .ADR .ADR>>
+
+<DEFINE STACK:ARGUMENT (DAT "AUX" TEM)
+ #DECL ((DAT) <DATUM ANY ANY>)
+ <COND (<N==? .DAT ,NO-DATUM>
+ <EMIT <INSTRUCTION `PUSH `TP* !<ADDR:TYPE .DAT>>>
+ <SET TEM <ADDR:VALUE .DAT>>
+ <EMIT <INSTRUCTION `PUSH
+ `TP*
+ !.TEM
+ !<COND (<MEMQ '`(TP) .TEM> '(-1))>>>)>
+ .DAT>
+
+<DEFINE STACK:ADR (ADR)
+ <EMIT <INSTRUCTION `PUSH `TP* !<ADDR:TYPE1 .ADR>>>
+ <EMIT <INSTRUCTION `PUSH `TP* !<ADDR:VALUE1 .ADR>>>
+ .ADR>
+
+<DEFINE MOVE:ARG (FROM1 TO1
+ "OPTIONAL" (KEEP <>)
+ "AUX" TMP TT TO TAC T1 TMP1 T2 FROM (NOTYET <>) (NOTYET2 <>)
+ VAL LSEXCH)
+ #DECL ((TMP FROM TO) <<PRIMTYPE LIST> ANY ANY> (TAC) AC (VAL) FIX)
+ <PROG ()
+ <COND
+ (<TYPE? .TO1 ATOM> <AND <==? .TO1 FLUSHED> <RET-TMP-AC .FROM1>> FLUSHED)
+ (<==? .FROM1 ,NO-DATUM> <RETURN ,NO-DATUM>)
+ (<AND <SET FROM .FROM1> <SET TMP1 <ACS? <SET TO .TO1>>> <SET TMP .TMP1>>
+ <COND (<==? <SET TT <DATTYP .TMP>> ANY-AC>
+ <COND (<TYPE? <DATTYP .FROM> AC> <SET TT <DATTYP .FROM>>)
+ (ELSE <SET TT <GETREG <>>>)>
+ <REPEAT ((L ()))
+ #DECL ((L) <LIST [REST AC]>)
+ <COND (<MEMQ .TT .TO>
+ <SET L (.TT !.L)>
+ <PUT .TT ,ACPROT T>
+ <SET TT <GETREG <>>>)
+ (ELSE
+ <PUT .TMP ,DATTYP .TT>
+ <MAPF <>
+ <FUNCTION (TT)
+ #DECL ((TT) AC)
+ <PUT .TT ,ACPROT <>>>
+ .L>
+ <RETURN>)>>)>
+ <AND <==? <SET T1 <DATVAL .TMP>> ANY-AC>
+ <COND (<TYPE? <DATVAL .FROM> AC>
+ <PUT .TMP ,DATVAL <SET T1 <DATVAL .FROM>>>)
+ (ELSE
+ <COND (<TYPE? .TT AC>
+ <SET TAC .TT>
+ <SET T2 <ACPROT .TAC>>
+ <PUT .TAC ,ACPROT T>)>
+ <PUT .TMP ,DATVAL <SET T1 <GETREG <>>>>
+ <COND (<TYPE? .TT AC>
+ <SET TAC .TT>
+ <PUT .TAC ,ACPROT .T2>)>)>>
+ <COND (<AND <TYPE? <DATTYP .FROM> AC>
+ <TYPE? <DATVAL .FROM> AC>
+ <==? .T1 <DATTYP .FROM>>
+ <OR <TYPE? .TT ATOM> <==? .TT <DATVAL .FROM>>>>
+ <EMIT <INSTRUCTION `EXCH <ACSYM .T1> <ADDRSYM <DATVAL .FROM>>>>
+ <SET LSEXCH <EXCH-ACL .T1 <SET T2 <DATVAL .FROM>> <ACLINK .T1>>>
+ <SET LSEXCH <EXCH-ACL .T2 .T1 <ACLINK .T2> .LSEXCH>>
+ <MAPF <>
+ <FUNCTION (S "AUX" (SNA <SINACS .S>))
+ <COND (<NOT <MEMQ .SNA .LSEXCH>>
+ <SET LSEXCH (.SNA !.LSEXCH)>
+ <EXCH-AC .T1 .T2 <SINACS .S>>)>>
+ <ACRESIDUE <DATVAL .FROM>>>)>
+ <AND <TYPE? .TT ATOM>
+ <TYPE? <DATTYP .FROM> AC>
+ <PUT .TMP ,DATTYP <SET TT <DATTYP .FROM>>>>
+ <AND <TYPE? .TT AC>
+ <SET TAC .TT>
+ <COND (<==? .TAC <DATTYP .FROM>> <FIX-ACLINK .TAC .TO .FROM>)
+ (<NOT <AND <NOT .KEEP> <ACLINK .TAC> <ACMEMQ .TAC .FROM>>>
+ <SGETREG .TAC .TO>)
+ (ELSE <SET NOTYET T>)>>
+ <AND <TYPE? .T1 AC>
+ <SET TAC .T1>
+ <COND (<==? <DATVAL .FROM> .TAC> <FIX-ACLINK .TAC .TO .FROM>)
+ (<NOT <AND <NOT .KEEP>
+ <NOT .NOTYET>
+ <ACLINK .TAC>
+ <ACMEMQ .TAC .FROM>>>
+ <SGETREG .TAC .TO>)
+ (ELSE <SET NOTYET2 T>)>>
+ <COND (<OR .NOTYET .NOTYET2>
+ <RET-TMP-AC .FROM>
+ <COND (.NOTYET
+ <SGETREG .TT .TO>
+ <MOVE:VALUE <DATVAL .FROM> .T1>
+ <MOVE:TYP <DATTYP .FROM> .TT>)
+ (ELSE
+ <SGETREG .T1 .TO>
+ <MOVE:TYP <DATTYP .FROM> .TT>
+ <MOVE:VALUE <DATVAL .FROM> .T1>)>
+ <PUT .FROM ,DATTYP FIX>
+ <PUT .FROM ,DATVAL DONT-CARE>)
+ (ELSE
+ <MOVE:TYP <DATTYP .FROM> .TT>
+ <MOVE:VALUE <DATVAL .FROM> .T1>)>
+ <REPEAT ((L .TO))
+ #DECL ((L) <PRIMTYPE LIST>)
+ <AND <EMPTY? .L> <RETURN .TO>>
+ <OR <==? .TMP .L>
+ <PROG ()
+ <MOVE:TYP <DATTYP .TMP> <DATTYP .L>>
+ <MOVE:VALUE <DATVAL .TMP> <DATVAL .L>>>>
+ <SET L <REST .L 2>>>)
+ (<SET TMP1 <ACS? .FROM>>
+ <SET TMP .TMP1>
+ <REPEAT ((L .TO))
+ #DECL ((L) <PRIMTYPE LIST>)
+ <MOVE:TYP <DATTYP .TMP> <DATTYP .L>>
+ <MOVE:VALUE <DATVAL .TMP> <DATVAL .L>>
+ <AND <EMPTY? <SET L <REST .L 2>>> <RETURN>>>)
+ (ELSE
+ <COND (<NOT <OR <TYPE? <DATTYP .TO> ATOM>
+ <AND <==? <LENGTH .TO> 2>
+ <=? <DATTYP .TO> <DATTYP .FROM>>>>>
+ <MOVE:TYP <DATTYP .FROM> ,ACO>
+ <REPEAT ((L .TO))
+ #DECL ((L) <PRIMTYPE LIST>)
+ <MOVE:TYP ,ACO <DATTYP .L>>
+ <AND <EMPTY? <SET L <REST .L 2>>> <RETURN>>>)>
+ <COND
+ (<NOT <OR <TYPE? <DATVAL .TO> ATOM>
+ <AND <==? <LENGTH .TO> 2> <=? <DATVAL .TO> <DATVAL .FROM>>>>>
+ <COND (<AND <TYPE? <DATVAL .FROM> ADDRESS:PAIR>
+ <OR <==? <SET VAL <CHTYPE <1 <2 <DATVAL .FROM>>> FIX>> -1>
+ <0? .VAL>>>
+ <REPEAT ((L .TO))
+ #DECL ((L) <PRIMTYPE LIST>)
+ <EMIT <INSTRUCTION <COND (<0? .VAL> `SETZM )
+ (ELSE `SETOM )>
+ !<ADDR:VALUE .L>>>
+ <AND <EMPTY? <SET L <REST .L 2>>> <RETURN>>>)
+ (ELSE
+ <MOVE:VALUE <DATVAL .FROM> ,ACO>
+ <REPEAT ((L .TO))
+ #DECL ((L) <PRIMTYPE LIST>)
+ <MOVE:VALUE ,ACO <DATVAL .L>>
+ <AND <EMPTY? <SET L <REST .L 2>>> <RETURN>>>)>)>)>
+ <COND (<TYPE? .TO1 DATUM>
+ <MAPF <>
+ <FUNCTION (X) <COND (<TYPE? .X AC> <PUT .X ,ACPROT <>>)>>
+ .TO>)>
+ <COND (<AND <NOT .KEEP> <NOT <TYPE? .TO1 ATOM>>>
+ <REPEAT ((L .FROM))
+ #DECL ((L) <PRIMTYPE LIST>)
+ <OR <MEMQ <1 .L> .TO> <RET-TMP-AC <1 .L> .FROM>>
+ <AND <EMPTY? <SET L <REST .L>>> <RETURN .TO>>>)
+ (<TYPE? .TO1 ATOM> .FROM1)
+ (ELSE .TO1)>>>
+
+<DEFINE MOVE:TYP (ADDRF ADDRT "AUX" TT TAC)
+ #DECL ((TAC) AC)
+ <COND (<=? .ADDRF .ADDRT>)
+ (<TYPE? .ADDRT AC>
+ <SET TAC .ADDRT>
+ <PUT .TAC ,ACPROT T>
+ <COND (<AND <TYPE? .ADDRF OFFPTR>
+ <MEMQ <SET TT <3 .ADDRF>> <ALLTYPES>>
+ <MEMQ <TYPEPRIM .TT> '![STORAGE UVECTOR!]>>
+ <TOACV <2 .ADDRF>>
+ <GETUVT <DATVAL <2 .ADDRF>> .TAC>)
+ (ELSE
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM .TAC>
+ !<ADDR:TYPE1 .ADDRF>>>)>
+ <PUT .TAC ,ACPROT <>>)
+ (<TYPE? .ADDRF AC>
+ <SET TAC .ADDRF>
+ <PUT .TAC ,ACPROT T>
+ <OR <TYPE? .ADDRT ATOM>
+ <EMIT <INSTRUCTION `MOVEM
+ <ACSYM .TAC>
+ !<ADDR:TYPE1 .ADDRT>>>>
+ <PUT .TAC ,ACPROT <>>)
+ (<NOT <TYPE? .ADDRT ATOM>>
+ <MOVE:TYP .ADDRF ,ACO>
+ <MOVE:TYP ,ACO .ADDRT>)>>
+
+<DEFINE MOVE:VALUE (ADDRF ADDRT "AUX" TAC)
+ #DECL ((TAC) AC)
+ <COND (<=? .ADDRT .ADDRF>)
+ (<TYPE? .ADDRT AC>
+ <SET TAC .ADDRT>
+ <PUT .TAC ,ACPROT T>
+ <IMCHK '(`MOVE `MOVEI `MOVNI `MOVSI )
+ <ACSYM .TAC>
+ .ADDRF>
+ <PUT .TAC ,ACPROT <>>)
+ (<TYPE? .ADDRF AC>
+ <SET TAC .ADDRF>
+ <PUT .TAC ,ACPROT T>
+ <OR <TYPE? .ADDRT ATOM>
+ <EMIT <INSTRUCTION `MOVEM
+ <ACSYM .TAC>
+ !<ADDR:VALUE1 .ADDRT>>>>
+ <PUT .TAC ,ACPROT <>>)
+ (<NOT <TYPE? .ADDRT ATOM>>
+ <MOVE:VALUE .ADDRF ,ACO>
+ <MOVE:VALUE ,ACO .ADDRT>)>>
+
+<DEFINE ACMEMQ (TAC DAT "AUX" (T1 <DATTYP .DAT>) (TT <DATVAL .DAT>))
+ #DECL ((TAC) AC (DAT) DATUM)
+ <OR <==? .T1 .TAC>
+ <==? .TT .TAC>
+ <AND <OR <ISTYPE? .T1> <==? .T1 .TT>>
+ <TYPE? .TT OFFPTR>
+ <TOACV <2 .TT>>
+ <==? <DATVAL <2 .TT>> .TAC>>>>
+
+<DEFINE EXCH-ACL (AC1 AC2 L "OPTIONAL" (LST ()))
+ #DECL ((AC1 AC2) AC (L) <LIST [REST DATUM]>)
+ <MAPF <>
+ <FUNCTION (D)
+ #DECL ((D) DATUM)
+ <COND (<NOT <MEMQ .D .LST>>
+ <EXCH-AC .AC1 .AC2 .D>
+ <SET LST (.D !.LST)>)>>
+ .L>
+ .LST>
+
+<DEFINE EXCH-AC (AC1 AC2 D "AUX" TMP)
+ #DECL ((AC1 AC2) AC (D) DATUM)
+ <COND (<AND <==? .AC1 <DATTYP .D>> <==? .AC2 <DATVAL .D>>>
+ <PUT .D ,DATVAL .AC1>
+ <PUT .D ,DATTYP .AC2>)
+ (<SET TMP <MEMQ .AC1 .D>>
+ <PUT .TMP 1 .AC2>
+ <PUT .AC2 ,ACLINK (.D !<ACLINK .AC2>)>
+ <PUT .AC1
+ ,ACLINK
+ <MAPF ,LIST
+ <FUNCTION (DAT)
+ <COND (<N==? .DAT .D> <MAPRET .DAT>)
+ (<MAPRET>)>>
+ <ACLINK .AC1>>>)
+ (<SET TMP <MEMQ .AC2 .D>>
+ <PUT .TMP 1 .AC1>
+ <PUT .AC1 ,ACLINK (.D !<ACLINK .AC1>)>
+ <PUT .AC2
+ ,ACLINK
+ <MAPF ,LIST
+ <FUNCTION (DAT)
+ <COND (<==? .DAT .D> <MAPRET>)
+ (ELSE <MAPRET .DAT>)>>
+ <ACLINK .AC2>>>)>>
+
+<DEFINE FIX-ACLINK (AC TO FROM "AUX" (L <MEMQ .FROM <ACLINK .AC>>))
+ #DECL ((AC) AC (L) <PRIMTYPE LIST>)
+ <COND (.L <PUT .L 1 .TO>)
+ (ELSE <PUT .AC ,ACLINK (.TO !<ACLINK .AC>)>)>>
+
+<DEFINE ACS? (DAT)
+ #DECL ((DAT) <PRIMTYPE LIST>)
+ <REPEAT ()
+ <AND <EMPTY? .DAT> <RETURN <>>>
+ <COND (<OR <TYPE? <DATVAL .DAT> AC> <==? <DATVAL .DAT> ANY-AC>>
+ <RETURN .DAT>)
+ (<AND <TYPE? <DATVAL .DAT> ATOM>
+ <OR <TYPE? <DATTYP .DAT> AC>
+ <==? <DATTYP .DAT> ANY-AC>>>
+ <RETURN .DAT>)>
+ <SET DAT <REST .DAT 2>>>>
+
+<DEFINE IMCHK (INS AC ISRC "OPTIONAL" (COM <>)
+ "AUX" SRC VAL (LN <LENGTH .INS>))
+ #DECL ((AC) <PRIMTYPE WORD> (VAL LN) FIX (INS) <LIST ANY ANY>
+ (SRC) <<PRIMTYPE LIST> ANY <VECTOR <PRIMTYPE WORD>>>)
+ <COND (<AND <TYPE? .ISRC ADDRESS:PAIR>
+ <NOT <EMPTY? <REST .ISRC>>>
+ <TYPE? <2 .ISRC> VECTOR>
+ <SET SRC .ISRC>>
+ <SET VAL <CHTYPE <1 <2 .SRC>> FIX>>
+ <COND (<AND <G=? .VAL 0>
+ <L? .VAL 262144>
+ <TYPE? <2 .INS> OPCODE!-OP>>
+ <EMIT <INSTRUCTION <2 .INS> .AC .VAL>>)
+ (<AND <G=? .LN 3>
+ <N==? <CHTYPE .VAL WORD> #WORD *400000000000*>
+ <L? <ABS .VAL> 262144>
+ <TYPE? <3 .INS> OPCODE!-OP>>
+ ;"Was negative immediate ins supplied?"
+ <EMIT <INSTRUCTION <3 .INS> .AC <- <ABS .VAL> <COND (.COM 1)
+ (0)>>>>)
+ (<AND <==? .LN 4>
+ <0? <CHTYPE <GETBITS .VAL <BITS 18>> FIX>>>
+ <EMIT <INSTRUCTION <4 .INS>
+ .AC
+ <CHTYPE <GETBITS .VAL <BITS 18 18>> FIX>>>)
+ (ELSE
+ <EMIT <INSTRUCTION <1 .INS> .AC !<ADDR:VALUE1 .SRC>>>)>)
+ (ELSE
+ <EMIT <INSTRUCTION <1 .INS> .AC !<ADDR:VALUE1 .ISRC>>>)>>
+
+<DEFINE GROUP:INITIAL (NAME)
+ <EMIT <INSTRUCTION TITLE .NAME>>
+ <EMIT <INSTRUCTION DECLARE!-OP '("VALUE" ATOM)>>
+ <EMIT <INSTRUCTION `MOVE `A* <FORM MQUOTE!-OP .NAME> -1>>
+ <EMIT <INSTRUCTION `MOVE `B* <FORM MQUOTE!-OP .NAME>>>
+ <EMIT <INSTRUCTION `JRST |FINIS >>>
+
+<DEFINE FUNCTION:INITIAL (NAME)
+ <AND .NAME <EMIT <INSTRUCTION TITLE .NAME <>>>>
+ <EMIT <SET RDCL <INSTRUCTION DECLARE!-OP 0>>> ;"Initial declarations.">
+
+<DEFINE SUB:INITIAL (NAME "AUX" DC)
+ #DECL ((DC) <FORM ATOM>)
+ <EMIT <SET DC <INSTRUCTION SUB-ENTRY!-OP .NAME 0>>>
+ <SET RDCL <REST .DC>>>
+
+<DEFINE INT:INITIAL (NAME) <SET RDCL <CHTYPE (0 0) IRSUBR>>>
+
+<DEFINE SUB:INT:INITIAL (NAME "AUX" DC)
+ #DECL ((DC) <FORM ATOM>)
+ <EMIT <SET DC <INSTRUCTION SUB-ENTRY!-OP .NAME 0>>>
+ <SET RDCL <REST .DC>>>
+
+<DEFINE FCN:INT:INITIAL (NAME)
+ <EMIT <INSTRUCTION TITLE .NAME <>>>
+ <EMIT <SET RDCL <INSTRUCTION DECLARE!-OP 0>>>>
+
+<DEFINE INT:LOSER:INITIAL (NAME FCN
+ "AUX" (ACSTR <1 <ACS .FCN>>) (TR <TOTARGS .FCN>)
+ (RQ <REQARGS .FCN>) (INAME <NODE-NAME .FCN>) TG
+ DC)
+ #DECL ((FCN) NODE (TR RQ) FIX (INAME) UVECTOR)
+ <COND (<=? .ACSTR '(STACK)>
+ <COND (<EMPTY? <REST .INAME>>
+ <LABEL:TAG <1 .INAME>>
+ <EMIT '<`SUBM `M* `(P) >>
+ <EMIT <INSTRUCTION MCALL!-OP .TR .NAME>>)
+ (ELSE
+ <SET TG <MAKE:TAG>>
+ <MAPR <>
+ <FUNCTION (NN "AUX" (LAST <EMPTY? <REST .NN>>))
+ <LABEL:TAG <1 .NN>>
+ <EMIT <INSTRUCTION `MOVEI `A* .TR>>
+ <COND (.LAST <LABEL:TAG .TG>)
+ (ELSE <BRANCH:TAG .TG>)>
+ <SET TR <- .TR 1>>>
+ .INAME>
+ <EMIT '<`SUBM `M* `(P) >>
+ <EMIT <INSTRUCTION ACALL!-OP `A* .NAME>>)>)
+ (ELSE
+ <LABEL:TAG <1 .INAME>>
+ <EMIT '<`SUBM `M* `(P) >>
+ <MAPF <>
+ <FUNCTION (L)
+ #DECL ((L) LIST)
+ <RET-TMP-AC <STACK:ARGUMENT <DATUM <1 .L> <2 .L>>>>>
+ .ACSTR>
+ <EMIT <INSTRUCTION MCALL!-OP .TR .NAME>>)>
+ <EMIT '<`JRST |MPOPJ >>
+ <EMIT <SET DC <INSTRUCTION SUB-ENTRY!-OP .NAME 0>>>
+ <SET RDCL <REST .DC>>>
+
+<DEFINE FCNSUB:FINAL (NOD) <EMIT <INSTRUCTION `JRST |FINIS >>>
+
+<DEFINE FS:INT:FINAL (ACS)
+ <COND (<=? .ACS '(STACK)> <EMIT '<`JRST |MPOPJ >>)
+ (ELSE <EMIT '<`JRST |FMPOPJ >>)>>
+
+<DEFINE INT:FINAL (NOD)
+ #DECL ((RDCL) <LIST ANY> (NOD) NODE)
+ <EMIT <INSTRUCTION `JRST |MPOPJ >>
+ <PUT .RDCL 1 .NOD>
+ .RDCL>
+
+
+<DEFINE ASSEM? (SRC-FLG "OPTIONAL" (BIN-FLG .BIN-FLG) "AUX" X (T <TIME>))
+ #DECL ((CODE:TOP) <LIST ANY>)
+ <COND (<AND <ASSIGNED? CSOURCE> .CSOURCE>
+ <PRT <REST .CODE:TOP>>)>
+ <PUTREST .CODE:TOP <SET X <CDUP <REST .CODE:TOP>>>>
+ <EXP-MAC .CODE:TOP>
+ <COND (.PEEP <PEEP .X !.X> <TERPRI>)>
+ <COND (.BIN-FLG
+ <ASSEMBLE1!-CODING!-PACKAGE .X <1 .OBLIST> <> .SRC-FLG>)
+ (ELSE .X)>>
+
+
+<DEFINE BLOCK:INITIAL () T>
+
+<DEFINE BLOCK:FINAL () T>
+
+<DEFINE PROG:END () <EMIT <INSTRUCTION `JRST |FINIS >>>
+
+<DEFINE UNBIND:FUNNY (N "TUPLE" Y)
+ <AND .SPECD
+ <EMIT <INSTRUCTION `MOVEI
+ `E*
+ .N
+ !.Y
+ <COND (.AC-HACK 1) (ELSE 0)>
+ <COND (.AC-HACK '`(FRM) ) (ELSE '`(TB) )>>>
+ <EMIT <INSTRUCTION `PUSHJ `P* |SSPEC1 >>>>
+
+<DEFINE UNBIND:LOCS (FROM TO "OPTIONAL" (FLG <>))
+ <COND (<NOT .FLG>
+ <AND <POP:LOCS .FROM .TO>
+ .SPECD
+ <EMIT <INSTRUCTION `PUSHJ `P* |SSPECS >>>)
+ (.SPECD
+ <EMIT '<`MOVE `TP* `FRM>>
+ <EMIT '<`PUSHJ `P* |SSPECS>>)>>
+
+<DEFINE POP:LOCS (FROM TO "AUX" (OTHERS ()) (AMNT 0) (PST 0) REG (PSTN 0) TEM)
+ #DECL ((FROM TO) LIST (AMNT PST PSTN) FIX (REG) AC)
+ <REPEAT ((FROM .FROM)) ;"First count known locals and # of slots."
+ #DECL ((FROM) LIST)
+ <AND <==? .TO .FROM> <RETURN>>
+ <COND (<TYPE? <SET TEM <1 .FROM>> FIX> <SET AMNT <+ .AMNT .TEM>>)
+ (<==? .TEM PSLOT> <SET PSTN <+ .PSTN 1>>)
+ (<==? .TEM PSTACK> <SET PST <+ .PST 1>>)
+ (ELSE <SET OTHERS (.TEM !.OTHERS)>)>
+ <SET FROM <REST .FROM>>>
+ <COND
+ (<0? .PST>
+ <OR <AND <0? .AMNT> <EMPTY? .OTHERS>>
+ <EMIT <INSTRUCTION DEALLOCATE (.AMNT !.OTHERS)>>>
+ <OR <0? .PSTN>
+ <EMIT <INSTRUCTION `SUB `P* [<FORM .PSTN (.PSTN)>]>>>)
+ (ELSE
+ <SET REG <GETREG <>>>
+ <COND
+ (<AND <1? .PST> <0? .PSTN>>
+ <EMIT <INSTRUCTION `POP `P* <ADDRSYM .REG>>>)
+ (ELSE
+ <REPEAT ((OFFS 0) (FST T))
+ #DECL ((OFFS) FIX)
+ <COND (<==? <SET TEM <1 .FROM>> PSLOT> <SET OFFS <+ .OFFS 1>>)
+ (<==? .TEM PSTACK>
+ <COND (.FST
+ <EMIT <INSTRUCTION `MOVEI
+ <ACSYM .REG>
+ `@
+ <- .OFFS>
+ '`(P) >>
+ <SET FST <>>)
+ (ELSE
+ <EMIT <INSTRUCTION `ADDI
+ <ACSYM .REG>
+ `@
+ <- .OFFS>
+ '`(P) >>)>)>
+ <AND <==? .TO <SET FROM <REST .FROM>>> <RETURN>>>
+ <EMIT <INSTRUCTION `SUB
+ `P*
+ [<FORM <SET PST <+ .PSTN .PST>> (.PST)>]>>)>
+ <EMIT <INSTRUCTION `ADDI
+ <ACSYM .REG>
+ !.OTHERS
+ .AMNT
+ (<ADDRSYM .REG>)>>
+ <EMIT <INSTRUCTION `HRLI <ACSYM .REG> (<ADDRSYM .REG>)>>
+ <EMIT <INSTRUCTION `SUB `TP* <ADDRSYM .REG>>>)>
+ <NOT <AND <0? .AMNT> <0? .PST>>>>
+
+;"This is machine dependant code associated with setting up argument TUPLEs."
+
+<DEFINE COPY:ARGPNTR ()
+ <EMIT <INSTRUCTION `MOVE `C* `AB >>
+ <EMIT <INSTRUCTION `MOVEI `D* 0>> ;"D will count args pushed.">
+
+<DEFINE BUMP:ARGPNTR ("OPTIONAL" (N 1))
+ #DECL ((N) FIX)
+ <SET N <* .N 2>>
+ <EMIT <INSTRUCTION `ADD `C* [<FORM .N (.N)>]>>
+ ;"Bump an AOBJN pointer">
+
+<DEFINE BUMP:CNTR ("OPTIONAL" (N 1))
+ #DECL ((N) FIX)
+ <SET N <* .N 2>>
+ <EMIT <INSTRUCTION `ADDI `D* .N>>>
+
+<DEFINE TEST:ARGPNTR (TAG) <EMIT <INSTRUCTION `JUMPGE `C* .TAG>>>
+
+<DEFINE REFERENCE:ARGPNTR ()
+ #DECL ((VALUE) <DATUM ADDRESS:C ADDRESS:C>)
+ <DATUM #ADDRESS:C (`(C) ) #ADDRESS:C (`(C) )>>
+
+<DEFINE TUPLE:FINAL ("AUX" (VAL <FUNCTION:VALUE T>))
+ #DECL ((VALUE) <DATUM AC AC>)
+ <EMIT <INSTRUCTION `PUSHJ `P* |MAKTUP >>
+ .VAL>
+
+<DEFINE REFERENCE:STACK:ADR (N "OPTIONAL" (AC-HACK .AC-HACK))
+ <COND (.AC-HACK <ADDRESS:C 1 `(FRM) !.N>)
+ (ELES <ADDRESS:C `(TB) !.N>)>>
+
+<DEFINE REFERENCE:STACK (N "AUX" (TT <REFERENCE:STACK:ADR .N>))
+ #DECL ((VALUE) <DATUM ADDRESS:C ADDRESS:C>)
+ <DATUM .TT .TT>>
+
+;"Machine dependant stuff for activations and environemnts"
+
+<DEFINE SPEC:REFERENCE:STACK (AC-HACK ADDRESS
+ "AUX" (TT
+ <REFERENCE:STACK:ADR .ADDRESS .AC-HACK>))
+ <DATUM .TT .TT>>
+
+<DEFINE MAKE:ENV ("AUX" (VAL <FUNCTION:VALUE T>))
+ <EMIT <INSTRUCTION `PUSHJ `P* |MAKENV >>
+ .VAL>
+
+<DEFINE ACT:INITIAL ()
+ <SET START:TAG <MAKE:TAG>>
+ <COND (.GLUE
+ <EMIT <INSTRUCTION `MOVEI `O* .START:TAG>>
+ <EMIT '<`SUB `O* `M >>
+ <EMIT '<`HRLI `O* TTP!-OP>>
+ <EMIT '<`PUSH `TP* `O* >>)
+ (ELSE
+ <EMIT <INSTRUCTION `PUSH `TP* [<FORM (TTP!-OP) .START:TAG>]>>)>
+ <EMIT <INSTRUCTION `PUSH `TP* [0]>>>
+
+<DEFINE ACT:FINAL ()
+ <EMIT <INSTRUCTION `MOVEM `TP* `(TB) 1>>
+ <LABEL:OFF .START:TAG>>
+
+<DEFINE MAKE:ACT ("AUX" (VAL <FUNCTION:VALUE T>))
+ <EMIT <INSTRUCTION `PUSHJ `P* |MAKACT >>
+ .VAL>
+
+<DEFINE BUILD:FRAME (PC)
+ <EMIT <INSTRUCTION `MOVEI `A* .PC>>
+ <AND .GLUE <EMIT '<`SUB `A* `M >>>
+ <EMIT <INSTRUCTION `PUSHJ `P* |BFRAME >>>
+
+;"Machine dependent segment hacking code."
+
+<DEFINE SEGMENT:LIST (N FLG)
+ <OR .FLG <EMIT <INSTRUCTION `PUSH `P* [.N]>>>
+ <EMIT <INSTRUCTION `MOVEI `O* |SEGLST >>
+ <EMIT <INSTRUCTION `PUSHJ `P* |RCALL >>
+ <EMIT <INSTRUCTION `SUB `P* [<FORM 1 (1)>]>>>
+
+<DEFINE SEGMENT:STACK (TAG FLG)
+ <OR .FLG <EMIT <INSTRUCTION `PUSH `P* [.TAG]>>>
+ <EMIT <INSTRUCTION `MOVEI `O* |SEGMNT >>
+ <EMIT <INSTRUCTION `PUSHJ `P* |RCALL >>>
+
+<DEFINE SEGMENT:FINAL (SUBR)
+ <EMIT <INSTRUCTION `POP `P* `A >>
+ <EMIT <INSTRUCTION ACALL!-OP `A* .SUBR>>>
+
+<DEFINE PCOUNTER (N) <EMIT <INSTRUCTION `PUSH `P* [.N]>>>
+
+<DEFINE COUNTP () <EMIT <INSTRUCTION `AOS `(P) >>>
+
+<DEFINE PUSH:BIND (ATM VAL DC)
+ <STACK:ADR <ADDRESS:PAIR ,BIND-BEGIN !<REFERENCE:ADR .ATM> 1>>
+ <STACK:ARGUMENT .VAL>
+ <STACK:ADR <REFERENCE:ADR .DC>>>
+
+<DEFINE PUSH:PAIR (VAL) <STACK:ARGUMENT .VAL>>
+
+<DEFINE PUSH:ATB (ATM)
+ <STACK:ADR <ADDRESS:PAIR ,BIND-BEGIN !<REFERENCE:ADR .ATM> 1>>>
+
+<DEFINE STORE:BIND (SYM VAL)
+ <RET-TMP-AC <MOVE:ARG .VAL <FUNCTION:VALUE>>>
+ <REGSTO T>
+ <EMIT <INSTRUCTION
+ `MOVEI
+ `E*
+ !<REFERENCE:STACK:ADR (<- <ADDR-SYM .SYM> 2> !.NTSLOTS)>>>
+ <EMIT <INSTRUCTION `MOVE
+ `C*
+ !<REFERENCE:ADR <NAME-SYM .SYM>>
+ 1>>
+ <EMIT <INSTRUCTION `MOVE
+ `D*
+ !<REFERENCE:ADR <DECL-SYM .SYM>>
+ 1>>
+ <EMIT <INSTRUCTION `PUSHJ `P* |IBIND >>>
+
+<DEFINE STORE:PAIR (SYM VAL)
+ <MOVE:ARG .VAL
+ <REFERENCE:STACK (<ADDR-SYM .SYM> !.NTSLOTS)>>>
+
+<DEFINE BIND:END () <EMIT <INSTRUCTION `PUSHJ `P* |SPECBN >>>
+
+<DEFINE REFERENCE:UNBOUND ()
+ #DECL ((VALUE) <DATUM ATOM ADDRESS:PAIR>)
+ <DATUM UNBOUND
+ <ADDRESS:PAIR '<TYPE-WORD!-OP UNBOUND> '[-1]>>>
+
+<DEFINE REFERENCE:ARG (NUMBER "AUX" TEM)
+ #DECL ((VALUE) <DATUM ADDRESS:C ADDRESS:C> (NUMBER) FIX)
+ <SET TEM <ADDRESS:C `(AB) <* 2 <- .NUMBER 1>>>>
+ <DATUM .TEM .TEM>>
+
+<DEFINE TEST:ARG (NUMBER TAG)
+ <EMIT <INSTRUCTION `CAMLE `AB* [<FORM (<+ 1 <* -2 .NUMBER>>)>]>>
+ <EMIT <INSTRUCTION `JRST .TAG>>>
+
+<DEFINE SALLOC:SLOTS ("TUPLE" TSLOTS)
+ <EMIT <INSTRUCTION ALLOCATE:SLOTS !.TSLOTS>>>
+
+<DEFINE ALLOC:SLOTS ("TUPLE" TSLOTS "AUX" (TOTARGS <+ <* <TOTARGS .FCN> 2> 2>))
+ <COND (<=? .AC-HACK '(FUNNY-STACK)>
+ <EMIT <INSTRUCTION `PUSH `TP* [<FORM (TTP!-MUDDLE) .TOTARGS>]>>
+ <EMIT <INSTRUCTION `PUSH `TP* `FRM >>
+ <EMIT <INSTRUCTION `MOVE `FRM* `TP >>)>
+ <EMIT <INSTRUCTION ALLOCATE:SLOTS !.TSLOTS>>>
+
+<DEFINE FAST:VAL () <EMIT <INSTRUCTION `PUSHJ `P* |CILVAL >>>
+
+<DEFINE FAST:SET () <EMIT <INSTRUCTION `PUSHJ `P* |CISET >>>
+
+<DEFINE FAST:GVAL () <EMIT <INSTRUCTION `PUSHJ `P* |CIGVAL >>>
+
+<DEFINE FAST:SETG () <EMIT <INSTRUCTION `PUSHJ `P* |CSETG >>>
+
+;"Special code for READ EOF hacks."
+
+<DEFINE TIME:STACK ()
+ <EMIT <INSTRUCTION `HLRZ `O* `TB >>
+ <EMIT <INSTRUCTION `PUSH `P* `O* >>
+ <EMIT <INSTRUCTION `PUSH `TP* '<TYPE-WORD!-OP TIME>>>
+ <EMIT <INSTRUCTION `PUSH `TP* `O* >>>
+
+<DEFINE TIME:CHECK ("AUX" BR)
+ <EMIT <INSTRUCTION GETYP!-OP `O* `A >>
+ <EMIT <INSTRUCTION `POP `P* `C >>
+ <EMIT <INSTRUCTION `CAIN `O* '<TYPE-CODE!-OP TIME>>>
+ <EMIT <INSTRUCTION `CAIE `B* '`(C) >>
+ <EMIT <INSTRUCTION `JRST <SET BR <MAKE:TAG>>>>
+ .BR>
+
+<ENDBLOCK>
+<ENDPACKAGE>
--- /dev/null
+
+<SETG OSETG ,SETG>
+
+<USE "DATIME">
+
+<USE "NOW">
+
+<COND (<L? ,MUDDLE 100>
+ <SETG COMPILER-DIR "NCOMPI">)
+ (<SETG COMPILER-DIR "MDL.COMP">)>
+
+<FLOAD "GETORD" "FBIN" "DSK" ,COMPILER-DIR>
+
+<COND (<L? ,MUDDLE 100>
+ <FLOAD "NCOMPI;SNMSET FBIN">)>
+
+<SETG WDCNTLC ![1623294726!]>
+
+<SETG WDSPACE ![17315143744!]>
+
+
+<SETG GC-COUNT 0>
+
+<DEFINE FCOMP (CH "TUPLE" TUP "EXTRA" (ACC <17 .CH>) VAL)
+;"Called by PLANs & PCOMPs to do File Compile.
+ Tastefully Closes & Resets Channel during Compilation.
+ Calling sequence is <FCOMP %.INCHAN \"IN\" \"OUT\">"
+ #DECL ((CH) CHANNEL (TUP) TUPLE (ACC) FIX)
+ <CLOSE .CH> ;"Flush PLAN Channel"
+ <COND (<NOT <SET VAL <FILE-COMPILE !.TUP>>> ;"Do It"
+ <ERROR .VAL>)>
+ <AND <RESET .CH> <ACCESS .CH .ACC>>
+ ;"Restore PLAN Channel to Former Glory"
+ <MODES-INIT> ;"Reset the Various Compiler Flags"
+ .VAL>
+
+<DEFINE FILE-COMPILE FCEX (INFILE
+ "OPTIONAL" OUTFILE
+ "AUX" (INCH <OPEN "READ" .INFILE>) OUTCH TEMPCH
+ (STARCPU <FIX <+ <TIME> 0.5>>) (GFLG T)
+ (PREV ()) (STARR <RTIME:SEC>) R (TW? <G? ,MUDDLE 100>)
+ (SRC-CHAN #FALSE ()) (IC <>) ATOM-LIST OC SOURCE-STR
+ FILE-DATA GC-HANDLER OREDEFINE REDONE LOSS ATL
+ (GCTIME 0.0000000) (OUTCHAN .OUTCHAN) VERS)
+ #DECL ((FCEX) <SPECIAL ACTIVATION> (SOURCE-STR INFILE OUTFILE VERS) STRING
+ (TW?) <OR ATOM FALSE>
+ (OUTCHAN) <SPECIAL CHANNEL> (INCH OC IC) <OR FALSE CHANNEL>
+ (TEMPCH SRC-CHAN) <SPECIAL <OR CHANNEL FALSE>> (PREV) LIST
+ (OUTCH) <OR FALSE CHANNEL> (STARCPU STARR ATNUM) <SPECIAL FIX>
+ (ATOM-LIST ATL) <SPECIAL <LIST [REST <OR LIST ATOM>]>>
+ (FILE-DATA) <LIST <LIST [REST ATOM]> ATOM> (REDONE) <LIST [REST
+ LIST]>
+ (GCTIME) <SPECIAL FLOAT>)
+ <COND (<NOT .INCH> <RETURN #FALSE ("INPUT FILE NOT FOUND") .FCEX>)>
+ <PRINSPEC "Input from " .INCH>
+ <COND (.TW?
+ <SET VERS <REST <MEMQ !\. <8 .INCH>>>>
+ <SET VERS
+ <SUBSTRUC .VERS 0 <- <LENGTH .VERS> <LENGTH <MEMQ !\; <8 .INCH>>>>>>)>
+ <CLOSE .INCH>
+ <SET OUTCH
+ <COND (<ASSIGNED? OUTFILE> <CHANNEL "PRINT" .OUTFILE>)
+ (ELSE
+ <CHANNEL "PRINT"
+ <SET OUTFILE
+ <COND (.TW?
+ <STRING !\< <10 .INCH> !\> <7 .INCH>
+ ".NBIN." .VERS>)
+ (<STRING <10 .INCH> !\; <7 .INCH> " NBIN">)>>>)>>
+ <PRINSPEC "Output to " .OUTCH>
+ <SET SOURCE-STR <COND (.TW? <STRING "SOURCE." .VERS>)
+ ("SOURCE")>>
+ <AND <==? .SOURCE T>
+ <SET SOURCE <OPEN "PRINT" <3 .INCH>
+ .SOURCE-STR
+ "DSK" <COND (.TW? <SNAME>)(ELSE "HUDINI")>>>>
+ <SET SRC-CHAN
+ <DO-AND-CHECK "Source listing generated "
+ .SOURCE-STR
+ SOURCE
+ .INCH
+ .OUTCH
+ #FALSE ()>>
+ <COND (<AND <ASSIGNED? PRECOMPILED> <TYPE? .PRECOMPILED STRING>>
+ <COND (<SET IC <OPEN "READ" .PRECOMPILED>>
+ <PRINSPEC "Will load precompilation from " .IC>
+ <CLOSE .IC>)>)>
+ <COND (<NOT .CAREFUL>
+ <PRINCTHEM "Bounds checking off." ,CRET>)>
+ <COND (.SPECIAL
+ <PRINCTHEM "Default declaration is SPECIAL." ,CRET>)>
+ <COND (<NOT <EMPTY? .REDO>> <PRINC "Recompiling: "> <PRINT .REDO> <TERPRI>)>
+ <COND (.GROUP-MODE
+ <PRINC "Making a GROUP named ">
+ <PRIN1 .GROUP-MODE>
+ <TERPRI>)>
+ <COND (<NOT <ASSIGNED? TEMPNAME>>
+ <SET TEMPNAME <STRING "_" <7 .INCH> <COND (.TW? ".TEMP")
+ (ELSE " >")>>>)>
+ <PRINCTHEM "Temporary output going to: " .TEMPNAME ,CRET>
+ <COND (<SET OC
+ <DO-AND-CHECK <COND (.TW? "Writing record ")
+ ("Running disowned, with record ")>
+ "RECORD"
+ DISOWN
+ .INCH
+ .OUTCH
+ .SRC-CHAN>>
+ <AND .ERROR-LOGOUT <ON "ERROR" ,ERROR-HANDLER 100>>
+ <PRINCTHEM "Toodle-oo." ,CRET>
+ <COND (<AND <NOT .TW?> <NOT <DEMON?>>> <VALRET ":PROCED
+">)>
+ <SETG COMPCHAN <SET OUTCHAN .OC>>
+ <PRINSPEC "Compilation record for: " .INCH>
+ <PRINSPEC "Output file: " .OUTCH>
+ <COND (<NOT .TW?> <PRINCTHEM ,CRET "It is now " <NOW> ,CRET ,CRET>)>)>
+ <SETG GC-COUNT 0>
+ <SET GC-HANDLER <ON "GC" ,COUNT-GCS 10>>
+ <SET KEEP-FIXUPS T>
+ <SET FILE-DATA <FIND-DEFINE-LOAD .INFILE>>
+ <PRINCTHEM "File loaded." ,CRET>
+ <COND (<SET TEMPCH <OPEN "PRINTB" .TEMPNAME>>)
+ (ELSE <ERROR CANT-OPEN-TEMPORARY-FILE!-ERRORS FILE-COMPILE>)>
+ <COND
+ (.IC
+ <COND (<ASSIGNED? REDEFINE> <SET OREDEFINE .REDEFINE>)>
+ <SET REDEFINE T>
+ <RESET .IC>
+ <SET REDONE
+ <MAPR ,LIST
+ <FUNCTION (L "AUX" (ATM <1 .L>))
+ #DECL ((ATM) ATOM (L) <LIST ATOM>)
+ <COND (.PACKAGE-MODE
+ <SET ATM <PACK-FIX .PACKAGE-MODE .ATM>>)>
+ <PUT .L 1 .ATM>
+ <COND (<GASSIGNED? .ATM> (.ATM ,.ATM)) (ELSE <MAPRET>)>>
+ .REDO>>
+ <REPEAT (F V)
+ <PRINT <SET F <READ .IC '<RETURN>>> .TEMPCH>
+ <COND (<AND <TYPE? .F FORM>
+ <NOT <EMPTY? .F>>
+ <OR <MEMQ <1 .F>
+ '![PACKAGE ENDPACKAGE ENTRY USE USE-DEFER
+ USE-TOTAL BLOCK ENDBLOCK!]>
+ <AND <==? <1 .F> SETG>
+ <==? <LENGTH .F> 3>
+ <OR <TYPE? <3 .F> RSUBR RSUBR-ENTRY>
+ <AND <TYPE? <SET V <3 .F>> FORM>
+ <G=? <LENGTH .V> 2>
+ <OR <==? <1 .V> RSUBR>
+ <==? <1 .V> RSUBR-ENTRY>
+ <AND <==? <1 .V> QUOTE>
+ <TYPE? <2 .V>
+ RSUBR
+ RSUBR-ENTRY>>>>>>
+ <AND <==? <1 .F> AND>
+ <==? <LENGTH .F> 4>
+ <=? <2 .F> '<ASSIGNED? GLUE>>
+ <=? <3 .F> '.GLUE>>>>
+ <SET V <EVAL .F>>
+ <COND (<AND .MAX-SPACE
+ <TYPE? .V RSUBR RSUBR-ENTRY>
+ <==? <LENGTH .F> 3>
+ <TYPE? <2 .F> ATOM>
+ <==? <2 .F> <2 .V>>>
+ <PUT .V GLUE>
+ <PUT .V RSUBR>
+ <SETG <2 .F> <RSUBR [#CODE ![!] <2 .V> <3 .V>]>>)>)>>
+ <CLOSE .IC>
+ <BUFOUT .TEMPCH>
+ <MAPF <>
+ <FUNCTION (L) #DECL ((L) <LIST ATOM ANY>) <SETG <1 .L> <2 .L>>>
+ .REDONE>
+ <SET REDONE ()>
+ <PRINCTHEM "Precompilation loaded." ,CRET>
+ <COND (<ASSIGNED? OREDEFINE> <SET REDEFINE .OREDEFINE>)
+ (ELSE <UNASSIGN REDEFINE>)>)
+ (<NOT <EMPTY? .IC>>
+ <PRINCTHEM ,CRET "Precompilation file not found." ,CRET>)>
+ <PRINTB ,WDCNTLC .TEMPCH>
+ <CLOSE .TEMPCH>
+ <PUT .TEMPCH 2 "PRINTO">
+ <SET ATOM-LIST
+ <MAPF ,LIST
+ <FUNCTION (ATM)
+ <COND (<OR <TYPE? ,.ATM FUNCTION>
+ <AND <TYPE? ,.ATM MACRO>
+ <NOT <EMPTY? ,.ATM>>
+ <TYPE? <1 ,.ATM> FUNCTION>>>
+ .ATM)
+ (ELSE
+ <COND (<AND .MAX-SPACE
+ <TYPE? ,.ATM RSUBR RSUBR-ENTRY>>
+ <SETG .ATM
+ <RSUBR [#CODE ![!] .ATM <3 ,.ATM>]>>)>
+ <MAPRET>)>>
+ <1 .FILE-DATA>>>
+ <FLUSH-COMMENTS>
+ <COND (<EMPTY? .ATOM-LIST>
+ <PRINCTHEM "No DEFINEd functions in this file." ,CRET>
+ <SET ATOM-LIST ()>)
+ (ELSE <SET ATOM-LIST <GETORDER !<SET ATL .ATOM-LIST>>>)>
+ <PRINCTHEM "Functions ordered." ,CRET>
+ <MAPF <>
+ <FUNCTION (A)
+ <COND (<NOT <GASSIGNED? .A>>
+ <PRIN1 .A>
+ <PRINCTHEM " not REdone." ,CRET>)>>
+ .REDO>
+ <COND
+ (.GROUP-MODE
+ <AND .PACKAGE-MODE <SET GROUP-MODE <PACK-FIX .PACKAGE-MODE .GROUP-MODE>>>
+ <COND (<AND .PACKAGE-MODE <NOT .SURVIVORS>>
+ <PROG ((OBLIST .OBLIST))
+ #DECL ((OBLIST) <SPECIAL ANY>)
+ <PACKAGE .PACKAGE-MODE>
+ <SET SURVIVORS
+ <MAPF ,LIST <FUNCTION (L) <MAPRET !.L>> <2 .OBLIST>>>
+ <ENDPACKAGE>>)
+ (<AND .PACKAGE-MODE <TYPE? .SURVIVORS LIST>>
+ <SET SURVIVORS
+ <MAPF ,LIST
+ <FUNCTION (A) <PACK-FIX .PACKAGE-MODE .A>>
+ .SURVIVORS>>)>
+ <SET ATOM-LIST <LINEARIZE .ATOM-LIST>>
+ <SET ATL <LINEARIZE .ATL>>
+ <REPEAT ((AL (START)) (AL1 <SET ATOM-LIST (START !.ATOM-LIST)>)
+ (AL2 <REST .AL1>) (AL4 .AL) AL5)
+ #DECL ((AL AL1 AL2 AL4 AL5) <LIST [REST ATOM]>)
+ <COND (<EMPTY? .AL2>
+ <SET ATL <REST .AL4>>
+ <SET ATOM-LIST <REST .ATOM-LIST>>
+ <RETURN>)
+ (<MEMQ <1 .AL2> .ATL> <SET AL2 <REST <SET AL1 .AL2>>>)
+ (ELSE
+ <SET AL <REST <PUTREST .AL .AL2>>>
+ <SET AL5 <REST .AL2>>
+ <PUTREST .AL2 ()>
+ <PUTREST .AL1 <SET AL2 .AL5>>)>>
+ <MAPF <>
+ <FUNCTION (AL)
+ <APPLY ,COMPILE
+ .AL
+ .SRC-CHAN
+ T
+ .CAREFUL
+ .SPECIAL
+ .REASONABLE
+ .GLUE
+ .HAIRY-ANALYSIS
+ .DEBUG-COMPILE>>
+ .ATL>
+ <COND (<SET LOSS
+ <APPLY ,COMPILE-GROUP
+ .ATOM-LIST
+ <COND (<TYPE? .SURVIVORS LIST> .SURVIVORS)
+ (ELSE .ATOM-LIST)>
+ .GROUP-MODE
+ .SRC-CHAN
+ T
+ .CAREFUL
+ .SPECIAL
+ .REASONABLE
+ .GLUE
+ .TEMPCH
+ .HAIRY-ANALYSIS
+ .DEBUG-COMPILE>>
+ <PRINC .LOSS>
+ <KILL-COMP>
+ <CLOSE .TEMPCH>
+ <PUT .TEMPCH 2 "READ">
+ <OR <RESET .TEMPCH> <ERROR WHERE-HAS-TEMP-FILE-GONE!-ERRORS>>
+ <BEGIN-HACK!-ICC!-CC!-PACKAGE "BTB">
+ <BEGIN-MHACK!-ICC!-CC!-PACKAGE>
+ <APPLY ,ASSEMBLE!-CODING!-PACKAGE .TEMPCH .OBLIST <> .SRC-CHAN>
+ <GUNASSIGN READ-TABLE>
+ <UNASSIGN READ-TABLE>)
+ (<RETURN .LOSS .FCEX>)>
+ <COND
+ (<GASSIGNED? .GROUP-MODE>
+ <MAPR <>
+ <FUNCTION (OBP "AUX" (OBJ <1 .OBP>) IT)
+ #DECL ((OBP) <LIST ANY>)
+ <COND (<AND <TYPE? .OBJ FORM>
+ <G=? <LENGTH .OBJ> 2>
+ <OR <==? <1 .OBJ> DEFINE> <==? <1 .OBJ> DEFMAC>>>
+ <AND .GFLG
+ <PUT .OBP 1 <FORM SETG .GROUP-MODE ,.GROUP-MODE>>
+ <PUTREST .OBP (.OBJ !<REST .OBP>)>>
+ <OR <TYPE? .SURVIVORS LIST> <MAPLEAVE>>
+ <SET OBJ <1 .OBP>>
+ <OR .GFLG
+ <MEMQ <SET IT <GET <2 .OBJ> VALUE '<2 .OBJ>>>
+ .SURVIVORS>
+ <AND <GASSIGNED? .IT> <TYPE? ,.IT RSUBR RSUBR-ENTRY>>
+ <COND (<EMPTY? .PREV>
+ <SET <2 .FILE-DATA> <REST .OBP>>)
+ (ELSE <SET OBP <PUTREST .PREV <REST .OBP>>>)>>
+ <SET GFLG <>>)>
+ <SET PREV .OBP>>
+ .<2 .FILE-DATA>>)>)
+ (ELSE
+ <AND .REASONABLE <SET ATOM-LIST <LINEARIZE .ATOM-LIST>>>
+ <MAPF <>
+ #FUNCTION ((AL)
+ #DECL ((AL) <SPECIAL <OR LIST ATOM>> (TEMPCH) <SPECIAL CHANNEL>)
+ <COND (<NOT .TW?> <SNAME-SETTER <COND (<TYPE? .AL LIST> <1 .AL>) (ELSE .AL)>>)>
+ <APPLY ,COMPILE
+ .AL
+ .SRC-CHAN
+ T
+ .CAREFUL
+ .SPECIAL
+ .REASONABLE
+ .GLUE
+ .HAIRY-ANALYSIS
+ .DEBUG-COMPILE>
+ <AND .SRC-CHAN
+ <PRINC ,CRET .SRC-CHAN>
+ <PRINC <ASCII 12> .SRC-CHAN>
+ <BUFOUT .SRC-CHAN>>
+ <BUFOUT .OUTCHAN>
+ <MAPF <>
+ #FUNCTION ((AT "AUX" ACC ACC2)
+ #DECL ((AT) ATOM (LN ACC ACC2) FIX)
+ <BLOCK ()>
+ <SET ACC <17 .TEMPCH>>
+ <RESET .TEMPCH>
+ <ACCESS .TEMPCH .ACC>
+ <PRINT <FORM SETG .AT ,.AT> .TEMPCH>
+ <AND .GLUE
+ <PRINT
+ <FORM AND
+ '<ASSIGNED? GLUE>
+ '.GLUE
+ <FORM PUT
+ <COND (<TYPE? ,.AT MACRO>
+ <FORM 1 <FORM GVAL .AT>>)
+ (<FORM GVAL .AT>)>
+ GLUE
+ <GET ,.AT GLUE>>>
+ .TEMPCH>>
+ <BUFOUT .TEMPCH>
+ <PRINTB ,WDCNTLC .TEMPCH>
+ <SET ACC2 <17 .TEMPCH>>
+ <ACCESS .TEMPCH <- .ACC 1>>
+ <PRINTB ,WDSPACE .TEMPCH>
+ <ACCESS .TEMPCH .ACC2>
+ <CLOSE .TEMPCH>
+ <ENDBLOCK>
+ <COND (<AND .MAX-SPACE <TYPE? ,.AT RSUBR RSUBR-ENTRY>>
+ <PUT ,.AT RSUBR>
+ <PUT ,.AT GLUE>
+ <SETG .AT <RSUBR [#CODE ![!] .AT <3 ,.AT>]>>)>)
+ <COND (<TYPE? .AL ATOM> (.AL)) (ELSE .AL)>>)
+ .ATOM-LIST>)>
+ <COND (.MAX-SPACE
+ <PROG ((REDEFINE T))
+ #DECL ((REDEFINE) <SPECIAL ATOM>)
+ <FLOAD <7 .TEMPCH> <8 .TEMPCH> <9 .TEMPCH> <10 .TEMPCH>>>)>
+ <COND (.NILOBL <BLOCK ()>)>
+ <AND .GLUE <DOGLUE .<2 .FILE-DATA>>>
+ <OR <SET R <GROUP-DUMP .OUTFILE <2 .FILE-DATA> ,PRINT>>
+ <ERROR GROUP-DUMP .R>>
+ <COND (.NILOBL <ENDBLOCK>)>
+ <CLOSE .OUTCH>
+ <CLOSE .TEMPCH>
+ <COND (.DESTROY
+ <RENAME <FILENAME .TEMPCH>>)>
+ <PRINTSTATS>
+ <OFF .GC-HANDLER>
+ <OFF ,ERROR-HANDLER>
+ <AND .SRC-CHAN <CLOSE .SRC-CHAN>>
+ <SETG COMPCHAN ,OUTCHAN>
+ <COND (<AND <NOT .TW?> <ASSIGNED? DISOWN> .DISOWN>
+ <APPLY ,LOGOUT>
+ "So you re-owned me, eh? I'm done anyway.")
+ (ELSE "Compilation completed. Your patience is godlike.")>>
+
+<DEFINE DOGLUE (GRP "AUX" OBJ)
+ #DECL ((GRP) LIST)
+ <REPEAT (RSBR NXT MCR)
+ <SET MCR <>>
+ <COND (<EMPTY? .GRP> <RETURN>)
+ (<AND <TYPE? <SET OBJ <1 .GRP>> FORM>
+ <G=? <LENGTH .OBJ> 2>
+ <MEMQ <1 .OBJ> '![DEFINE SETG DEFMAC]>
+ <GASSIGNED? <SET OBJ <GET <2 .OBJ> VALUE '<2 .OBJ>>>>
+ <OR <TYPE? <SET RSBR ,.OBJ> RSUBR>
+ <AND <TYPE? .RSBR MACRO>
+ <NOT <EMPTY? .RSBR>>
+ <TYPE? <SET RSBR <1 .RSBR>> RSUBR>
+ <SET MCR T>>>
+ <GET .RSBR GLUE>>
+ <COND (<AND <NOT <EMPTY? <REST .GRP>>>
+ <TYPE? <SET NXT <2 .GRP>> FORM>
+ <==? <LENGTH .NXT> 4>
+ <==? <1 .NXT> AND>
+ <=? <2 .NXT> '<ASSIGNED? GLUE>>
+ <=? <3 .NXT> '.GLUE>
+ <=? <2 <2 <4 .NXT>>> .OBJ>>)
+ (ELSE
+ <SET GRP <PUTREST .GRP (0 !<REST .GRP>)>>)>
+ <COND (<==? <2 .RSBR> .OBJ>
+ <PUT <SET GRP <REST .GRP>> 1 <FORM AND '<ASSIGNED? GLUE>
+ '.GLUE
+ <FORM PUT <COND (.MCR <FORM 1 <FORM GVAL .OBJ>>)
+ (ELSE <FORM GVAL .OBJ>)> GLUE
+ <GET .RSBR GLUE>>>>)
+ (ELSE <PUTREST .GRP <REST .GRP 2>>)>)>
+ <SET GRP <REST .GRP>>>>
+
+<DEFINE PACK-FIX (PCK ATM
+ "AUX" (S <PNAME .ATM>) (WIN <>)
+ (PO <LOOKUP .PCK <GET PACKAGE OBLIST>>))
+ <AND .PO <SET PO ,.PO>>
+ <MAPF <>
+ <FUNCTION (O)
+ #DECL ((O) OBLIST)
+ <AND <SET WIN <LOOKUP .S .O>> <MAPLEAVE>>>
+ .PO>
+ <COND (.WIN) (.PO <INSERT .S <1 .PO>>) (ELSE .ATM)>>
+
+<DEFINE LINEARIZE (ATOM-LIST) #DECL ((ATOM-LIST) LIST)
+ <REPEAT ((L <SET ATOM-LIST (START !.ATOM-LIST)>) (LL <REST .L>))
+ #DECL ((L LL) LIST)
+ <COND (<EMPTY? .LL> <RETURN <REST .ATOM-LIST>>)
+ (<TYPE? <1 .LL> LIST>
+ <PUTREST .L <1 .LL>>
+ <PUTREST <SET L <REST .L <- <LENGTH .L> 1>>>
+ <SET LL <REST .LL>>>)
+ (ELSE <SET LL <REST <SET L .LL>>>)>>>
+
+<DEFINE NSETG (ATM VAL)
+ <COND (<NOT <MEMQ .ATM .REDO>> <OSETG .ATM .VAL>)>>
+
+
+<DEFINE KILL-COMP ("AUX" (ENTS <LOOKUP "CC" <GET PACKAGE OBLIST>>)
+ INTS ENTO INTO)
+ <GUNASSIGN COMPILE>
+ <GUNASSIGN COMPILE-GROUP>
+ <COND (<NOT <TYPE? ,GDECL FSUBR>>
+ <GUNASSIGN GDECL>)>
+ <COND (<NOT <TYPE? ,MANIFEST SUBR>>
+ <GUNASSIGN MANIFEST>)>
+ <COND (.ENTS <SET ENTO <PUT .ENTS OBLIST>>)>
+ <COND (<AND .ENTO <SET INTS <LOOKUP "ICC" .ENTO>>>
+ <SET INTO <PUT .INTS OBLIST>>)>
+ <COND (.ENTO <MUNGOB .ENTO>)>
+ <COND (.INTO <MUNGOB .INTO>)>
+ <COND (.ENTS <REMOVE .ENTS>)>
+ <COND (.INTS <REMOVE .INTS>)>>
+
+<DEFINE MUNGOB (OB) #DECL ((OB) OBLIST)
+ <MAPF <>
+ <FUNCTION (L) #DECL ((L) LIST)
+ <MAPF <>
+ <FUNCTION (ATM)
+ <GUNASSIGN <SET ATM <CHTYPE .ATM ATOM>>> ; "LINKS?"
+ <UNASSIGN .ATM>
+ <REMOVE .ATM>> .L>> .OB>>
+
+
+<DEFINE PRINTSTATS ("AUX" (TSTARCPU <- <FIX <+ 0.5 <TIME>>> .STARCPU>)
+ (TSTARR <- <RTIME:SEC> .STARR>))
+ #DECL((STARCPU STARR TSTARCPU TSTARR) FIX)
+ <COND (<L? .TSTARR 0> ;"Went over midnight."
+ <SET TSTARR <+ .TSTARR %<* 24 60 60>>>)>
+ <PRINCTHEM ,CRET ,CRET "Total time used is" ,CRET ,TAB>
+ <PRINTIME .TSTARCPU "CPU time,">
+ <PRINCTHEM ,CRET ,TAB>
+ <PRINTIME <FIX .GCTIME> "garbage collector CPU time,">
+ <PRINCTHEM ,CRET ,TAB>
+ <PRINTIME .TSTARR "real time.">
+ <PRINCTHEM ,CRET
+ "CPU utilization is " <* 100.0 </ .TSTARCPU <FLOAT .TSTARR>>>
+ "%." ,CRET
+ "Number of garbage collects = " ,GC-COUNT ,CRET>>
+
+<DEFINE PRINTIME (AMT STR) #DECL((AMT) FIX)
+ <COND (<G? .AMT %<* 60 60>>
+ <PRINCTHEM </ .AMT %<* 60 60>> " hours ">
+ <SET AMT <MOD .AMT %<* 60 60>>>)>
+ <COND (<G? .AMT 60>
+ <PRINCTHEM </ .AMT 60> " min. ">
+ <SET AMT <MOD .AMT 60>>)>
+ <PRINCTHEM .AMT " sec. " .STR>>
+
+
+<DEFINE STATUS ("AUX" FL PL)
+ <COND (<AND <ASSIGNED? ATOM-LIST> .GROUP-MODE <GASSIGNED? COMPILE>>
+ <PRINCTHEM ,CRET "Running group " <LENGTH .ATOM-LIST> " long.">
+ <PRINTSTATS>)
+ (<AND <ASSIGNED? ATOM-LIST> <ASSIGNED? AL>>
+ <SET FL <LENGTH .ATOM-LIST>>
+ <SET PL <- .FL <LENGTH <MEMQ .AL .ATOM-LIST>>>>
+ <PRINCTHEM ,CRET "Running: " .PL " finished, working on ">
+ <PRIN1 .AL>
+ <PRINCTHEM ", and " <- .FL .PL 1> " to go.">
+ <PRINTSTATS>)
+ (<AND <ASSIGNED? STARCPU> <ASSIGNED? STARR>>
+ <COND (<NOT <ASSIGNED? FILE-DATA>>
+ <PRINC "
+Files not yet loaded.">
+ <PRINTSTATS>)
+ (<NOT <ASSIGNED? ATOM-LIST>>
+ <PRINC"
+Files loaded, but functions not yet ordered for compilation.">
+ <PRINTSTATS>)
+ (ELSE <PRINC "
+Almost done, just cleaning up and writing out final file.">
+ <PRINTSTATS>)>)
+ (ELSE <PRINCTHEM ,CRET "I'm not running." ,CRET>)>>
+
+<DEFINE COUNT-GCS (TI RS SU) <SETG GC-COUNT <+ ,GC-COUNT 1>>
+ <AND <ASSIGNED? GCTIME> <SET GCTIME <+ .GCTIME .TI>>>>
+
+<GDECL (GC-COUNT) FIX>
+
+<SETG NOT-COMPILE-TIME
+ '![PREV
+ SPLOUTEM
+ REVERSE
+ ORDEREM
+ REMEMIT
+ FINDREC
+ FINDEM
+ FINDEMALL
+ GETORDER
+ PRINSPEC
+ DO-AND-CHECK
+ FIND-DEFINE-LOAD
+ FDREAD-LP
+ NEW-DEFINE
+ NEW-FLOAD
+ HELP
+ NOT-COMPILE-TIME!]>
+
+<MANIFEST CRET NOT-COMPILE-TIME>
+
+<SETG CRET "
+">
+
+<SETG TAB <ASCII 9> ;"Char Tab">
+
+<MANIFEST CRET TAB>
+
+<DEFMAC PRINCTHEM ("ARGS" A) #DECL ((A) LIST)
+ <FORM PROG ()
+ !<MAPF ,LIST <FUNCTION (X)
+ <FORM PRINC .X>>
+ .A>>>
+
+<DEFINE FIND-DEFINE-LOAD (FNM "AUX" GRP (OLD-FLOAD ,FLOAD))
+ <SET GRP <GROUP-LOAD .FNM>>
+ (<1 <GET-ATOMS ..GRP>> .GRP)>
+
+<DEFINE GET-ATOMS (L "AUX" (L1 .L) (AL ()) (LL ()) TEM TT MCR ATM VAL)
+ #DECL ((L AL L1 LL) LIST (TT) FORM)
+ <REPEAT ()
+ <SET MCR <>>
+ <COND (<EMPTY? .L1> <RETURN (.AL .L)>)
+ (<AND <TYPE? <1 .L1> FORM>
+ <NOT <EMPTY? <SET TT <1 .L1>>>>>
+ <COND (<OR <==? <1 .TT> DEFINE>
+ <SET MCR <==? <1 .TT> DEFMAC>>>
+ <COND (<AND .MCR .MACRO-FLUSH>
+ <PUT .L1 1 <FORM DEFINE <ATOM "A"> ()>>)
+ (ELSE
+ <PUT .L1 1 <FORM <1 .TT> <2 .TT> <>>>)>
+ <SET ATM <GET <2 .TT> VALUE '<2 .TT>>>
+ <OR <AND .MCR <NOT .MACRO-COMPILE>>
+ <SET AL (.ATM !.AL)>>)>)>
+ <SET L1 <REST .L1>>>>
+
+<DEFINE NEW-ERROR (FRM "TUPLE" TUP "EXTRA" (OUTCHAN ,COMPCHAN))
+ #DECL ((TUP) TUPLE (OUTCHAN) <SPECIAL ANY>)
+ <COND (<AND <NOT <EMPTY? .TUP>> <==? <1 .TUP> CONTROL-G?!-ERRORS>>
+ <INT-LEVEL 0>
+ <OFF ,ERROR-HANDLER> ;"HAVE TO NEST TO TURN HANDLER ON AND OFF"
+ <ERROR !.TUP>
+ <ON "ERROR" ,ERROR-HANDLER 100>
+ <ERRET T .FRM>)
+ (ELSE <PRINC"
+***********************************************************
+* ERROR ERROR ERROR ERROR ERROR ERROR ERROR *
+***********************************************************
+
+to wit,">
+ <MAPF <> ,PRINT .TUP>
+ <PRINC "
+Compilation totally aborted.
+Status at death was:
+
+">
+ <STATUS> <FRATM>
+ <APPLY ,LOGOUT> <OFF ,ERROR-HANDLER>)>>
+
+<SETG COMPCHAN ,OUTCHAN>
+
+<OFF <SETG ERROR-HANDLER <ON "ERROR" ,NEW-ERROR 100>>>
+
+<DEFINE PRINSPEC (STR CHAN) #DECL((STR) STRING (CHAN) CHANNEL)
+ <PRINCTHEM .STR <FILENAME .CHAN> ,CRET>>
+
+
+<DEFINE FILENAME (CHAN) #DECL ((CHAN) CHANNEL)
+ <COND (<G? ,MUDDLE 100>
+ <STRING <9 .CHAN> ":<" <10 .CHAN> !\> <7 .CHAN> !\. <8 .CHAN>>)
+ (<STRING <9 .CHAN> !\: <10 .CHAN> !\; <7 .CHAN> !\ <8 .CHAN>>)>>
+
+<DEFINE DO-AND-CHECK (STR1 STR2 ATM INCH OUTCH FOOCH "AUX" NEW-CHAN)
+ <COND (<AND <ASSIGNED? .ATM> ..ATM> ;"Do it?"
+ <PRINC .STR1>
+ <COND ;"Yes. Get the channel."
+ (<TYPE? ..ATM CHANNEL> ;"Output channel already open."
+ <COND (<OR <0? <1 ..ATM>> <NOT <=? "PRINT" <2 ..ATM>>>>
+ ;"But is it good?"
+ <CLOSE .INCH> <CLOSE .OUTCH> <AND .FOOCH <CLOSE .FOOCH>>
+ <RETURN #FALSE("CLOSED special channel??") .FCEX>)
+ (ELSE <SET NEW-CHAN ..ATM>)>)
+ (<TYPE? ..ATM STRING> ;"Name of output file given."
+ <COND (<SET NEW-CHAN <OPEN "PRINT" ..ATM>>) ;"So try opening it."
+ (ELSE ;"Bad name."
+ <CLOSE .INCH> <CLOSE .OUTCH> <AND .FOOCH <CLOSE .FOOCH>>
+ <RETURN #FALSE("Can't open channel.") .FCEX>)>)
+ (<SET NEW-CHAN
+ <OPEN "PRINT" <7 .INCH> .STR2 "DSK" <10 .INCH>>>)
+ (ELSE <CLOSE .INCH> <CLOSE .OUTCH> <AND .FOOCH <CLOSE .FOOCH>>
+ <RETURN #FALSE("Can't open channel.") .FCEX>)>
+ <PRINSPEC "on " .NEW-CHAN>
+ .NEW-CHAN)>>
+
+<DEFINE FLUSH-COMMENTS ("AUX" (A <ASSOCIATIONS>) B)
+ <REPEAT ()
+ <SET B <NEXT .A>>
+ <COND (<==? <INDICATOR .A> COMMENT>
+ <PUT <ITEM .A> COMMENT>)>
+ <OR <SET A .B> <RETURN>>>>
+
+<SETG DEMON?
+ %<FIXUP!-RSUBRS '[
+#CODE ![4793303048 28063301637 17859346449 17330864128 23085680158 17859346471
+17200316423 23085680158 13893633 5768480256 0 2!]
+ DEMON?
+ #DECL ("VALUE" <OR FALSE ATOM>)
+ T]
+ '(54 FINIS!-MUDDLE 230942 (8 5))>>
+
+
--- /dev/null
+
+<PACKAGE "COMPDEC">
+
+<ENTRY FCNS
+ DEATH
+ TMPS
+ IDT
+ STYPES
+ PLUSINF
+ MINUSINF
+ IPUT
+ TEMPV
+ DEBUGSW
+ INSTRUCTION
+ INTH
+ FCN
+ IRSUBR
+ STACK
+ SNODES
+ PSTACK
+ ANY-AC
+ DUMMY-MAPF
+ INCONSISTENCY
+ SEGS
+ SPEC
+ CODVEC
+ QUOTE-CODE
+ RETURN-CODE
+ IPUT-CODE
+ SEG-CODE
+ PREDV
+ ACAGE
+ NUMACS
+ SYM-SLOT
+ SAVED-STK
+ PARENT
+ TYPE-INFO
+ PROG-VARS
+ CURRENT-TYPE
+ NODE1
+ PUTR-CODE
+ ISUBR-CODE
+ EOF-CODE
+ IREMAS-CODE
+ GVAL-CODE
+ SPARE4-CODE
+ ACRESIDUE
+ AC-F
+ LOOPVARS-LENGTH
+ ADDVAR
+ FSET-CODE
+ OFFPTR
+ CSYMT-SLOT
+ CPOTLV-SLOT
+ PROG-CODE
+ COMP-TYPES
+ INACS-SLOT
+ SAVED-STACK-STATE
+ NODE-NAME
+ AGND
+ REQARGS
+ LOOP-VARS
+ DECL-SYM
+ PUT-CODE
+ FLVAL-CODE
+ SETG-CODE
+ BACK-CODE
+ PUT-SAME-CODE
+ AC-E
+ SS-POTENT-SLOT
+ NUM-SYM-SLOT
+ RSUBR-DECLS
+ NODEF
+ AND-CODE
+ MT-CODE
+ BITS-CODE
+ PUTBITS-CODE
+ COPY-LIST-CODE
+ SPARE1-CODE
+ ACLINK
+ LINKED
+ SS-SYM-SLOT
+ ATAG
+ ASSUM
+ RETURN-STATES
+ PURE-SYM
+ NUM-SYM
+ KID
+ GNAME-SYM
+ CHTYPE-CODE
+ SAVED-NUM-SYM-SLOT
+ NODE
+ SYMTAB
+ INACS
+ USAGE-SYM
+ GDECL-SYM
+ MAP-CODE
+ MARGS-CODE
+ DATVAL
+ ALLACS
+ AC-D
+ SAVED-AC-STATE
+ NODE-SUBR
+ LIVE-VARS
+ SPEC-SYM
+ AS-NXT-CODE
+ SUBSTRUC-CODE
+ BIT-TEST-CODE
+ SPARE3-CODE
+ TMPAC
+ NO-RESIDUE
+ NOT-PREF
+ P-N-STO-RES
+ P-N-NO-STO-RES
+ FRMNO
+ NOT-CODE
+ TEST-CODE
+ MIN-MAX-CODE
+ READ-EOF2-CODE
+ TAG-CODE
+ LENGTH-CONTROL-STATE
+ SAVED-NTSLOTS
+ KIDS
+ PREDIC
+ MAKE:TAG
+ NODEPR
+ NODEFM
+ GNEXT-SYM
+ FIX-CODE
+ MFCN-CODE
+ IRSUBR-CODE
+ CASE-CODE
+ SCL
+ ACSYM
+ ACNUM
+ AC-C
+ P-N-CLEAN
+ CINACS-SLOT
+ NODE-TYPE
+ USLOTS
+ DEAD-VARS
+ DEATH-LIST
+ COMPOSIT-TYPE
+ PROG-AC
+ PRED
+ COPY-CODE
+ LENGTH?-CODE
+ AC
+ LINACS-SLOT
+ TMPLS
+ INIT-DECL-TYPE
+ NODECOND
+ FUNCTION-CODE
+ AGAIN-CODE
+ 0-TST-CODE
+ GETBITS-CODE
+ MAPRET-STOP-CODE
+ LSH-CODE
+ SYMBOL
+ SAVED-STATE
+ ACO
+ LENGTH-PROG-VARS
+ CSTORED-SLOT
+ NODEB
+ SET-CODE
+ ROT-CODE
+ AC-B
+ REGS
+ PROG-SLOT
+ SAVED-BSTB
+ BINDING-STRUCTURE
+ CDST
+ VSPCD
+ NAME-SYM
+ INIT-SYM
+ EQ-CODE
+ ALL-REST-CODE
+ DISPATCH
+ TMPNO
+ AC1SYM
+ REACS
+ LSYM-SLOT
+ DST
+ RTAG
+ ACCUM-TYPE
+ DATUM
+ ARGNUM-SYM
+ ADDR-SYM
+ STORED
+ USED-AT-ALL
+ POTLV
+ NAME
+ ARGNUM
+ FGVAL-CODE
+ ID-CODE
+ FORM-F-CODE
+ INFO-CODE
+ TEMP
+ STORED-RESIDUE
+ SAVED-POTLV-SLOT
+ SAVED-CODE:PTR
+ CLAUSES
+ TRG
+ VARTBL
+ LVARTBL
+ SUBR-CODE
+ LNTH-CODE
+ STACKFORM-CODE
+ ASSIGNED?-CODE
+ GET2-CODE
+ AS-IT-IND-VAL-CODE
+ COMMON
+ DATTYP
+ AC-A
+ ACS
+ RET-AGAIN-ONLY
+ SEGMENT-CODE
+ FSETG-CODE
+ ISTRUC-CODE
+ MFIRST-CODE
+ ACPREF
+ SS-STORED-SLOT
+ STORED-SLOT
+ STK-B
+ AGAIN-STATES
+ CODE-SYM
+ BST
+ RSUBR-CODE
+ 1?-CODE
+ REST-CODE
+ ABS-CODE
+ MPSBR-CODE
+ UNWIND-CODE
+ PRINT-CODE
+ OBLIST?-CODE
+ ADDRSYM
+ AC-H
+ LAST-AC-1
+ NOT-STORED-RESIDUE
+ P-N-LINKED
+ SAVED-RET-FLAG
+ SAVED-FRMS
+ STACKS
+ ASS?
+ BRANCH-CODE
+ LVAL-CODE
+ OR-CODE
+ ISTRUC2-CODE
+ READ-EOF-CODE
+ MAPLEAVE-CODE
+ MEMQ-CODE
+ REP-STATE
+ SS-DAT-SLOT
+ SAVED-PROG-AC-SLOT
+ LENGTH-CSTATE
+ RESULT-TYPE
+ SIDE-EFFECTS
+ SSLOTS
+ PRE-ALLOC
+ NEXT-SYM
+ FORM-CODE
+ TY?-CODE
+ FLOAT-CODE
+ GET-CODE
+ SPECS-START
+ BTP-B
+ SPCS-X
+ RES-TYP
+ GO-CODE
+ BITL-CODE
+ TOP-CODE
+ SPARE2-CODE
+ AC-G
+ LAST-AC
+ ATIME
+ ACTIVATED
+ TOTARGS
+ VTB
+ RQRG
+ COND-CODE
+ ARITH-CODE
+ NTH-CODE
+ MOD-CODE
+ ACPROT
+ IND
+ ALL
+ NOTE
+ WARNING
+ PRIM-CODE
+ DONT-CARE
+ FLUSHED
+ NO-RETURN
+ NO-DATUM
+ MESSAGE
+ GROUP-NAME
+ FUZZ
+ COMMON-TYPE
+ COMMON-SYMTAB
+ COMMON-ITEM
+ COMMON-PRIMTYPE
+ COMMON-DATUM
+ COMMON-SYMT
+ TRANSFORM
+ TRANS
+ N0?
+ POPWR2
+ DEALLOCATE
+ TOKEN
+ ERRS
+ WARNS
+ NOTES
+ DEBUG-COMPILE
+ REASONABLE
+ CAREFUL
+ PRECOMPILED
+ HAIRY-ANALYSIS
+ SRC-FLG
+ BIN-FLG
+ GLOSP
+ ANALY-OK
+ VERBOSE
+ COMPILER
+ IND
+ ADDRESS:C
+ FUNNY-STACK>
+
+
+<SETG PLUSINF <CHTYPE <MIN> FIX>>
+
+<SETG MINUSINF <CHTYPE <MAX> FIX>>
+
+"Type specification for NODE."
+
+<NEWTYPE NODE
+ VECTOR
+ '<VECTOR FIX
+ ANY
+ ANY
+ ANY
+ <LIST [REST NODE]>
+ FIX
+ <OR FALSE ATOM>
+ [REST
+ LIST
+ ANY
+ ANY
+ LIST
+ FIX
+ SYMTAB
+ FIX
+ FIX
+ <OR FALSE ATOM>
+ ATOM
+ ANY
+ LIST
+ LIST
+ ANY
+ ANY
+ ANY
+ ANY
+ ANY
+ ANY
+ ANY
+ <PRIMTYPE LIST>
+ FIX
+ FIX
+ LIST
+ LIST
+ LIST
+ LIST
+ LIST]>>
+
+"Offsets into pass 1 structure entities and functions to create same."
+
+<SETG NODE-TYPE <OFFSET 1 NODE>>
+
+;"Code specifying the node type."
+
+<SETG PARENT <OFFSET 2 NODE>>
+
+;"Pointer to parent node."
+
+<SETG RESULT-TYPE <OFFSET 3 NODE>>
+
+;"Type expression for result returned by code
+ generated by this node."
+
+<SETG NODE-NAME <OFFSET 4 NODE>>
+
+;"Usually name of SUBR associated with this node."
+
+<SETG KIDS <OFFSET 5 NODE>>
+
+;"List of sub-nodes for this node."
+
+<SETG STACKS <OFFSET 6 NODE>>
+
+;"Amount of stack needed by this node."
+
+<SETG SEGS <OFFSET 7 NODE>>
+
+;"Predicate: any segments among kids?"
+
+<SETG TYPE-INFO <OFFSET 8 NODE>>
+
+;"Points to transient type info for this node."
+
+<SETG SIDE-EFFECTS <OFFSET 9 NODE>>
+
+;"General info about side effects (format not yet firm.)"
+
+<SETG RSUBR-DECLS <OFFSET 10 NODE>>
+
+;"Function only: final rsubr decls."
+
+<SETG BINDING-STRUCTURE <OFFSET 11 NODE>>
+
+;"Partially compiled arg list."
+
+<SETG SPECS-START <OFFSET 12 NODE>>
+
+;"Offset to 1st special."
+
+<SETG SYMTAB <OFFSET 13 NODE>>
+
+;"Pointer to local symbol table."
+
+<SETG SSLOTS <OFFSET 14 NODE>>
+
+;"Number of specials."
+
+<SETG USLOTS <OFFSET 15 NODE>>
+
+;"Number of unspecials."
+
+<SETG ACTIVATED <OFFSET 16 NODE>>
+
+;"Predicate: any named activation?"
+
+<SETG TMPLS <OFFSET 17 NODE>>
+
+;"Offset to unamed temps."
+
+<SETG PRE-ALLOC <OFFSET 18 NODE>>
+
+;"Variable slots allocated in advance."
+
+<SETG STK-B <OFFSET 19 NODE>>
+
+;"Base of stack at entry."
+
+<SETG BTP-B <OFFSET 20 NODE>>
+
+;"Base of stack after bindings."
+
+<SETG SPCS-X <OFFSET 21 NODE>>
+
+;"Predicate: any specials bound?"
+
+<SETG DST <OFFSET 22 NODE>>
+
+;"Destination spec for value of node."
+
+<SETG CDST <OFFSET 23 NODE>>
+
+;"Current destination used."
+
+<SETG ATAG <OFFSET 24 NODE>>
+
+;"Label for local againing."
+
+<SETG RTAG <OFFSET 25 NODE>>
+
+;"Label for local Returning."
+
+<SETG ASSUM <OFFSET 26 NODE>>
+
+;"Node type assumptions."
+
+<SETG AGND <OFFSET 27 NODE>>
+
+;"Predicate: Again possible?"
+
+<SETG ACS <OFFSET 28 NODE>>
+
+;"Predicate: AC call possible? (if not false
+ ac structure)"
+
+<SETG TOTARGS <OFFSET 29 NODE>>
+
+;"Total number of args (including optional)."
+
+<SETG REQARGS <OFFSET 30 NODE>>
+
+;"Required arguemnts."
+
+<SETG LOOP-VARS <OFFSET 31 NODE>>
+
+"Variables kept in acs thru loop."
+
+<SETG AGAIN-STATES <OFFSET 32 NODE>>
+
+"States at agains"
+
+<SETG RETURN-STATES <OFFSET 33 NODE>>
+
+"States at repeats."
+
+<SETG PROG-VARS <OFFSET 34 NODE>>
+
+"Vars handled in this prog/repeat."
+
+;"Information used for merging states with prog-nodes"
+
+<SETG CLAUSES <OFFSET <INDEX ,KIDS> NODE>>
+
+;"For COND clauses."
+
+<SETG NODE-SUBR <OFFSET <INDEX ,RSUBR-DECLS> NODE>>
+
+;"For many nodes, the SUBR (not its name)."
+
+<SETG PREDIC <OFFSET <INDEX ,NODE-NAME> NODE>>
+
+;"For cond clause nodes, the predicate."
+
+<SETG ACCUM-TYPE <OFFSET <INDEX ,DST> NODE>>
+
+;"Accumulated type from all returns etc."
+
+<SETG DEAD-VARS <OFFSET <INDEX ,CDST> NODE>>
+
+<SETG LIVE-VARS <OFFSET <INDEX ,TYPE-INFO> NODE>>
+
+<SETG VSPCD <OFFSET <INDEX ,ATAG> NODE>>
+
+<SETG INIT-DECL-TYPE <OFFSET <INDEX ,RTAG> NODE>>
+
+" Definitions associated with compiler symbol tables."
+
+"Offsets for variable description blocks"
+
+<NEWTYPE SYMTAB
+ VECTOR
+ '<VECTOR <PRIMTYPE VECTOR>
+ ATOM
+ <OR FALSE ATOM>
+ FIX
+ <OR ATOM FIX>
+ <OR FALSE ATOM>
+ LIST
+ ANY
+ ANY
+ FIX
+ <OR FALSE NODE>
+ <OR FALSE 'T>
+ <OR FALSE DATUM LIST>
+ <OR FALSE 'T>
+ <OR FALSE 'T>
+ LIST
+ ANY
+ ANY
+ <OR FALSE FIX>>>
+
+<SETG NEXT-SYM <OFFSET 1 SYMTAB>>
+
+;"Pointer to next symbol table entry."
+
+<SETG NAME-SYM <OFFSET 2 SYMTAB>>
+
+;"Name of variable."
+
+<SETG SPEC-SYM <OFFSET 3 SYMTAB>>
+
+;"Predicate: special?"
+
+<SETG CODE-SYM <OFFSET 4 SYMTAB>>
+
+;"Code specifying whether AUX, OPTIONAL etc."
+
+<SETG ARGNUM-SYM <OFFSET 5 SYMTAB>>
+
+;"If an argument, which one."
+
+<SETG PURE-SYM <OFFSET 6 SYMTAB>>
+
+;"Predicate: unchanged in function?"
+
+<SETG DECL-SYM <OFFSET 7 SYMTAB>>
+
+;"Decl for this variable."
+
+<SETG ADDR-SYM <OFFSET 8 SYMTAB>>
+
+;"Where do I live?"
+
+<SETG INIT-SYM <OFFSET 9 SYMTAB>>
+
+;"Predicate: initial value? if so what."
+
+<SETG FRMNO <OFFSET 10 SYMTAB>>
+
+;"ID of my frame."
+
+<SETG RET-AGAIN-ONLY <OFFSET 11 SYMTAB>>
+
+;"Predicate: used only in AGAIN/RETURN?"
+
+<SETG ASS? <OFFSET 12 SYMTAB>>
+
+;"Predicate: used in ASSIGNED?"
+
+<SETG INACS <OFFSET 13 SYMTAB>>
+
+;"Predicate: currently in some AC?"
+
+<SETG STORED <OFFSET 14 SYMTAB>>
+
+;"Predicate: stored in slot?"
+
+<SETG USED-AT-ALL <OFFSET 15 SYMTAB>>
+
+;"Predicate: symbolused at all."
+
+<SETG DEATH-LIST <OFFSET 16 SYMTAB>>
+
+;"List of info associated with life time."
+
+<SETG CURRENT-TYPE <OFFSET 17 SYMTAB>>
+
+;"Current decl determined by analysis"
+
+<SETG COMPOSIT-TYPE <OFFSET 18 SYMTAB>>
+
+<SETG USAGE-SYM <OFFSET 19 SYMTAB>>
+
+"How a variable is used in a loop."
+
+<SETG PROG-AC <OFFSET <INDEX ,CURRENT-TYPE> SYMTAB>>
+
+<SETG NUM-SYM <OFFSET <INDEX ,COMPOSIT-TYPE> SYMTAB>>
+
+<SETG POTLV <OFFSET <INDEX ,USED-AT-ALL> SYMTAB>>
+
+
+"Slot used to store information for variables in loops."
+
+;"Type as figured out by all uses of symbol."
+
+<DEFINE NODE1 (TYP PAR RES-TYP NAME KID)
+ <CHTYPE [.TYP .PAR .RES-TYP .NAME .KID 0 <>] NODE>>
+
+"Create a function node with all its hair."
+
+<DEFINE NODEF (TYP PAR RES-TYP NAME KID RSD BST HAT VTB ACS? TRG RQRG)
+ <CHTYPE [.TYP .PAR .RES-TYP .NAME .KID 0 <> () <> .RSD .BST 0 .VTB 0
+ 0 <> <MAKE:TAG "FRM"> <> () () <> <> <> <> .RES-TYP <> <>
+ .ACS? .TRG .RQRG] NODE>>
+
+"Create a PROG/REPEAT node with nearly as much hair."
+
+<DEFINE NODEPR (TYP PAR RES-TYP NAME KID VL BST HAT VTB)
+ <CHTYPE [.TYP
+ .PAR
+ .RES-TYP
+ .NAME
+ .KID
+ 0
+ <>
+ ()
+ <>
+ .VL
+ .BST
+ 0
+ .VTB
+ 0
+ 0
+ <>
+ <MAKE:TAG "FRM">
+ <>
+ ()
+ ()
+ <>
+ <>
+ <>
+ <>
+ .RES-TYP
+ <>
+ <>
+ <>
+ 0
+ 0
+ ()
+ ()
+ ()
+ ()]
+ NODE>>
+
+"Create a COND node."
+
+<DEFINE NODECOND (TYP PAR RES-TYP NAME CLAU)
+ <CHTYPE [.TYP .PAR .RES-TYP .NAME .CLAU 0 <> () <>] NODE>>
+
+"Create a node for a COND clause."
+
+<DEFINE NODEB (TYP PAR RES-TYP PRED CLAU)
+ <CHTYPE [.TYP .PAR .RES-TYP .PRED .CLAU 0 <> () <>] NODE>>
+
+"Create a node for a SUBR call etc."
+
+<DEFINE NODEFM (TYP PAR RES-TYP NAME KID SUB)
+ <CHTYPE [.TYP .PAR .RES-TYP .NAME .KID 0 <> () <> .SUB] NODE>>
+\f
+
+<DEFINE ADDVAR (NAM SPEC CODE ARGNUM PURE DCL ADDR INIT)
+ <SET VARTBL <CHTYPE [.VARTBL .NAM .SPEC .CODE .ARGNUM .PURE .DCL .ADDR .INIT 0 <>
+ <> <> T <> () <> ANY 0] SYMTAB>>>
+
+
+"Some specialized decl stuff."
+
+<SETG LVARTBL
+ <PROG ((VARTBL []))
+ #DECL ((VARTBL) <SPECIAL ANY>)
+ <ADDVAR OBLIST T -1 0 T '(<OR LIST OBLIST>) <> <>>
+ <ADDVAR OUTCHAN T -1 0 T '(CHANNEL) <> <>>
+ <ADDVAR INCHAN T -1 0 T '(CHANNEL) <> <>>
+ .VARTBL>>
+
+<PUT CHANNEL DECL '<CHANNEL FIX [11 ANY] [5 FIX]>>
+
+<PUT STRING DECL '<STRING [REST CHARACTER]>>
+
+<PUT OBLIST DECL '<UVECTOR [REST <LIST [REST <OR ATOM LINK>]>]>>
+
+"Codes for the node types in the tree built by pass1 and modified by
+other passes."
+
+"Give symbolic codes arbitrary increasing values."
+
+<PROG ((N 1))
+ <SETG CODVEC
+ <MAPF ,UVECTOR
+ <FUNCTION (ATM) <SETG .ATM .N> <SET N <+ .N 1>> .ATM>
+ ![FUNCTION-CODE
+ QUOTE-CODE
+ SEGMENT-CODE
+ FORM-CODE
+ PROG-CODE
+ SUBR-CODE
+ COND-CODE
+ BRANCH-CODE
+ RSUBR-CODE
+ LVAL-CODE
+ SET-CODE
+ OR-CODE
+ AND-CODE
+ RETURN-CODE
+ COPY-CODE
+ GO-CODE
+ AGAIN-CODE
+ ARITH-CODE
+ 0-TST-CODE
+ NOT-CODE
+ 1?-CODE
+ TEST-CODE
+ EQ-CODE
+ TY?-CODE
+ LNTH-CODE
+ MT-CODE
+ NTH-CODE
+ REST-CODE
+ PUT-CODE
+ PUTR-CODE
+ FLVAL-CODE
+ FSET-CODE
+ FGVAL-CODE
+ FSETG-CODE
+ MIN-MAX-CODE
+ STACKFORM-CODE
+ CHTYPE-CODE
+ ABS-CODE
+ FIX-CODE
+ FLOAT-CODE
+ MOD-CODE
+ ID-CODE
+ ASSIGNED?-CODE
+ ISTRUC-CODE
+ ISTRUC2-CODE
+ BITS-CODE
+ BITL-CODE
+ GETBITS-CODE
+ PUTBITS-CODE
+ MAP-CODE
+ MFCN-CODE
+ ISUBR-CODE
+ READ-EOF-CODE
+ READ-EOF2-CODE
+ EOF-CODE
+ GET-CODE
+ GET2-CODE
+ IPUT-CODE
+ IREMAS-CODE
+ IRSUBR-CODE
+ MARGS-CODE
+ MPSBR-CODE
+ MAPLEAVE-CODE
+ MAPRET-STOP-CODE
+ UNWIND-CODE
+ GVAL-CODE
+ SETG-CODE
+ SEG-CODE
+ LENGTH?-CODE
+ TAG-CODE
+ MFIRST-CODE
+ PRINT-CODE
+ MEMQ-CODE
+ FORM-F-CODE
+ INFO-CODE
+ OBLIST?-CODE
+ AS-NXT-CODE
+ AS-IT-IND-VAL-CODE
+ ALL-REST-CODE
+ CASE-CODE
+ SUBSTRUC-CODE
+ BACK-CODE
+ TOP-CODE
+ COPY-LIST-CODE
+ PUT-SAME-CODE
+ ROT-CODE
+ LSH-CODE
+ BIT-TEST-CODE
+ SPARE1-CODE
+ SPARE2-CODE
+ SPARE3-CODE
+ SPARE4-CODE!]>>
+ <SETG COMP-TYPES .N>>
+
+
+<USE "NPRINT">
+
+"Build a dispatch table based on node types."
+
+<DEFINE DISPATCH (DEFAULT "TUPLE" PAIRS
+ "AUX" (TT <IVECTOR ,COMP-TYPES '.DEFAULT>))
+ #DECL ((PAIRS) <TUPLE [REST <LIST FIX ANY>]>
+ (TT) VECTOR)
+ <REPEAT ((PAIR '(1 1))) #DECL ((PAIR) <LIST FIX ANY>)
+ <COND (<EMPTY? .PAIRS><RETURN .TT>)>
+ <PUT .TT <1 <SET PAIR <1 .PAIRS>>> <2 .PAIR>>
+ <SET PAIRS <REST .PAIRS>>>>
+
+<SETG PREDV <IUVECTOR ,COMP-TYPES 0>>
+
+<MAPF <>
+ <FUNCTION (N) <PUT ,PREDV .N 1>>
+ ![,0-TST-CODE
+ ,1?-CODE
+ ,NOT-CODE
+ ,TEST-CODE
+ ,EQ-CODE
+ ,TY?-CODE
+ ,MT-CODE
+ ,OR-CODE
+ ,AND-CODE
+ ,ASSIGNED?-CODE
+ ,ISUBR-CODE
+ ,NTH-CODE
+ ,MEMQ-CODE
+ ,LENGTH?-CODE
+ ,OBLIST?-CODE
+ ,AS-NXT-CODE
+ ,COND-CODE
+ ,BIT-TEST-CODE!]>
+
+"Predicate: does this type have special predicate code?"
+
+<PUT REP-STATE
+ DECL
+ '<LIST [5 <LIST [REST SYMTAB DATUM <OR FALSE ATOM> <OR ATOM FALSE>]>]>>
+
+<PUT SYMBOL DECL '<OR SYMTAB TEMP COMMON>>
+
+<NEWTYPE TEMP VECTOR '<VECTOR SCL <OR FALSE DATUM>>>
+
+<NEWTYPE SAVED-STATE
+ LIST
+ '<LIST [REST
+ <LIST AC
+ <OR FALSE <LIST [REST SYMBOL]>>
+ [REST <LIST SYMBOL [3 ANY]>]>]>>
+
+<SETG TMPNO <OFFSET 1 TEMP>>
+
+<SETG TMPAC <OFFSET 2 TEMP>>
+
+<SETG DATTYP <OFFSET 1 DATUM>>
+
+<SETG DATVAL <OFFSET 2 DATUM>>
+
+<SETG ADDRSYM <OFFSET 1 AC>>
+
+<SETG ACSYM <OFFSET 2 AC>>
+
+<SETG ACLINK <OFFSET 3 AC>>
+
+<SETG ACAGE <OFFSET 4 AC>>
+
+<SETG ACNUM <OFFSET 5 AC>>
+
+<SETG ACPROT <OFFSET 6 AC>>
+
+<SETG AC1SYM <OFFSET 7 AC>>
+
+<SETG ACRESIDUE <OFFSET 8 AC>>
+
+<SETG ACPREF <OFFSET 9 AC>>
+
+<NEWTYPE AC
+ VECTOR
+ '<<PRIMTYPE VECTOR> <PRIMTYPE WORD>
+ <PRIMTYPE WORD>
+ <OR <LIST [REST DATUM]> FALSE>
+ FIX
+ FIX
+ <OR FALSE ATOM>
+ <PRIMTYPE WORD>
+ <OR FALSE LIST>
+ <OR FALSE ATOM>>>
+
+<NEWTYPE DATUM
+ LIST
+ '<<PRIMTYPE LIST> <OR ATOM <PRIMTYPE LIST> <PRIMTYPE VECTOR>>
+ <OR ATOM <PRIMTYPE LIST> <PRIMTYPE VECTOR>>>>
+
+<NEWTYPE OFFPTR LIST '<<PRIMTYPE LIST> FIX DATUM ATOM>>
+
+<NEWTYPE TEMPV LIST>
+
+<NEWTYPE IRSUBR LIST>
+
+"A TOKEN GIVES INFORMATION TO CUP"
+
+<NEWTYPE TOKEN VECTOR '<<PRIMTYPE VECTOR> FIX>>
+
+<NEWTYPE ADDRESS:PAIR LIST>
+
+<NEWTYPE ADDRESS:C LIST>
+
+<SETG ALLACS
+ <MAPF ,UVECTOR
+ <FUNCTION (N1 N2 N N+1 NAME "AUX" THISAC)
+ <SETG .NAME <SET THISAC <CHTYPE [.N1 .N2 <> 0 .N <> .N+1 <> <>] AC>>>
+ <EVAL <FORM GDECL (.NAME) AC>> .THISAC>
+ ![`A `B `C `D `E `F `TVP `SP!]
+ ![`A* `B* `C* `D* `E* `F* `TVP* `SP*!]
+ ![1 2 3 4 5 6 7 8!]
+ ![`B* `C* `D* `E* `F* `TVP* `SP* `AB*!]
+ ![AC-A AC-B AC-C AC-D AC-E AC-F AC-G AC-H!]>>
+
+<SETG NUMACS <LENGTH ,ALLACS>>
+
+<SETG LAST-AC ,AC-H>
+
+<SETG LAST-AC-1 ,AC-G>
+
+<DEFINE REACS ()
+ <MAPF <>
+ <FUNCTION (AC)
+ #DECL ((AC) AC)
+ <PUT .AC ,ACLINK <>>
+ <PUT .AC ,ACPROT <>>
+ <PUT .AC ,ACAGE 0>
+ <PUT .AC ,ACRESIDUE <>>
+ <PUT .AC ,ACPREF <>>>
+ ,ALLACS>
+ <SETG REGS 8>
+ <SETG ATIME 0>>
+
+<GDECL (ALLACS) !<UVECTOR [8 AC]> (ATIME REGS) FIX (LAST-AC LAST-AC-1 AC0) AC>
+
+<MANIFEST SS-SYM-SLOT SS-DAT-SLOT SS-STORED-SLOT SS-POTENT-SLOT>
+
+<MANIFEST TMPFRM TMPNO THOME TUSERS DATTYP DATVAL ADDRSYM ACSYM ACLINK ACAGE
+ ACNUM ACPROT AC1SYM ACRESIDUE ACPREF ACINUSE TMPAC COMMON-DATUM
+ NUMACS POTLV>
+
+<MAPF <> ,MANIFEST ,CODVEC>
+
+<MANIFEST TOT-MODES RESTS RMODES COMP-TYPES
+GDECL-SYM GNAME-SYM GNEXT-SYM FRMNO INIT-SYM ADDR-SYM TOTARGS REQARGS
+DECL-SYM PURE-SYM ARGNUM-SYM CODE-SYM SPEC-SYM NAME-SYM NEXT-SYM PREDIC
+NODE-SUBR CLAUSES ACS TMPLS ACTIVATED USLOTS SSLOTS SYMTAB SPECS-START
+BINDING-STRUCTURE RSUBR-DECLS SEGS STACKS KIDS NODE-NAME RESULT-TYPE PARENT
+NODE-TYPE SIDE-EFFECTS RET-AGAIN-ONLY ASS? INACS STORED DST CDST ACCUM-TYPE
+INIT-DECL-TYPE VSPCD AGND ASSUM RTAG ATAG SPCS-X BTP-B STK-B PRE-ALLOC
+USED-AT-ALL CURRENT-TYPE DEATH-LIST COMPOSIT-TYPE AGAIN-STATES RETURN-STATES
+PROG-VARS LOOP-VARS PROG-AC NUM-SYM TYPE-INFO USAGE-SYM LIVE-VARS
+DEAD-VARS>
+
+<REACS>
+
+<SETG LINKED 1>
+
+<SETG NO-RESIDUE 10000000>
+
+<SETG STORED-RESIDUE 1000000>
+
+<SETG NOT-STORED-RESIDUE 100000>
+
+<SETG NOT-PREF 10000>
+
+<SETG P-N-CLEAN 1000>
+
+<SETG P-N-STO-RES 100>
+
+<SETG P-N-NO-STO-RES 10>
+
+<SETG P-N-LINKED 1>
+
+<MANIFEST LINKED
+ NO-RESIDUE
+ STORED-RESIDUE
+ NOT-STORED-RESIDUE
+ NOT-PREF
+ P-N-LINKED
+ P-N-CLEAN
+ P-N-STO-RES
+ P-N-NO-STO-RES>
+
+<SETG ACO <CHTYPE [`O* `O* <> 0 0 <> `A* <> <>] AC>>
+
+<SETG SS-SYM-SLOT 1>
+
+"POINTER TO SYMBOL"
+
+<SETG SS-DAT-SLOT 2>
+
+"DATUM OF THE SYMBOL"
+
+<SETG SS-STORED-SLOT 3>
+
+"IS THE SYMBOL STORED"
+
+<SETG SS-POTENT-SLOT 4>
+
+"IS THE SYMBOL POTENTIAL"
+
+<MANIFEST SS-SYM-SLOT SS-DAT-SLOT SS-STORED-SLOT SS-POTENT-SLOT>
+
+"MANIFESTS FOR PROG-AC"
+
+<SETG PROG-SLOT 1>
+
+<SETG NUM-SYM-SLOT 2>
+
+<SETG STORED-SLOT 3>
+
+<SETG INACS-SLOT 4>
+
+"MANIFESTED VARIABLES FOR SLOT STORE IN PROG-VARS"
+
+<SETG SYM-SLOT 1>
+
+<SETG SAVED-NUM-SYM-SLOT 2>
+
+<SETG SAVED-PROG-AC-SLOT 3>
+
+<SETG SAVED-POTLV-SLOT 4>
+
+<SETG LENGTH-PROG-VARS 4>
+
+"MANIFESTS FOR AGAIN AND RETURN STATES"
+
+<SETG SAVED-AC-STATE 1>
+
+<SETG SAVED-CODE:PTR 2>
+
+<SETG SAVED-STACK-STATE 3>
+
+<SETG SAVED-RET-FLAG 4>
+
+<SETG LENGTH-CONTROL-STATE 4>
+
+"OFFSETS FOR STACK:INFO"
+
+<SETG SAVED-FRMS 1>
+
+<SETG SAVED-BSTB 2>
+
+<SETG SAVED-NTSLOTS 3>
+
+<SETG SAVED-STK 4>
+
+"SLOTS FOR SAVED-AC-SLOT"
+
+<SETG CSYMT-SLOT 1>
+
+<SETG CINACS-SLOT 2>
+
+<SETG CSTORED-SLOT 3>
+
+<SETG CPOTLV-SLOT 4>
+
+<SETG LENGTH-CSTATE 4>
+
+"SLOTS FOR LOOP-VARS"
+
+<SETG LSYM-SLOT 1>
+
+<SETG LINACS-SLOT 2>
+
+<SETG LOOPVARS-LENGTH 2>
+
+<MANIFEST NUM-SYM-SLOT
+ LSYM-SLOT
+ LOOPVARS-LENGTH
+ LINACS-SLOT
+ SAVED-FRMS
+ CSYMT-SLOT
+ CINACS-SLOT
+ CSTORED-SLOT
+ CPOTLV-SLOT
+ LENGTH-CSTATE
+ SAVED-BSTB
+ SAVED-NTSLOTS
+ SAVED-STK
+ STORED-SLOT
+ INACS-SLOT
+ PROG-SLOT
+ SYM-SLOT
+ SAVED-NUM-SYM-SLOT
+ SAVED-POTLV-SLOT
+ SAVED-PROG-AC-SLOT
+ LENGTH-PROG-VARS
+ LENGTH-CONTROL-STATE
+ SAVED-AC-STATE
+ SAVED-CODE:PTR
+ SAVED-STACK-STATE
+ SAVED-RET-FLAG>
+
+<NEWTYPE COMMON
+ VECTOR
+ '<<PRIMTYPE VECTOR> ATOM <OR COMMON SYMTAB> FIX ANY <PRIMTYPE LIST>>>
+
+<SETG COMMON-TYPE <OFFSET 1 COMMON>>
+
+"TYPE OF COMMON (ATOM)"
+
+<SETG COMMON-SYMT <OFFSET 2 COMMON>>
+
+"POINTER TO OR COMMON SYMTAB"
+
+<SETG COMMON-ITEM <OFFSET 3 COMMON>>
+
+"3RD ARGUMENT TO NTH,REST,PUT ETC."
+
+<SETG COMMON-PRIMTYPE <OFFSET 4 COMMON>>
+
+"PRIMTYPE OF OBJECT IN COMMON"
+
+<SETG COMMON-DATUM <OFFSET 5 COMMON>>
+
+"DATUM FOR THIS COMMON"
+
+<MANIFEST COMMON-TYPE COMMON-SYMTAB COMMON-ITEM COMMON-PRIMTYPE COMMON-DATUM>
+
+<NEWTYPE TRANS
+ VECTOR
+ '<<PRIMTYPE VECTOR> NODE <UVECTOR [7 FIX]> <UVECTOR [7 FIX]>>>
+
+<DEFINE MESSAGE (SEVERITY STR "TUPLE" TEXT)
+ <AND <GASSIGNED? DEBUGSW> <ERROR .SEVERITY .STR>>
+ <MAPF <>
+ <FUNCTION (SEV ATM)
+ #DECL ((ATM SEV) ATOM)
+ <COND (<==? .SEV .SEVERITY>
+ <AND <ASSIGNED? .ATM> <SET .ATM T>>
+ <MAPLEAVE>)>>
+ '(ERROR NOTE WARNING INCONSISTANCY INCONSISTENCY)
+ '(ERRS NOTES WARNS INCONS INCONS)>
+ <PRINC "*** ">
+ <PRINC .SEVERITY> ;"Typically NOTE, WARNING, ERROR, or INCONSISTANCY"
+ <PRINC " ">
+ <PRINC .STR>
+ <REPEAT ()
+ <COND (<EMPTY? .TEXT> <RETURN 0>)
+ (<==? <TYPE <1 .TEXT>> ATOM> <PRINC <1 .TEXT>>)
+ (<TYPE? <1 .TEXT> NODE>
+ <COND (<GASSIGNED? NODE-COMPLAIN>
+ <TERPRI>
+ <NODE-COMPLAIN <1 .TEXT>>
+ <TERPRI>)>)
+ (ELSE <PRIN1 <1 .TEXT>>)>
+ <PRINC " "> ;"Space"
+ <SET TEXT <REST .TEXT>>>
+ <TERPRI>
+ <COND (<==? .SEVERITY ERROR> <RETURN " COMPILATION ABORTED " .COMPILER>)
+ (<OR <==? .SEVERITY INCONSISTANCY> <==? .SEVERITY INCONSISTENCY>>
+ <RETURN " INFORM BKD; OR CLR; " .COMPILER>)>
+ T>
+
+<SETG INSTRUCTION ,FORM>
+
+<ENDPACKAGE>
--- /dev/null
+
+<PACKAGE "COMPDEC">
+
+<ENTRY FCNS
+ TMPS
+ IDT
+ STYPES
+ PLUSINF
+ MINUSINF
+ IPUT
+ TEMPV
+ DEBUGSW
+ INSTRUCTION
+ INTH
+ FCN
+ IRSUBR
+ STACK
+ SNODES
+ PSTACK
+ ANY-AC
+ DUMMY-MAPF
+ INCONSISTENCY
+ SEGS
+ SPEC
+ CODVEC
+ QUOTE-CODE
+ RETURN-CODE
+ IPUT-CODE
+ SEG-CODE
+ PREDV
+ ACAGE
+ NUMACS
+ SYM-SLOT
+ SAVED-STK
+ PARENT
+ TYPE-INFO
+ PROG-VARS
+ CURRENT-TYPE
+ NODE1
+ PUTR-CODE
+ ISUBR-CODE
+ EOF-CODE
+ IREMAS-CODE
+ GVAL-CODE
+ SPARE4-CODE
+ ACRESIDUE
+ AC-F
+ LOOPVARS-LENGTH
+ ADDVAR
+ FSET-CODE
+ OFFPTR
+ CSYMT-SLOT
+ CPOTLV-SLOT
+ PROG-CODE
+ COMP-TYPES
+ INACS-SLOT
+ SAVED-STACK-STATE
+ NODE-NAME
+ AGND
+ REQARGS
+ LOOP-VARS
+ DECL-SYM
+ PUT-CODE
+ FLVAL-CODE
+ SETG-CODE
+ BACK-CODE
+ PUT-SAME-CODE
+ AC-E
+ SS-POTENT-SLOT
+ NUM-SYM-SLOT
+ RSUBR-DECLS
+ NODEF
+ AND-CODE
+ MT-CODE
+ BITS-CODE
+ PUTBITS-CODE
+ COPY-LIST-CODE
+ SPARE1-CODE
+ ACLINK
+ LINKED
+ SS-SYM-SLOT
+ ATAG
+ ASSUM
+ RETURN-STATES
+ PURE-SYM
+ NUM-SYM
+ KID
+ GNAME-SYM
+ CHTYPE-CODE
+ SAVED-NUM-SYM-SLOT
+ NODE
+ SYMTAB
+ INACS
+ USAGE-SYM
+ GDECL-SYM
+ MAP-CODE
+ MARGS-CODE
+ DATVAL
+ ALLACS
+ AC-D
+ SAVED-AC-STATE
+ NODE-SUBR
+ LIVE-VARS
+ SPEC-SYM
+ AS-NXT-CODE
+ SUBSTRUC-CODE
+ BIT-TEST-CODE
+ SPARE3-CODE
+ TMPAC
+ NO-RESIDUE
+ NOT-PREF
+ P-N-STO-RES
+ P-N-NO-STO-RES
+ FRMNO
+ NOT-CODE
+ TEST-CODE
+ MIN-MAX-CODE
+ READ-EOF2-CODE
+ TAG-CODE
+ LENGTH-CONTROL-STATE
+ SAVED-NTSLOTS
+ KIDS
+ PREDIC
+ MAKE:TAG
+ NODEPR
+ NODEFM
+ GNEXT-SYM
+ FIX-CODE
+ MFCN-CODE
+ IRSUBR-CODE
+ CASE-CODE
+ SCL
+ ACSYM
+ ACNUM
+ AC-C
+ P-N-CLEAN
+ CINACS-SLOT
+ NODE-TYPE
+ USLOTS
+ DEAD-VARS
+ DEATH-LIST
+ COMPOSIT-TYPE
+ PROG-AC
+ PRED
+ COPY-CODE
+ LENGTH?-CODE
+ AC
+ LINACS-SLOT
+ TMPLS
+ INIT-DECL-TYPE
+ NODECOND
+ FUNCTION-CODE
+ AGAIN-CODE
+ 0-TST-CODE
+ GETBITS-CODE
+ MAPRET-STOP-CODE
+ LSH-CODE
+ SYMBOL
+ SAVED-STATE
+ ACO
+ LENGTH-PROG-VARS
+ CSTORED-SLOT
+ NODEB
+ SET-CODE
+ ROT-CODE
+ AC-B
+ REGS
+ PROG-SLOT
+ SAVED-BSTB
+ BINDING-STRUCTURE
+ CDST
+ VSPCD
+ NAME-SYM
+ INIT-SYM
+ EQ-CODE
+ ALL-REST-CODE
+ DISPATCH
+ TMPNO
+ AC1SYM
+ REACS
+ LSYM-SLOT
+ DST
+ RTAG
+ ACCUM-TYPE
+ DATUM
+ ARGNUM-SYM
+ ADDR-SYM
+ STORED
+ USED-AT-ALL
+ POTLV
+ NAME
+ ARGNUM
+ FGVAL-CODE
+ ID-CODE
+ FORM-F-CODE
+ INFO-CODE
+ TEMP
+ STORED-RESIDUE
+ SAVED-POTLV-SLOT
+ SAVED-CODE:PTR
+ CLAUSES
+ TRG
+ VARTBL
+ LVARTBL
+ SUBR-CODE
+ LNTH-CODE
+ STACKFORM-CODE
+ ASSIGNED?-CODE
+ GET2-CODE
+ AS-IT-IND-VAL-CODE
+ COMMON
+ DATTYP
+ AC-A
+ ACS
+ RET-AGAIN-ONLY
+ SEGMENT-CODE
+ FSETG-CODE
+ ISTRUC-CODE
+ MFIRST-CODE
+ ACPREF
+ SS-STORED-SLOT
+ STORED-SLOT
+ STK-B
+ AGAIN-STATES
+ CODE-SYM
+ BST
+ RSUBR-CODE
+ 1?-CODE
+ REST-CODE
+ ABS-CODE
+ MPSBR-CODE
+ UNWIND-CODE
+ PRINT-CODE
+ OBLIST?-CODE
+ ADDRSYM
+ AC-H
+ LAST-AC-1
+ NOT-STORED-RESIDUE
+ P-N-LINKED
+ SAVED-RET-FLAG
+ SAVED-FRMS
+ STACKS
+ ASS?
+ BRANCH-CODE
+ LVAL-CODE
+ OR-CODE
+ ISTRUC2-CODE
+ READ-EOF-CODE
+ MAPLEAVE-CODE
+ MEMQ-CODE
+ REP-STATE
+ SS-DAT-SLOT
+ SAVED-PROG-AC-SLOT
+ LENGTH-CSTATE
+ RESULT-TYPE
+ SIDE-EFFECTS
+ SSLOTS
+ PRE-ALLOC
+ NEXT-SYM
+ FORM-CODE
+ TY?-CODE
+ FLOAT-CODE
+ GET-CODE
+ SPECS-START
+ BTP-B
+ SPCS-X
+ RES-TYP
+ GO-CODE
+ BITL-CODE
+ TOP-CODE
+ SPARE2-CODE
+ AC-G
+ LAST-AC
+ ATIME
+ ACTIVATED
+ TOTARGS
+ VTB
+ RQRG
+ COND-CODE
+ ARITH-CODE
+ NTH-CODE
+ MOD-CODE
+ ACPROT
+ IND
+ ALL
+ NOTE
+ WARNING
+ PRIM-CODE
+ DONT-CARE
+ FLUSHED
+ NO-RETURN
+ NO-DATUM
+ MESSAGE
+ GROUP-NAME
+ FUZZ
+ COMMON-TYPE
+ COMMON-SYMTAB
+ COMMON-ITEM
+ COMMON-PRIMTYPE
+ COMMON-DATUM
+ COMMON-SYMT
+ TRANSFORM
+ TRANS
+ N0?
+ POPWR2
+ DEALLOCATE
+ TOKEN
+ ERRS
+ WARNS
+ NOTES
+ DEBUG-COMPILE
+ REASONABLE
+ CAREFUL
+ PRECOMPILED
+ HAIRY-ANALYSIS
+ SRC-FLG
+ BIN-FLG
+ GLOSP
+ ANALY-OK
+ VERBOSE
+ COMPILER
+ IND
+ ADDRESS:C>
+
+
+<SETG PLUSINF <CHTYPE <MIN> FIX>>
+
+<SETG MINUSINF <CHTYPE <MAX> FIX>>
+
+"Type specification for NODE."
+
+<NEWTYPE NODE
+ VECTOR
+ '<VECTOR FIX
+ ANY
+ ANY
+ ANY
+ <LIST [REST NODE]>
+ FIX
+ <OR FALSE ATOM>
+ [REST
+ LIST
+ ANY
+ ANY
+ LIST
+ FIX
+ SYMTAB
+ FIX
+ FIX
+ <OR FALSE ATOM>
+ ATOM
+ ANY
+ LIST
+ LIST
+ ANY
+ ANY
+ ANY
+ ANY
+ ANY
+ ANY
+ ANY
+ <PRIMTYPE LIST>
+ FIX
+ FIX
+ LIST
+ LIST
+ LIST
+ LIST
+ LIST]>>
+
+"Offsets into pass 1 structure entities and functions to create same."
+
+<SETG NODE-TYPE <OFFSET 1 NODE>>
+
+;"Code specifying the node type."
+
+<SETG PARENT <OFFSET 2 NODE>>
+
+;"Pointer to parent node."
+
+<SETG RESULT-TYPE <OFFSET 3 NODE>>
+
+;"Type expression for result returned by code
+ generated by this node."
+
+<SETG NODE-NAME <OFFSET 4 NODE>>
+
+;"Usually name of SUBR associated with this node."
+
+<SETG KIDS <OFFSET 5 NODE>>
+
+;"List of sub-nodes for this node."
+
+<SETG STACKS <OFFSET 6 NODE>>
+
+;"Amount of stack needed by this node."
+
+<SETG SEGS <OFFSET 7 NODE>>
+
+;"Predicate: any segments among kids?"
+
+<SETG TYPE-INFO <OFFSET 8 NODE>>
+
+;"Points to transient type info for this node."
+
+<SETG SIDE-EFFECTS <OFFSET 9 NODE>>
+
+;"General info about side effects (format not yet firm.)"
+
+<SETG RSUBR-DECLS <OFFSET 10 NODE>>
+
+;"Function only: final rsubr decls."
+
+<SETG BINDING-STRUCTURE <OFFSET 11 NODE>>
+
+;"Partially compiled arg list."
+
+<SETG SPECS-START <OFFSET 12 NODE>>
+
+;"Offset to 1st special."
+
+<SETG SYMTAB <OFFSET 13 NODE>>
+
+;"Pointer to local symbol table."
+
+<SETG SSLOTS <OFFSET 14 NODE>>
+
+;"Number of specials."
+
+<SETG USLOTS <OFFSET 15 NODE>>
+
+;"Number of unspecials."
+
+<SETG ACTIVATED <OFFSET 16 NODE>>
+
+;"Predicate: any named activation?"
+
+<SETG TMPLS <OFFSET 17 NODE>>
+
+;"Offset to unamed temps."
+
+<SETG PRE-ALLOC <OFFSET 18 NODE>>
+
+;"Variable slots allocated in advance."
+
+<SETG STK-B <OFFSET 19 NODE>>
+
+;"Base of stack at entry."
+
+<SETG BTP-B <OFFSET 20 NODE>>
+
+;"Base of stack after bindings."
+
+<SETG SPCS-X <OFFSET 21 NODE>>
+
+;"Predicate: any specials bound?"
+
+<SETG DST <OFFSET 22 NODE>>
+
+;"Destination spec for value of node."
+
+<SETG CDST <OFFSET 23 NODE>>
+
+;"Current destination used."
+
+<SETG ATAG <OFFSET 24 NODE>>
+
+;"Label for local againing."
+
+<SETG RTAG <OFFSET 25 NODE>>
+
+;"Label for local Returning."
+
+<SETG ASSUM <OFFSET 26 NODE>>
+
+;"Node type assumptions."
+
+<SETG AGND <OFFSET 27 NODE>>
+
+;"Predicate: Again possible?"
+
+<SETG ACS <OFFSET 28 NODE>>
+
+;"Predicate: AC call possible? (if not false
+ ac structure)"
+
+<SETG TOTARGS <OFFSET 29 NODE>>
+
+;"Total number of args (including optional)."
+
+<SETG REQARGS <OFFSET 30 NODE>>
+
+;"Required arguemnts."
+
+<SETG LOOP-VARS <OFFSET 31 NODE>>
+
+"Variables kept in acs thru loop."
+
+<SETG AGAIN-STATES <OFFSET 32 NODE>>
+
+"States at agains"
+
+<SETG RETURN-STATES <OFFSET 33 NODE>>
+
+"States at repeats."
+
+<SETG PROG-VARS <OFFSET 34 NODE>>
+
+"Vars handled in this prog/repeat."
+
+;"Information used for merging states with prog-nodes"
+
+<SETG CLAUSES <OFFSET <INDEX ,KIDS> NODE>>
+
+;"For COND clauses."
+
+<SETG NODE-SUBR <OFFSET <INDEX ,RSUBR-DECLS> NODE>>
+
+;"For many nodes, the SUBR (not its name)."
+
+<SETG PREDIC <OFFSET <INDEX ,NODE-NAME> NODE>>
+
+;"For cond clause nodes, the predicate."
+
+<SETG ACCUM-TYPE <OFFSET <INDEX ,DST> NODE>>
+
+;"Accumulated type from all returns etc."
+
+<SETG DEAD-VARS <OFFSET <INDEX ,CDST> NODE>>
+
+<SETG LIVE-VARS <OFFSET <INDEX ,TYPE-INFO> NODE>>
+
+<SETG VSPCD <OFFSET <INDEX ,ATAG> NODE>>
+
+<SETG INIT-DECL-TYPE <OFFSET <INDEX ,RTAG> NODE>>
+
+" Definitions associated with compiler symbol tables."
+
+"Offsets for variable description blocks"
+
+<NEWTYPE SYMTAB
+ VECTOR
+ '<VECTOR <PRIMTYPE VECTOR>
+ ATOM
+ <OR FALSE ATOM>
+ FIX
+ <OR ATOM FIX>
+ <OR FALSE ATOM>
+ LIST
+ ANY
+ ANY
+ FIX
+ <OR FALSE NODE>
+ <OR FALSE 'T>
+ <OR FALSE DATUM LIST>
+ <OR FALSE 'T>
+ <OR FALSE 'T>
+ LIST
+ ANY
+ ANY
+ <OR FALSE FIX>>>
+
+<SETG NEXT-SYM <OFFSET 1 SYMTAB>>
+
+;"Pointer to next symbol table entry."
+
+<SETG NAME-SYM <OFFSET 2 SYMTAB>>
+
+;"Name of variable."
+
+<SETG SPEC-SYM <OFFSET 3 SYMTAB>>
+
+;"Predicate: special?"
+
+<SETG CODE-SYM <OFFSET 4 SYMTAB>>
+
+;"Code specifying whether AUX, OPTIONAL etc."
+
+<SETG ARGNUM-SYM <OFFSET 5 SYMTAB>>
+
+;"If an argument, which one."
+
+<SETG PURE-SYM <OFFSET 6 SYMTAB>>
+
+;"Predicate: unchanged in function?"
+
+<SETG DECL-SYM <OFFSET 7 SYMTAB>>
+
+;"Decl for this variable."
+
+<SETG ADDR-SYM <OFFSET 8 SYMTAB>>
+
+;"Where do I live?"
+
+<SETG INIT-SYM <OFFSET 9 SYMTAB>>
+
+;"Predicate: initial value? if so what."
+
+<SETG FRMNO <OFFSET 10 SYMTAB>>
+
+;"ID of my frame."
+
+<SETG RET-AGAIN-ONLY <OFFSET 11 SYMTAB>>
+
+;"Predicate: used only in AGAIN/RETURN?"
+
+<SETG ASS? <OFFSET 12 SYMTAB>>
+
+;"Predicate: used in ASSIGNED?"
+
+<SETG INACS <OFFSET 13 SYMTAB>>
+
+;"Predicate: currently in some AC?"
+
+<SETG STORED <OFFSET 14 SYMTAB>>
+
+;"Predicate: stored in slot?"
+
+<SETG USED-AT-ALL <OFFSET 15 SYMTAB>>
+
+;"Predicate: symbolused at all."
+
+<SETG DEATH-LIST <OFFSET 16 SYMTAB>>
+
+;"List of info associated with life time."
+
+<SETG CURRENT-TYPE <OFFSET 17 SYMTAB>>
+
+;"Current decl determined by analysis"
+
+<SETG COMPOSIT-TYPE <OFFSET 18 SYMTAB>>
+
+<SETG USAGE-SYM <OFFSET 19 SYMTAB>>
+
+"How a variable is used in a loop."
+
+<SETG PROG-AC <OFFSET <INDEX ,CURRENT-TYPE> SYMTAB>>
+
+<SETG NUM-SYM <OFFSET <INDEX ,COMPOSIT-TYPE> SYMTAB>>
+
+<SETG POTLV <OFFSET <INDEX ,USED-AT-ALL> SYMTAB>>
+
+
+"Slot used to store information for variables in loops."
+
+;"Type as figured out by all uses of symbol."
+
+<DEFINE NODE1 (TYP PAR RES-TYP NAME KID)
+ <CHTYPE [.TYP .PAR .RES-TYP .NAME .KID 0 <>] NODE>>
+
+"Create a function node with all its hair."
+
+<DEFINE NODEF (TYP PAR RES-TYP NAME KID RSD BST HAT VTB ACS? TRG RQRG)
+ <CHTYPE [.TYP .PAR .RES-TYP .NAME .KID 0 <> () <> .RSD .BST 0 .VTB 0
+ 0 <> <MAKE:TAG "FRM"> <> () () <> <> <> <> .RES-TYP <> <>
+ .ACS? .TRG .RQRG] NODE>>
+
+"Create a PROG/REPEAT node with nearly as much hair."
+
+<DEFINE NODEPR (TYP PAR RES-TYP NAME KID VL BST HAT VTB)
+ <CHTYPE [.TYP
+ .PAR
+ .RES-TYP
+ .NAME
+ .KID
+ 0
+ <>
+ ()
+ <>
+ .VL
+ .BST
+ 0
+ .VTB
+ 0
+ 0
+ <>
+ <MAKE:TAG "FRM">
+ <>
+ ()
+ ()
+ <>
+ <>
+ <>
+ <>
+ .RES-TYP
+ <>
+ <>
+ <>
+ 0
+ 0
+ ()
+ ()
+ ()
+ ()]
+ NODE>>
+
+"Create a COND node."
+
+<DEFINE NODECOND (TYP PAR RES-TYP NAME CLAU)
+ <CHTYPE [.TYP .PAR .RES-TYP .NAME .CLAU 0 <> () <>] NODE>>
+
+"Create a node for a COND clause."
+
+<DEFINE NODEB (TYP PAR RES-TYP PRED CLAU)
+ <CHTYPE [.TYP .PAR .RES-TYP .PRED .CLAU 0 <> () <>] NODE>>
+
+"Create a node for a SUBR call etc."
+
+<DEFINE NODEFM (TYP PAR RES-TYP NAME KID SUB)
+ <CHTYPE [.TYP .PAR .RES-TYP .NAME .KID 0 <> () <> .SUB] NODE>>
+\f
+
+<DEFINE ADDVAR (NAM SPEC CODE ARGNUM PURE DCL ADDR INIT)
+ <SET VARTBL <CHTYPE [.VARTBL .NAM .SPEC .CODE .ARGNUM .PURE .DCL .ADDR .INIT 0 <>
+ <> <> T <> () <> ANY 0] SYMTAB>>>
+
+
+"Some specialized decl stuff."
+
+<SETG LVARTBL
+ <PROG ((VARTBL []))
+ #DECL ((VARTBL) <SPECIAL ANY>)
+ <ADDVAR OBLIST T -1 0 T '(<OR LIST OBLIST>) <> <>>
+ <ADDVAR OUTCHAN T -1 0 T '(CHANNEL) <> <>>
+ <ADDVAR INCHAN T -1 0 T '(CHANNEL) <> <>>
+ .VARTBL>>
+
+<PUT CHANNEL DECL '<CHANNEL FIX [11 ANY] [5 FIX]>>
+
+<PUT STRING DECL '<STRING [REST CHARACTER]>>
+
+<PUT OBLIST DECL '<UVECTOR [REST <LIST [REST <OR ATOM LINK>]>]>>
+
+"Codes for the node types in the tree built by pass1 and modified by
+other passes."
+
+"Give symbolic codes arbitrary increasing values."
+
+<PROG ((N 1))
+ <SETG CODVEC
+ <MAPF ,UVECTOR
+ <FUNCTION (ATM) <SETG .ATM .N> <SET N <+ .N 1>> .ATM>
+ ![FUNCTION-CODE
+ QUOTE-CODE
+ SEGMENT-CODE
+ FORM-CODE
+ PROG-CODE
+ SUBR-CODE
+ COND-CODE
+ BRANCH-CODE
+ RSUBR-CODE
+ LVAL-CODE
+ SET-CODE
+ OR-CODE
+ AND-CODE
+ RETURN-CODE
+ COPY-CODE
+ GO-CODE
+ AGAIN-CODE
+ ARITH-CODE
+ 0-TST-CODE
+ NOT-CODE
+ 1?-CODE
+ TEST-CODE
+ EQ-CODE
+ TY?-CODE
+ LNTH-CODE
+ MT-CODE
+ NTH-CODE
+ REST-CODE
+ PUT-CODE
+ PUTR-CODE
+ FLVAL-CODE
+ FSET-CODE
+ FGVAL-CODE
+ FSETG-CODE
+ MIN-MAX-CODE
+ STACKFORM-CODE
+ CHTYPE-CODE
+ ABS-CODE
+ FIX-CODE
+ FLOAT-CODE
+ MOD-CODE
+ ID-CODE
+ ASSIGNED?-CODE
+ ISTRUC-CODE
+ ISTRUC2-CODE
+ BITS-CODE
+ BITL-CODE
+ GETBITS-CODE
+ PUTBITS-CODE
+ MAP-CODE
+ MFCN-CODE
+ ISUBR-CODE
+ READ-EOF-CODE
+ READ-EOF2-CODE
+ EOF-CODE
+ GET-CODE
+ GET2-CODE
+ IPUT-CODE
+ IREMAS-CODE
+ IRSUBR-CODE
+ MARGS-CODE
+ MPSBR-CODE
+ MAPLEAVE-CODE
+ MAPRET-STOP-CODE
+ UNWIND-CODE
+ GVAL-CODE
+ SETG-CODE
+ SEG-CODE
+ LENGTH?-CODE
+ TAG-CODE
+ MFIRST-CODE
+ PRINT-CODE
+ MEMQ-CODE
+ FORM-F-CODE
+ INFO-CODE
+ OBLIST?-CODE
+ AS-NXT-CODE
+ AS-IT-IND-VAL-CODE
+ ALL-REST-CODE
+ CASE-CODE
+ SUBSTRUC-CODE
+ BACK-CODE
+ TOP-CODE
+ COPY-LIST-CODE
+ PUT-SAME-CODE
+ ROT-CODE
+ LSH-CODE
+ BIT-TEST-CODE
+ SPARE1-CODE
+ SPARE2-CODE
+ SPARE3-CODE
+ SPARE4-CODE!]>>
+ <SETG COMP-TYPES .N>>
+
+
+<USE "NPRINT">
+
+"Build a dispatch table based on node types."
+
+<DEFINE DISPATCH (DEFAULT "TUPLE" PAIRS
+ "AUX" (TT <IVECTOR ,COMP-TYPES '.DEFAULT>))
+ #DECL ((PAIRS) <TUPLE [REST <LIST FIX ANY>]>
+ (TT) VECTOR)
+ <REPEAT ((PAIR '(1 1))) #DECL ((PAIR) <LIST FIX ANY>)
+ <COND (<EMPTY? .PAIRS><RETURN .TT>)>
+ <PUT .TT <1 <SET PAIR <1 .PAIRS>>> <2 .PAIR>>
+ <SET PAIRS <REST .PAIRS>>>>
+
+<SETG PREDV <IUVECTOR ,COMP-TYPES 0>>
+
+<MAPF <>
+ <FUNCTION (N) <PUT ,PREDV .N 1>>
+ ![,0-TST-CODE
+ ,1?-CODE
+ ,NOT-CODE
+ ,TEST-CODE
+ ,EQ-CODE
+ ,TY?-CODE
+ ,MT-CODE
+ ,OR-CODE
+ ,AND-CODE
+ ,ASSIGNED?-CODE
+ ,ISUBR-CODE
+ ,NTH-CODE
+ ,MEMQ-CODE
+ ,LENGTH?-CODE
+ ,OBLIST?-CODE
+ ,AS-NXT-CODE
+ ,COND-CODE
+ ,BIT-TEST-CODE!]>
+
+"Predicate: does this type have special predicate code?"
+
+<PUT REP-STATE
+ DECL
+ '<LIST [5 <LIST [REST SYMTAB DATUM <OR FALSE ATOM> <OR ATOM FALSE>]>]>>
+
+<PUT SYMBOL DECL '<OR SYMTAB TEMP COMMON>>
+
+<NEWTYPE TEMP VECTOR '<VECTOR SCL <OR FALSE DATUM>>>
+
+<NEWTYPE SAVED-STATE
+ LIST
+ '<LIST [REST
+ <LIST AC
+ <OR FALSE <LIST [REST SYMBOL]>>
+ [REST <LIST SYMBOL [3 ANY]>]>]>>
+
+<SETG TMPNO <OFFSET 1 TEMP>>
+
+<SETG TMPAC <OFFSET 2 TEMP>>
+
+<SETG DATTYP <OFFSET 1 DATUM>>
+
+<SETG DATVAL <OFFSET 2 DATUM>>
+
+<SETG ADDRSYM <OFFSET 1 AC>>
+
+<SETG ACSYM <OFFSET 2 AC>>
+
+<SETG ACLINK <OFFSET 3 AC>>
+
+<SETG ACAGE <OFFSET 4 AC>>
+
+<SETG ACNUM <OFFSET 5 AC>>
+
+<SETG ACPROT <OFFSET 6 AC>>
+
+<SETG AC1SYM <OFFSET 7 AC>>
+
+<SETG ACRESIDUE <OFFSET 8 AC>>
+
+<SETG ACPREF <OFFSET 9 AC>>
+
+<NEWTYPE AC
+ VECTOR
+ '<<PRIMTYPE VECTOR> <PRIMTYPE WORD>
+ <PRIMTYPE WORD>
+ <OR <LIST [REST DATUM]> FALSE>
+ FIX
+ FIX
+ <OR FALSE ATOM>
+ <PRIMTYPE WORD>
+ <OR FALSE LIST>
+ <OR FALSE ATOM>>>
+
+<NEWTYPE DATUM
+ LIST
+ '<<PRIMTYPE LIST> <OR ATOM <PRIMTYPE LIST> <PRIMTYPE VECTOR>>
+ <OR ATOM <PRIMTYPE LIST> <PRIMTYPE VECTOR>>>>
+
+<NEWTYPE OFFPTR LIST '<<PRIMTYPE LIST> FIX DATUM ATOM>>
+
+<NEWTYPE TEMPV LIST>
+
+<NEWTYPE IRSUBR LIST>
+
+"A TOKEN GIVES INFORMATION TO CUP"
+
+<NEWTYPE TOKEN VECTOR '<<PRIMTYPE VECTOR> FIX>>
+
+<NEWTYPE ADDRESS:PAIR LIST>
+
+<NEWTYPE ADDRESS:C LIST>
+
+<SETG ALLACS
+ <MAPF ,UVECTOR
+ <FUNCTION (N1 N2 N N+1 NAME "AUX" THISAC)
+ <SETG .NAME <SET THISAC <CHTYPE [.N1 .N2 <> 0 .N <> .N+1 <> <>] AC>>>
+ <EVAL <FORM GDECL (.NAME) AC>> .THISAC>
+ ![`A `B `C `D `E `F `TVP `SP!]
+ ![`A* `B* `C* `D* `E* `F* `TVP* `SP*!]
+ ![1 2 3 4 5 6 7 8!]
+ ![`B* `C* `D* `E* `F* `TVP* `SP* `AB*!]
+ ![AC-A AC-B AC-C AC-D AC-E AC-F AC-G AC-H!]>>
+
+<SETG NUMACS <LENGTH ,ALLACS>>
+
+<SETG LAST-AC ,AC-H>
+
+<SETG LAST-AC-1 ,AC-G>
+
+<DEFINE REACS ()
+ <MAPF <>
+ <FUNCTION (AC)
+ #DECL ((AC) AC)
+ <PUT .AC ,ACLINK <>>
+ <PUT .AC ,ACPROT <>>
+ <PUT .AC ,ACAGE 0>
+ <PUT .AC ,ACRESIDUE <>>
+ <PUT .AC ,ACPREF <>>>
+ ,ALLACS>
+ <SETG REGS 8>
+ <SETG ATIME 0>>
+
+<GDECL (ALLACS) !<UVECTOR [8 AC]> (ATIME REGS) FIX (LAST-AC LAST-AC-1 AC0) AC>
+
+<MANIFEST SS-SYM-SLOT SS-DAT-SLOT SS-STORED-SLOT SS-POTENT-SLOT>
+
+<MANIFEST TMPFRM TMPNO THOME TUSERS DATTYP DATVAL ADDRSYM ACSYM ACLINK ACAGE
+ ACNUM ACPROT AC1SYM ACRESIDUE ACPREF ACINUSE TMPAC COMMON-DATUM
+ NUMACS POTLV>
+
+<MAPF <> ,MANIFEST ,CODVEC>
+
+<MANIFEST TOT-MODES RESTS RMODES COMP-TYPES
+GDECL-SYM GNAME-SYM GNEXT-SYM FRMNO INIT-SYM ADDR-SYM TOTARGS REQARGS
+DECL-SYM PURE-SYM ARGNUM-SYM CODE-SYM SPEC-SYM NAME-SYM NEXT-SYM PREDIC
+NODE-SUBR CLAUSES ACS TMPLS ACTIVATED USLOTS SSLOTS SYMTAB SPECS-START
+BINDING-STRUCTURE RSUBR-DECLS SEGS STACKS KIDS NODE-NAME RESULT-TYPE PARENT
+NODE-TYPE SIDE-EFFECTS RET-AGAIN-ONLY ASS? INACS STORED DST CDST ACCUM-TYPE
+INIT-DECL-TYPE VSPCD AGND ASSUM RTAG ATAG SPCS-X BTP-B STK-B PRE-ALLOC
+USED-AT-ALL CURRENT-TYPE DEATH-LIST COMPOSIT-TYPE AGAIN-STATES RETURN-STATES
+PROG-VARS LOOP-VARS PROG-AC NUM-SYM TYPE-INFO USAGE-SYM LIVE-VARS
+DEAD-VARS>
+
+<REACS>
+
+<SETG LINKED 1>
+
+<SETG NO-RESIDUE 10000000>
+
+<SETG STORED-RESIDUE 1000000>
+
+<SETG NOT-STORED-RESIDUE 100000>
+
+<SETG NOT-PREF 10000>
+
+<SETG P-N-CLEAN 1000>
+
+<SETG P-N-STO-RES 100>
+
+<SETG P-N-NO-STO-RES 10>
+
+<SETG P-N-LINKED 1>
+
+<MANIFEST LINKED
+ NO-RESIDUE
+ STORED-RESIDUE
+ NOT-STORED-RESIDUE
+ NOT-PREF
+ P-N-LINKED
+ P-N-CLEAN
+ P-N-STO-RES
+ P-N-NO-STO-RES>
+
+<SETG ACO <CHTYPE [`O* `O* <> 0 0 <> `A* <> <>] AC>>
+
+<SETG SS-SYM-SLOT 1>
+
+"POINTER TO SYMBOL"
+
+<SETG SS-DAT-SLOT 2>
+
+"DATUM OF THE SYMBOL"
+
+<SETG SS-STORED-SLOT 3>
+
+"IS THE SYMBOL STORED"
+
+<SETG SS-POTENT-SLOT 4>
+
+"IS THE SYMBOL POTENTIAL"
+
+<MANIFEST SS-SYM-SLOT SS-DAT-SLOT SS-STORED-SLOT SS-POTENT-SLOT>
+
+"MANIFESTS FOR PROG-AC"
+
+<SETG PROG-SLOT 1>
+
+<SETG NUM-SYM-SLOT 2>
+
+<SETG STORED-SLOT 3>
+
+<SETG INACS-SLOT 4>
+
+"MANIFESTED VARIABLES FOR SLOT STORE IN PROG-VARS"
+
+<SETG SYM-SLOT 1>
+
+<SETG SAVED-NUM-SYM-SLOT 2>
+
+<SETG SAVED-PROG-AC-SLOT 3>
+
+<SETG SAVED-POTLV-SLOT 4>
+
+<SETG LENGTH-PROG-VARS 4>
+
+"MANIFESTS FOR AGAIN AND RETURN STATES"
+
+<SETG SAVED-AC-STATE 1>
+
+<SETG SAVED-CODE:PTR 2>
+
+<SETG SAVED-STACK-STATE 3>
+
+<SETG SAVED-RET-FLAG 4>
+
+<SETG LENGTH-CONTROL-STATE 4>
+
+"OFFSETS FOR STACK:INFO"
+
+<SETG SAVED-FRMS 1>
+
+<SETG SAVED-BSTB 2>
+
+<SETG SAVED-NTSLOTS 3>
+
+<SETG SAVED-STK 4>
+
+"SLOTS FOR SAVED-AC-SLOT"
+
+<SETG CSYMT-SLOT 1>
+
+<SETG CINACS-SLOT 2>
+
+<SETG CSTORED-SLOT 3>
+
+<SETG CPOTLV-SLOT 4>
+
+<SETG LENGTH-CSTATE 4>
+
+"SLOTS FOR LOOP-VARS"
+
+<SETG LSYM-SLOT 1>
+
+<SETG LINACS-SLOT 2>
+
+<SETG LOOPVARS-LENGTH 2>
+
+<MANIFEST NUM-SYM-SLOT
+ LSYM-SLOT
+ LOOPVARS-LENGTH
+ LINACS-SLOT
+ SAVED-FRMS
+ CSYMT-SLOT
+ CINACS-SLOT
+ CSTORED-SLOT
+ CPOTLV-SLOT
+ LENGTH-CSTATE
+ SAVED-BSTB
+ SAVED-NTSLOTS
+ SAVED-STK
+ STORED-SLOT
+ INACS-SLOT
+ PROG-SLOT
+ SYM-SLOT
+ SAVED-NUM-SYM-SLOT
+ SAVED-POTLV-SLOT
+ SAVED-PROG-AC-SLOT
+ LENGTH-PROG-VARS
+ LENGTH-CONTROL-STATE
+ SAVED-AC-STATE
+ SAVED-CODE:PTR
+ SAVED-STACK-STATE
+ SAVED-RET-FLAG>
+
+<NEWTYPE COMMON
+ VECTOR
+ '<<PRIMTYPE VECTOR> ATOM <OR COMMON SYMTAB> FIX ANY <PRIMTYPE LIST>>>
+
+<SETG COMMON-TYPE <OFFSET 1 COMMON>>
+
+"TYPE OF COMMON (ATOM)"
+
+<SETG COMMON-SYMT <OFFSET 2 COMMON>>
+
+"POINTER TO OR COMMON SYMTAB"
+
+<SETG COMMON-ITEM <OFFSET 3 COMMON>>
+
+"3RD ARGUMENT TO NTH,REST,PUT ETC."
+
+<SETG COMMON-PRIMTYPE <OFFSET 4 COMMON>>
+
+"PRIMTYPE OF OBJECT IN COMMON"
+
+<SETG COMMON-DATUM <OFFSET 5 COMMON>>
+
+"DATUM FOR THIS COMMON"
+
+<MANIFEST COMMON-TYPE COMMON-SYMTAB COMMON-ITEM COMMON-PRIMTYPE COMMON-DATUM>
+
+<NEWTYPE TRANS
+ VECTOR
+ '<<PRIMTYPE VECTOR> NODE <UVECTOR [7 FIX]> <UVECTOR [7 FIX]>>>
+
+<DEFINE MESSAGE (SEVERITY STR "TUPLE" TEXT)
+ <AND <GASSIGNED? DEBUGSW> <ERROR .SEVERITY .STR>>
+ <MAPF <>
+ <FUNCTION (SEV ATM)
+ #DECL ((ATM SEV) ATOM)
+ <COND (<==? .SEV .SEVERITY>
+ <AND <ASSIGNED? .ATM> <SET .ATM T>>
+ <MAPLEAVE>)>>
+ '(ERROR NOTE WARNING INCONSISTANCY INCONSISTENCY)
+ '(ERRS NOTES WARNS INCONS INCONS)>
+ <PRINC "*** ">
+ <PRINC .SEVERITY> ;"Typically NOTE, WARNING, ERROR, or INCONSISTANCY"
+ <PRINC " ">
+ <PRINC .STR>
+ <REPEAT ()
+ <COND (<EMPTY? .TEXT> <RETURN 0>)
+ (<==? <TYPE <1 .TEXT>> ATOM> <PRINC <1 .TEXT>>)
+ (<TYPE? <1 .TEXT> NODE>
+ <COND (<GASSIGNED? NODE-COMPLAIN>
+ <TERPRI>
+ <NODE-COMPLAIN <1 .TEXT>>
+ <TERPRI>)>)
+ (ELSE <PRIN1 <1 .TEXT>>)>
+ <PRINC " "> ;"Space"
+ <SET TEXT <REST .TEXT>>>
+ <TERPRI>
+ <COND (<==? .SEVERITY ERROR> <RETURN " COMPILATION ABORTED " .COMPILER>)
+ (<OR <==? .SEVERITY INCONSISTANCY> <==? .SEVERITY INCONSISTENCY>>
+ <RETURN " INFORM BKD; OR CLR; " .COMPILER>)>
+ T>
+
+<SETG INSTRUCTION ,FORM>
+
+<ENDPACKAGE>
+\ 3
\ No newline at end of file
--- /dev/null
+<PACKAGE "COMSUB">
+
+<ENTRY SUBSTRUC-GEN>
+
+<USE "CODGEN" "CACS" "CHKDCL" "COMCOD" "COMPDEC" "STRGEN">
+
+
+"ROUTINES TO GENERATE SUBSTRUCT FOR THE COMPILER. CURRENTLY ONLY\r
+ HACKS UVECTOR AND VECTOR
+ CASES 1) COPYING (ALWAYS HACKED) (I.E 1 ARG)
+ 2) COPYING PORTIONS (2 OR 3 ARGS) (ALWAYS HACKED)
+ 3) COPYING INTO STRUCTURES HACKED IN 2 CASES
+ <SUBSTRUC .X .N1 .N2 <REST .X>>
+ <SUBSTRUC <REST .X> .N1 .N2 .X>"
+
+"NODE STRUCTURE IS FAIRLY MUNGED TO ALLOW FOR REASONABILITY.
+ 1==> STRUCTURE NODE
+ THIS IS ACTUALLY RESTED
+ 2==> NUMBER NODE (IF IT EXISTS)
+ 3==> RESTED STRUCTURE NODE (IF IT EXISTS)
+ DECISION AS TO FOURTH ARG WILL TRY TO BE MADE DURING PASS1 OR SYMANA"
+
+<DEFINE SUBSTRUC-GEN (NOD WHERE
+ "AUX" (K <KIDS .NOD>) (STRNOD <1 .K>)
+ (TPS <STRUCTYP <RESULT-TYPE .STRNOD>>) L)
+ #DECL ((NOD) NODE (WHERE) <OR ATOM DATUM> (K) <LIST [REST NODE]>)
+ <COND (<1? <SET L <LENGTH .K>>> <COPY-SB-GEN .STRNOD .TPS .WHERE>)
+ (<==? .L 2> <COPY-ELE-SB-GEN .STRNOD .TPS <2 .K> .WHERE>)
+ (<==? .L 3> <COPY-INTO-SB-GEN .STRNOD .TPS <2 .K> <3 .K> .WHERE>)
+ (<MESSAGE INCONSISTENCY "BAD NODE TO SUBSTRUC">)>>
+
+\\f
+
+"ROUTINE TO COPY INTO A NEW STRUCTION (1 OR 2 ARGUMENT SUBSTRUCTS."
+
+<DEFINE COPY-SB-GEN (STRNOD TPS WHERE
+ "AUX" SDAT TDAT NDAT NAC SAC (END-LABEL <MAKE:TAG "SUB">)
+ TAC)
+ #DECL ((STRNOD) NODE (TPS) ATOM (WHERE) <OR ATOM DATUM>
+ (SDAT TDAT NDAT) DATUM (TAC NAC SAC) AC)
+ <SET SDAT <GEN .STRNOD DONT-CARE>>
+ <COND (<==? <DATVAL .SDAT> ,AC-A>
+ <MUNG-AC ,AC-A .SDAT>
+ <EMIT <INSTRUCTION `HLRE `A* `A >>)
+ (<SGETREG ,AC-A <>>
+ <EMIT <INSTRUCTION `HLRE `A* !<ADDR:VALUE .SDAT>>>)>
+ <REGSTO T>
+ <EMIT <INSTRUCTION `MOVNS `A >>
+ <EMIT <INSTRUCTION `PUSH `P* `A >>
+ <SET TDAT <GEN-COPY .TPS>>
+ <SET TAC <DATVAL .TDAT>>
+ <PUT .TAC ,ACPROT T>
+ <SET NDAT <DATUM FIX ANY-AC>>
+ <SET NAC <GETREG .NDAT>>
+ <PUT .NDAT ,DATVAL .NAC>
+ <SET NAC <DATVAL .NDAT>>
+ <EMIT <INSTRUCTION `POP `P* <ADDRSYM .NAC>>>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM .NAC> .END-LABEL>>
+ <EMIT <INSTRUCTION `ADDI <ACSYM .NAC> (<ADDRSYM .TAC>)>>
+ <PUT .NAC ,ACPROT T>
+ <TOACV .SDAT>
+ <SET SAC <DATVAL .SDAT>>
+ <BLTAC .SAC .TAC .NAC <==? .TPS UVECTOR> .SDAT>
+ <PUT .NAC ,ACPROT <>>
+ <RET-TMP-AC .SDAT>
+ <PUT .TAC ,ACPROT <>>
+ <PUT .NAC ,ACPROT <>>
+ <RET-TMP-AC .NDAT>
+ <LABEL:TAG .END-LABEL>
+ <MOVE:ARG .TDAT .WHERE>>
+
+\\f
+
+"HERE FOR 3 ARGUMENT SUBSTRUCS"
+
+<DEFINE COPY-ELE-SB-GEN (STRNOD TPS NUMNOD WHERE
+ "AUX" TDAT (SDAT <>) NDAT
+ (NUM
+ <COND (<==? <NODE-TYPE .NUMNOD> ,QUOTE-CODE>
+ <NODE-NAME .NUMNOD>)>) TAC
+ (END-LABEL <MAKE:TAG "SUB">) (ONO .NO-KILL)
+ (NO-KILL .ONO) NAC SAC)
+ #DECL ((STRNOD NUMNOD) NODE (TPS) ATOM (WHERE) <OR ATOM DATUM>
+ (SDAT) <OR FALSE DATUM> (NDAT TDAT) DATUM (TAC NAC SAC) AC
+ (NO-KILL) <SPECIAL LIST>)
+ <COND (.NUM
+ <COND (<L? .NUM 0> <MESSAGE ERROR "OUT OF BOUNDS SUBSTRUC">)>
+ <REGSTO T>
+ <COND (<==? .TPS VECTOR>
+ <EMIT <INSTRUCTION `MOVEI `A* <* .NUM 2>>>)
+ (<==? .TPS UVECTOR> <EMIT <INSTRUCTION `MOVEI `A* .NUM>>)
+ (<MESSAGE INCONSISTENCY "BAD SUBSTRUC NODE">)>
+ <SET TDAT <GEN-COPY .TPS>>
+ <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>
+ <PUT <SET SAC <DATVAL .SDAT>> ,ACPROT T>
+ <TOACV .TDAT>
+ <SET TAC <DATVAL .TDAT>>
+ <PUT .SAC ,ACPROT <>>
+ <COND (<==? .NUM 0>)
+ (<COND (.CAREFUL <KNOWN-CAREFUL-CHECK .SDAT .TPS .NUM>)>
+ <BLTAC+NUM .SAC .TAC .NUM <> .TPS .SDAT>
+ <COND (<==? .TPS UVECTOR>
+ <SET NAC <GETREG <>>>
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM .NAC>
+ !<ADDR:VALUE .TDAT>>>
+ <EMIT <INSTRUCTION `HLRE `O* <ADDRSYM .NAC>>>
+ <EMIT <INSTRUCTION `SUB <ACSYM .NAC> 0>>
+ <UVECTOR-MUNG-SB .SDAT .NAC>)>)>)
+ (ELSE
+ <COND (<NOT <COMMUTE-STRUC <> .STRNOD .NUMNOD>>
+ <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>)>
+ <SET NDAT <DATUM FIX ,AC-A>>
+ <SET NAC <SGETREG ,AC-A <>>>
+ <SET NDAT <GEN .NUMNOD .NDAT>>
+ <COND (.CAREFUL
+ <EMIT <INSTRUCTION `JUMPL <ACSYM <DATVAL .NDAT>> |CERR1 >>)>
+ <COND (<==? .TPS VECTOR>
+ <EMIT <INSTRUCTION `ASH <ACSYM <DATVAL .NDAT>> 1>>
+ <MUNG-AC .NAC .NDAT T>)>
+ <EMIT <INSTRUCTION `PUSH `P* <ADDRSYM .NAC>>>
+ <RET-TMP-AC .NDAT>
+ <REGSTO T>
+ <SET TDAT <GEN-COPY .TPS>>
+ <COND (.SDAT <TOACV .SDAT>)
+ (<SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>
+ <DELAY-KILL .NO-KILL .ONO>)>
+ <SET SAC <DATVAL .SDAT>>
+ <PUT .SAC ,ACPROT T>
+ <TOACV .TDAT>
+ <SET TAC <DATVAL .TDAT>>
+ <PUT .TAC ,ACPROT T>
+ <SET NAC <GETREG <>>>
+ <EMIT <INSTRUCTION `POP `P* <ADDRSYM .NAC>>>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM .NAC> .END-LABEL>>
+ <COND (.CAREFUL <UNKNOWN-CAREFUL-CHECK .SDAT .NAC>)>
+ <EMIT <INSTRUCTION `ADDI <ACSYM .NAC> (<ADDRSYM .TAC>)>>
+ <PUT .NAC ,ACPROT T>
+ <BLTAC .SAC .TAC .NAC <> .SDAT>
+ <PUT .NAC ,ACPROT <>>
+ <PUT .TAC ,ACPROT <>>
+ <PUT .SAC ,ACPROT <>>
+ <RET-TMP-AC .NDAT>
+ <AND <==? .TPS UVECTOR> <UVECTOR-MUNG-SB .SDAT .NAC>>)>
+ <RET-TMP-AC .SDAT>
+ <LABEL:TAG .END-LABEL>
+ <MOVE:ARG .TDAT .WHERE>>
+
+\\f
+
+"ROUTINE TO COPY INTO A UVECTOR OR VECTOR
+ <SUBSTRUC .X .N1 .N2 <REST .X>> or
+ <SUBSTRUC <REST .X> .N1 .N2 .X>."
+
+<DEFINE COPY-INTO-SB-GEN (STRNOD TPS NUMNOD CPYNOD WHERE
+ "AUX" NDAT TDAT SDAT SAC TAC NAC
+ (NUM
+ <COND (<==? <NODE-TYPE .NUMNOD> ,QUOTE-CODE>
+ <NODE-NAME .NUMNOD>)>) RV FLG DDAT DAC
+ (ONO .NO-KILL) (NO-KILL .ONO) TEM TEM2
+ (OTHN <>) END-LABEL RR)
+ #DECL ((STRNOD NUMNOD CPYNOD) NODE (WHERE) <OR ATOM DATUM>
+ (NDAT DDAT TDAT SDAT) DATUM (DAC NAC TAC SAC) AC
+ (NO-KILL) <SPECIAL LIST>)
+ <SET FLG <SUB-CASE-1 .STRNOD .CPYNOD>>
+ <COND (<AND <==? <NODE-TYPE <SET TEM <2 <KIDS .STRNOD>>>> ,QUOTE-CODE>
+ <OR <AND <==? <NODE-TYPE .CPYNOD> ,LVAL-CODE> <SET TEM2 0>>
+ <AND <==? <NODE-TYPE .CPYNOD> ,REST-CODE>
+ <==? <NODE-TYPE <SET TEM2 <2 <KIDS .CPYNOD>>>>
+ ,QUOTE-CODE>
+ <SET TEM2 <NODE-NAME .TEM2>>>>>
+ <SET OTHN <ABS <- <NODE-NAME .TEM> .TEM2>>>
+ <OR <==? .TPS UVECTOR> <SET OTHN <* .OTHN 2>>>)>
+ <COND
+ (.NUM
+ <SET RV <COMMUTE-STRUC <> .STRNOD .CPYNOD>>
+ <COND (<L? .NUM 0> <MESSAGE ERROR "OUT OF BOUNDS SUBSTRUC">)>
+ <COND (.RV
+ <SET TDAT <GEN .CPYNOD DONT-CARE>>
+ <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>)
+ (ELSE
+ <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>
+ <SET TDAT <GEN .CPYNOD DONT-CARE>>)>
+ <COND
+ (<==? .NUM 0>)
+ (<COND
+ (.FLG
+ <TOACV .SDAT>
+ <SET SAC <DATVAL .SDAT>>
+ <PUT .SAC ,ACPROT T>
+ <TOACV .TDAT>
+ <SET TAC <DATVAL .TDAT>>
+ <PUT .SAC ,ACPROT <>>
+ <COND (.CAREFUL
+ <KNOWN-CAREFUL-CHECK .SDAT .TPS .NUM>
+ <KNOWN-CAREFUL-CHECK .TDAT .TPS .NUM>)>
+ <RET-TMP-AC .SDAT>
+ <BLTAC+NUM .SAC .TAC .NUM <> .TPS <>>)
+ (ELSE
+ <TOACV .SDAT>
+ <SET SAC <DATVAL .SDAT>>
+ <MUNG-AC .SAC .SDAT <>>
+ <PUT .SAC ,ACPROT T>
+ <COND (.OTHN <PUT <SET DAC <GETREG <>>> ,ACPROT T>)
+ (ELSE
+ <SET DDAT <DATUM .TPS ANY-AC>>
+ <SET DAC <GETREG .DDAT>>
+ <PUT .DDAT ,DATVAL .DAC>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .DAC> !<ADDR:VALUE .TDAT>>>
+ <PUT .DAC ,ACPROT T>
+ <COND (<NOT .CAREFUL>
+ <EMIT <INSTRUCTION `SUBI
+ <ACSYM .DAC>
+ (<ADDRSYM .SAC>)>>)>)>
+ <REST-IT .SAC <- .NUM 1> .TPS>
+ <COND (.CAREFUL
+ <COND (.OTHN <KNOWN-CAREFUL-CHECK .TDAT .TPS .NUM>)
+ (ELSE
+ <REST-IT .DAC <- .NUM 1> .TPS>
+ <EMIT <INSTRUCTION `SUBI
+ <ACSYM .DAC>
+ (<ADDRSYM .SAC>)>>)>)>
+ <BBLT .SAC .DAC .NUM .OTHN .TPS>
+ <PUT .DAC ,ACPROT <>>
+ <RET-TMP-AC .SDAT>
+ <OR .OTHN <RET-TMP-AC .DDAT>>)>)>)
+ (ELSE
+ <SET RV <COMMUTE-STRUC <> .NUMNOD .STRNOD>>
+ <SET RR
+ <AND <COMMUTE-STRUC <> .CPYNOD .NUMNOD>
+ <COMMUTE-STRUC <> .CPYNOD .STRNOD>>>
+ <COND (.RR <SET TDAT <GEN .CPYNOD DONT-CARE>>)>
+ <COND (.RV
+ <SET NDAT <GEN .NUMNOD <DATUM FIX ANY-AC>>>
+ <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>)
+ (ELSE
+ <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>
+ <SET NDAT <GEN .NUMNOD <DATUM FIX ANY-AC>>>)>
+ <DELAY-KILL .NO-KILL .ONO>
+ <COND (<NOT .RR> <SET TDAT <GEN .CPYNOD DONT-CARE>>)>
+ <TOACV .NDAT>
+ <SET NAC <DATVAL .NDAT>>
+ <PUT .NAC ,ACPROT T>
+ <EMIT <INSTRUCTION `JUMPE
+ <ACSYM .NAC>
+ <SET END-LABEL <MAKE:TAG "SUBSTR">>>>
+ <COND (.CAREFUL <EMIT <INSTRUCTION `JUMPL <ACSYM .NAC> |CERR1 >>)>
+ <MUNG-AC .NAC .NDAT T>
+ <COND
+ (.FLG
+ <TOACV .SDAT>
+ <SET SAC <DATVAL .SDAT>>
+ <PUT .SAC ,ACPROT T>
+ <COND (<N==? .TPS UVECTOR> <EMIT <INSTRUCTION `ASH <ACSYM .NAC> 1>>)>
+ <AND .CAREFUL <UNKNOWN-CAREFUL-CHECK .SDAT .NAC>>
+ <EMIT <INSTRUCTION `HRLI <ACSYM .NAC> (<ADDRSYM .NAC>)>>
+ <EMIT <INSTRUCTION `ADD <ACSYM .NAC> !<ADDR:VALUE .TDAT>>>
+ <AND .CAREFUL <RCHK .NAC T>>
+ <PUT .NAC ,ACPROT <>>
+ <PUT .SAC ,ACPROT <>>
+ <BLTAC+DAT .SAC .TDAT .NAC>)
+ (ELSE
+ <COND (.OTHN <SET DAC <GETREG <>>>)
+ (ELSE
+ <SET DDAT <DATUM .TPS ANY-AC>>
+ <SET DAC <GETREG .DDAT>>
+ <PUT .DDAT ,DATVAL .DAC>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .DAC> !<ADDR:VALUE .TDAT>>>)>
+ <EMIT <INSTRUCTION `SUBI <ACSYM .NAC> 1>>
+ <COND (<N==? .TPS UVECTOR> <EMIT <INSTRUCTION `ASH <ACSYM .NAC> 1>>)>
+ <EMIT <INSTRUCTION `HRLI <ACSYM .NAC> (<ADDRSYM .NAC>)>>
+ <PUT .DAC ,ACPROT T>
+ <TOACV .SDAT>
+ <SET SAC <DATVAL .SDAT>>
+ <PUT .SAC ,ACPROT T>
+ <COND (<AND <NOT .CAREFUL> <NOT .OTHN>>
+ <EMIT <INSTRUCTION `SUBI <ACSYM .DAC> (<ADDRSYM .SAC>)>>)>
+ <REST-IT .SAC .NAC .TPS>
+ <COND (.CAREFUL
+ <COND (.OTHN
+ <COND (<NOT <0? .OTHN>>
+ <EMIT <INSTRUCTION `CAML
+ <ACSYM .SAC>
+ [<FORM (<- .OTHN>) 0>]>>
+ <EMIT '<`JRST |CERR2 >>)>)
+ (ELSE
+ <REST-IT .DAC .NAC .TPS>
+ <EMIT <INSTRUCTION `SUBI
+ <ACSYM .DAC>
+ (<ADDRSYM .SAC>)>>)>)>
+ <BBLT .SAC .DAC .NAC .OTHN .TPS>
+ <PUT .SAC ,ACPROT <>>
+ <PUT .NAC ,ACPROT <>>
+ <PUT .DAC ,ACPROT <>>
+ <OR .OTHN <RET-TMP-AC .DDAT>>)>
+ <RET-TMP-AC .NDAT>
+ <LABEL:TAG .END-LABEL>)>
+ <RET-TMP-AC .SDAT>
+ <MOVE:ARG .TDAT .WHERE>>
+
+\\f
+
+"ROUTINE TO GENERATE A CALL TO IBLOCK AND ALSO GENERATE THE APPROPRIATE DATUM"
+
+<DEFINE GEN-COPY (TPS "AUX" (DAT <DATUM .TPS ,AC-B>))
+ #DECL ((DAT) DATUM (TPS) ATOM)
+ <SGETREG ,AC-B .DAT>
+ <COND (<==? .TPS UVECTOR>
+ <EMIT <INSTRUCTION `MOVEI `O |IBLOCK >>)
+ (<EMIT <INSTRUCTION `MOVEI `O 1 |IBLOK1 >>)>
+ <EMIT <INSTRUCTION `PUSHJ `P* |RCALL >>
+ .DAT>
+
+"ROUTINES TO DETERMINE THE CASE OF THE SUBSTRUC WITH 4 ARGUMENTS"
+
+"SUB-CASE-1 LOOKS FOR <SUBSTRUC <REST .X> .N1 .N2 .X> AND SIMILAR CASES WHERE
+ BLTS ARE ALWAYS POSSIBLE.
+ STRNOD== NODE OF STRUCTURE
+ CPYNOD== NODE OF STRUCTURE TO COPY INTO"
+
+<DEFINE SUB-CASE-1 (STRNOD CPYNOD
+ "AUX" (DATA <GET-SUB-DATA .STRNOD>)
+ (DATAC <GET-SUB-DATA .CPYNOD>))
+ #DECL ((STRNOD CPYNOD) NODE (DATAC DATA) <OR FALSE LIST>)
+ <AND .DATA
+ .DATAC
+ <==? <1 .DATA> <1 .DATAC>>
+ <TYPE? <2 .DATAC> FIX>
+ <OR <0? <2 .DATAC>>
+ <AND <TYPE? <2 .DATA> FIX> <G=? <2 .DATA> <2 .DATAC>>>>>>
+
+<DEFINE SUB-CASE-2 (STRNOD CPYNOD
+ "AUX" (DATA <GET-SUB-DATA .STRNOD>)
+ (DATAC <GET-SUB-DATA .CPYNOD>))
+ #DECL ((STRNOD CPYNOD) NODE (DATAC DATA) <OR FALSE LIST>)
+ <AND .DATA
+ .DATAC
+ <==? <1 .DATA> <1 .DATAC>>
+ <TYPE? <2 .DATA> FIX>
+ <OR <0? <2 .DATA>>
+ <AND <TYPE? <2 .DATAC> FIX> <L? <2 .DATA> <2 .DATAC>>>>>>
+
+<DEFINE GET-SUB-DATA (NOD "AUX" SYM TNOD (NTYP <NODE-TYPE .NOD>))
+ #DECL ((NOD TNOD) NODE (SYM) SYMTAB (NTYP) FIX)
+ <COND (<OR <==? .NTYP ,LVAL-CODE> <==? .NTYP ,SET-CODE>>
+ (<NODE-NAME .NOD> 0))
+ (<AND <==? .NTYP ,REST-CODE>
+ <COND (<OR <==? <SET NTYP <NODE-TYPE <SET TNOD <1 <KIDS .NOD>>>>>
+ ,LVAL-CODE>
+ <==? .NTYP ,SET-CODE>>
+ <SET SYM <NODE-NAME .TNOD>>)>>
+ (.SYM <NODE-NAME <2 <KIDS .NOD>>>))>>
+
+
+"ROUTINE TO DO BLT: AC1==> SOURCE
+ AC2==> START OF DEST
+ AC3==> END OF DEST."
+
+<DEFINE BLTAC (AC1 AC2 AC3 FLG SD)
+ #DECL ((AC3 AC1 AC2) AC (FLG) <OR FALSE ATOM> (SD) DATUM)
+ <EMIT <INSTRUCTION `HRLI `O* (<ADDRSYM .AC1>)>>
+ <EMIT <INSTRUCTION `HRRI `O* (<ADDRSYM .AC2>)>>
+ <EMIT <INSTRUCTION `BLT
+ `O*
+ <COND (.FLG 0) (ELSE -1)>
+ (<ADDRSYM .AC3>)>>>
+
+"HERE TO BLT WITH SOME KNOWLEDGE
+ AC1==> SOURCE
+ AC2==> START OF DEST
+ AC3==> NUMBER OF WORDS TO TRANSMIT"
+
+<DEFINE BLTAC+NUM (AC1 AC2 NUM FLG TPS DAT)
+ #DECL ((AC1 AC2) AC (NUM) FIX (FLG) <OR FALSE ATOM>)
+ <OR <==? .TPS UVECTOR> <SET NUM <* .NUM 2>>>
+ <MUNG-AC .AC1 .DAT>
+ <EMIT <INSTRUCTION `HRLI <ACSYM .AC1> (<ADDRSYM .AC1>)>>
+ <EMIT <INSTRUCTION `HRRI <ACSYM .AC1> (<ADDRSYM .AC2>)>>
+ <EMIT <INSTRUCTION `BLT
+ <ACSYM .AC1>
+ <COND (.FLG .NUM) (ELSE <- .NUM 1>)>
+ (<ADDRSYM .AC2>)>>>
+
+"HERE TO BLT BUT WITH A DATUM AS DEST SLOT"
+
+<DEFINE BLTAC+DAT (SAC TDAT NAC)
+ #DECL ((NAC SAC) AC (TDAT) DATUM)
+ <PUT .SAC ,ACPROT <>>
+ <SGETREG .SAC <>>
+ <EMIT <INSTRUCTION `HRLI <ACSYM .SAC> (<ADDRSYM .SAC>)>>
+ <EMIT <INSTRUCTION `HRR <ACSYM .SAC> !<ADDR:VALUE .TDAT>>>
+ <EMIT <INSTRUCTION `BLT <ACSYM .SAC> -1 (<ADDRSYM .NAC>)>>>
+
+"ROUTINE TO GENERATE CHECKS FOR THE CASE WHERE THE LENGTH IS KNOWN."
+
+<DEFINE KNOWN-CAREFUL-CHECK (SAC TPS NUM)
+ #DECL ((SAC) DATUM (TPS) ATOM (NUM) FIX)
+ <EMIT <INSTRUCTION `HLRE `O !<ADDR:VALUE .SAC>>>
+ <COND (<==? .TPS UVECTOR> <EMIT <INSTRUCTION `ADDI `O .NUM>>)
+ (<EMIT <INSTRUCTION `ADDI `O <* .NUM 2>>>)>
+ <EMIT <INSTRUCTION `JUMPG `O |COMPER >>>
+
+<DEFINE UNKNOWN-CAREFUL-CHECK (SAC NAC)
+ #DECL ((NAC) AC (SAC) DATUM)
+ <EMIT <INSTRUCTION `HLRE `O !<ADDR:VALUE .SAC>>>
+ <EMIT <INSTRUCTION `ADDI `O (<ADDRSYM .NAC>)>>
+ <EMIT <INSTRUCTION `JUMPG `O |COMPER >>>
+
+"ROUTINE TO REST A VECTOR/UVECTOR AND CHECK FOR BOUNDS
+ AC==> UV/V
+ TPS== PRIMTYPE
+ NUM== AMOUNT TO REST."
+
+<DEFINE REST-IT (AC NUM TPS)
+ #DECL ((AC) AC (TPS) ATOM (NUM) <OR FIX AC>)
+ <COND (<TYPE? .NUM AC>
+ <EMIT <INSTRUCTION `ADD <ACSYM .AC> <ADDRSYM .NUM>>>)
+ (ELSE
+ <COND (<==? .TPS UVECTOR>) (<SET NUM <* .NUM 2>>)>
+ <EMIT <INSTRUCTION `ADD <ACSYM .AC> [<FORM (.NUM) .NUM>]>>)>
+ <COND (.CAREFUL <RCHK .AC T>)>>
+
+<DEFINE BBLT (SAC DAC NUM OTHN TPS "AUX" (TG <MAKE:TAG>))
+ #DECL ((AC1 AC2) AC (NUM) <OR FIX AC> (OTHN) <OR FALSE FIX>)
+ <COND (.OTHN
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM .DAC>
+ [<FORM (<ADDRSYM .SAC>) .OTHN>]>>)
+ (ELSE <EMIT <INSTRUCTION `HRLI <ACSYM .DAC> <ADDRSYM .SAC>>>)>
+ <COND (<N==? .TPS UVECTOR> <EMIT <INSTRUCTION `ADDI <ACSYM .SAC> 1>>)>
+ <EMIT <COND (<TYPE? .NUM FIX> <INSTRUCTION `HRLI <ACSYM .SAC> .NUM>)
+ (ELSE
+ <INSTRUCTION `HRLI
+ <ACSYM .SAC>
+ <COND (<==? .TPS UVECTOR> 1) (ELSE 2)>
+ (<ADDRSYM .NUM>)>)>>
+ <LABEL:TAG .TG>
+ <EMIT <INSTRUCTION `POP <ACSYM .SAC> `@ <ADDRSYM .DAC>>>
+ <EMIT <INSTRUCTION `TLNE <ACSYM .SAC> -1>>
+ <EMIT <INSTRUCTION `JRST .TG>>>
+
+<DEFINE UVECTOR-MUNG-SB (SDAT TAC "AUX" SAC)
+ #DECL ((SDAT) DATUM (TAC SAC) AC)
+ <TOACV .SDAT>
+ <SET SAC <DATVAL .SDAT>>
+ <EMIT <INSTRUCTION `HLRE `O* <ADDRSYM .SAC>>>
+ <EMIT <INSTRUCTION `SUB <ACSYM .SAC> `O* >>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O* (<ADDRSYM .SAC>)>>
+ <EMIT <INSTRUCTION PUTYP!-OP!-PACKAGE `O* (<ADDRSYM .TAC>)>>
+ <PUT .TAC ,ACPROT <>>>
+<ENDPACKAGE>
--- /dev/null
+<PACKAGE "COMTEM">
+
+<ENTRY TEMPLATE-NTH TEMPLATE-PUT GET:TEMPLATE:LENGTH>
+
+<USE "CODGEN" "CACS" "CHKDCL" "COMCOD" "COMPDEC">
+
+<DEFINE TEMPLATE-NTH (NOD WHERE TYP TPS NK NNUM STRN NUMN
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>) EX1 EX2
+ "AUX" RLEN COMPLFORM (DIR1 .DIR)
+ (FLS <==? .WHERE FLUSHED>)
+ (B2 <COND (.BRANCH .BRANCH) (ELSE <MAKE:TAG>)>)
+ (TTYPE <GET <SET TYP <ISTYPE? .TYP>> TEMPLATE-DATA>)
+ DEST (NORMUSE <1 .TTYPE>) (RESTUSE <2 .TTYPE>)
+ (RX <GEN .STRN <DATUM .TYP ANY-AC>>) RUSE LENCOMB PC
+ TYPER PCA BITR IDX AC1 AC2)
+ #DECL ((B2 TYPER) ATOM (AC1 AC2) <PRIMTYPE WORD>
+ (NNUM RLEN LENCOMB PC PCA IDX) FIX (DEST) <LIST <PRIMTYPE WORD>>
+ (RX RUSE) DATUM (TTYPE) <VECTOR [2 LIST] [2 FIX] ANY [2 FIX]>
+ (RESTUSE NORMUSE) <LIST [REST LIST]> (COMPLFORM) <LIST ATOM [4 FIX]>
+ (STRN NOD) NODE)
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <COND (<G? .NNUM <3 .TTYPE>>
+ <COND (<0? <4 .TTYPE>> <MESSAGE ERROR TEMPLATE-OVERFLOW!-ERRORS>)>
+ <SET RLEN <+ 1 <MOD <- .NNUM 1 <3 .TTYPE>> <4 .TTYPE>>>>
+ <SET COMPLFORM <NTH .RESTUSE .RLEN>>
+ <SET COMPLFORM
+ (<1 .COMPLFORM>
+ <2 .COMPLFORM>
+ <3 .COMPLFORM>
+ <+ <4 .COMPLFORM>
+ <* <7 .TTYPE>
+ <COND (<G? <- </ <- .NNUM <3 .TTYPE>> <4 .TTYPE>> 1> 0>
+ <- </ <- .NNUM <3 .TTYPE>> <4 .TTYPE>> 1>)
+ (ELSE 0)>>>
+ <5 .COMPLFORM>)>)
+ (ELSE <SET COMPLFORM <NTH .NORMUSE .NNUM>>)>
+ <SET RUSE
+ <GOODACS .NOD <COND (.FLS DONT-CARE) (ELSE .WHERE)>>>
+ <SET TYPER <1 .COMPLFORM>>
+ <SET PCA <3 .COMPLFORM>>
+ <SET PC <5 .COMPLFORM>>
+ <SET LENCOMB <2 .COMPLFORM>>
+ <SET DEST (<ADDRSYM <DATVAL .RX>>)>
+ <COND (<AND <NOT <==? .LENCOMB 72>>
+ <NOT <1? .LENCOMB>>
+ <NOT <==? .LENCOMB 36>>>
+ <COND (<==? <DATVAL .RUSE> ANY-AC>
+ <PUT .RUSE ,DATVAL <GETREG .RUSE>>)
+ (ELSE <SGETREG <DATVAL .RUSE> .RUSE>)>
+ <SET AC2 <ACSYM <DATVAL .RUSE>>>)>
+ <COND (<5 .TTYPE>
+ <SET IDX <+ <4 .COMPLFORM> 1>>
+ <MUNG-AC <DATVAL .RX> .RX>
+ <EMIT <INSTRUCTION `LDB `O [<FORM (74816) 1 .DEST>]>>
+ <EMIT <INSTRUCTION `SUB <ACSYM <DATVAL .RX>> `O >>)
+ (ELSE <SET IDX <- <4 .COMPLFORM> <6 .TTYPE>>>)>
+ <COND (<OR <AND <NOT <==? .LENCOMB 72>> <G? .LENCOMB 36>>
+ <AND <==? .LENCOMB 36> <NOT <0? .PCA>>>>
+ <COND (<==? <DATTYP .RUSE> ANY-AC>
+ <PUT .RUSE ,DATTYP <GETREG .RUSE>>)
+ (ELSE <SGETREG <DATTYP .RUSE> .RUSE>)>
+ <SET AC1 <ACSYM <DATTYP .RUSE>>>)>
+ <TOACV .RX>
+ <SET DEST (<ADDRSYM <DATVAL .RX>>)>
+ <COND
+ (<==? .LENCOMB 72>
+ <COND (<NOT .FLS>
+ <COND (<AND .BRANCH .NOTF>
+ <SET WHERE <MOVE:ARG <REFERENCE .DIR1> .RUSE>>)
+ (ELSE
+ <PUT .RUSE ,DATTYP <OFFPTR .IDX .RX .TYP>>
+ <PUT .RUSE ,DATVAL <OFFPTR .IDX .RX .TYP>>
+ <SET WHERE <MOVE:ARG .RUSE .WHERE>>)>)>
+ <COND (.BRANCH
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE
+ `O
+ .IDX
+ (!<ADDR:VALUE .RX>)>>
+ <EMIT <INSTRUCTION <COND (.DIR `CAIE ) (ELSE `CAIN )>
+ `O
+ '<TYPE-CODE!-OP!-PACKAGE FALSE>>>
+ <BRANCH:TAG .BRANCH>)>
+ <COND (<OR .FLS <AND .BRANCH .NOTF>> <RET-TMP-AC .RX>)>)
+ (<NOT <0? .PCA>>
+ <COND (<==? .LENCOMB 36>
+ <EMIT <INSTRUCTION `MOVE .AC2 .IDX .DEST>>
+ <RET-TMP-AC .RX>
+ <EMIT <INSTRUCTION `HRLI .AC1 '<TYPE-CODE!-OP!-PACKAGE STRING>>>
+ <EMIT <INSTRUCTION `HRRI .AC1 .PCA>>)
+ (ELSE
+ <PUT .RUSE ,DATTYP .TYPER>
+ <COND (<==? .PC 36> <EMIT <INSTRUCTION `HLR .AC2 .IDX .DEST>>)
+ (ELSE <EMIT <INSTRUCTION `HRR .AC2 .IDX .DEST>>)>
+ <RET-TMP-AC .RX>
+ <EMIT <INSTRUCTION `HRLI
+ .AC2
+ <COND (<==? .TYPER UVECTOR> <- .PCA>)
+ (ELSE <* -2 .PCA>)>>>)>)
+ (<==? .LENCOMB 54>
+ <COND (<==? .PC 36>
+ <EMIT <INSTRUCTION `MOVE .AC2 .IDX .DEST>>
+ <EMIT <INSTRUCTION `HLR .AC1 <+ .IDX 1> .DEST>>)
+ (ELSE
+ <EMIT <INSTRUCTION `MOVE .AC2 <+ .IDX 1> .DEST>>
+ <EMIT <INSTRUCTION `HRR .AC1 .IDX .DEST>>)>
+ <EMIT <INSTRUCTION `HRLI .AC1 '<TYPE-CODE!-OP!-PACKAGE STRING>>>
+ <RET-TMP-AC .RX>)
+ (<==? .LENCOMB 36>
+ <PUT .RUSE ,DATTYP .TYPER>
+ <PUT .RUSE ,DATVAL <OFFPTR <- .IDX 1> .RX .TYP>>)
+ (<==? .LENCOMB 18>
+ <PUT .RUSE ,DATTYP .TYPER>
+ <COND (<AND <==? .TYPER FALSE> .FLS>)
+ (<EMIT <INSTRUCTION <COND (<==? .PC 36>
+ <COND (<==? .TYPER FIX> `HLRE )
+ (<==? .TYPER FLOAT> `HLLZ )
+ (ELSE `HLRZ )>)
+ (ELSE
+ <COND (<==? .TYPER FIX> `HRRE )
+ (<==? .TYPER FLOAT> `HRLZ )
+ (ELSE `HRRZ )>)>
+ .AC2
+ .IDX
+ .DEST>>)>
+ <COND (<==? .TYPER FALSE>
+ <COND (<NOT .FLS> <SET WHERE <MOVE:ARG .RUSE .WHERE>>)>
+ <COND (<AND .BRANCH <NOT .DIR>> <BRANCH:TAG .BRANCH>)>)>)
+ (<1? .LENCOMB>
+ <EMIT <INSTRUCTION `MOVE `O .IDX .DEST>>
+ <SET BITR
+ <BITS 1 <COND (<G? .PC 18> <- .PC 19>) (ELSE <- .PC 1>)>>>
+ <SET BITR
+ <PUTBITS #WORD *000000000000* .BITR #WORD *777777777777*>>
+ <RET-TMP-AC .RX>
+ <COND (<OR <AND <NOT .DIR> <NOT .BRANCH> <NOT .FLS>>
+ <AND <NOT .DIR1> <NOT .FLS>>>
+ <RET-TMP-AC <MOVE:ARG <REFERENCE <>> .RUSE>>)>
+ <COND (<G? .PC 18> <EMIT <INSTRUCTION `TLNN `O .BITR>>)
+ (ELSE <EMIT <INSTRUCTION `TRNN `O .BITR>>)>
+ <SET BITR <MAKE:TAG>>
+ <COND (<NOT .DIR> <BRANCH:TAG .B2>)
+ (ELSE <BRANCH:TAG .BITR>)>
+ <COND (<OR <AND <NOT .DIR> <NOT .BRANCH> <NOT .FLS>>
+ <AND .DIR1 <NOT .FLS>>>
+ <MOVE:ARG <REFERENCE T> .RUSE>)>
+ <COND (<AND .DIR .BRANCH> <BRANCH:TAG .B2>)>
+ <LABEL:TAG .BITR>
+ <COND (<NOT .BRANCH> <LABEL:TAG .B2>)>)
+ (ELSE
+ <PUT .RUSE ,DATTYP .TYPER>
+ <EMIT <INSTRUCTION `LDB
+ .AC2
+ <BYTE <- .PC .LENCOMB> .LENCOMB .IDX .DEST>>>)>
+ <COND (<NOT <OR <NOT <0? .PCA>>
+ <G? .LENCOMB 36>
+ <1? .LENCOMB>
+ <==? .LENCOMB 36>>>
+ <RET-TMP-AC .RX>)>
+ <COND (<AND <NOT <==? .LENCOMB 72>> <NOT <==? .TYPER FALSE>>>
+ <MOVE:ARG .RUSE .WHERE>)
+ (ELSE .WHERE)>>
+
+\\f
+
+<DEFINE TEMPLATE-PUT (NOD WHERE TYP TPS NK NNUM SNOD NNOD VNOD
+ "OPTIONAL" EX1 EX2
+ "AUX" CK YDAT XDAT RLEN DEST COMPLFORM XTP VDAT
+ (TTYPE <GET <SET TYP <ISTYPE? .TYP>> TEMPLATE-DATA>)
+ (NORMUSE <1 .TTYPE>) (RESTUSE <2 .TTYPE>)
+ (RX <GEN .SNOD <GOODACS .NOD .WHERE>>) LENCOMB PC
+ TYPER PCA BITR IDX AC1 AC2 TT)
+ #DECL ((PCA NNUM PC IDX LENCOMB RLEN) FIX (TYPER) ATOM
+ (AC1 AC2) <PRIMTYPE WORD> (DEST) <LIST <PRIMTYPE WORD>>
+ (RX XDAT YDAT VDAT) DATUM (RESTUSE NORMUSE) <LIST [REST LIST]>
+ (TTYPE) <VECTOR [2 LIST] [2 FIX] ANY [2 FIX]>
+ (COMPLFORM) <LIST ATOM [4 FIX]> (SNOD VNOD NOD) NODE)
+ <COND (<G? .NNUM <3 .TTYPE>>
+ <COND (<0? <4 .TTYPE>> <MESSAGE ERROR TEMPLATE-OVERFLOW!-ERRORS>)>
+ <SET RLEN <+ 1 <MOD <- .NNUM 1 <3 .TTYPE>> <4 .TTYPE>>>>
+ <SET COMPLFORM <NTH .RESTUSE .RLEN>>
+ <SET COMPLFORM
+ (<1 .COMPLFORM>
+ <2 .COMPLFORM>
+ <3 .COMPLFORM>
+ <+ <4 .COMPLFORM>
+ <* <7 .TTYPE>
+ <COND (<G? <- </ <- .NNUM <3 .TTYPE>> <4 .TTYPE>> 1> 0>
+ <- </ <- .NNUM <3 .TTYPE>> <4 .TTYPE>> 1>)
+ (ELSE 0)>>>
+ <5 .COMPLFORM>)>)
+ (ELSE <SET COMPLFORM <NTH .NORMUSE .NNUM>>)>
+ <SET LENCOMB <2 .COMPLFORM>>
+ <SET TYPER <1 .COMPLFORM>>
+ <SET PCA <3 .COMPLFORM>>
+ <SET PC <5 .COMPLFORM>>
+ <TOACV .RX>
+ <SET DEST (<ADDRSYM <DATVAL .RX>>)>
+ <COND (<SET CK <5 .TTYPE>>
+ <SET IDX <+ <4 .COMPLFORM> 1>>
+ <COND (<AND <5 .TTYPE> <N==? .WHERE FLUSHED>>
+ <PUT <DATVAL .RX> ,ACPROT T>
+ <SET YDAT <DATUM .TYP ANY-AC>>
+ <PUT .YDAT ,DATVAL <GETREG .YDAT>>
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM <DATVAL .YDAT>>
+ <ADDRSYM <DATVAL .RX>>>>
+ <PUT <DATVAL .RX> ,ACPROT <>>)>)
+ (ELSE <SET IDX <- <4 .COMPLFORM> <6 .TTYPE>>>)>
+ <SET XTP <ISTYPE? <RESULT-TYPE .VNOD>>>
+ <COND
+ (<NOT <1? .LENCOMB>>
+ <SET VDAT
+ <GEN .VNOD
+ <DATUM <COND (<NOT <ISTYPE-GOOD? .XTP>> ANY-AC) (ELSE .XTP)>
+ ANY-AC>>>
+ <COND
+ (<AND <NOT <==? .LENCOMB 72>>
+ <SET XTP <ISTYPE? <RESULT-TYPE .VNOD>>>>
+ <COND (<NOT <OR <==? .TYPER .XTP> <1? .LENCOMB>>>
+ <MESSAGE ERROR TEMPLATE-TYPE-ERROR-PUT!-ERRORS>)>)
+ (ELSE
+ <COND (<AND .CAREFUL
+ <NOT <==? .TYPER ANY>>
+ <NOT <==? <RESULT-TYPE .VNOD> .TYPER>>>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O !<ADDR:TYPE .VDAT>>>
+ <EMIT <INSTRUCTION `CAIE
+ `O
+ <FORM TYPE-CODE!-OP!-PACKAGE .TYPER>>>
+ <BRANCH:TAG |COMPER >)>)>)>
+ <TOACV .RX>
+ <SET DEST (<ADDRSYM <DATVAL .RX>>)>
+ <COND (<AND .CK <NOT <1? .LENCOMB>>>
+ <MUNG-AC <DATVAL .RX> .RX>
+ <EMIT <INSTRUCTION `LDB `O [<FORM (74816) 1 .DEST>]>>
+ <EMIT <INSTRUCTION `SUB <ACSYM <DATVAL .RX>> `O >>)>
+ <COND (<NOT <1? .LENCOMB>> <SET AC2 <ACSYM <DATVAL .VDAT>>>)>
+ <COND
+ (<==? .LENCOMB 72>
+ <TOACT .VDAT>
+ <EMIT <INSTRUCTION `MOVEM <ACSYM <DATTYP .VDAT>> .IDX .DEST>>
+ <RET-TMP-AC <DATTYP .VDAT> .VDAT>
+ <EMIT <INSTRUCTION `MOVEM .AC2 <+ .IDX 1> .DEST>>)
+ (<NOT <0? .PCA>>
+ <COND (<==? .LENCOMB 36>
+ <COND (.CAREFUL
+ <EMIT `HRRZ `O !<ADDR:TYPE .VDAT>>
+ <EMIT <INSTRUCTION `CAIE <ACSYM <DATTYP .VDAT>> .PCA>>
+ <BRANCH:TAG |COMPER >)>
+ <EMIT <INSTRUCTION `MOVEM .AC2 .IDX .DEST>>)
+ (ELSE
+ <COND (.CAREFUL
+ <EMIT <INSTRUCTION `HLRZ `O <ADDRSYM <DATVAL .VDAT>>>>
+ <EMIT <INSTRUCTION `CAIE
+ `O
+ <COND (<==? .TYPER UVECTOR> <- .PCA>)
+ (ELSE <* -2 .PCA>)>>>
+ <BRANCH:TAG |COMPER >)>
+ <EMIT <INSTRUCTION <COND (<==? .PC 36> `HRLM ) (ELSE `HRRM )>
+ .AC2
+ .IDX
+ .DEST>>)>)
+ (<==? .LENCOMB 54>
+ <TOACT .VDAT>
+ <COND (<==? .PC 36>
+ <EMIT <INSTRUCTION `MOVEM .AC2 .IDX .DEST>>
+ <EMIT <INSTRUCTION `HRLM
+ <ACSYM <DATTYP .VDAT>>
+ <+ .IDX 1>
+ .DEST>>
+ <RET-TMP-AC <DATTYP .VDAT> .VDAT>)
+ (ELSE
+ <EMIT <INSTRUCTION `MOVEM .AC2 <+ .IDX 1> .DEST>>
+ <EMIT <INSTRUCTION `HRRM <ACSYM <DATTYP .VDAT>> .IDX .DEST>>
+ <RET-TMP-AC <DATTYP .VDAT> .VDAT>)>
+ <RET-TMP-AC <DATTYP .VDAT> .VDAT>)
+ (<==? .LENCOMB 36>
+ <EMIT <INSTRUCTION `MOVEM .AC2 .IDX .DEST>>)
+ (<==? .LENCOMB 18>
+ <EMIT <INSTRUCTION <COND (<==? .PC 36>
+ <COND (<==? .TYPER FLOAT> `HLLM ) (ELSE `HRLM )>)
+ (ELSE
+ <COND (<==? .TYPER FLOAT> `HLRM )
+ (ELSE `HRRM )>)>
+ .AC2
+ .IDX
+ .DEST>>)
+ (<1? .LENCOMB>
+ <SET BITR <BITS 1 <- .PC 1>>>
+ <SET BITR
+ <PUTBITS #WORD *000000000000* .BITR #WORD *777777777777*>>
+ <SET VDAT <GEN .VNOD DONT-CARE>>
+ <TOACV .RX>
+ <SET DEST (<ADDRSYM <DATVAL .RX>>)>
+ <COND (.CK
+ <MUNG-AC <DATVAL .RX> .RX>
+ <EMIT <INSTRUCTION `LDB `O [<FORM (74816) 1 .DEST>]>>
+ <EMIT <INSTRUCTION `SUB <ACSYM <DATVAL .RX>> `O >>)>
+ <COND (<NOT .XTP>
+ <SET XDAT <DATUM FIX ANY-AC>>
+ <PUT <DATVAL .RX> ,ACPROT T>
+ <PUT .XDAT ,DATVAL <GETREG .XDAT>>
+ <PUT <DATVAL .RX> ,ACPROT <>>
+ <SET TT <ACSYM <DATVAL .XDAT>>>)
+ (ELSE <RET-TMP-AC .VDAT> <SET TT 0>)>
+ <EMIT <INSTRUCTION `MOVE .TT [.BITR]>>
+ <COND (.XTP
+ <EMIT <INSTRUCTION <COND (<==? .XTP FALSE> `ANDCAM ) (ELSE `IORM )>
+ .TT
+ .IDX
+ .DEST>>)
+ (ELSE
+ <D:B:TAG <SET BITR <MAKE:TAG>> .VDAT T <RESULT-TYPE .VNOD>>
+ <RET-TMP-AC .XDAT>
+ <EMIT <INSTRUCTION `ANDCAM .TT .IDX .DEST>>
+ <EMIT '<`SKIPA >>
+ <LABEL:TAG .BITR>
+ <RET-TMP-AC .VDAT>
+ <EMIT <INSTRUCTION `IORM .TT .IDX .DEST>>)>)
+ (ELSE
+ <EMIT <INSTRUCTION `DPB
+ .AC2
+ <BYTE <- .PC .LENCOMB> .LENCOMB .IDX .DEST>>>)>
+ <COND (<NOT <1? .LENCOMB>> <RET-TMP-AC .VDAT>)>
+ <COND (<NOT <5 .TTYPE>> <MOVE:ARG .RX .WHERE>)
+ (<N==? .WHERE FLUSHED>
+ <RET-TMP-AC .RX>
+ <MOVE:ARG .YDAT .WHERE>)
+ (ELSE <MOVE:ARG .RX .WHERE>)>>
+
+"ROUTINE TO FIND THE LENGTH OF A TEMPLATE"
+
+<DEFINE GET:TEMPLATE:LENGTH (NM DAT NDAT "AUX" (TD <GET .NM TEMPLATE-DATA>))
+ #DECL ((NM) ATOM (TD) <OR FALSE <VECTOR [2 LIST] [5 ANY]>>
+ (NDAT) <OR <DATUM ANY AC> AC>)
+ <COND (<NOT .TD>
+ <MESSAGE INCONSISTENCY "TEMPLATE DATA NOT AVAIABLE">)>
+ <COND
+ (<NOT <5 .TD>>
+ <MESSAGE WARNING "ASKING LENGTH OF CONSTANT TEMPLATE">
+ <EMIT <INSTRUCTION `MOVEI
+ <ACSYM <COND (<TYPE? .NDAT DATUM> <DATVAL .NDAT>)
+ (ELSE .NDAT)>>
+ <LENGTH <1 .TD>>>>)
+ (ELSE
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM <COND (<TYPE? .NDAT DATUM> <DATVAL .NDAT>)
+ (ELSE .NDAT)>>
+ !<ADDR:VALUE1
+ <COND (<TYPE? .DAT DATUM> <DATVAL .DAT>)>>>>
+ <EMIT <INSTRUCTION `HRRZ
+ <ACSYM <COND (<TYPE? .NDAT DATUM> <DATVAL .NDAT>)
+ (ELSE .NDAT)>>
+ (<ADDRSYM <COND (<TYPE? .NDAT DATUM>
+ <DATVAL .NDAT>)
+ (ELSE .NDAT)>>)
+ <COND (<EMPTY? <2 .TD>> 0) (ELSE -1)>>>)>>
+
+<DEFINE BYTE (BOUND SIZE "TUPLE" LOC)
+ [<FORM (<+ <* .BOUND 4096> <* .SIZE 64>>) !.LOC>]>
+
+<ENDPACKAGE>
--- /dev/null
+
+<DEFINE CONFORM (R1 R2 T1 T2
+ "AUX" (X <3 .T1>) (Y <3 .T2>) (AR1 <TYPE? <DATVAL .R1> AC>) M1
+ M2 (AR2 <TYPE? <DATVAL .R2> AC>) AC (VAL <>))
+ #DECL ((T1 T2) TRANS (X Y) <UVECTOR [7 FIX]> (R1 R2) DATUM (AC) AC
+ (M1 M2) FIX)
+ <SET AC <COND (.AR1 <DATVAL .R1>) (ELSE <DATVAL .R2>)>>
+ <COND (<N==? <7 .X> <7 .Y>>
+ <COND (<0? <7 .X>> <HWSH .R2 .R1 <6 .X>>)
+ (ELSE <HWSH .R1 .R2 <6 .Y>>)>)
+ (<N==? <6 .X> <6 .Y>>
+ <COND (<0? <6 .X>> <HWH .R2 .R1>) (ELSE <HWH .R1 .R2>)>)>
+ <COND (<N==? <1 .X> <1 .Y>>
+ <AND <NOT <0? <1 .Y>>> <SET VAL T>>
+ <MUNG-AC .AC <COND (.AR1 .R1)(ELSE .R2)>>
+ <EMIT <INSTRUCTION `MOVNS <ADDRSYM .AC>>>)
+ (<NOT <0? <1 .X>>> <SET VAL T>)>
+ <COND (<OR <NOT <0? <4 .X>>> <NOT <0? <4 .Y>>>>
+ <SET M1 <M* <4 .X> <4 .Y> <5 .X> <5 .Y>>>
+ <SET M2 <M* <4 .Y> <4 .X> <5 .Y> <5 .X>>>
+ <COND (<AND <G=? .M1 .M2> <0? <MOD .M1 .M2>>>
+ <SET M1 </ .M1 .M2>>
+ <SET M2 1>)
+ (<AND <G? .M2 .M1> <0? <MOD .M2 .M1>>>
+ <SET M2 </ .M2 .M1>>
+ <SET M1 1>)>
+ <COND (<NOT <1? .M1>>
+ <TOACV .R2>
+ <MUNG-AC <DATVAL .R2> .R2>
+ <IMCHK '(`IMUL `IMULI )
+ <ACSYM <DATVAL .R2>>
+ <REFERENCE:ADR .M1>>)>
+ <COND (<NOT <1? .M2>>
+ <TOACV .R1>
+ <MUNG-AC <DATVAL .R1> .R1>
+ <IMCHK '(`IMUL `IMULI )
+ <ACSYM <DATVAL .R1>>
+ <REFERENCE:ADR .M2>>)>)>
+ <COND (<AND <OR <NOT <0? <2 .X>>> <NOT <0? <2 .Y>>>>
+ <NOT <0? <SET M1 <- <3 .X> <3 .Y>>>>>>
+ <COND (<TYPE? <DATVAL .R2> AC>
+ <MUNG-AC <DATVAL .R2> .R2>
+ <IMCHK <COND (<L? .M1 0> <SET M1 <- .M1>> '(`SUB
+ `SUBI ))
+ (ELSE '(`ADD `ADDI ))>
+ <ACSYM <DATVAL .R2>>
+ <REFERENCE:ADR .M1>>)
+ (ELSE
+ <TOACV .R1>
+ <MUNG-AC <DATVAL .R1> .R1>
+ <IMCHK <COND (<L? .M1 0> <SET M1 <- .M1>> '(`ADD
+ `ADDI ))
+ (ELSE '(`SUB `SUBI ))>
+ <ACSYM <DATVAL .R1>>
+ <REFERENCE:ADR .M1>>)>)>
+ .VAL>
+
+<DEFINE M* (A B C D)
+ #DECL ((A B C D) FIX)
+ <* <COND (<OR <==? .A 1> <==? .A 2>> .C) (ELSE 1)>
+ <COND (<OR <==? .B 3> <==? .B 4>> .D) (ELSE 1)>>>
+
+<DEFINE HWSH (R1 R2 HW)
+ #DECL ((R1 R2) DATUM (HW) FIX)
+ <COND (<NOT <0? .HW>>
+ <COND (<TYPE? <DATVAL .R1> AC>
+ <MUNG-AC <DATVAL .R1> .R1>
+ <EMIT <INSTRUCTION `HLRZS <ADDRSYM <DATVAL .R1>>>>)
+ (ELSE
+ <MUNG-AC <DATVAL .R2> .R2>
+ <EMIT <INSTRUCTION `MOVSS <ADDRSYM <DATVAL .R2>>>>)>)
+ (ELSE
+ <COND (<TYPE? <DATVAL .R1> AC>
+ <MUNG-AC <DATVAL .R1> .R1>
+ <EMIT <INSTRUCTION `HLRES <ADDRSYM <DATVAL .R1>>>>)
+ (ELSE
+ <MUNG-AC <DATVAL .R2> .R2>
+ <EMIT <INSTRUCTION `MOVSS <ADDRSYM <DATVAL .R2>>>>)>)>>
+
+<DEFINE HWH (R1 R2)
+ #DECL ((R1 R2) DATUM)
+ <COND (<TYPE? <DATVAL .R1> AC>
+ <MUNG-AC <DATVAL .R1> .R1>
+ <EMIT <INSTRUCTION `HRRES <ADDRSYM <DATVAL .R1>>>>)
+ (ELSE
+ <MUNG-AC <DATVAL .R2> .R2>
+ <EMIT <INSTRUCTION `ANDI <ACSYM <DATVAL .R2>> 262143>>)>>
+\f\ 3\ 3\ 3\ 3
\ No newline at end of file
--- /dev/null
+
+<DEFINE PRINT-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>) RT)
+ #DECL ((N) NODE (LN) FIX (K) <LIST [REST NODE]>)
+ <COND (<SEGFLUSH .N .R>)
+ (ELSE
+ <ARGCHK .LN '(1 2) <NODE-NAME .N>>
+ <SET RT <EANA <1 .K> ANY <NODE-NAME .N>>>
+ <COND (<1? .LN>
+ <PUTREST .K (<NODEFM ,SUBR-CODE .N ANY LVAL () ,LVAL>)>
+ <PUT <2 .K>
+ ,KIDS
+ (<NODE1 ,QUOTE-CODE <2 .K> ATOM OUTCHAN ()>)>)>
+ <EANA <2 .K> CHANNEL <NODE-NAME .N>>
+ <PUT .N ,NODE-TYPE ,PRINT-CODE>
+ <TYPE-OK? .RT .R>)>>
+
+<DEFINE FLATSIZE-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>))
+ #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
+ <COND (<SEGFLUSH .N .R>)
+ (ELSE
+ <ARGCHK .LN '(2 3) FLATSIZE>
+ <EANA <1 .K> ANY FLATSIZE>
+ <EANA <2 .K> FIX FLATSIZE>
+ <COND (<==? .LN 2>
+ <PUTREST <REST .K> (<NODE1 ,QUOTE-CODE .N FIX 10 ()>)>)>
+ <EANA <3 .K> FIX FLATSIZE>
+ <PUT .N ,NODE-TYPE ,ISUBR-CODE>
+ <TYPE-OK? '<OR FIX FALSE> .R>)>>
+
+<DEFINE UNPARSE-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>))
+ #DECL ((N) NODE (K) <LIST [REST NODE]>)
+ <COND (<SEGFLUSH .N .R>)
+ (ELSE
+ <ARGCHK .LN '(1 2) UNPARSE>
+ <EANA <1 .K> ANY UNPARSE>
+ <COND (<1? .LN> <PUTREST .K (<NODE1 ,QUOTE-CODE .N FIX 10 ()>)>)>
+ <EANA <2 .K> FIX UNPARSE>
+ <PUT .N ,NODE-TYPE ,ISUBR-CODE>
+ <TYPE-OK? STRING .R>)>>
+
+<DEFINE TERPRI-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>))
+ #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
+ <COND (<SEGFLUSH .N .R>)
+ (ELSE
+ <ARGCHK .LN '(0 1) TERPRI>
+ <COND (<0? .LN>
+ <PUT .N
+ ,KIDS
+ <SET K (<NODEFM ,SUBR-CODE .N ANY LVAL () ,LVAL>)>>
+ <PUT <1 .K>
+ ,KIDS
+ (<NODE1 ,QUOTE-CODE <1 .K> ATOM OUTCHAN ()>)>)>
+ <EANA <1 .K> CHANNEL TERPRI>
+ <PUT .N ,NODE-TYPE ,ISUBR-CODE>
+ <TYPE-OK? <COND (<==? <NODE-SUBR .N> ,CRLF> ATOM) (ELSE FALSE)> .R>)>>
+
+<DEFINE READCHR-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>))
+ #DECL ((N) NODE (LN) FIX)
+ <COND (<SEGFLUSH .N .R>)
+ (ELSE
+ <ARGCHK .LN '(0 1) <NODE-NAME .N>>
+ <COND (<0? .LN>
+ <PUT .N
+ ,KIDS
+ <SET K (<NODEFM ,SUBR-CODE .N ANY LVAL () ,LVAL>)>>
+ <PUT <1 .K>
+ ,KIDS
+ (<NODE1 ,QUOTE-CODE <1 .K> ATOM INCHAN ()>)>)>
+ <EANA <1 .K> CHANNEL <NODE-NAME .N>>
+ <PUT .N ,NODE-TYPE ,ISUBR-CODE>
+ <TYPE-OK? ANY .R>)>>
+
+<PUT ,READCHR ANALYSIS ,READCHR-ANA>
+
+<PUT ,NEXTCHR ANALYSIS ,READCHR-ANA>
+
+<PUT ,PRINC ANALYSIS ,PRINT-ANA>
+
+<PUT ,PRIN1 ANALYSIS ,PRINT-ANA>
+
+<PUT ,PRINT ANALYSIS ,PRINT-ANA>
+
+<PUT ,FLATSIZE ANALYSIS ,FLATSIZE-ANA>
+
+<PUT ,UNPARSE ANALYSIS ,UNPARSE-ANA>
+
+<PUT ,TERPRI ANALYSIS ,TERPRI-ANA>
+
+<PUT ,CRLF ANALYSIS ,TERPRI-ANA>
+
+<DEFINE PRINT-GEN (N W
+ "AUX" (K <KIDS .N>) (OB <1 .K>) (CH <2 .K>)
+ (RT <ISTYPE? <RESULT-TYPE .OB>>)
+ (PCOD <LENGTH <MEMQ <NODE-SUBR .N> ,PRINTERS>>) DAT
+ CDAT)
+ #DECL ((N OB CH) NODE (K) <LIST [REST NODE]> (PCOD) FIX (DAT CDAT) DATUM)
+ <SET DAT
+ <GEN .OB
+ <COND (<SIDE-EFFECTS .CH> <DATUM ,AC-C ,AC-D>)
+ (ELSE DONT-CARE)>>>
+ <SET PCOD
+ <+ <COND (<==? .RT ATOM> 3)
+ (<==? .RT STRING> 6)
+ (<==? .RT CHARACTER> 9)
+ (ELSE 0)>
+ .PCOD>>
+ <COND (<OR <==? <DATTYP .DAT> ,AC-A>
+ <==? <DATVAL .DAT> ,AC-A>
+ <==? <DATTYP .DAT> ,AC-B>
+ <==? <DATVAL .DAT> ,AC-B>>
+ <SET DAT
+ <MOVE:ARG
+ .DAT
+ <DATUM <COND (<AND <TYPE? <DATTYP .DAT> ATOM>
+ <ISTYPE? <DATTYP .DAT>>>
+ <DATTYP .DAT>)
+ (ELSE ,AC-C)>
+ ,AC-D>>>)>
+ <SET CDAT <GEN .CH <DATUM ,AC-A ,AC-B>>>
+ <SET DAT <MOVE:ARG .DAT
+ <DATUM <COND (<OR <==? .RT ATOM> <==? .PCOD 12>> .RT)
+ (ELSE ,AC-C)>
+ ,AC-D>>>
+ <RET-TMP-AC <MOVE:ARG .CDAT <DATUM ,AC-A ,AC-B>>>
+ <RET-TMP-AC .DAT>
+ <REGSTO T>
+ <EMIT <INSTRUCTION `PUSHJ `P* <NTH ,IPRINTERS .PCOD>>>
+ <MOVE:ARG <FUNCTION:VALUE T> .W>>
+
+<SETG PRINTERS ![,PRINC ,PRIN1 ,PRINT!]>
+
+<SETG IPRINTERS
+ ![|CIPRIN
+ |CIPRN1
+ |CIPRNC
+ |CPATM
+ |CP1ATM
+ |CPCATM
+ |CPSTR
+ |CP1STR
+ |CPCSTR
+ |CIPRIN
+ |CIPRN1
+ |CPCH!]>
+\f\ 3\ 3\ 3\ 3
\ No newline at end of file
--- /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>
--- /dev/null
+
+<PACKAGE "CHKDCL">
+
+<ENTRY TYPE-AND TYPE-OK? TASTEFUL-DECL GET-ELE-TYPE STRUCTYP TYPE-ATOM-OK? ISTYPE-GOOD? TYPE-MERGE DEFERN TOP-TYPE ISTYPE? TYPESAME ANY-PAT STRUC GETBSYZ GEN-DECL REST-DECL MINL GET-RANGE>
+
+<USE "COMPDEC">
+
+<SETG DECL-RESTED 1>
+
+<SETG DECL-ELEMENT 2>
+
+<SETG DECL-ITEM-COUNT 3>
+
+<SETG DECL-IN-REST 4>
+
+<SETG DECL-IN-COUNT-VEC 5>
+
+<SETG DECL-REST-VEC 6>
+
+<MANIFEST DECL-RESTED DECL-ELEMENT DECL-ITEM-COUNT DECL-IN-REST DECL-IN-COUNT-VEC DECL-REST-VEC>
+
+<SETG HIGHBOUND 2>
+
+<SETG LOWBOUND 1>
+
+<MANIFEST HIGHBOUND LOWBOUND>
+
+<SETG ALLWORDS '<PRIMTYPE WORD>>
+
+<SETG TASTEFUL-DECL '
\ No newline at end of file
--- /dev/null
+<SETG ANALYZERS
+ <DISPATCH ,SUBR-ANA
+ (,QUOTE-CODE ,QUOTE-ANA)
+ (,FUNCTION-CODE ,FUNC-ANA)
+ (,SEGMENT-CODE ,SEGMENT-ANA)
+ (,FORM-CODE ,FORM-AN)
+ (,PROG-CODE ,PRG-REP-ANA)
+ (,SUBR-CODE ,SUBR-ANA)
+ (,COND-CODE ,COND-ANA)
+ (,COPY-CODE ,COPY-AN)
+ (,RSUBR-CODE ,RSUBR-ANA)
+ (,ISTRUC-CODE ,ISTRUC-ANA)
+ (,ISTRUC2-CODE ,ISTRUC2-ANA)
+ (,READ-EOF-CODE ,READ-ANA)
+ (,READ-EOF2-CODE ,READ2-ANA)
+ (,GET-CODE ,GET-ANA)
+ (,GET2-CODE ,GET2-ANA)
+ (,MAP-CODE ,MAPPER-AN)
+ (,MARGS-CODE ,MARGS-ANA)
+ (,ARITH-CODE ,ARITH-ANA)
+ (,TEST-CODE ,ARITHP-ANA)
+ (,0-TST-CODE ,ARITHP-ANA)
+ (,1?-CODE ,ARITHP-ANA)
+ (,MIN-MAX-CODE ,ARITH-ANA)
+ (,ABS-CODE ,ABS-ANA)
+ (,FIX-CODE ,FIX-ANA)
+ (,FLOAT-CODE ,FLOAT-ANA)
+ (,MOD-CODE ,MOD-ANA)
+ (,LNTH-CODE ,LENGTH-ANA)
+ (,MT-CODE ,EMPTY?-ANA)
+ (,NTH-CODE ,NTH-ANA)
+ (,REST-CODE ,REST-ANA)
+ (,PUT-CODE ,PUT-ANA)
+ (,PUTR-CODE ,PUTREST-ANA)
+ (,UNWIND-CODE ,UNWIND-ANA)
+ (,FORM-F-CODE ,FORM-F-ANA)
+ (,COPY-LIST-CODE ,COPY-AN)
+ (,BACK-CODE ,BACK-ANA)
+ (,TOP-CODE ,TOP-ANA)
+ (,SUBSTRUC-CODE ,SUBSTRUC-ANA)>>
+<SETG GENERATORS
+ <DISPATCH ,DEFAULT-GEN
+ (,FORM-CODE ,FORM-GEN)
+ (,PROG-CODE ,PROG-REP-GEN)
+ (,SUBR-CODE ,SUBR-GEN)
+ (,COND-CODE ,COND-GEN)
+ (,LVAL-CODE ,LVAL-GEN)
+ (,SET-CODE ,SET-GEN)
+ (,OR-CODE ,OR-GEN)
+ (,AND-CODE ,AND-GEN)
+ (,RETURN-CODE ,RETURN-GEN)
+ (,COPY-CODE ,COPY-GEN)
+ (,AGAIN-CODE ,AGAIN-GEN)
+ (,GO-CODE ,GO-GEN)
+ (,ARITH-CODE ,ARITH-GEN)
+ (,RSUBR-CODE ,RSUBR-GEN)
+ (,0-TST-CODE ,0-TEST)
+ (,NOT-CODE ,NOT-GEN)
+ (,1?-CODE ,1?-GEN)
+ (,TEST-CODE ,TEST-GEN)
+ (,EQ-CODE ,==-GEN)
+ (,TY?-CODE ,TYPE?-GEN)
+ (,LNTH-CODE ,LNTH-GEN)
+ (,MT-CODE ,MT-GEN)
+ (,REST-CODE ,REST-GEN)
+ (,NTH-CODE ,NTH-GEN)
+ (,PUT-CODE ,PUT-GEN)
+ (,PUTR-CODE ,PUTREST-GEN)
+ (,FLVAL-CODE ,FLVAL-GEN)
+ (,FSET-CODE ,FSET-GEN)
+ (,FGVAL-CODE ,FGVAL-GEN)
+ (,FSETG-CODE ,FSETG-GEN)
+ (,STACKFORM-CODE ,STACKFORM-GEN)
+ (,MIN-MAX-CODE ,MIN-MAX)
+ (,CHTYPE-CODE ,CHTYPE-GEN)
+ (,FIX-CODE ,FIX-GEN)
+ (,FLOAT-CODE ,FLOAT-GEN)
+ (,ABS-CODE ,ABS-GEN)
+ (,MOD-CODE ,MOD-GEN)
+ (,ID-CODE ,ID-GEN)
+ (,ASSIGNED?-CODE ,ASSIGNED?-GEN)
+ (,ISTRUC-CODE ,ISTRUC-GEN)
+ (,ISTRUC2-CODE ,ISTRUC-GEN)
+ (,BITS-CODE ,BITS-GEN)
+ (,GETBITS-CODE ,GETBITS-GEN)
+ (,BITL-CODE ,BITLOG-GEN)
+ (,PUTBITS-CODE ,PUTBITS-GEN)
+ (,ISUBR-CODE ,ISUBR-GEN)
+ (,EOF-CODE ,ID-GEN)
+ (,READ-EOF2-CODE ,READ2-GEN)
+ (,READ-EOF-CODE ,SUBR-GEN)
+ (,IPUT-CODE ,IPUT-GEN)
+ (,IREMAS-CODE ,IREMAS-GEN)
+ (,GET-CODE ,GET-GEN)
+ (,GET2-CODE ,GET2-GEN)
+ (,IRSUBR-CODE ,IRSUBR-GEN)
+ (,MAP-CODE ,MAPFR-GEN)
+ (,MARGS-CODE ,MPARGS-GEN)
+ (,MAPLEAVE-CODE ,MAPLEAVE-GEN)
+ (,MAPRET-STOP-CODE ,MAPRET-STOP-GEN)
+ (,UNWIND-CODE ,UNWIND-GEN)
+ (,GVAL-CODE ,GVAL-GEN)
+ (,SETG-CODE ,SETG-GEN)
+ (,TAG-CODE ,TAG-GEN)
+ (,PRINT-CODE ,PRINT-GEN)
+ (,MEMQ-CODE ,MEMQ-GEN)
+ (,LENGTH?-CODE ,LENGTH?-GEN)
+ (,FORM-F-CODE ,FORM-F-GEN)
+ (,INFO-CODE ,INFO-GEN)
+ (,OBLIST?-CODE ,OBLIST?-GEN)
+ (,AS-NXT-CODE ,AS-NXT-GEN)
+ (,AS-IT-IND-VAL-CODE ,ASSOC-FIELD-GET)
+ (,ALL-REST-CODE ,ALL-REST-GEN)
+ (,COPY-LIST-CODE ,LIST-BUILD)
+ (,PUT-SAME-CODE ,SPEC-PUT-GEN)
+ (,BACK-CODE ,BACK-GEN)
+ (,TOP-CODE ,TOP-GEN)
+ (,SUBSTRUC-CODE ,SUBSTRUC-GEN)
+ (,ROT-CODE ,ROT-GEN)
+ (,LSH-CODE ,LSH-GEN)
+ (,BIT-TEST-CODE ,BIT-TEST-GEN)>>
+\f\ 3\ 3\ 3\ 3
\ No newline at end of file
--- /dev/null
+
+
+<REMOVE MUDREF!-OP!-PACKAGE>
+
+<NEWTYPE MUDREF!-OP!-PACKAGE WORD>
+<LINK OP!-PACKAGE "OP">
+<REMOVE IRSUBR>
+<SET HELP-COMPIL T>
+<SET GLUE!- T>
+<SETG TEMPLATE-NTH T>
+<SETG TEMPLATE-PUT T>
+
+<FLOAD "PS:<COMPIL>BOPHAC.MUD">
+<FLOAD "PS:<COMPIL>MUDHAK.MUD">
+
+<BEGIN-HACK "COMPIL">
+
+<BEGIN-MHACK>
+
+
+<SETG L-LOADER ,CLOSE>
+
+<MAPF <> ,REMOVE (
+ DEBUGSW
+ IRSUBR
+ NOTE
+ WARNING
+ ERRS
+ WARNS
+ NOTES
+ DEBUG-COMPILE
+ REASONABLE
+ CAREFUL
+ PRECOMPILED
+ HAIRY-ANALYSIS
+ SRC-FLG
+ BIN-FLG
+ GLOSP
+ ANALY-OK
+ VERBOSE
+ COMPILER)>
+<FLOAD "SRC:<MDL.COMP>COMPDE.NBIN">
--- /dev/null
+<PACKAGE "INFCMP">
+
+<ENTRY ALLTYPES-ANA ROOT-ANA ERRORS-ANA INTERRUPTS-ANA INFO-GEN OBLIST?-ANA OBLIST?-GEN
+ ASSOCIATIONS-ANA NEXT-ANA ASSOC-HACK ASSOC-FIELD-GET AS-NXT-GEN>
+
+<USE "SYMANA" "CHKDCL" "CODGEN" "CACS" "COMCOD" "COMPDEC">
+
+<DEFINE ALLTYPES-ANA (N R)
+ <INFO-GET .N .R |TYPVEC '<VECTOR [REST ATOM]>>>
+
+<DEFINE ROOT-ANA (N R) <INFO-GET .N .R |ROOT OBLIST>>
+
+<DEFINE ERRORS-ANA (N R) <INFO-GET .N .R |ERROBL OBLISTT>>
+
+<DEFINE INTERRUPTS-ANA (N R) <INFO-GET .N .R |INTOBL OBLIST>>
+
+<DEFINE INFO-GET (N R SYM TYP)
+ #DECL ((N) NODE)
+ <ARGCHK <LENGTH <KIDS .N>> 0 <NODE-NAME .N>>
+ <PUT .N ,NODE-TYPE ,INFO-CODE>
+ <PUT .N ,NODE-NAME .SYM>
+ <TYPE-OK? .R .TYP>>
+
+<DEFINE INFO-GEN (N W
+ "AUX" (ADR <ADDRESS:C <NODE-NAME .N>>))
+ #DECL ((N) NODE (VALUE) DATUM)
+ <MOVE:ARG <DATUM <ISTYPE? <RESULT-TYPE .N>> .ADR> .W>>
+
+<PUT ,ALLTYPES ANALYSIS ,ALLTYPES-ANA>
+
+<PUT ,ROOT ANALYSIS ,ROOT-ANA>
+
+<PUT ,ERRORS ANALYSIS ,ERRORS-ANA>
+
+<PUT ,INTERRUPTS ANALYSIS ,INTERRUPTS-ANA>
+
+<DEFINE OBLIST?-ANA (N R "AUX" (K <KIDS .N>))
+ #DECL ((N) NODE (K) <LIST [REST NODE]>)
+ <COND (<SEGFLUSH .N .R>)
+ (ELSE
+ <ARGCHK <LENGTH .K> 1 OBLIST?>
+ <EANA <1 .K> ATOM OBLIST?>
+ <PUT .N ,NODE-TYPE ,OBLIST?-CODE>)>
+ <TYPE-OK? '<OR FALSE OBLIST> .R>>
+
+<PUT ,OBLIST? ANALYSIS ,OBLIST?-ANA>
+
+<DEFINE OBLIST?-GEN (N W
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
+ "AUX" (FLS <==? .W FLUSHED>) (SDIR .DIR)
+ (B2
+ <COND (<AND .FLS .BRANCH> .BRANCH)
+ (ELSE <MAKE:TAG>)>) (B3 <MAKE:TAG>) (RW .W)
+ ATO B4 VAC W2)
+ #DECL ((N) NODE (ATO) DATUM (NK FLS DIR SDIR NOTF BRANCH) <OR FALSE ATOM>)
+ <SET W <GOODACS .N .W>>
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <SET ATO <GEN <1 <KIDS .N>> <DATUM ATOM ANY-AC>>>
+ <VAR-STORE <>>
+ <COND
+ (<AND .BRANCH .FLS>
+ <COND (<OR <==? ,MUDDLE 105> <==? ,MUDDLE 55>>
+ <EMIT <INSTRUCTION <COND (.DIR `SKIPE ) (ELSE `SKIPN )>
+ 2
+ (<ADDRSYM <DATVAL .ATO>>)>>
+ <BRANCH:TAG .BRANCH>
+ <RET-TMP-AC .ATO>)
+ (ELSE
+ <EMIT <INSTRUCTION `HRRZ 2 (<ADDRSYM <DATVAL .ATO>>)>>
+ <EMIT <INSTRUCTION <COND (.DIR `JUMPN) (ELSE `JUMPE)> .BRANCH>>
+ <RET-TMP-AC .ATO>)>)
+ (<OR .NOTF <NOT <==? <NOT .BRANCH> <NOT .DIR>>>>
+ <RET-TMP-AC .ATO>
+ <COND (<OR <==? ,MUDDLE 105> <==? ,MUDDLE 55>>
+ <EMIT <INSTRUCTION <COND (.DIR `SKIPE ) (ELSE `SKIPN )>
+ 2
+ (<ADDRSYM <DATVAL .ATO>>)>>
+ <BRANCH:TAG .B3>)
+ (ELSE
+ <EMIT <INSTRUCTION `HRRZ 2 (<ADDRSYM <DATVAL .ATO>>)>>
+ <EMIT <INSTRUCTION <COND (.DIR `JUMPN) (ELSE `JUMPE)> .B3>>)>
+ <MOVE:ARG <REFERENCE .SDIR> .W>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B3>)
+ (ELSE
+ <SET W2 <DATUM OBLIST <DATVAL .W>>>
+ <COND (<TYPE? <DATVAL .W2> AC>
+ <SGETREG <SET VAC <DATVAL .W2>> .W2>)
+ (ELSE <PUT .W2 ,DATVAL <SET VAC <GETREG .W2>>>)>
+ <RET-TMP-AC .ATO>
+ <COND (.BRANCH
+ <COND (<OR <==? ,MUDDLE 105> <==? ,MUDDLE 55>>
+ <EMIT <INSTRUCTION `SKIPN <ACSYM .VAC> 2
+ (<ADDRSYM <DATVAL .ATO>>)>>)
+ (ELSE
+ <EMIT <INSTRUCTION `HRRZ <ACSYM .VAC> 2
+ (<ADDRSYM <DATVAL .ATO>>)>>)>
+ <COND (<==? .BRANCH .B2>
+ <COND (<OR <==? ,MUDDLE 105> <==? ,MUDDLE 55>>
+ <BRANCH:TAG .BRANCH>)
+ (ELSE
+ <EMIT <INSTRUCTION `JUMPE <ACSYM .VAC> .BRANCH>>)>
+ <GEN-OBL .VAC .W .W2>)
+ (ELSE
+ <COND (<OR <==? ,MUDDLE 105> <==? ,MUDDLE 55>>
+ <BRANCH:TAG .B3>)
+ (ELSE
+ <EMIT <INSTRUCTION `JUMPE <ACSYM .VAC> .B3>>)>
+ <GEN-OBL .VAC .W .W2>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B3>)>)
+ (ELSE
+ <COND (<OR <==? ,MUDDLE 105> <==? ,MUDDLE 55>>
+ <EMIT <INSTRUCTION `SKIPN <ACSYM .VAC> 2
+ (<ADDRSYM <DATVAL .ATO>>)>>
+ <BRANCH:TAG .B2>)
+ (ELSE
+ <EMIT <INSTRUCTION `HRRZ <ACSYM .VAC> 2
+ (<ADDRSYM <DATVAL .ATO>>)>>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM .VAC> .B2>>)>
+ <GEN-OBL .VAC .W .W2>
+ <RET-TMP-AC .W>
+ <BRANCH:TAG .B3>
+ <LABEL:TAG .B2>
+ <MOVE:ARG <REFERENCE <>> .W>
+ <LABEL:TAG .B3>)>)>
+ <MOVE:ARG .W .RW>>
+
+<DEFINE GEN-OBL (AC W1 W2 "AUX" (B <MAKE:TAG>))
+ #DECL ((AC) AC (W1 W2) DATUM)
+ <COND (<OR <==? ,MUDDLE 105> <==? ,MUDDLE 55>>
+ <EMIT <INSTRUCTION `JUMPL <ACSYM .AC> .B>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .AC> (<ADDRSYM .AC>)>>
+ <LABEL:TAG .B>)
+ (ELSE
+ <EMIT <INSTRUCTION `CAMGE <ACSYM .AC> |VECBOT>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .AC> (<ADDRSYM .AC>)>>
+ <EMIT <INSTRUCTION `HRLI <ACSYM .AC> -1>>)>
+ <MOVE:ARG .W2 .W1>>
+
+<DEFINE ASSOCIATIONS-ANA (N R) <AS-NXT .N .R <>>>
+
+<DEFINE NEXT-ANA (N R) <AS-NXT .N .R T>>
+
+<DEFINE AS-NXT (N R ARG)
+ <COND (<SEGFLUSH .N .R>)
+ (ELSE
+ <COND (.ARG
+ <ARGCHK <LENGTH <KIDS .N>> 1 NEXT>
+ <EANA <1 <KIDS .N>> ASOC NEXT>)
+ (ELSE <ARGCHK <LENGTH <KIDS .N>> 0 ASSOCIATIONS>)>
+ <PUT .N ,NODE-TYPE ,AS-NXT-CODE>)>
+ <TYPE-OK? .R '<OR ASOC FALSE>>>
+
+<DEFINE ASSOC-HACK (N R)
+ <COND (<SEGFLUSH .N .R>)
+ (ELSE
+ <ARGCHK <LENGTH <KIDS .N>> 1 <NODE-NAME .N>>
+ <EANA <1 <KIDS .N>> ASOC <NODE-NAME .N>>
+ <PUT .N ,NODE-TYPE ,AS-IT-IND-VAL-CODE>)>
+ <TYPE-OK? .R ANY>>
+
+<PUT ,ASSOCIATIONS ANALYSIS ,ASSOCIATIONS-ANA>
+
+<PUT ,NEXT ANALYSIS ,NEXT-ANA>
+
+<PUT ,ITEM ANALYSIS ,ASSOC-HACK>
+
+<PUT ,INDICATOR ANALYSIS ,ASSOC-HACK>
+
+<PUT ,AVALUE ANALYSIS ,ASSOC-HACK>
+
+<DEFINE ASSOC-FIELD-GET (N W "AUX" (NN <1 <KIDS .N>>) DAT OFF)
+ #DECL ((N NN) NODE (OFF) FIX)
+ <SET OFF
+ <COND (<==? <NODE-SUBR .N> ,ITEM> 0)
+ (<==? <NODE-SUBR .N> ,AVALUE> 2)
+ (ELSE 4)>>
+ <SET DAT <GEN .NN <DATUM ASOC ANY-AC>>>
+ <SET DAT <OFFPTR .OFF .DAT ASOC>>
+ <MOVE:ARG <DATUM .DAT .DAT> .W>>
+
+<DEFINE AS-NXT-GEN (N W
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
+ "AUX" (FLS <==? .W FLUSHED>) (SDIR .DIR)
+ (B2
+ <COND (<AND .FLS .BRANCH> .BRANCH)
+ (ELSE <MAKE:TAG>)>) (B3 <MAKE:TAG>) (RW .W) ATO
+ B4 VAC W2)
+ #DECL ((N) NODE (ATO) DATUM (NK FLS DIR SDIR NOTF BRANCH) <OR FALSE ATOM>)
+ <SET W <GOODACS .N .W>>
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <SET ATO
+ <COND (<==? <NODE-NAME .N> NEXT>
+ <GEN <1 <KIDS .N>> <DATUM ASOC ANY-AC>>)
+ (ELSE
+ <SET ATO <DATUM ASOC ANY-AC>>
+ <PUT .ATO ,DATVAL <GETREG .ATO>>
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM <DATVAL .ATO>>
+ |NODES
+ 1>>
+ .ATO)>>
+ <VAR-STORE <>>
+ <COND
+ (<AND .BRANCH .FLS>
+ <EMIT <INSTRUCTION `HRRZ `O* 6 (<ADDRSYM <DATVAL .ATO>>)>>
+ <EMIT <INSTRUCTION <COND (.DIR `JUMPN ) (ELSE `JUMPE )>
+ `O*
+ .BRANCH>>
+ <RET-TMP-AC .ATO>)
+ (<OR .NOTF <NOT <==? <NOT .BRANCH> <NOT .DIR>>>>
+ <RET-TMP-AC .ATO>
+ <EMIT <INSTRUCTION `HRRZ `O* 6 (<ADDRSYM <DATVAL .ATO>>)>>
+ <EMIT <INSTRUCTION <COND (.DIR `JUMPN ) (ELSE `JUMPE )> `O* .B3>>
+ <MOVE:ARG <REFERENCE .SDIR> .W>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B3>)
+ (ELSE
+ <SET W2 <DATUM ASOC <DATVAL .W>>>
+ <COND (<TYPE? <DATVAL .W2> AC>
+ <SGETREG <SET VAC <DATVAL .W2>> .W2>)
+ (ELSE <PUT .W2 ,DATVAL <SET VAC <GETREG .W2>>>)>
+ <RET-TMP-AC .ATO>
+ <COND (.BRANCH
+ <COND (<==? .BRANCH .B2>
+ <EMIT <INSTRUCTION `HRRZ
+ <ACSYM .VAC>
+ 6
+ (<ADDRSYM <DATVAL .ATO>>)>>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM .VAC> .BRANCH>>
+ <MOVE:ARG .W2 .W>)
+ (ELSE
+ <EMIT <INSTRUCTION `HRRZ
+ <ACSYM .VAC>
+ 6
+ (<ADDRSYM <DATVAL .ATO>>)>>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM .VAC> .B3>>
+ <MOVE:ARG .W2 .W>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B3>)>)
+ (ELSE
+ <EMIT <INSTRUCTION `HRRZ
+ <ACSYM .VAC>
+ 6
+ (<ADDRSYM <DATVAL .ATO>>)>>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM .VAC> .B2>>
+ <MOVE:ARG .W2 .W>
+ <RET-TMP-AC .W>
+ <BRANCH:TAG .B3>
+ <LABEL:TAG .B2>
+ <MOVE:ARG <REFERENCE <>> .W>
+ <LABEL:TAG .B3>)>)>
+ <MOVE:ARG .W .RW>>
+
+<ENDPACKAGE>
+\f
\ No newline at end of file
--- /dev/null
+<PACKAGE "ISTRUC">
+
+<ENTRY ISTRUC-GEN>
+
+<USE "CODGEN" "COMCOD" "CACS" "CHKDCL" "COMPDEC">
+
+
+"ILIST, IVECTOR, IUVECTOR AND ISTRING."
+
+<DEFINE ISTRUC-GEN (N W
+ "AUX" (NAM <NODE-NAME .N>) (K <KIDS .N>)
+ (NT <NODE-TYPE .N>) (BYTSZ <>))
+ #DECL ((N NUM EL) NODE)
+ <COND (<==? .NAM ITUPLE>
+ <ITUPLE-GEN .N
+ .W
+ <==? .NT ,ISTRUC-CODE>
+ <1 .K>
+ <2 .K>
+ <ISTYPE? <RESULT-TYPE .N>>
+ .BYTSZ>)
+ (ELSE
+ <PROG ((STK (0 !.STK)))
+ #DECL ((STK) <SPECIAL LIST>)
+ <COND (<==? .NAM IBYTES>
+ <SET BYTSZ <1 .K>>
+ <SET K <REST .K>>)>
+ <APPLY <NTH ,IERS <LENGTH <MEMQ .NAM ,NAMVEC>>>
+ .N
+ .W
+ <==? .NT ,ISTRUC-CODE>
+ <1 .K>
+ <2 .K>
+ <ISTYPE? <RESULT-TYPE .N>>
+ .BYTSZ>>)>>
+
+<DEFINE ILIST-GEN (N W GENR NUMN EL TYP BYTSZ "AUX" NUM START TEM END ELD)
+ #DECL ((N NUMN EL) NODE (NUM VALUE) DATUM (START END) ATOM)
+ <SET NUM <GEN .NUMN DONT-CARE>>
+ <EMIT <INSTRUCTION `PUSH `P* !<ADDR:VALUE .NUM>>>
+ <RET-TMP-AC .NUM>
+ <STACK:ARGUMENT <REFERENCE ()>>
+ <STACK:ARGUMENT <REFERENCE ()>>
+ <ADD:STACK 4>
+ <ADD:STACK PSLOT>
+ <COND (.GENR <SET ELD <GEN .EL DONT-CARE>>)>
+ <REGSTO T>
+ <LABEL:TAG <SET START <MAKE:TAG>>>
+ <EMIT '<`SOSGE `(P) >>
+ <BRANCH:TAG <SET END <MAKE:TAG>>>
+ <RET-TMP-AC <COND (.GENR <DOEVS .ELD <DATUM ,AC-C ,AC-D>>)
+ (ELSE <GEN .EL <DATUM ,AC-C ,AC-D>>)>>
+ <REGSTO T>
+ <EMIT '<`MOVEI `E* >>
+ <EMIT '<`PUSHJ `P* |CICONS >>
+ <EMIT '<`SKIPE `(TP) >>
+ <EMIT '<`HRRM `B* `@ `(TP) >>
+ <EMIT '<`MOVEM `B* `(TP) >>
+ <EMIT '<`SKIPN `(TP) -2>>
+ <EMIT '<`MOVEM `B* `(TP) -2>>
+ <BRANCH:TAG .START>
+ <LABEL:TAG .END>
+ <EMIT '<`MOVE `B* `(TP) -2>>
+ <EMIT '<`SUB `TP* [<4 (4)>]>>
+ <EMIT '<`SUB `P* [<1 (1)>]>>
+ <AND .GENR <RET-TMP-AC .ELD>>
+ <SET TEM <DATUM .TYP ,AC-B>>
+ <SGETREG ,AC-B .TEM>
+ <MOVE:ARG .TEM .W>>
+
+<DEFINE IVEC-GEN (N W GENR NUMN EL TYP BYTSZ
+ "AUX" NT (UV <==? .TYP UVECTOR>) START END TEM (ETY <>) ADS
+ ACS ANAC ATAG DAT AC OFPT ELD TTEM)
+ #DECL ((N NUMN EL) NODE (NT) FIX (DAT TEM) DATUM (AC) AC (OFPT) OFFPTR)
+ <REGSTO T>
+ <RET-TMP-AC <GEN .NUMN <DATUM FIX ,AC-A>>>
+ <COND (.UV <EMIT '<`MOVEI `O* |IBLOCK >>)
+ (ELSE <EMIT '<`MOVEI `O* |IBLOK1 >>)>
+ <REGSTO T>
+ <EMIT '<`PUSHJ `P* |RCALL >>
+ <COND
+ (<AND <NOT .GENR>
+ <==? <NODE-TYPE .EL> ,QUOTE-CODE>
+ <==? <NODE-NAME .EL> #LOSE *000000000000*>>
+ <MOVE:ARG <FUNCTION:VALUE T> .W>)
+ (<AND <NOT .GENR>
+ <OR <==? <SET NT <NODE-TYPE .EL>> ,QUOTE-CODE>
+ <==? .NT ,LVAL-CODE>
+ <==? .NT ,FLVAL-CODE>
+ <==? .NT ,FGVAL-CODE>
+ <==? .NT ,GVAL-CODE>>>
+ <SET DAT <DATUM .TYP ,AC-B>>
+ <SGETREG <DATVAL .DAT> .DAT>
+ <MUNG-AC ,AC-B .DAT>
+ <SET TEM
+ <GEN .EL
+ <COND (<AND .UV <SET ETY <ISTYPE? <RESULT-TYPE .EL>>>>
+ <DATUM .ETY <GETREG <>>>)
+ (ELSE <ANY2ACS>)>>>
+ <EMIT <INSTRUCTION `MOVE <SET ACS <ACSYM <SET AC <GETREG <>>>>> `B >>
+ <SET ADS <ADDRSYM .AC>>
+ <COND (<==? <NODE-TYPE .NUMN> ,QUOTE-CODE>
+ <OR <G? <CHTYPE <NODE-NAME .NUMN> FIX> 0>
+ <MESSAGE ERROR "BAD ARG TO " <NODE-NAME .N>>>)
+ (ELSE <EMIT <INSTRUCTION `JUMPGE .ACS <SET END <MAKE:TAG>>>>)>
+ <LABEL:TAG <SET START <MAKE:TAG>>>
+ <MUNG-AC .AC>
+ <SET OFPT <OFFPTR <COND (.UV -1) (ELSE 0)> <DATUM .TYP .AC> .TYP>>
+ <MOVE:ARG .TEM <DATUM <COND (.ETY) (.UV WORD) (ELSE .OFPT)> .OFPT>>
+ <AND <TYPE? <DATVAL .TEM> AC> <MUNG-AC <DATVAL .TEM> .TEM>>
+ <AND <TYPE? <DATTYP .TEM> AC> <MUNG-AC <DATTYP .TEM> .TEM>>
+ <COND (.UV <EMIT <INSTRUCTION `AOBJN .ACS .START>>)
+ (ELSE
+ <EMIT <INSTRUCTION `ADD .ACS '[<2 (2)>]>>
+ <EMIT <INSTRUCTION `JUMPL .ACS .START>>)>
+ <AND <ASSIGNED? END> <LABEL:TAG .END>>
+ <COND (.ETY
+ <EMIT <INSTRUCTION `MOVEI
+ `O*
+ <FORM TYPE-CODE!-OP!-PACKAGE .ETY>>>
+ <EMIT <INSTRUCTION PUTYP!-OP!-PACKAGE `O* (.ADS)>>)
+ (.UV
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O* !<ADDR:TYPE .TEM>>>
+ <EMIT <INSTRUCTION PUTYP!-OP!-PACKAGE `O* (.ADS)>>)>
+ <RET-TMP-AC .OFPT>
+ <MOVE:ARG .DAT .W>)
+ (ELSE
+ <REGSTO T>
+ <COND (<==? <NODE-TYPE .NUMN> ,QUOTE-CODE>
+ <OR <G? <CHTYPE <NODE-NAME .NUMN> FIX> 0>
+ <MESSAGE ERROR "BAD ARG TO " <NODE-NAME .N>>>)
+ (ELSE <EMIT <INSTRUCTION `JUMPGE `B* <SET END <MAKE:TAG>>>>)>
+ <SET ETY <ISTYPE? <RESULT-TYPE .EL>>>
+ <COND (<AND .UV .CAREFUL <NOT .ETY>>
+ <EMIT <INSTRUCTION `PUSH `P* '[0]>>
+ <ADD:STACK PSLOT>)>
+ <STACK:ARGUMENT <DATUM .TYP ,AC-B>>
+ <STACK:ARGUMENT <DATUM .TYP ,AC-B>>
+ <ADD:STACK 4>
+ <COND (<AND .ETY .UV>
+ <COND (<N==? <NODE-TYPE .NUMN> ,QUOTE-CODE>
+ <EMIT '<`HLRE `O* `B >>
+ <EMIT '<`SUB `B* `O* >>)>
+ <EMIT <INSTRUCTION `MOVEI
+ `O*
+ <FORM TYPE-CODE!-OP!-PACKAGE .ETY>>>
+ <EMIT <INSTRUCTION PUTYP!-OP!-PACKAGE
+ `O*
+ <COND (<==? <NODE-TYPE .NUMN> ,QUOTE-CODE>
+ <NODE-NAME .NUMN>)
+ (ELSE 0)>
+ `(B) >>)>
+ <COND (.GENR <SET ELD <GEN .EL DONT-CARE>> <REGSTO T>)>
+ <LABEL:TAG <SET START <MAKE:TAG>>>
+ <SET TTEM
+ <COND (<AND .UV .ETY> <DATUM .ETY ANY-AC>)
+ (.UV DONT-CARE)
+ (ELSE <DATUM ANY-AC ANY-AC>)>>
+ <SET TEM <COND (.GENR <DOEVS .ELD .TTEM>) (ELSE <GEN .EL .TTEM>)>>
+ <AND <TYPE? <DATVAL .TEM> AC> <MUNG-AC <DATVAL .TEM> .TEM>>
+ <AND <TYPE? <DATTYP .TEM> AC> <MUNG-AC <DATTYP .TEM> .TEM>>
+ <EMIT <INSTRUCTION `MOVE <SET ACS <ACSYM <SET AC <GETREG <>>>>> `(TP) >>
+ <COND (<AND .UV <NOT .ETY>>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O* !<ADDR:TYPE .TEM>>>
+ <COND (.CAREFUL
+ <EMIT <INSTRUCTION `SKIPE '`(P) >>
+ <BRANCH:TAG <SET ATAG <MAKE:TAG>>>)>
+ <COND (<==? <NODE-TYPE .NUMN> ,QUOTE-CODE>
+ <EMIT <INSTRUCTION PUTYP!-OP!-PACKAGE
+ `O*
+ <NODE-NAME .NUMN>
+ (<ADDRSYM .AC>)>>)
+ (ELSE
+ <PUT .AC ,ACPROT T>
+ <EMIT <INSTRUCTION `HLRE
+ <ACSYM <SET ANAC <GETREG <>>>>
+ <ADDRSYM .AC>>>
+ <PUT .AC ,ACPROT <>>
+ <EMIT <INSTRUCTION `SUBM .ACS <ADDRSYM .ANAC>>>
+ <EMIT <INSTRUCTION PUTYP!-OP!-PACKAGE
+ `O*
+ (<ADDRSYM .ANAC>)>>)>
+ <COND (.CAREFUL
+ <EMIT <INSTRUCTION `MOVEM `O* '`(P) >>
+ <LABEL:TAG .ATAG>
+ <EMIT <INSTRUCTION `CAIE `O* `@ '`(P) >>
+ <BRANCH:TAG |COMPER >)>)>
+ <SET OFPT <OFFPTR <COND (.UV -1) (ELSE 0)> <DATUM .TYP .AC> .TYP>>
+ <VAR-STORE T>
+ <MOVE:ARG .TEM <DATUM <COND (.UV WORD) (ELSE .OFPT)> .OFPT>>
+ <EMIT <INSTRUCTION `ADD .ACS <COND (.UV '[<1 (1)>]) (ELSE '[<2 (2)>])>>>
+ <EMIT <INSTRUCTION `MOVEM .ACS '`(TP) >>
+ <EMIT <INSTRUCTION `JUMPL .ACS .START>>
+ <RET-TMP-AC .OFPT>
+ <RET-TMP-AC .TEM>
+ <SET TEM <DATUM <COND (<ISTYPE? <RESULT-TYPE .N>>) (ELSE ,AC-A)> ,AC-B>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM <CHTYPE <DATVAL .TEM> AC>> -2 '`(TP) >>
+ <EMIT <INSTRUCTION `SUB `TP* '[<4 (4)>]>>
+ <COND (<AND .UV .CAREFUL <NOT .ETY>>
+ <EMIT <INSTRUCTION `SUB `P* '[<1 (1)>]>>)>
+ <AND <ASSIGNED? END> <LABEL:TAG .END>>
+ <MOVE:ARG .TEM .W>)>>
+
+<DEFINE DOEVS (D W)
+ #DECL ((D VALUE) DATUM)
+ <STACK:ARGUMENT .D>
+ <REGSTO T>
+ <SUBR:CALL EVAL 1>
+ <MOVE:ARG <FUNCTION:VALUE T> .W>>
+
+<DEFINE ISTR-GEN (N W GENR NUMN EL TYP BYTSZ
+ "AUX" RES NK TN NN TT ACS OAC TEM BP START END ETY DAT
+ (SOB <==? <NODE-SUBR .N> ,ISTRING>) ELD TTEM
+ (OT <COND (.SOB CHARACTER) (ELSE FIX)>)
+ (NT <COND (.SOB STRING) (ELSE BYTES)>) (SIZ 7) SIZD)
+ #DECL ((N NUMN EL) NODE (TN SIZ) FIX (RES DAT SIZD TEM) DATUM (TT) AC
+ (NN) <PRIMTYPE WORD> (BYTSZ) <OR FALSE NODE>
+ (BP) <FORM ANY <LIST ANY>>)
+ <COND (.BYTSZ
+ <COND (<==? <NODE-TYPE .BYTSZ> ,QUOTE-CODE>
+ <SET SIZ <NODE-NAME .BYTSZ>>)
+ (ELSE <SET SIZD <GEN .BYTSZ <DATUM FIX ANY-AC>>>)>)>
+ <REGSTO T>
+ <COND (<==? <NODE-TYPE .NUMN> ,QUOTE-CODE>
+ <SET NK T>
+ <SGETREG ,AC-A <>>
+ <AND <OR <L? <SET TN <NODE-NAME .NUMN>> 0> <G? .TN 262143>>
+ <MESSAGE ERROR "BAD ARG TO ISTRING/IBYTES ">>
+ <COND (<ASSIGNED? SIZD>
+ <EMIT '<`MOVEI `A* 36>>
+ <EMIT <INSTRUCTION `IDIV `A* !<ADDR:VALUE .SIZD>>>
+ <EMIT <INSTRUCTION `MOVEI `O* .TN>>
+ <EMIT '<`ADDI `O* (`A ) -1>>
+ <EMIT '<`IDIVM `O* `A >>)
+ (ELSE
+ <EMIT <INSTRUCTION `MOVEI
+ `A*
+ </ <+ .TN </ 36 .SIZ> -1> </ 36 .SIZ>>>>)>)
+ (ELSE
+ <SET NK <>>
+ <SET TEM <GEN .NUMN <DATUM FIX ,AC-A>>>
+ <MUNG-AC ,AC-A .TEM>
+ <RET-TMP-AC .TEM>
+ <SGETREG ,AC-B <>>
+ <ADD:STACK PSLOT>
+ <COND (<NOT <ASSIGNED? SIZD>>
+ <EMIT '<`PUSH `P* `A >>
+ <EMIT <INSTRUCTION `ADDI `A* <- </ 36 .SIZ> 1>>>
+ <EMIT <INSTRUCTION `IDIVI `A* </ 36 .SIZ>>>)
+ (ELSE
+ <EMIT '<`PUSH `P* `A >>
+ <EMIT '<`MOVEI `A* 36>>
+ <EMIT <INSTRUCTION `IDIV `A* !<ADDR:VALUE .SIZD>>>
+ <EMIT <INSTRUCTION `MOVE `O* (`P )>>
+ <EMIT '<`ADDI `O* (`A ) -1>>
+ <EMIT '<`IDIVM `O* `A >>)>)>
+ <EMIT '<`MOVEI `O* |IBLOCK >>
+ <EMIT '<`PUSHJ `P* |RCALL >>
+ <SET RES <DATUM UVECTOR ,AC-B>>
+ <SGETREG ,AC-B .RES>
+ <MUNG-AC ,AC-A>
+ <MUNG-AC ,AC-B .RES>
+ <COND
+ (<AND <NOT .GENR> <==? <NODE-TYPE .EL> ,QUOTE-CODE> <NOT <ASSIGNED? SIZD>>>
+ <COND (<NOT <0? <CHTYPE <SET NN <NODE-NAME .EL>> FIX>>>
+ <OR .NK
+ <EMIT <INSTRUCTION `JUMPGE `B* <SET END <MAKE:TAG>>>>>
+ <SET NN <WOFBYTE .SIZ <CHTYPE .NN FIX>>>
+ <SET DAT <DATUM FIX FIX>>
+ <PUT .DAT ,DATVAL <GETREG .DAT>>
+ <EMIT <INSTRUCTION `MOVE <SET ACS <ACSYM <DATVAL .DAT>>> `B >>
+ <EMIT <INSTRUCTION `MOVE <SET OAC <ACSYM <GETREG <>>>> [.NN]>>
+ <LABEL:TAG <SET START <MAKE:TAG>>>
+ <EMIT <INSTRUCTION `MOVEM
+ .OAC
+ (<ADDRSYM <CHTYPE <DATVAL .DAT> AC>>)>>
+ <EMIT <INSTRUCTION `AOBJN .ACS .START>>
+ <RET-TMP-AC .DAT>
+ <MUNG-AC <DATVAL .DAT>>)>)
+ (ELSE
+ <OR .NK
+ <ASSIGNED? SIZD>
+ <EMIT <INSTRUCTION `JUMPGE `B* <SET END <MAKE:TAG>>>>>
+ <RET-TMP-AC <STACK:ARGUMENT .RES>>
+ <COND (.NK <EMIT <INSTRUCTION `PUSH `P* [.TN]>>)
+ (ELSE <EMIT '<`PUSH `P* `(P) >>)>
+ <EMIT <INSTRUCTION `PUSH
+ `P*
+ [<SET BP
+ <FORM (<COND (<NOT <ASSIGNED? SIZD>>
+ <ORB #WORD *000000440000*
+ <LSH .SIZ 6>>)
+ (ELSE #WORD *000000440000*)>)
+ (IDX)>>]>>
+ <MAPF <> ,ADD:STACK '(2 PSLOT PSLOT)>
+ <COND (<ASSIGNED? SIZD>
+ <SGETREG ,AC-A <>>
+ <EMIT '<`MOVEI 36>>
+ <EMIT <INSTRUCTION `IDIV !<ADDR:VALUE .SIZD>>>
+ <EMIT '<`ASH `A* 6>>
+ <EMIT <INSTRUCTION `IOR `A* !<ADDR:VALUE .SIZD>>>
+ <RET-TMP-AC .SIZD>
+ <EMIT '<`DPB `A* [<(#WORD *000000300600*) `(P) >]>>
+ <EMIT '<`ASH `A* 6>>
+ <EMIT '<`HRRM `A* `(TP) -1>>
+ <COND (<NOT .NK>
+ <EMIT '<`SKIPG `(P) -1>>
+ <BRANCH:TAG <SET END <MAKE:TAG>>>)>)>
+ <COND (.GENR <SET ELD <GEN .EL DONT-CARE>> <REGSTO T>)>
+ <LABEL:TAG <SET START <MAKE:TAG>>>
+ <SET ETY <ISTYPE? <RESULT-TYPE .EL>>>
+ <SET TTEM
+ <COND (<AND .CAREFUL <NOT .ETY>> <DATUM ANY-AC ANY-AC>)
+ (ELSE <DATUM .OT ANY-AC>)>>
+ <SET TEM <COND (.GENR <DOEVS .ELD .TTEM>) (ELSE <GEN .EL .TTEM>)>>
+ <COND (<AND .CAREFUL <NOT .ETY>>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O* !<ADDR:TYPE .TEM>>>
+ <EMIT <INSTRUCTION `CAIE `O* <FORM TYPE-CODE!-OP!-PACKAGE .OT>>>
+ <BRANCH:TAG |COMPER >)>
+ <EMIT <INSTRUCTION `HRRZ <ACSYM <SET TT <GETREG <>>>> '`(TP) >>
+ <PUT <2 .BP> 1 <ADDRSYM .TT>>
+ <EMIT <INSTRUCTION `IDPB <ACSYM <CHTYPE <DATVAL .TEM> AC>> '`(P) >>
+ <MUNG-AC <DATVAL .TEM> .TEM>
+ <AND <TYPE? <DATTYP .TEM> AC> <MUNG-AC <DATTYP .TEM> .TEM>>
+ <RET-TMP-AC .TEM>
+ <VAR-STORE T>
+ <EMIT '<`SOSE `(P) -1>>
+ <BRANCH:TAG .START>
+ <COND (<ASSIGNED? END> <LABEL:TAG .END>)>
+ <EMIT '<`MOVE `B* `(TP) >>
+ <EMIT '<`HRL `B* `(TP) -1>>
+ <EMIT '<`SUB `TP* [<2 (2)>]>>
+ <EMIT '<`SUB `P* [<2 (2)>]>>
+ <SGETREG <DATVAL .RES> .RES>)>
+ <RET-TMP-AC .RES>
+ <COND (.NK
+ <EMIT <INSTRUCTION `MOVE
+ `A*
+ [<FORM .TN
+ (<FORM TYPE-CODE!-OP!-PACKAGE .NT>)>]>>)
+ (ELSE
+ <AND <ASSIGNED? END> <LABEL:TAG .END>>
+ <EMIT '<`POP `P* `A >>
+ <EMIT <INSTRUCTION `HRLI `A* <FORM TYPE-CODE!-OP!-PACKAGE .NT>>>)>
+ <COND (<NOT <ASSIGNED? SIZD>>
+ <EMIT <INSTRUCTION `HRLI
+ `B*
+ <CHTYPE <ORB <LSH .SIZ 6> <LSH <MOD 36 .SIZ> 12>>
+ FIX>>>)>
+ <EMIT '<`SUBI `B* 1>>
+ <MOVE:ARG <FUNCTION:VALUE T> .W>>
+
+<DEFINE ITUPLE-GEN (N W GENR NUMN EL TYP BYTSZ
+ "AUX" (START <MAKE:TAG>) (END <MAKE:TAG>) NX NT TEM
+ (NTEM <DATUM FIX ,AC-D>) (DOFLG <>) (ONEFLG <>)
+ (SFLG <GOOD-TUPLE .N>) ELD TTEM NW)
+ #DECL ((NT) FIX (NTEM TEM) DATUM (START END) ATOM (NUMN N EL) NODE
+ (DOFLG) <OR FIX ATOM FALSE>)
+ <REGSTO T>
+ <OR <TYPE-OK? <RESULT-TYPE .NUMN> FIX>
+ <MESSAGE ERROR "BAD ARG TO ITUPLE" .N>>
+ <COND (<==? <NODE-TYPE .NUMN> ,QUOTE-CODE>
+ <COND (<L? <SET DOFLG <NODE-NAME .NUMN>> 0>
+ <MESSAGE ERROR "BAD-ARG TO ITUPLE" .N>)>)>
+ <COND
+ (<AND .SFLG <0? .DOFLG>> <ADD:STACK 2>)
+ (<COND
+ (<AND <NOT .GENR>
+ <==? <NODE-TYPE .EL> ,QUOTE-CODE>
+ <==? <NODE-NAME .EL> #LOSE *000000000000*>>
+ <COND (.DOFLG <EMIT <INSTRUCTION `MOVEI `A* <* .DOFLG 2>>>)
+ (ELSE
+ <GEN .NUMN .NTEM>
+ <AND .CAREFUL <EMIT <INSTRUCTION `JUMPL `D* |COMPER >>>
+ <EMIT <INSTRUCTION `MOVEI `A* (<ADDRSYM <CHTYPE <DATVAL .NTEM> AC>>)>>
+ <EMIT <INSTRUCTION `ASH `A* 1>>
+ <EMIT <INSTRUCTION `PUSH `P* <ADDRSYM <CHTYPE <DATVAL .NTEM> AC>>>>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM <CHTYPE <DATVAL .NTEM> AC>> .END>>
+ <RET-TMP-AC .NTEM>)>
+ <REGSTO T>
+ <EMIT '<`PUSHJ `P* |TPALOC >>
+ <COND (<SET NX <GOOD-TUPLE .N>> <ADD:STACK <+ <CHTYPE .NX FIX> 2>>)
+ (ELSE <ADD:STACK PSTACK>)>
+ <LABEL:TAG .END>)
+ (<AND <NOT .GENR>
+ <OR <==? <SET NT <NODE-TYPE .EL>> ,QUOTE-CODE>
+ <==? .NT ,LVAL-CODE>
+ <==? .NT ,FLVAL-CODE>
+ <==? .NT ,FGVAL-CODE>
+ <==? .NT ,GVAL-CODE>>>
+ <COND (<NOT .DOFLG>
+ <GEN .NUMN .NTEM>
+ <AND .CAREFUL
+ <EMIT <INSTRUCTION `JUMPL
+ <ACSYM <CHTYPE <DATVAL .NTEM> AC>>
+ |COMPER >>>)>
+ <SET TEM <GEN .EL <DATUM ANY-AC ANY-AC>>>
+ <COND (<NOT .DOFLG> <TOACV .NTEM> <ADD:STACK PSLOT> <ADD:STACK PSTACK>)>
+ <COND (.DOFLG
+ <COND (<==? .DOFLG 1> <SET ONEFLG T>)
+ (<EMIT <INSTRUCTION `PUSH `P* <VECTOR <- .DOFLG 1>>>>)>)
+ (ELSE
+ <EMIT <INSTRUCTION `PUSH `P* <ADDRSYM <CHTYPE <DATVAL .NTEM> AC>>>>
+ <EMIT <INSTRUCTION `PUSH `P* <ADDRSYM <CHTYPE <DATVAL .NTEM> AC>>>>)>
+ <COND (<NOT .DOFLG>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM <CHTYPE <DATVAL .NTEM> AC>> .END>>)>
+ <TOACV .TEM>
+ <EMIT <INSTRUCTION `PUSH `TP* <ADDRSYM <CHTYPE <DATTYP .TEM> AC>>>>
+ <EMIT <INSTRUCTION `PUSH `TP* <ADDRSYM <CHTYPE <DATVAL .TEM> AC>>>>
+ <COND (<NOT .DOFLG>
+ <EMIT '<`SOSG -1 `(P) >>
+ <EMIT <INSTRUCTION `JRST .END>>
+ <RET-TMP-AC .NTEM>)>
+ <RET-TMP-AC .TEM>
+ <REGSTO T>
+ <COND (<AND .DOFLG .ONEFLG>)
+ (<LABEL:TAG .START>
+ <EMIT '<INTGO!-OP!-PACKAGE>>
+ <EMIT <INSTRUCTION `PUSH `TP* -1 `(TP) >>
+ <EMIT <INSTRUCTION `PUSH `TP* -1 `(TP) >>
+ <EMIT <COND (.DOFLG '<`SOSE `(P) >) ('<`SOSE -1 `(P) >)>>
+ <EMIT <INSTRUCTION `JRST .START>>)>
+ <LABEL:TAG .END>
+ <COND (<SET NX <GOOD-TUPLE .N>>
+ <OR .ONEFLG <EMIT '<`SUB `P* [<1 (1)>]>>>
+ <ADD:STACK <+ <CHTYPE .NX FIX> 2>>)>)
+ (ELSE
+ <COND (<NOT .DOFLG>
+ <GEN .NUMN .NTEM>
+ <EMIT <INSTRUCTION `PUSH `P* <ADDRSYM <CHTYPE <DATVAL .NTEM> AC>>>>
+ <EMIT <INSTRUCTION `PUSH `P* <ADDRSYM <CHTYPE <DATVAL .NTEM> AC>>>>)
+ (ELSE
+ <EMIT <INSTRUCTION `PUSH `P* [.DOFLG]>>
+ <EMIT <INSTRUCTION `PUSH `P* [.DOFLG]>>)>
+ <ADD:STACK PSLOT>
+ <ADD:STACK PSTACK>
+ <COND (<NOT .DOFLG>
+ <AND .CAREFUL
+ <EMIT <INSTRUCTION `JUMPL
+ <ACSYM <CHTYPE <DATVAL .NTEM> AC>>
+ |COMPER >>>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM <CHTYPE <DATVAL .NTEM> AC>> .END>>
+ <RET-TMP-AC .NTEM>)>
+ <COND (.GENR <SET ELD <GEN .EL DONT-CARE>>)>
+ <COND (<AND .DOFLG <0? .DOFLG>> <REGSTO T>)
+ (<REGSTO T>
+ <LABEL:TAG .START>
+ <EMIT '<INTGO!-OP!-PACKAGE>>
+ <SET TEM
+ <COND (.GENR <DOEVS .ELD <DATUM ANY-AC ANY-AC>>)
+ (ELSE <GEN .EL <DATUM ANY-AC ANY-AC>>)>>
+ <EMIT <INSTRUCTION `PUSH `TP* <ADDRSYM <CHTYPE <DATTYP .TEM> AC>>>>
+ <EMIT <INSTRUCTION `PUSH `TP* <ADDRSYM <CHTYPE <DATVAL .TEM> AC>>>>
+ <RET-TMP-AC .TEM>
+ <REGSTO T>
+ <EMIT <INSTRUCTION `SOSE -1 `(P) >>
+ <BRANCH:TAG .START>)>
+ <LABEL:TAG .END>)>)>
+ <COND (<NOT .SFLG>
+ <COND (.DOFLG <EMIT <INSTRUCTION `MOVEI `D* <* .DOFLG 2>>>)
+ (ELSE <EMIT '<`MOVE `D* `(P) >> <EMIT '<`ASH `D* 1>>)>
+ <EMIT '<`AOS `(P) >>)
+ (<EMIT <INSTRUCTION `MOVEI `D* <* .DOFLG 2>>>)>
+ <SET NW <TUPLE:FINAL>>
+ <COND (<==? .W DONT-CARE> .NW) (ELSE <MOVE:ARG .W .NW>)>>
+
+<SETG NAMVEC '![ITUPLE ILIST IFORM IVECTOR IUVECTOR ISTRING IBYTES!]>
+
+<SETG IERS
+ ![,ISTR-GEN
+ ,ISTR-GEN
+ ,IVEC-GEN
+ ,IVEC-GEN
+ ,ILIST-GEN
+ ,ILIST-GEN
+ ,ITUPLE-GEN!]>
+
+<DEFINE WOFBYTE (SIZ VAL "AUX" (M <MOD 36 .SIZ>) (NUM </ 36 .SIZ>))
+ #DECL ((SIZ VAL NUM M) FIX)
+ <REPEAT ((TOT 0))
+ #DECL ((TOT) FIX)
+ <SET TOT <CHTYPE <ORB <LSH .TOT .SIZ> .VAL> FIX>>
+ <AND <L? <SET NUM <- .NUM 1>> 0> <RETURN <LSH .TOT .M>>>>>
+<ENDPACKAGE>\ 3\ 3\ 3
\ No newline at end of file
--- /dev/null
+<PACKAGE "LNQGEN">
+
+<ENTRY LENGTH?-GEN>
+
+<USE "CODGEN" "COMCOD" "CACS" "CHKDCL" "COMPDEC" "COMTEM">
+
+<DEFINE LENGTH?-GEN (N W
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
+ "AUX" QDAT (STR <1 <KIDS .N>>) (FLG <>) (NUM <2 <KIDS .N>>)
+ (TYP <RESULT-TYPE .STR>) (TPS <STRUCTYP .TYP>)
+ (TYP1 <COND (<ISTYPE? .TYP>) (ELSE .TPS)>)
+ (FLS <==? .W FLUSHED>) (SDIR .DIR) (B3 <MAKE:TAG>) NK
+ NN
+ (B2
+ <COND (<AND .FLS .BRANCH> .BRANCH)
+ (ELSE <MAKE:TAG>)>) SAC NAC STRD NUMD TEM T1
+ (TEMP? <==? .TPS TEMPLATE>) (RW .W))
+ #DECL ((N STR NUM) NODE (QDAT STRD NUMD) DATUM (SAC NAC) AC (NN) FIX
+ (TPS TYP1 B2 B3) ATOM (NK FLS DIR SDIR NOTF BRANCH) <OR FALSE ATOM>)
+ <SET W <GOODACS .N .W>>
+ <COND (<==? <NODE-TYPE .NUM> ,QUOTE-CODE>
+ <SET NK T>
+ <COND (<OR <L? <SET NN <NODE-NAME .NUM>> 0> <G? .NN 262144>>
+ <MESSAGE ERROR " ARG OUT OF RANGE LENGTH? " .NN>)>)
+ (ELSE <SET NK <>>)>
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <COND
+ (<==? .TPS LIST>
+ <SET STRD <GEN .STR <DATUM .TYP1 ANY-AC>>>
+ <COND
+ (.NK
+ <PUT <SET NUMD <REG? FIX .W>>
+ ,DATVAL
+ <SET NAC <GETREG .NUMD>>>
+ <EMIT <INSTRUCTION `MOVSI <ACSYM .NAC> <- -1 .NN>>>)
+ (ELSE
+ <SET NUMD <GEN .NUM DONT-CARE>>
+ <COND (<TYPE? <DATVAL .NUMD> AC>
+ <EMIT <INSTRUCTION `MOVNS <ADDRSYM <SET NAC <DATVAL .NUMD>>>>>)
+ (ELSE
+ <EMIT <INSTRUCTION `MOVN
+ <ACSYM <SET NAC <GETREG .NUMD>>>
+ !<ADDR:VALUE .NUMD>>>
+ <RET-TMP-AC <DATVAL .NUMD> .NUMD>
+ <PUT .NUMD ,DATVAL .NAC>)>
+ <RET-TMP-AC <DATTYP .NUMD> .NUMD>
+ <PUT .NUMD ,DATTYP FIX>
+ <EMIT <INSTRUCTION `MOVSI <ACSYM .NAC> -1 (<ADDRSYM .NAC>)>>)>
+ <VAR-STORE>
+ <PUT .NAC ,ACPROT T>
+ <TOACV .STRD>
+ <PUT .NAC ,ACPROT <>>
+ <SET SAC <DATVAL .STRD>>
+ <MUNG-AC .SAC .STRD>
+ <MUNG-AC .NAC .NUMD>
+ <EMIT <INSTRUCTION `JUMPE
+ <ACSYM .SAC>
+ <COND (.DIR .B2) (ELSE .B3)>>>
+ <EMIT <INSTRUCTION `HRRZ <ACSYM .SAC> (<ADDRSYM .SAC>)>>
+ <EMIT <INSTRUCTION `AOBJN <ACSYM .NAC> '.HERE!-OP!-PACKAGE -2>>
+ <RET-TMP-AC .STRD>
+ <COND (<AND .BRANCH .FLS>
+ <COND (<NOT .DIR> <BRANCH:TAG .B2> <LABEL:TAG .B3>)>
+ <RET-TMP-AC .NUMD>)
+ (<OR .NOTF <NOT <==? <NOT .BRANCH> <NOT .DIR>>>>
+ <RET-TMP-AC .NUMD>
+ <COND (<AND .NOTF .DIR> <BRANCH:TAG .B3> <LABEL:TAG .B2>)>
+ <MOVE:ARG <REFERENCE .SDIR> .W>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B3>)
+ (ELSE
+ <COND (.BRANCH
+ <BRANCH:TAG .B3>
+ <LABEL:TAG .B2>
+ <EMIT <INSTRUCTION `MOVEI <ACSYM .NAC> (<ADDRSYM .NAC>)>>
+ <SET W <MOVE:ARG .NUMD .W>>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B3>)
+ (ELSE
+ <COND (<==? .NAC <DATVAL .W>> <RET-TMP-AC .NAC .NUMD>)>
+ <COND (<==? <DATTYP .NUMD> <DATTYP .W>>
+ <RET-TMP-AC <DATTYP .NUMD> .NUMD>)>
+ <RET-TMP-AC <MOVE:ARG <REFERENCE <>> .W>>
+ <BRANCH:TAG .B2>
+ <LABEL:TAG .B3>
+ <EMIT <INSTRUCTION `MOVEI <ACSYM .NAC> (<ADDRSYM .NAC>)>>
+ <SET W <MOVE:ARG .NUMD .W>>
+ <LABEL:TAG .B2>)>)>)
+ (ELSE
+ <COND
+ (<AND <N==? .TPS STRING> <N==? .TPS BYTES>
+ .NK
+ <OR .FLS .NOTF <N==? <NOT .BRANCH> <NOT .DIR>>>>
+ <COND (.TEMP?
+ <SET STRD <GEN .STR DONT-CARE>>
+ <RET-TMP-AC <DATTYP .STRD> .STRD>)
+ (<SET STRD <GEN .STR <DATUM .TYP1 ANY-AC>>>)>
+ <VAR-STORE>
+ <COND (.TEMP?
+ <SET QDAT <DATUM FIX ANY-AC>>
+ <COND (<TYPE? <DATVAL .STRD> AC>
+ <PUT .QDAT ,DATVAL <DATVAL .STRD>>)
+ (ELSE <PUT .QDAT ,DATVAL <GETREG .QDAT>>)>
+ <GET:TEMPLATE:LENGTH <ISTYPE? .TYP> .STRD .QDAT>
+ <EMIT <INSTRUCTION <COND (<COND (<AND .BRANCH .FLS> .DIR)
+ (ELSE .DIR)>
+ `CAIL )
+ (ELSE `CAIG )>
+ <ACSYM <DATVAL .QDAT>>
+ .NN>>
+ <RET-TMP-AC .QDAT>)
+ (<EMIT <INSTRUCTION <COND (<COND (<AND .BRANCH .FLS> .DIR)
+ (ELSE <NOT .DIR>)>
+ `CAML )
+ (ELSE `CAMG )>
+ <ACSYM <SET SAC <DATVAL .STRD>>>
+ [<FORM
+ (<- <* .NN
+ <COND (<OR <==? .TPS VECTOR>
+ <==? .TPS TUPLE>>
+ 2)
+ (ELSE 1)>>>)>]>>)>
+ <RET-TMP-AC .STRD>
+ <SET FLG T>)
+ (<OR <==? .TPS STRING> <==? .TPS BYTES>>
+ <SET STRD <GEN .STR DONT-CARE>>
+ <RET-TMP-AC <DATVAL .STRD> .STRD>
+ <COND (<TYPE? <DATTYP .STRD> AC>
+ <SET STRD <DATUM FIX <SET NAC <DATTYP <SET NUMD .STRD>>>>>
+ <SET SAC
+ <COND (<AND <TYPE? .W DATUM> <TYPE? <DATVAL .W> AC>>
+ <SGETREG <DATVAL .W> .STRD>)
+ (<ACRESIDUE .NAC> <GETREG .STRD>)
+ (ELSE .NAC)>>
+ <PUT .STRD ,DATVAL .SAC>
+ <COND (<N==? .NAC .SAC>
+ <EMIT <INSTRUCTION `MOVEI <ACSYM .SAC> (<ADDRSYM .NAC>)>>
+ <RET-TMP-AC .NAC .NUMD>)
+ (ELSE
+ <RET-TMP-AC .NUMD>
+ <SGETREG .SAC .STRD>
+ <MUNG-AC .SAC .STRD>
+ <EMIT <INSTRUCTION `MOVEI
+ <ACSYM .SAC>
+ (<ADDRSYM .NAC>)>>)>)
+ (ELSE
+ <SET SAC
+ <COND (<AND <TYPE? .W DATUM> <TYPE? <DATVAL .W> AC>>
+ <SGETREG <DATVAL .W> <>>)
+ (ELSE <GETREG <>>)>>
+ <EMIT <INSTRUCTION `HRRZ <ACSYM .SAC> !<ADDR:TYPE .STRD>>>
+ <RET-TMP-AC <DATTYP .STRD> .STRD>
+ <SET STRD <DATUM FIX .SAC>>
+ <PUT .SAC ,ACLINK (.STRD !<ACLINK .SAC>)>)>)
+ (ELSE
+ <SET STRD <GEN .STR DONT-CARE>>
+ <RET-TMP-AC <DATTYP .STRD> .STRD>
+ <COND
+ (<AND <TYPE? .W DATUM>
+ <TYPE? <DATVAL .STRD> AC>
+ <==? <DATVAL .W> <DATVAL .STRD>>>
+ <COND (.TEMP?
+ <GET:TEMPLATE:LENGTH .STRD <SET SAC <DATVAL .STRD>>>)
+ (ELSE
+ <EMIT <INSTRUCTION
+ `HLRES <ADDRSYM <SET SAC <DATVAL .STRD>>>>>)>)
+ (ELSE
+ <SET SAC
+ <COND (<AND <TYPE? .W DATUM> <TYPE? <DATVAL .W> AC>>
+ <SGETREG <DATVAL .W> .STRD>)
+ (ELSE <GETREG .STRD>)>>
+ <RET-TMP-AC .STRD>
+ <PUT .SAC ,ACPROT T>
+ <COND (.TEMP? <GET:TEMPLATE:LENGTH <ISTYPE? .TYP> .STRD .SAC>)
+ (<EMIT <INSTRUCTION `HLRE <ACSYM .SAC> !<ADDR:VALUE .STRD>>>)>
+ <PUT .SAC ,ACPROT <>>
+ <PUT .STRD ,DATVAL .SAC>)>
+ <PUT .STRD ,DATTYP FIX>
+ <COND (<NOT .TEMP?>
+ <EMIT <INSTRUCTION `MOVNS <ADDRSYM .SAC>>>
+ <COND (<OR <==? .TPS VECTOR> <==? .TPS TUPLE>>
+ <EMIT <INSTRUCTION `ASH <ACSYM .SAC> -1>>)>)>)>
+ <COND (<NOT .FLG>
+ <MUNG-AC .SAC .STRD>
+ <SET NUMD <GEN .NUM DONT-CARE>>
+ <RET-TMP-AC <DATTYP .NUMD> .NUMD>
+ <VAR-STORE>
+ <PUT .NUMD ,DATTYP FIX>
+ <COND (<N==? .SAC <DATVAL .STRD>>
+ <COND (<ACLINK .SAC> <TOACV .STRD> <SET SAC <DATVAL .STRD>>)
+ (ELSE
+ <MOVE:VALUE <DATVAL .STRD> .SAC>
+ <PUT .SAC ,ACLINK (.STRD !<ACLINK .SAC>)>
+ <PUT .STRD ,DATVAL .SAC>)>)>
+ <IMCHK <COND (<COND (<AND .BRANCH .FLS> .DIR)
+ (<OR .NOTF <N==? <NOT .BRANCH> <NOT .DIR>>>
+ <NOT .DIR>)
+ (ELSE <AND <SET FLG <=? .W .STRD>> .DIR>)>
+ '(`CAMG `CAIG ))
+ (ELSE '(`CAMLE `CAILE ))>
+ <ACSYM .SAC>
+ <DATVAL .NUMD>>
+ <RET-TMP-AC .NUMD>)>
+ <COND (<AND .BRANCH .FLS>
+ <BRANCH:TAG .BRANCH>
+ <OR .FLG <RET-TMP-AC .STRD>>)
+ (<OR .NOTF <N==? <NOT .BRANCH> <NOT .DIR>>>
+ <OR .FLG <RET-TMP-AC .STRD>>
+ <BRANCH:TAG .B2>
+ <COND (.BRANCH
+ <MOVE:ARG <REFERENCE .SDIR> .W>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B2>)>)
+ (ELSE
+ <COND (.BRANCH
+ <COND (<NOT .FLG> <BRANCH:TAG .B2>)>
+ <RET-TMP-AC <MOVE:ARG .STRD .W>>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B2>)
+ (ELSE
+ <BRANCH:TAG .B2>
+ <RET-TMP-AC <MOVE:ARG .STRD .W>>
+ <BRANCH:TAG .B3>
+ <LABEL:TAG .B2>
+ <MOVE:ARG <REFERENCE <>> .W>
+ <LABEL:TAG .B3>)>)>)>
+ <MOVE:ARG .W .RW>>
+
+<ENDPACKAGE>
+\f\ 3\ 3\ 3\ 3
\ No newline at end of file
--- /dev/null
+<PACKAGE "MAPANA">
+
+<ENTRY MAPPER-AN MAPRET-STOP-ANA MAPLEAVE-ANA MENTROPY MAUX MAUX1 MTUPLE MBAD
+ MOPT MOPT2 MARGS-ANA MNORM>
+
+<USE "SYMANA" "CHKDCL" "COMPDEC" "ADVMESS">
+
+<SETG SPECIAL-MAPF-R-SUBRS ![,LIST ,+ ,* ,MAX ,MIN!]>
+
+<DEFINE MAPPER-AN (MNOD MRTYP
+ "AUX" (K <KIDS .MNOD>) TT ITRNOD FAP T TF (MPSTRS ())
+ (R? <==? <NODE-SUBR .MNOD> ,MAPR>) (TUPCNT 1)
+ (RETYPS NO-RETURN) TEM ASSU L-D L-V D-V VALSPCD SBR
+ (SBRL <>) (SEGFX ()) FINTYPE STATE (FRET T) (FSTOP T)
+ (OV .VARTBL) NSTR (CHF <>))
+ #DECL ((FAP ITRNOD) NODE (K) <LIST [REST NODE]> (TUPCNT TT NSTR) FIX
+ (MPSTRS L-V D-V) <SPECIAL LIST> (R?) <SPECIAL <OR ATOM FALSE>>
+ (STATE) <SPECIAL FIX> (SEGFX) <SPECIAL <LIST [REST NODE]>>
+ (MNOD) <SPECIAL NODE> (OV) SYMTAB
+ (FRET FSTOP MRTYP RETYPS) <SPECIAL ANY> (VALSPCD) <SPECIAL LIST>
+ (ASSU L-D) LIST (SBRL) <OR UVECTOR FALSE>)
+ <SET TF <EANA <SET FAP <1 .K>> ANY <NODE-NAME .MNOD>>>
+ <COND (<AND <SET SBR <SUBAP? .FAP>>
+ <SET SBRL <MEMQ ,.SBR ,SPECIAL-MAPF-R-SUBRS>>>
+ <PUT .FAP ,NODE-TYPE ,MFIRST-CODE>
+ <COND (<N==? ,.SBR ,LIST> <SET FINTYPE '<OR FIX FLOAT>> <SET STATE 1>)
+ (ELSE <SET FINTYPE LIST>)>
+ <PUT .FAP ,NODE-SUBR <LENGTH .SBRL>>)>
+ <PUT .MNOD ,STACKS <* <SET NSTR <- <LENGTH .K> 2>> 2>>
+ <SET ITRNOD <2 .K>>
+ <MAPF <>
+ <FUNCTION (N)
+ #DECL ((N) NODE)
+ <COND (<L? <MINL <RESULT-TYPE .N>> 1> <SET CHF T>)>>
+ <REST .K 2>>
+ <COND
+ (<==? <SET TT <NODE-TYPE .ITRNOD>> ,MFCN-CODE>
+ <PUT .ITRNOD ,SIDE-EFFECTS <>>
+ <MAPF <>
+ <FUNCTION (N "AUX" RT R)
+ #DECL ((N) NODE)
+ <SET RT <EANA .N STRUCTURED <NODE-NAME .MNOD>>>
+ <COND (<AND .VERBOSE
+ <OR <NOT <SET R <STRUCTYP .RT>>> <==? .R TEMPLATE>>>
+ <ADDVMESS
+ .MNOD
+ ("Non-specific structure for MAPF/R: "
+ .N
+ " type is: "
+ .RT)>)>>
+ <SET K <REST .K 2>>>
+ <SET L-D <SAVE-L-D-STATE .VARTBL>>
+ <PROG ((HTMPS 0) (TMPS 0) (VARTBL <SYMTAB .ITRNOD>) (KK .K) (LL .LIFE)
+ (OVV .VERBOSE))
+ #DECL ((HTMPS TMPS) <SPECIAL FIX> (VARTBL) <SPECIAL SYMTAB>
+ (KK) <LIST [REST NODE]>)
+ <COND (.VERBOSE <PUTREST <SET VERBOSE .OVV> ()>)>
+ <SET LIFE .LL>
+ <SET L-V ()>
+ <SET FSTOP T>
+ <RESET-VARS .VARTBL .OV>
+ <MUNG-L-D-STATE .VARTBL>
+ <SET K .KK>
+ <SET RETYPS NO-RETURN>
+ <SET ASSU <BUILD-TYPE-LIST .OV>>
+ <SET VALSPCD <BUILD-TYPE-LIST .OV>>
+ <REPEAT ((CNT <+ .NSTR 1>) (B <BINDING-STRUCTURE .ITRNOD>))
+ #DECL ((B) <LIST [REST SYMTAB]> (CNT) FIX)
+ <COND (<L? <SET CNT <- .CNT 1>> 0> <RETURN>)>
+ <PUT <1 .B> ,CODE-SYM 3>
+ <PUT <1 .B> ,USED-AT-ALL T>
+ <SET B <REST .B>>>
+ <REPEAT ((BNDS <REST <BINDING-STRUCTURE .ITRNOD> <+ .NSTR 1>>))
+ <COND (<EMPTY? .BNDS>
+ <AND <NOT <EMPTY? .K>>
+ <MESSAGE ERROR
+ "MAPF FUNC TAKES TOO FEW ARGS. "
+ .ITRNOD>>
+ <RETURN>)>
+ <AND <APPLY <NTH ,MAPANALS <CODE-SYM <1 .BNDS>>>
+ <1 .BNDS>
+ <COND (<NOT <EMPTY? .K>> <1 .K>)>>
+ <SET BNDS <REST .BNDS>>>
+ <OR <EMPTY? .K> <SET K <REST .K>>>>
+ <PUT .ITRNOD ,VSPCD (())>
+ <PROG ((STMPS .TMPS) (SHTMPS .HTMPS) (LL .LIFE) (OV .VERBOSE))
+ #DECL ((STMPS SHTMPS) FIX)
+ <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
+ <SET LIFE .LL>
+ <SET FRET T>
+ <SET TMPS .STMPS>
+ <SET HTMPS .SHTMPS>
+ <PUT .ITRNOD ,ASSUM <BUILD-TYPE-LIST .VARTBL>>
+ <PUT .ITRNOD ,ACCUM-TYPE NO-RETURN>
+ <SET TEM <SEQ-AN <KIDS .ITRNOD> <INIT-DECL-TYPE .ITRNOD>>>
+ <OR <NOT <AGND .ITRNOD>>
+ <ASSUM-OK? <ASSUM .ITRNOD> <AGND .ITRNOD>>
+ <AGAIN>>>
+ <COND (<N==? .TEM NO-RETURN>
+ <COND (<NOT .FRET>
+ <SET L-V <MSAVE-L-D-STATE .L-V .OV>>
+ <ASSERT-TYPES <ORUPC .VARTBL <VSPCD .ITRNOD>>>)
+ (ELSE <SET L-V <SAVE-L-D-STATE .OV>>)>)
+ (<N==? <ACCUM-TYPE .ITRNOD> NO-RETURN>
+ <ASSERT-TYPES <VSPCD .ITRNOD>>)>
+ <SET VALSPCD <ORUPC .OV .VALSPCD>>
+ <OR <ASSUM-OK? .ASSU <BUILD-TYPE-LIST .VARTBL>> <AGAIN>>
+ <PUT .ITRNOD ,ACCUM-TYPE <TYPE-MERGE .TEM <ACCUM-TYPE .ITRNOD>>>
+ <PUT .ITRNOD
+ ,RESULT-TYPE
+ <TYPE-OK? <ACCUM-TYPE .ITRNOD> <INIT-DECL-TYPE .ITRNOD>>>>
+ <ASSERT-TYPES .VALSPCD>
+ <COND (<ASSIGNED? STATE>
+ <FIX-STATE <ACCUM-TYPE .ITRNOD> .ITRNOD>
+ <COND (<G? .STATE 4>
+ <SET SBRL <>>
+ <PUT .FAP ,NODE-TYPE ,GVAL-CODE>
+ <SET FINTYPE '<OR FIX FLOAT>>)
+ (ELSE
+ <SET FINTYPE <NTH '![FIX FLOAT FLOAT!] <- .STATE 1>>>)>)>
+ <SAVE-SURVIVORS .L-D .LIFE T>
+ <SAVE-SURVIVORS .L-V .LIFE>
+ <SET D-V
+ <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
+ (ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
+ <FREST-L-D-STATE .D-V>
+ <SET LIFE <KILL-REM .LIFE .OV>>
+ <COND (.SBRL <MUNG-SEGS .SEGFX>)>
+ <COND (<SIDE-EFFECTS .ITRNOD>
+ <PUT .MNOD
+ ,SIDE-EFFECTS
+ (!<SIDE-EFFECTS .ITRNOD> !<SIDE-EFFECTS .MNOD>)>)>
+ <COND (<AND <==? <NODE-TYPE .FAP> ,QUOTE-CODE>
+ <==? <NODE-NAME .FAP> #FALSE ()>>
+ <TYPE-OK? <COND (.CHF <TYPE-MERGE FALSE .TEM .RETYPS>)
+ (ELSE <TYPE-OK? <TYPE-MERGE .TEM .RETYPS> .MRTYP>)>
+ .MRTYP>)
+ (<ASSIGNED? FINTYPE>
+ <COND (<==? .FINTYPE LIST>
+ <TYPE-OK? <TYPE-MERGE <FORM LIST
+ [REST <RESULT-TYPE .ITRNOD>]>
+ .RETYPS>
+ .MRTYP>)
+ (ELSE <TYPE-OK? <TYPE-MERGE .FINTYPE .RETYPS> .MRTYP>)>)
+ (<AND <==? <NODE-TYPE .FAP> ,GVAL-CODE>
+ <MEMQ <NODE-NAME .FAP> '![VECTOR UVECTOR!]>>
+ <SET TEM <FORM <NODE-NAME .FAP> [REST .TEM]>>
+ <TYPE-OK? <TYPE-MERGE .RETYPS .TEM> .MRTYP>)
+ (ELSE <TYPE-OK? <TYPE-MERGE <APPLTYP .FAP> .RETYPS> .MRTYP>)>)
+ (ELSE
+ <COND (<N==? .TT ,MPSBR-CODE> <EANA .ITRNOD APPLICABLE <NODE-NAME .MNOD>>)>
+ <MAPF <>
+ <FUNCTION (N "AUX" RT R)
+ #DECL ((N) NODE)
+ <SET RT <EANA .N STRUCTURED <NODE-NAME .MNOD>>>
+ <COND (<AND .VERBOSE
+ <OR <NOT <SET R <STRUCTYP .RT>>> <==? .R TEMPLATE>>>
+ <ADDVMESS
+ .MNOD
+ ("Non-specific structure for MAPF/R: "
+ .N
+ " type is: "
+ .RT)>)>>
+ <SET MPSTRS <REST .K 2>>>
+ <COND (<==? .TT ,MPSBR-CODE>
+ <SET TEM <EANA <1 <KIDS .ITRNOD>> ANY <NODE-NAME .MNOD>>>
+ <COND (.CHF <SET TEM <TYPE-MERGE .TEM FALSE>>)>)
+ (ELSE <SET TEM ANY>)>
+ <COND (<ASSIGNED? STATE>
+ <FIX-STATE .TEM <1 <KIDS .ITRNOD>>>
+ <COND (<G? .STATE 4>
+ <SET SBRL <>>
+ <PUT .FAP ,NODE-TYPE ,GVAL-CODE>
+ <SET FINTYPE '<OR FIX FLOAT>>)
+ (ELSE
+ <SET FINTYPE <NTH '![FIX FLOAT FLOAT!] <- .STATE 1>>>)>)>
+ <COND (.SBRL <MUNG-SEGS .SEGFX>)>
+ <COND (<AND <==? <NODE-TYPE .FAP> ,QUOTE-CODE>
+ <==? <NODE-NAME .FAP> #FALSE ()>>
+ <TYPE-OK? .TEM .MRTYP>)
+ (<ASSIGNED? FINTYPE>
+ <COND (<==? .FINTYPE LIST>
+ <TYPE-OK? <FORM LIST [REST .TEM]> .MRTYP>)
+ (ELSE <TYPE-OK? .FINTYPE .MRTYP>)>)
+ (<AND <==? <NODE-TYPE .FAP> ,GVAL-CODE>
+ <MEMQ <NODE-NAME .FAP> '![VECTOR UVECTOR!]>>
+ <SET TEM <FORM <NODE-NAME .FAP> [REST .TEM]>>
+ <TYPE-OK? <TYPE-MERGE .RETYPS .TEM> .MRTYP>)
+ (ELSE <TYPE-OK? <APPLTYP .FAP> .MRTYP>)>)>>
+
+\\f
+
+<DEFINE FIX-STATE (TEM N "AUX" TT (SG <MEMQ <NODE-TYPE .N> ,SEG-CODES>))
+ #DECL ((STATE TT) FIX (N) NODE)
+ <SET TT
+ <COND (<==? .TEM FIX> 1)
+ (<==? .TEM FLOAT> 2)
+ (<NOT <TYPE-OK? .TEM FLOAT>>
+ <PUT .N
+ ,RESULT-TYPE
+ <COND (.SG
+ <TYPE-MERGE '<STRUCTURED [REST FIX]>
+ <RESULT-TYPE .N>>)
+ (ELSE FIX)>>
+ 1)
+ (<NOT <TYPE-OK? .TEM FIX>>
+ <PUT .N
+ ,RESULT-TYPE
+ <COND (.SG
+ <TYPE-MERGE '<STRUCTURED [REST FLOAT]>
+ <RESULT-TYPE .N>>)
+ (ELSE FLOAT)>>
+ 2)
+ (ELSE 3)>>
+ <SET STATE <NTH <NTH ,ASTATE .STATE> .TT>>>
+
+<SETG SEG-CODES ![,SEG-CODE ,SEGMENT-CODE!]>
+
+<DEFINE MUNG-SEGS (SEGS)
+ #DECL ((SEGS) <LIST [REST NODE]>)
+ <MAPF <>
+ <FUNCTION (N) #DECL ((N) NODE) <PUT .N ,NODE-TYPE ,SEG-CODE>>
+ .SEGS>>
+
+<DEFINE MARGS-ANA (N R "AUX" (MK .MPSTRS) (NN <NODE-NAME .N>))
+ #DECL ((N) NODE (NN) FIX (MK) <LIST [REST NODE]>)
+ <SET R
+ <TYPE-OK? <GET-ELE-TYPE <RESULT-TYPE <NTH .MK .NN>> ALL .R?>
+ .R>>
+ <COND (.R? <TYPE-OK? .R '<STRUCTURED ANY>>) (ELSE .R)>>
+
+<DEFINE MAUX (SYM STRUC)
+ #DECL ((SYM) SYMTAB (STRUC) <OR FALSE NODE>)
+ <COND (.STRUC <MESSAGE ERROR "TOO MANY ARGS TOO MAPF FCN ">)
+ (ELSE <NORM-BAN .SYM>)>
+ T>
+
+<DEFINE MAUX1 (SYM STRUC)
+ #DECL ((SYM) SYMTAB (STRUC) <OR FALSE NODE>)
+ <COND (.STRUC <MESSAGE ERROR "TOO MANY ARGS TO MAPF FCN ">)>
+ T>
+
+<DEFINE MNORM (SYM STRUC "AUX" (VARTBL <NEXT-SYM .SYM>) TEM COD N)
+ #DECL ((SYM) SYMTAB (STRUC) <OR NODE FALSE> (VARTBL) <SPECIAL SYMTAB>
+ (MNOD N) NODE)
+ <COND (.STRUC
+ <PUT .SYM ,PURE-SYM <>> ;"Tell VARANA to allocate me."
+ <OR <SET TEM
+ <TYPE-OK? <GET-ELE-TYPE <RESULT-TYPE .STRUC> ALL .R?>
+ <1 <DECL-SYM .SYM>>>>
+ <MESSAGE ERROR "BAD MAP FUNC ARG " <NAME-SYM .SYM>>>
+ <COND (.R? <SET TEM <TYPE-AND .TEM '<STRUCTURED ANY>>>)>
+ <COND (<N=? .TEM <1 <DECL-SYM .SYM>>>
+ <PUT .SYM ,CURRENT-TYPE .TEM>)>
+ <PUT .SYM ,COMPOSIT-TYPE .TEM>)
+ (ELSE <MESSAGE ERROR "TOO FEW MAPF ARGS FOR FCN ">)>
+ T>
+
+<DEFINE MOPT (SYM STRUC "AUX" (VARTBL <NEXT-SYM .SYM>))
+ #DECL ((SYM) SYMTAB (VARTBL) <SPECIAL SYMTAB> (STRUC) <OR FALSE NODE>)
+ <COND (.STRUC <PUT .SYM ,INIT-SYM <>> <MNORM .SYM .STRUC>)
+ (ELSE <NORM-BAN .SYM>)>
+ T>
+
+<DEFINE MBAD (SYM STRUC) <MESSAGE ERROR "BAD ARG DECL IN MAP FCN " <NAME-SYM .SYM>>>
+
+<DEFINE MOPT2 (SYM STRUC) <COND (.STRUC <MNORM .SYM .STRUC>)> T>
+\\f
+
+<DEFINE MTUPLE (SYM STRUC
+ "AUX" (VARTBL <NEXT-SYM .SYM>)
+ (ATYP
+ <GET-ELE-TYPE <1 <DECL-SYM .SYM>>
+ <SET TUPCNT <+ .TUPCNT 1>>>))
+ <COND (.STRUC
+ <COND (.R?
+ <SET TEM <EANA .STRUC STRUCTURED .NAME>>
+ <==? <STRUCTYP .TEM> <STRUCTYP .ATYP>>)
+ (ELSE
+ <OR <TYPE-OK? <GET-ELE-TYPE <EANA .STRUC STRUCTURED .NAME>
+ ALL>
+ .ATYP>
+ <MESSAGE ERROR "BAD MAP FCN ARG " <NAME-SYM .SYM>>>)>
+ <>)
+ (ELSE T)>>
+
+<DEFINE MENTROPY (N R) T>
+
+<SETG MAPANALS
+ [,MENTROPY
+ ,MAUX
+ ,MAUX1
+ ,MTUPLE
+ ,MBAD
+ ,MOPT
+ ,MOPT
+ ,MOPT2
+ ,MOPT2
+ ,MBAD
+ ,MENTROPY
+ ,MNORM
+ ,MNORM]>
+
+"Additional SUBR analyzers associated with MAP hackers."
+
+<DEFINE MAPLEAVE-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>) TEM)
+ #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
+ <COND (<ASSIGNED? MNOD>
+ <ARGCHK .LN '(0 1) MAPLEAVE>
+ <COND (<0? .LN>
+ <PUT .N
+ ,KIDS
+ <SET K (<NODE1 ,QUOTE-CODE .N ATOM T ()>)>>)>
+ <SET TEM <EANA <1 .K> .MRTYP MAPLEAVE>>
+ <SET VALSPCD <ORUPC .VARTBL .VALSPCD>>
+ <SET D-V
+ <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
+ (ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
+ <SET FSTOP <>>
+ <SET RETYPS <TYPE-MERGE .RETYPS .TEM>>
+ <PUT .N ,NODE-TYPE ,MAPLEAVE-CODE>)
+ (ELSE <SUBR-C-AN .N .R>)>
+ NO-RETURN>
+
+\\f
+
+<DEFINE MAPRET-STOP-ANA (NOD R "AUX" (ARGS 0) (TYP NO-RETURN) TYP1 ITRNOD)
+ #DECL ((MNOD NOD ITRNOD) NODE (ARGS) FIX)
+ <PROG ()
+ <OR <ASSIGNED? MNOD> <RETURN <SUBR-C-AN .NOD .R>>>
+ <SET ITRNOD <2 <KIDS .MNOD>>>
+ <OR <NODE-NAME <1 <KIDS .MNOD>>>
+ <MESSAGE ERROR " NOTHING TO MAPSTOP/RET TO " .MNOD>>
+ <MAPF <>
+ <FUNCTION (N)
+ #DECL ((N) NODE)
+ <COND (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
+ <==? <NODE-TYPE .N> ,SEG-CODE>>
+ <SET TYP1
+ <EANA <1 <KIDS .N>>
+ <COND (<ASSIGNED? STATE>
+ '<STRUCTURED [REST <OR FIX FLOAT>]>)
+ (ELSE STRUCTURED)>
+ SEGMENT>>
+ <COND (<ASSIGNED? STATE> <SET STATE 5>)
+ (ELSE <SET SEGFX (.N !.SEGFX)>)>
+ <SET TYP <TYPE-MERGE .TYP <GET-ELE-TYPE .TYP1 ALL>>>
+ <PUT .NOD ,SEGS T>)
+ (ELSE
+ <SET ARGS <+ .ARGS 1>>
+ <SET TYP
+ <TYPE-MERGE
+ .TYP
+ <EANA .N
+ <COND (<ASSIGNED? STATE> '<OR FIX FLOAT>)
+ (ELSE ANY)>
+ <NODE-NAME .NOD>>>>)>>
+ <KIDS .NOD>>
+ <AND <ASSIGNED? STATE> <N==? .TYP NO-RETURN> <FIX-STATE .TYP .NOD>>
+ <COND (<==? <NODE-SUBR .NOD> ,MAPRET>
+ <SET L-V
+ <COND (.FRET <SAVE-L-D-STATE .VARTBL>)
+ (ELSE <MSAVE-L-D-STATE .L-V .VARTBL>)>>
+ <PUT .ITRNOD
+ ,VSPCD
+ <COND (.FRET <BUILD-TYPE-LIST .VARTBL>)
+ (ELSE <ORUPC .VARTBL <VSPCD .ITRNOD>>)>>
+ <SET FRET <>>)
+ (ELSE
+ <SET D-V
+ <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
+ (ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
+ <SET VALSPCD <ORUPC .VARTBL .VALSPCD>>
+ <SET FSTOP <>>)>
+ <PUT <2 <KIDS .MNOD>>
+ ,ACCUM-TYPE
+ <TYPE-MERGE <ACCUM-TYPE <2 <KIDS .MNOD>>> .TYP>>
+ <PUT .NOD ,STACKS <* .ARGS 2>>
+ <PUT .NOD ,NODE-TYPE ,MAPRET-STOP-CODE>>
+ NO-RETURN>
+
+<PUT ,MAPLEAVE ANALYSIS ,MAPLEAVE-ANA>
+
+<PUT ,MAPRET ANALYSIS ,MAPRET-STOP-ANA>
+
+<PUT ,MAPSTOP ANALYSIS ,MAPRET-STOP-ANA>
+
+<DEFINE SUBAP? (NOD "AUX" TT (COD 0))
+ #DECL ((COD) FIX (NOD) NODE)
+ <AND <OR <==? <SET COD <NODE-TYPE .NOD>> ,FGVAL-CODE>
+ <==? .COD ,GVAL-CODE>
+ <==? .COD ,MFIRST-CODE>>
+ <==? <NODE-TYPE <SET NOD <1 <KIDS .NOD>>>> ,QUOTE-CODE>
+ <GASSIGNED? <SET TT <NODE-NAME .NOD>>>
+ <TYPE? ,.TT SUBR>
+ .TT>>
+
+<ENDPACKAGE>
--- /dev/null
+<PACKAGE "MAPGEN">
+
+<ENTRY MAPFR-GEN MAPRET-STOP-GEN MAPLEAVE-GEN NOTIMP MBINDERS MPARGS-GEN
+ MOPTG MOPTG2>
+
+<USE "CODGEN" "CACS" "COMCOD" "COMPDEC" "CHKDCL" "CARGEN" "CUP" "NEWREP" "CARGEN">
+
+
+" Definitions of offsets into MAPINFO vector used by MAP hackers inferiors."
+
+<SETG MAP-STRS 1>
+
+<SETG MAP-SRC 2>
+
+\\f
+
+<SETG MAP-FR 3>
+
+<SETG MAP-TAG 4>
+
+<SETG MAP-STK 5>
+
+<SETG MAP-STOF 6>
+
+<SETG MAP-OFF 7>
+
+<SETG MAP-TGL 8>
+
+<SETG MAP-STSTR 9>
+
+<SETG MAP-STKFX 10>
+
+<SETG MAP-POFF 11>
+
+<MANIFEST MAP-FR MAP-TAG MAP-STK MAP-STOF MAP-OFF MAP-TGL MAP-STSTR MAP-STKFX MAP-POFF
+ MAP-SRC MAP-STRS>
+\\f
+
+<DEFINE MAPFR-GEN (NOD WHERE "AUX" (K <KIDS .NOD>) (COD <NODE-TYPE <2 .K>>))
+ #DECL ((NOD) NODE (COD) FIX (K) <LIST [REST NODE]>)
+ <COND
+ (<==? .COD ,MFCN-CODE> <REGSTO <> <>> <HMAPFR .NOD .WHERE .K>)
+ (ELSE
+ <REGSTO <>>
+ <PROG ((FAP <1 .K>) MPINFO (INRAP <2 .K>) (W <GOODACS .NOD .WHERE>)
+ (DTEM <DATUM FIX ANY-AC>) F? FF? (MAYBE-FALSE <>) (ANY? <>)
+ (NARG <LENGTH <SET K <REST .K 2>>>) (RW .WHERE) (POFF 0)
+ (R? <==? <NODE-SUBR .NOD> ,MAPR>) (OFFS 0) (STKOFFS <>)
+ (MAPEND <ILIST .NARG '<MAKE:TAG "MAP">>) (MAPLP <MAKE:TAG "MAP">)
+ (SUBRC <AP? .FAP>) (STB .STK) STOP (STK (0 !.STK)) TT)
+ #DECL ((FAP INRAP) NODE (DTEM) DATUM (NARG POFF OFFS) FIX
+ (STKOFFS) <OR FALSE LIST> (MAPLP) ATOM (MAPEND) <LIST [REST
+ ATOM]>
+ (STK) <SPECIAL LIST> (STOP STB) LIST
+ (MPINFO) <SPECIAL <VECTOR <LIST [REST NODE]>
+ DATUM
+ <OR FALSE ATOM>
+ <LIST [REST ATOM]>
+ ANY
+ <OR FALSE LIST>
+ FIX
+ LIST
+ LIST
+ <PRIMTYPE LIST>
+ FIX>>)
+ <SET WHERE
+ <COND (<==? .WHERE FLUSHED> FLUSHED) (ELSE <GOODACS .NOD .WHERE>)>>
+ <SET F? <DO-FIRST-SETUP .FAP .WHERE <> <> <> <>>>
+ <OR .F? <SET FF? <==? <NODE-TYPE .FAP> ,MFIRST-CODE>>>
+ <SET ANY? <PUSH-STRUCS .K T <> () <>>>
+ <SET STOP .STK>
+ <SET STK (0 !.STK)>
+ <COND (.F? <SET MAYBE-FALSE <DO-FINAL-SETUP .FAP .SUBRC>>)>
+ <REGSTO <>>
+ <LABEL:TAG .MAPLP>
+ <EMIT '<INTGO!-OP!-PACKAGE>>
+ <COND (<N==? .COD ,MPSBR-CODE>
+ <RET-TMP-AC <STACK:ARGUMENT <GEN .INRAP DONT-CARE>>>
+ <ADD:STACK 2>)>
+ <COND (.F? <SET STKOFFS <FIND-FIRST-STRUC .DTEM .STB <NOT .PRE>>>)>
+ <SET OFFS <- 1 <* .NARG 2>>>
+ <SET MPINFO
+ [.K
+ .DTEM
+ .R?
+ .MAPEND
+ .F?
+ .STKOFFS
+ .OFFS
+ ()
+ .STK
+ '(0)
+ <SET POFF <COND (.MAYBE-FALSE -2) (.F? -1) (ELSE 0)>>]>
+ <SET STK (0 !.STK)>
+ <COND
+ (<==? .COD ,MPSBR-CODE>
+ <COND (.F?
+ <DO-STACK-ARGS .MAYBE-FALSE <GEN <1 <KIDS .INRAP>> DONT-CARE>>)
+ (.FF?
+ <DO-FUNNY-HACK <GEN <1 <KIDS .INRAP>> DONT-CARE>
+ (<- .OFFS 1> ())
+ .NOD
+ .FAP
+ <1 <KIDS .INRAP>>>)
+ (<N==? .WHERE FLUSHED>
+ <MOVE:ARG <GEN <1 <KIDS .INRAP>> .W>
+ <DATUM <SET TT <ADDRESS:C <+ -2 .OFFS> '`(TP) >>
+ .TT>>)
+ (ELSE <GEN <1 <KIDS .INRAP>> FLUSHED>)>)
+ (ELSE
+ <REPEAT ((I .NARG))
+ #DECL ((I) FIX)
+ <RET-TMP-AC <STACK:ARGUMENT <MPARGS-GEN .NOD DONT-CARE>>>
+ <AND <0? <SET I <- .I 1>>> <RETURN>>>
+ <SUBR:CALL APPLY <+ .NARG 1>>
+ <COND (.F? <DO-STACK-ARGS .MAYBE-FALSE <FUNCTION:VALUE>>)
+ (.FF?
+ <DO-FUNNY-HACK <FUNCTION:VALUE>
+ (<- .OFFS 1> ())
+ .NOD
+ .FAP
+ .INRAP>)
+ (<N==? .WHERE FLUSHED>
+ <MOVE:ARG <FUNCTION:VALUE>
+ <DATUM <SET TT <ADDRESS:C <+ -2 .OFFS> '`(TP) >>
+ .TT>>)>)>
+ <COND (<AND .F? <NOT .STKOFFS>> <RET-TMP-AC .DTEM>)>
+ <COND (.ANY? <EMIT <INSTRUCTION `SETZM .POFF '`(P) >>)>
+ <BRANCH:TAG .MAPLP>
+ <GEN-TAGS <MAP-TGL .MPINFO> <>>
+ <MAPF <>
+ <FUNCTION (N)
+ #DECL ((N) NODE)
+ <COND (<NOT <ISTYPE? <STRUCTYP <RESULT-TYPE .N>>>>
+ <EMIT '<`SETZM |DSTORE >>
+ <MAPLEAVE>)>>
+ .K>
+ <COND (.F? <SET WHERE <DO-LAST .SUBRC .MAYBE-FALSE .WHERE>>)
+ (.FF? <SET WHERE <DO-FUNNY-LAST .FAP <- .OFFS 2> .WHERE>>)
+ (<N==? .WHERE FLUSHED>
+ <SET WHERE
+ <MOVE:ARG <DATUM <SET TT <ADDRESS:C <+ -2 .OFFS> '`(TP) >>
+ .TT>
+ .WHERE>>)>
+ <POP:LOCS .STOP .STB>
+ <SET STK .STB>
+ <MOVE:ARG .WHERE .RW>>)>>
+
+\\f
+
+<DEFINE PUSH-STRUCS (K SM ACS BST NONO "AUX" (NL <>) S TEM TT NEW)
+ #DECL ((K) <LIST [REST NODE]> (BST) <LIST [REST SYMTAB]> (S) SYMTAB)
+ <MAPF <>
+ <FUNCTION (N "AUX" (RT <RESULT-TYPE .N>))
+ #DECL ((N) NODE)
+ <COND (.ACS
+ <SET TEM
+ <GEN .N
+ <COND (<SET TT <ISTYPE-GOOD? .RT>> <DATUM .TT ANY-AC>)
+ (ELSE <DATUM ANY-AC ANY-AC>)>>>
+ <COND (.TT
+ <RET-TMP-AC <DATTYP .TEM> .TEM>
+ <PUT .TEM ,DATTYP .TT>)>
+ <COND (<TYPE? .NONO DATUM>
+ <COND (<OR <==? <DATVAL .NONO> <DATTYP .TEM>>
+ <==? <DATTYP .NONO> <DATTYP .TEM>>>
+ <SET NEW <DATUM <GETREG <>> <DATVAL .TEM>>>
+ <PUT <DATTYP .NEW> ,ACPROT T>)>
+ <COND (<OR <==? <DATVAL .NONO> <DATVAL .TEM>>
+ <==? <DATTYP .NONO> <DATVAL .TEM>>>
+ <COND (<ASSIGNED? NEW>
+ <PUT .NEW ,DATVAL <GETREG <>>>
+ <PUT <DATTYP .NEW> ,ACPROT <>>)
+ (ELSE
+ <SET NEW
+ <DATUM <DATTYP .TEM> <GETREG <>>>>)>)>
+ <SET TEM <MOVE:ARG .TEM .NEW>>)>
+ <MUNG-AC <DATVAL .TEM>>
+ <SET S <1 .BST>>
+ <COND (<TYPE? <ADDR-SYM .S> TEMPV>
+ <SET TT <CREATE-TMP .TT>>
+ <PUT .S
+ ,ADDR-SYM
+ <CHTYPE (.BSTB
+ .TT
+ <COND (<=? .AC-HACK '(FUNNY-STACK)>
+ <* <TOTARGS .FCN> -2>)
+ (ELSE 0)>
+ !.TMPS)
+ TEMPV>>)>
+ <PUT .S ,INACS .TEM>
+ <PUT .S ,STORED <>>
+ <COND (<TYPE? <SET TT <DATTYP .TEM>> AC>
+ <PUT .TT ,ACRESIDUE (.S !<ACRESIDUE .TT>)>)>
+ <PUT <SET TT <DATVAL .TEM>> ,ACRESIDUE (.S !<ACRESIDUE .TT>)>
+ <RET-TMP-AC .TEM>
+ <SET BST <REST .BST>>)
+ (ELSE
+ <RET-TMP-AC <STACK:ARGUMENT <GEN .N DONT-CARE>>>
+ <AND .SM <ADD:STACK 2>>)>
+ <COND (<AND <SET RT <STRUCTYP .RT>>
+ <NOT .ACS>
+ <OR <==? .RT LIST> <==? .RT TEMPLATE>>>
+ <SET NL T>)
+ (<NOT .RT> <SET NL T>)>>
+ .K>
+ <COND (.NL <EMIT '<`PUSH `P* [-1]>> <AND .SM <ADD:STACK PSLOT>>)>
+ .NL>
+
+<DEFINE KEEP-IN-ACS (BST K R? "AUX" D S PTYP)
+ #DECL ((BST) <LIST [REST SYMTAB]> (K) <LIST [REST NODE]>)
+ <MAPF <>
+ <FUNCTION (S N
+ "AUX" (D <INACS .S>) (PTYP <STRUCTYP <RESULT-TYPE .N>>) A1 A)
+ #DECL ((S) SYMTAB (D) <OR DATUM FALSE> (N) NODE (A) AC)
+ <COND (<N==? <NAME-SYM .S> DUMMY-MAPF> <MAPLEAVE>)>
+ <COND (<AND <NOT .D>
+ <OR .R? <AND <N==? .PTYP STRING> <N==? .PTYP BYTES>>>>
+ <SET D
+ <MOVE:ARG <LADDR .S <> <>>
+ <DATUM <COND (<OR <==? .PTYP STRING>
+ <==? .PTYP BYTES>>
+ ANY-AC)
+ (ELSE .PTYP)>
+ ANY-AC>>>
+ <PUT .S ,INACS <DATUM <DATTYP .D> <DATVAL .D>>>
+ <PUT <SET A <DATVAL .D>> ,ACRESIDUE (.S !<ACRESIDUE .A>)>
+ <COND (<TYPE? <SET A1 <DATTYP .D>> AC>
+ <PUT .A1 ,ACRESIDUE (.S !<ACRESIDUE .A1>)>)>
+ <PUT .S ,STORED <>>
+ <RET-TMP-AC .D>)>>
+ .BST
+ .K>
+ T>
+
+<DEFINE REST-STRUCS (BST K LV NR TG R? "AUX" DAT PTYP (CNT 0) TEM ACFLG)
+ #DECL ((BST) <LIST [REST SYMTAB]> (K) <LIST [REST NODE]> (CNT) FIX
+ (LV) LIST)
+ <REPEAT ((BST .BST))
+ #DECL ((BST) <LIST [REST SYMTAB]>)
+ <COND (<OR <EMPTY? .BST> <N==? <NAME-SYM <1 .BST>> DUMMY-MAPF>> <RETURN>)>
+ <SET CNT <+ .CNT 1>>
+ <SET PTYP <STRUCTYP <RESULT-TYPE <1 .K>>>>
+ <COND (<SET TEM <MEMQ <1 .BST> .LV>> <SET DAT <2 .TEM>>)
+ (ELSE <SET DAT <LADDR <1 .BST> <> <>>>)>
+ <COND (<TYPE? <DATVAL .DAT> AC> <SET ACFLG T>) (ELSE <SET ACFLG <>>)>
+ <COND
+ (<==? .PTYP LIST>
+ <COND (.ACFLG
+ <EMIT <INSTRUCTION `HRRZ
+ <ACSYM <DATVAL .DAT>>
+ (<ADDRSYM <DATVAL .DAT>>)>>
+ <COND (<1? .NR>
+ <EMIT <INSTRUCTION `JUMPN <ACSYM <DATVAL .DAT>> .TG>>)>)
+ (ELSE
+ <EMIT <INSTRUCTION `HRRZ `@ !<ADDR:VALUE .DAT>>>
+ <EMIT <INSTRUCTION `MOVEM !<ADDR:VALUE .DAT>>>
+ <COND (<1? .NR> <EMIT <INSTRUCTION `JUMPN .TG>>)>)>)
+ (<OR <==? .PTYP VECTOR> <==? .PTYP TUPLE>>
+ <COND (.ACFLG
+ <EMIT <INSTRUCTION `ADD <ACSYM <DATVAL .DAT>> '[<2 (2)>]>>
+ <COND (<1? .NR>
+ <EMIT <INSTRUCTION `JUMPL <ACSYM <DATVAL .DAT>> .TG>>)>)
+ (ELSE
+ <EMIT '<`MOVE [<2 (2)>]>>
+ <EMIT <INSTRUCTION `ADDB !<ADDR:VALUE .DAT>>>
+ <COND (<1? .NR> <EMIT <INSTRUCTION `JUMPL .TG>>)>)>)
+ (<OR <==? .PTYP UVECTOR> <==? .PTYP STORAGE>>
+ <COND (.ACFLG
+ <COND (<1? .NR>
+ <EMIT <INSTRUCTION `AOBJN <ACSYM <DATVAL .DAT>> .TG>>)
+ (<EMIT <INSTRUCTION `ADD
+ <ACSYM <DATVAL .DAT>>
+ '[<1 (1)>]>>)>)
+ (ELSE
+ <EMIT '<`MOVE [<1 (1)>]>>
+ <EMIT <INSTRUCTION `ADDB !<ADDR:VALUE .DAT>>>
+ <COND (<1? .NR> <EMIT <INSTRUCTION `JUMPL .TG>>)>)>)
+ (<OR <==? .PTYP STRING> <==? .PTYP BYTES>>
+ <COND (.R?
+ <EMIT <INSTRUCTION `IBP !<ADDR:VALUE .DAT>>>
+ <EMIT <INSTRUCTION `SOS !<ADDR:TYPE .DAT>>>)>
+ <COND (<1? .NR>
+ <COND (<TYPE? <DATTYP .DAT> AC>
+ <EMIT <INSTRUCTION `TRNE <ACSYM <DATTYP .DAT>> -1>>
+ <BRANCH:TAG .TG>)
+ (ELSE
+ <EMIT <INSTRUCTION `HRRZ `O* !<ADDR:TYPE .DAT>>>
+ <EMIT <INSTRUCTION `JUMPN `O* .TG>>)>)>)>
+ <SET BST <REST .BST>>
+ <SET K <REST .K>>>
+ <REPEAT ()
+ <COND (<L? <SET CNT <- .CNT 1>> 0> <RETURN>)>
+ <PUT <1 .BST> ,STORED T>
+ <PUT <1 .BST> ,INACS <>>
+ <SET BST <REST .BST>>>>
+
+<DEFINE FIND-FIRST-STRUC (DTEM STB FL "AUX" DAC (STKOFFS <>))
+ #DECL ((DTEM) DATUM (DAC) AC (STB) LIST)
+ <COND (<AND .FL <SET STKOFFS <STACK:L .STB <2 .FRMS>>>>)
+ (ELSE
+ <MOVE:ARG <REFERENCE 524290> .DTEM>
+ <PUT .DTEM ,DATTYP <ADDRESS:PAIR |$TTP >>
+ <EMIT <INSTRUCTION `IMUL
+ <ACSYM <SET DAC <DATVAL .DTEM>>>
+ '`(P) >>
+ <EMIT <INSTRUCTION `SUBM `TP* <ADDRSYM .DAC>>>)>
+ .STKOFFS>
+
+<DEFINE DO-FINAL-SETUP (FAP SUBRC "AUX" (MAYBE-FALSE <>))
+ #DECL ((FAP) NODE)
+ <COND (<NOT .SUBRC>
+ <RET-TMP-AC <STACK:ARGUMENT <GEN .FAP DONT-CARE>>>)>
+ <COND (<AND <NOT .SUBRC>
+ <OR <NOT .REASONABLE> <N==? <NODE-TYPE .FAP> ,GVAL-CODE>>
+ <SET MAYBE-FALSE <TYPE-OK? <RESULT-TYPE .FAP> FALSE>>>
+ <EMIT '<`PUSH `P* [0]>>
+ <ADD:STACK PSLOT>
+ <PCOUNTER 1>
+ <EMIT '<GETYP!-OP!-PACKAGE `O* -1 `(TP) >>
+ <EMIT '<`CAIN `O* <TYPE-CODE!-OP!-PACKAGE FALSE>>>
+ <EMIT '<`SETOM -1 `(P) >>)
+ (ELSE <PCOUNTER <COND (.SUBRC 0) (ELSE 1)>>)>
+ <ADD:STACK PSTACK>
+ .MAYBE-FALSE>
+
+<DEFINE DO-STACK-ARGS (MAYBE-FALSE DAT "AUX" TT (T1 <MAKE:TAG>) (T2
+ <MAKE:TAG>))
+ #DECL ((DAT) DATUM (T1 T2) ATOM)
+ <COND
+ (<N==? .DAT ,NO-DATUM>
+ <COND (.MAYBE-FALSE
+ <SET DAT <MOVE:ARG .DAT <DATUM ANY-AC ANY-AC>>>
+ <EMIT '<`SKIPGE -1 `(P) >>
+ <BRANCH:TAG .T1>
+ <STACK:ARGUMENT .DAT>
+ <COUNTP>
+ <BRANCH:TAG .T2>
+ <LABEL:TAG .T1>
+ <RET-TMP-AC <MOVE:ARG .DAT
+ <DATUM <SET TT <ADDRESS:C -1 '`(TP) >> .TT>>>
+ <LABEL:TAG .T2>)
+ (<RET-TMP-AC <STACK:ARGUMENT .DAT>> <COUNTP>)>)>>
+
+\\f
+
+<DEFINE DO-FUNNY-LAST (N OFFS W "AUX" TT TYP)
+ #DECL ((N) NODE (OFFS) FIX)
+ <COND (<==? <NODE-SUBR .N> 5> <SET OFFS <- .OFFS 2>>)>
+ <SET TYP <ISTYPE-GOOD? <RESULT-TYPE <PARENT .N>>>>
+ <SET TT <ADDRESS:C .OFFS '`(TP) >>
+ <MOVE:ARG <DATUM <COND (.TYP .TYP) (ELSE .TT)> .TT> .W>>
+
+<SETG MINS
+ '![![`CAMGE `CAMLE `IMULM `ADDM !]
+ ![`CAMGE `CAMLE `FMPRM `FADRM !]!]>
+
+<DEFINE DO-FUNNY-HACK (DAT OFFS N FAP NN
+ "AUX" (COD <NODE-SUBR .FAP>) (LMOD <RESULT-TYPE .NN>)
+ (MOD <RESULT-TYPE .N>) ACSY)
+ #DECL ((OFFS) <LIST FIX LIST> (DAT) DATUM (COD) FIX (N FAP NN) NODE)
+ <COND (<==? .COD 5>
+ <RET-TMP-AC <MOVE:ARG .DAT <DATUM ,AC-C ,AC-D>>>
+ <REGSTO T>
+ <EMIT '<`MOVEI `E* 0>>
+ <EMIT '<`PUSHJ `P* |CICONS >>
+ <EMIT <INSTRUCTION `SKIPE <1 .OFFS> !<2 .OFFS> '`(TP) >>
+ <EMIT <INSTRUCTION `HRRM
+ `@
+ `B*
+ <1 .OFFS>
+ !<2 .OFFS>
+ '`(TP) >>
+ <EMIT <INSTRUCTION `MOVEM `B* <1 .OFFS> !<2 .OFFS> '`(TP) >>
+ <SET OFFS <STFIXIT .OFFS '(-2)>>
+ <EMIT <INSTRUCTION `SKIPN <1 .OFFS> !<2 .OFFS> '`(TP) >>
+ <EMIT <INSTRUCTION `MOVEM `B* <1 .OFFS> !<2 .OFFS> '`(TP) >>)
+ (ELSE
+ <SET DAT <MOVE:ARG .DAT <DATUM .LMOD ANY-AC>>>
+ <SET MOD <OR <AND <==? .MOD FIX> 1> 2>>
+ <AND <==? .MOD 2> <==? .LMOD FIX> <SET DAT <GEN-FLOAT .DAT>>>
+ <SET ACSY <ACSYM <DATVAL .DAT>>>
+ <RET-TMP-AC .DAT>
+ <EMIT <INSTRUCTION <NTH <NTH ,MINS .MOD> .COD>
+ .ACSY
+ <1 .OFFS>
+ !<2 .OFFS>
+ '`(TP) >>
+ <COND (<L? .COD 3>
+ <EMIT <INSTRUCTION `MOVEM
+ .ACSY
+ <1 .OFFS>
+ !<2 .OFFS>
+ '`(TP) >>)>)>
+ T>
+
+<DEFINE DO-LAST (SUBRC MAYBE-FALSE WHERE "AUX" TG TG2)
+ <REGSTO T>
+ <COND (.MAYBE-FALSE
+ <EMIT '<`POP `P* `A >>
+ <EMIT '<`POP `P* 0>>
+ <EMIT <INSTRUCTION `JUMPL `O <SET TG <MAKE:TAG>>>>
+ <COND (.SUBRC <GOOD-CALL .SUBRC>)
+ (ELSE <EMIT '<ACALL!-OP!-PACKAGE `A* APPLY>>)>
+ <BRANCH:TAG <SET TG2 <MAKE:TAG>>>
+ <LABEL:TAG .TG>
+ <EMIT '<`POP `TP* `B >>
+ <EMIT '<`POP `TP* `A >>
+ <LABEL:TAG .TG2>
+ <SET WHERE <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>)
+ (ELSE
+ <EMIT '<`POP `P* `A >>
+ <COND (.SUBRC <GOOD-CALL .SUBRC>)
+ (ELSE <EMIT '<ACALL!-OP!-PACKAGE `A* APPLY>>)>
+ <SET WHERE <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>)>>
+
+<DEFINE GOOD-CALL (SBR "AUX" TP SB)
+ #DECL ((TP) LIST)
+ <COND (<AND <GASSIGNED? .SBR>
+ <TYPE? <SET SB ,.SBR> SUBR>
+ <SET TP <GET-TMPS .SB>>
+ <G=? <LENGTH .TP> 4>
+ <==? <4 .TP> STACK>>
+ <EMIT <INSTRUCTION `PUSHJ `P* <6 .TP>>>)
+ (ELSE <EMIT <INSTRUCTION ACALL!-OP!-PACKAGE `A* .SBR>>)>>
+
+<SETG SLOT-FIRST [<CHTYPE <MIN> FIX> <CHTYPE <MAX> FIX> 1 0]>
+
+<SETG FSLOT-FIRST [<MIN> <MAX> 1.0 0.0000000]>
+
+\\f
+
+<DEFINE DO-FIRST-SETUP (FAP W ACS CHF ONES FLS
+ "AUX" (COD 0)
+ (TYP <ISTYPE? <RESULT-TYPE <PARENT .FAP>>>) DAT
+ TEM TT T1)
+ #DECL ((FAP) NODE (COD) FIX)
+ <COND
+ (<==? <NODE-TYPE .FAP> ,MFIRST-CODE>
+ <SET COD <NODE-SUBR .FAP>>
+ <COND (<==? .COD 5>
+ <STACK:ARGUMENT <REFERENCE <COND (.TYP <CHTYPE () .TYP>)
+ (ELSE ())>>>
+ <STACK:ARGUMENT <REFERENCE ()>>
+ <ADD:STACK 4>
+ <>)
+ (<NOT .ACS>
+ <STACK:ARGUMENT
+ <REFERENCE <COND (<==? .TYP FLOAT> <NTH ,FSLOT-FIRST .COD>)
+ (ELSE <NTH ,SLOT-FIRST .COD>)>>>
+ <ADD:STACK 2>
+ <>)>)
+ (<NODE-NAME .FAP> T)
+ (<NOT .ACS>
+ <RET-TMP-AC <STACK:ARGUMENT <REFERENCE <>>>>
+ <ADD:STACK 2>
+ <>)>>
+
+\\f
+
+<DEFINE DO-FIRST-SETUP-2 (FAP W ACS CHF ONES FLS
+ "AUX" (COD 0)
+ (TYP <ISTYPE? <RESULT-TYPE <PARENT .FAP>>>) DAT
+ TEM TT T1)
+ #DECL ((FAP) NODE (COD) FIX (ACS) <OR FALSE SYMTAB>)
+ <COND
+ (<AND <NOT <NODE-NAME .FAP>> .FLS> <SET TEM <SET ACS <>>>)
+ (<==? <NODE-TYPE .FAP> ,MFIRST-CODE>
+ <SET COD <NODE-SUBR .FAP>>
+ <COND (<==? .COD 5> <SET TEM #FALSE (1)>)
+ (.ACS
+ <SET T1
+ <MOVE:ARG <REFERENCE <COND (<==? .TYP FLOAT>
+ <NTH ,FSLOT-FIRST .COD>)
+ (ELSE <NTH ,SLOT-FIRST .COD>)>>
+ <GOODACS <PARENT .FAP> .W>>>
+ <SET TEM <>>)
+ (ELSE <SET TEM <>>)>)
+ (<NODE-NAME .FAP> <SET TEM T>)
+ (<AND .ACS <NOT .CHF>>
+ <SET DAT <GOODACS <PARENT .FAP> .W>>
+ <COND (<NOT .ONES>
+ <COND (<==? <SET TEM <DATTYP .DAT>> ANY-AC>
+ <PUT .DAT ,DATTYP <GETREG .DAT>>)
+ (<TYPE? .TEM AC> <SGETREG .TEM .DAT>)>
+ <COND (<==? <SET TEM <DATVAL .DAT>> ANY-AC>
+ <PUT .DAT ,DATVAL <GETREG .DAT>>)
+ (<TYPE? .TEM AC> <SGETREG .TEM .DAT>)>)>
+ <SET T1 .DAT>
+ <SET TEM <>>)
+ (.ACS
+ <SET T1 <MOVE:ARG <REFERENCE <>> <GOODACS <PARENT .FAP> .W>>>
+ <SET TEM <>>)
+ (ELSE <SET TEM <>>)>
+ <COND (<AND .ACS <NOT .TEM> <EMPTY? .TEM>>
+ <SET TT <CREATE-TMP .TYP>>
+ <PUT .ACS
+ ,ADDR-SYM
+ <CHTYPE (.BSTB
+ .TT
+ <COND (<=? .AC-HACK '(FUNNY-STACK)>
+ <* <TOTARGS .FCN> -2>)
+ (ELSE 0)>
+ !.TMPS)
+ TEMPV>>
+ <COND (<OR .CHF <NOT .ONES>>
+ <PUT .ACS ,INACS .T1>
+ <PUT .ACS ,STORED <>>
+ <PUT <SET TT <DATVAL .T1>>
+ ,ACRESIDUE
+ (.ACS !<ACRESIDUE .TT>)>
+ <COND (<AND <NOT .TYP> <TYPE? <DATTYP .T1> AC>>
+ <PUT <SET TT <DATTYP .T1>>
+ ,ACRESIDUE
+ (.ACS !<ACRESIDUE .TT>)>)>)>
+ <RET-TMP-AC .T1>
+ <>)
+ (ELSE .TEM)>>
+
+\\f
+
+<DEFINE MPARGS-GEN (N W
+ "AUX" (MP .MPINFO) DAT TT ETAG
+ (STKD <STACK:L .STK <MAP-STSTR .MP>>)
+ (OFFS <FORM - <MAP-OFF .MP> !.STKD>))
+ #DECL ((MP)
+ <VECTOR <LIST [REST NODE]>
+ DATUM
+ <OR FALSE ATOM>
+ <LIST [REST ATOM]>
+ ANY
+ <OR LIST FALSE>
+ FIX
+ LIST
+ LIST
+ LIST>
+ (STKD OFFS)
+ <PRIMTYPE LIST>
+ (DAT)
+ DATUM
+ (ETAG)
+ ATOM)
+ <COND (<NOT <MAP-STK .MP>>
+ <SET DAT <DATUM <SET TT <ADDRESS:C .OFFS '`(TP) >> .TT>>
+ <PUT .MP ,MAP-OFF <+ <MAP-OFF .MP> 2>>)
+ (<NOT <MAP-STOF .MP>>
+ <SET OFFS
+ <FORM + <MAP-OFF .MP> !<STACK:L .STK <MAP-STSTR .MP>>>>
+ <SET DAT
+ <DATUM <SET TT <SPEC-OFFPTR 0 <MAP-SRC .MP> VECTOR (.OFFS)>>
+ .TT>>
+ <PUT .MP ,MAP-OFF <+ <MAP-OFF .MP> 2>>)
+ (ELSE
+ <SET DAT
+ <DATUM <SET TT
+ <ADDRESS:C !<MAP-STOF .MP>
+ <COND (.AC-HACK `(FRM) ) (`(TB) )>
+ <COND (.AC-HACK <+ <* <TOTARGS .FCN> -2> 1>)
+ (0)>>>
+ .TT>>)>
+ <COND (<AND <MAP-STK .MP> <MAP-STOF .MP>>
+ <PUT .MP ,MAP-STOF (2 !<MAP-STOF .MP>)>)>
+ <SET W
+ <MOVE:ARG <STACKM <1 <MAP-STRS .MP>>
+ .DAT
+ <MAP-FR .MP>
+ <SET ETAG <1 <MAP-TAG .MP>>>
+ <MAP-POFF .MP>>
+ .W>>
+ <PUT .MP ,MAP-STRS <REST <MAP-STRS .MP>>>
+ <AND <EMPTY? <MAP-STRS .MP>> <RET-TMP-AC <MAP-SRC .MP>>>
+ <PUT .MP
+ ,MAP-TGL
+ ((.ETAG (<FORM - !<MAP-STKFX .MP>> !.STKD))
+ !<MAP-TGL .MP>)>
+ <PUT .MP ,MAP-STKFX .STKD>
+ <PUT .MP ,MAP-TAG <REST <MAP-TAG .MP>>>
+ .W>
+
+\\f
+
+<DEFINE STACKM (N SRC R? LBL POFF
+ "AUX" (STY <STRUCTYP <RESULT-TYPE .N>>) (COD 0) TT
+ (ETY <GET-ELE-TYPE <RESULT-TYPE .N> ALL>) SAC TEM)
+ #DECL ((N) NODE (SRC TEM) DATUM (SAC) AC (COD POFF) FIX)
+ <SET ETY <ISTYPE-GOOD? .ETY>>
+ <COND
+ (<OR <==? .STY TUPLE> <==? .STY VECTOR>>
+ <SET SAC
+ <DATVAL <SET TEM <MOVE:ARG .SRC <DATUM .STY ANY-AC> T>>>>
+ <EMIT <INSTRUCTION `JUMPGE <ACSYM .SAC> .LBL>>
+ <EMIT <INSTRUCTION `MOVE `O '[<2 (2)>]>>
+ <EMIT <INSTRUCTION `ADDM `O !<ADDR:VALUE .SRC>>>
+ <COND (.R?
+ <COND (<==? .STY TUPLE> <PUT .TEM ,DATTYP <DATTYP .SRC>>)
+ (ELSE .TEM)>)
+ (ELSE
+ <SET TT <OFFPTR 0 .TEM .STY>>
+ <COND (.ETY <DATUM .ETY .TT>) (ELSE <DATUM .TT .TT>)>)>)
+ (<==? .STY LIST>
+ <SET SAC
+ <DATVAL <SET TEM <MOVE:ARG .SRC <DATUM LIST ANY-AC> T>>>>
+ <EMIT <INSTRUCTION `SKIPL .POFF `(P) >>
+ <EMIT <INSTRUCTION `HRRZ <ACSYM .SAC> (<ADDRSYM .SAC>)>>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM .SAC> .LBL>>
+ <EMIT <INSTRUCTION `MOVEM <ACSYM .SAC> !<ADDR:VALUE .SRC>>>
+ <MUNG-AC .SAC .TEM>
+ <COND (.R? .TEM)
+ (ELSE
+ <COND (<1? <SET COD <DEFERN <GET-ELE-TYPE <RESULT-TYPE .N> ALL>>>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .SAC> 1 (<ADDRSYM .SAC>)>>)
+ (<NOT <0? .COD>>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O (<ADDRSYM .SAC>)>>
+ <EMIT <INSTRUCTION `CAIN `O TDEFER!-OP!-PACKAGE>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .SAC> 1 (<ADDRSYM .SAC>)>>)>
+ <SET TT <OFFPTR 0 .TEM LIST>>
+ <DATUM <COND (.ETY .ETY) (ELSE .TT)> .TT>)>)
+ (<OR <==? .STY UVECTOR> <==? .STY STORAGE>>
+ <SET SAC
+ <DATVAL <SET TEM <MOVE:ARG .SRC <DATUM UVECTOR ANY-AC> T>>>>
+ <EMIT <INSTRUCTION `JUMPGE <ACSYM .SAC> .LBL>>
+ <EMIT <INSTRUCTION `MOVE `O '[<1 (1)>]>>
+ <EMIT <INSTRUCTION `ADDM `O !<ADDR:VALUE .SRC>>>
+ <COND (.R? .TEM)
+ (ELSE
+ <SET TT <OFFPTR -1 .TEM UVECTOR>>
+ <DATUM <COND (.ETY .ETY) (ELSE .TT)> .TT>)>)
+ (<OR <==? .STY STRING> <==? .STY BYTES>>
+ <EMIT <INSTRUCTION `HRRZ `O !<ADDR:TYPE .SRC>>>
+ <EMIT <INSTRUCTION `SOJL `O .LBL>>
+ <COND (.R?
+ <SET TEM <MOVE:ARG .SRC <DATUM ANY-AC ANY-AC> T>>
+ <EMIT <INSTRUCTION `HRRM `O !<ADDR:TYPE .SRC>>>
+ <EMIT <INSTRUCTION `IBP !<ADDR:VALUE .SRC>>>
+ .TEM)
+ (ELSE
+ <EMIT <INSTRUCTION `HRRM `O !<ADDR:TYPE .SRC>>>
+ <SET TEM <DATUM <COND (<==? .STY STRING> CHARACTER)
+ (ELSE FIX)> ANY-AC>>
+ <PUT .TEM ,DATVAL <GETREG .TEM>>
+ <EMIT <INSTRUCTION `ILDB
+ <ACSYM <DATVAL .TEM>>
+ !<ADDR:VALUE .SRC>>>
+ .TEM)>)
+ (ELSE ;"Don't know type of structure, much more hair."
+ <RET-TMP-AC <MOVE:ARG .SRC <FUNCTION:VALUE> T>>
+ <REGSTO T>
+ <SET TEM <FUNCTION:VALUE T>>
+ <PUT ,AC-D ,ACPROT T>
+ <EMIT '<`PUSHJ `P* |TYPSEG >>
+ <EMIT <INSTRUCTION `SKIPL .POFF '`(P) >>
+ <EMIT '<`XCT |INCR1 `(C) >>
+ <EMIT '<`XCT |TESTR `(C) >>
+ <BRANCH:TAG .LBL>
+ <COND (.R?
+ <EMIT '<`MOVE `A* |DSTORE>>
+ <EMIT '<`MOVE `B* `D >>)
+ (ELSE
+ <EMIT '<`XCT |TYPG `(C) >>
+ <EMIT '<`XCT |VALG `(C) >>
+ <EMIT '<`JSP `E* |CHKAB >>)>
+ <EMIT '<`MOVE `O |DSTORE>>
+ <EMIT <INSTRUCTION `MOVEM `O !<ADDR:TYPE .SRC>>>
+ <EMIT <INSTRUCTION `MOVEM `D* !<ADDR:VALUE .SRC>>>
+ <EMIT '<`SETZM |DSTORE>>
+ <PUT ,AC-D ,ACPROT <>>
+ .TEM)>>
+
+<DEFINE ISET (TYP S1 S2 R? TG CHF NRG TG2
+ "AUX" (PTYP <STRUCTYP .TYP>) D1 A1 A2 COD D2
+ (ETYP
+ <TYPE-AND <1 <DECL-SYM .S2>> <GET-ELE-TYPE .TYP ALL .R?>>)
+ TEM (TT <ISTYPE-GOOD? <1 <DECL-SYM .S2>>>) ET (BIND <>))
+ #DECL ((S1 S2) SYMTAB (D1) <OR DATUM FALSE> (A1) AC (COD NR) FIX
+ (FSYM) <OR FALSE SYMTAB>)
+ <LVAL-UP .S1>
+ <SET D1 <INACS .S1>>
+ <COND (<AND <NOT .D1> <OR .R? <AND <N==? .PTYP STRING> <N==? .PTYP BYTES>>>>
+ <SET D1
+ <MOVE:ARG <LADDR .S1 <> <>>
+ <DATUM <COND (<OR <==? .PTYP STRING> <==? .PTYP BYTES>>
+ ANY-AC)
+ (ELSE .PTYP)>
+ ANY-AC>>>
+ <PUT .S1 ,INACS <DATUM <DATTYP .D1> <DATVAL .D1>>>
+ <PUT <SET A1 <DATVAL .D1>> ,ACRESIDUE (.S1 !<ACRESIDUE .A1>)>
+ <RET-TMP-AC .D1>)
+ (<NOT .D1> <SET D1 <LADDR .S1 <> <>>>)
+ (ELSE <SET A1 <DATVAL .D1>>)>
+ <COND (<INACS .S1> <PUT .S1 ,STORED <>>)>
+ <COND (<OR .CHF <NOT <1? .NRG>>>
+ <RETURN-UP .INRAP .STK>
+ <COND (<==? .PTYP LIST> <EMIT <INSTRUCTION `JUMPE <ACSYM .A1> .TG>>)
+ (<OR <==? .PTYP VECTOR>
+ <==? .PTYP UVECTOR>
+ <==? .PTYP TUPLE>
+ <==? .PTYP STORAGE>>
+ <EMIT <INSTRUCTION `JUMPGE <ACSYM .A1> .TG>>)
+ (<TYPE? <SET A2 <DATTYP .D1>> AC>
+ <EMIT <INSTRUCTION `TRNN <ACSYM .A2> -1>>
+ <BRANCH:TAG .TG>)
+ (ELSE
+ <EMIT <INSTRUCTION `HRRZ `O* !<ADDR:TYPE .D1>>>
+ <EMIT <INSTRUCTION `JUMPE `O* .TG>>)>)>
+ <COND (<1? .NRG>
+ <LABEL:TAG .TG2>
+ <OR .PRE
+ <PROG ()
+ <SALLOC:SLOTS <TMPLS .INRAP>>
+ <ADD:STACK <TMPLS .INRAP>>
+ <SET NTSLOTS (<FORM GVAL <TMPLS .INRAP>> !.NTSLOTS)>
+ <SET GSTK .STK>
+ <SET STK (0 !.STK)>>>
+ <AND .PRE <SET GSTK .STK> <SET STK (0 !.STK)>>)>
+ <COND (<TYPE? <ADDR-SYM .S2> TEMPV>
+ <SET TT <CREATE-TMP .TT>>
+ <PUT .S2
+ ,ADDR-SYM
+ <CHTYPE (.BSTB
+ .TT
+ <COND (<=? .AC-HACK '(FUNNY-STACK)>
+ <* <TOTARGS .FCN> -2>)
+ (ELSE 0)>
+ !.TMPS)
+ TEMPV>>)
+ (ELSE <SET BIND T>)>
+ <COND
+ (.R?
+ <COND (.BIND <BINDUP .S2 <DATUM !.D1>>)
+ (ELSE <PUT .S2 ,INACS <SET D2 <DATUM !.D1>>>)>)
+ (ELSE
+ <COND (<NOT .BIND>
+ <COND (<TYPE? <DATTYP .D1> AC> <PUT <DATTYP .D1> ,ACPROT T>)>
+ <COND (<TYPE? <DATVAL .D1> AC> <PUT <DATVAL .D1> ,ACPROT T>)>
+ <COND (<SET ET <ISTYPE-GOOD? .ETYP>>
+ <PUT <SET D2 <DATUM .ET ANY-AC>> ,DATVAL <GETREG .D2>>)
+ (ELSE
+ <PUT <SET D2 <DATUM ANY-AC ANY-AC>>
+ ,DATTYP
+ <SET TEM <GETREG .D2>>>
+ <PUT .TEM ,ACPROT T>
+ <PUT .D2 ,DATVAL <GETREG .D2>>
+ <PUT .TEM ,ACPROT <>>)>
+ <COND (<TYPE? <DATVAL .D1> AC> <PUT <DATVAL .D1> ,ACPROT <>>)>
+ <COND (<TYPE? <DATTYP .D1> AC> <PUT <DATTYP .D1> ,ACPROT <>>)>
+ <PUT .S2 ,INACS .D2>)
+ (ELSE <SET ET <ISTYPE-GOOD? .ETYP>>)>
+ <COND
+ (<==? .PTYP LIST>
+ <COND (.BIND
+ <COND (<TYPE? <DATVAL .D1> AC> <PUT <DATVAL .D1> ,ACPROT T>)>
+ <SET TEM <GETREG <>>>
+ <COND (<TYPE? <DATVAL .D1> AC> <PUT <DATVAL .D1> ,ACPROT <>>)>)
+ (ELSE <SET TEM <DATVAL .D2>>)>
+ <COND (<NOT <0? <SET COD <DEFERN .ETYP>>>>
+ <COND (<1? .COD>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .TEM> 1 (<ADDRSYM .A1>)>>)
+ (ELSE
+ <EMIT <INSTRUCTION `MOVE <ACSYM .TEM> <ADDRSYM .A1>>>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE
+ `O*
+ (<ADDRSYM .A1>)>>
+ <EMIT '<`CAIN `O* TDEFER!-OP!-PACKAGE>>
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM .TEM>
+ 1
+ (<ADDRSYM .TEM>)>>)>
+ <SET A1 .TEM>)>
+ <COND (<NOT .BIND>
+ <COND (<NOT .ET>
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM <DATTYP .D2>>
+ (<ADDRSYM .A1>)>>)>
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM <DATVAL .D2>>
+ 1
+ (<ADDRSYM .A1>)>>)
+ (ELSE
+ <SET TEM <OFFPTR 0 <DATUM LIST .A1> LIST>>
+ <BINDUP .S2 <DATUM .TEM .TEM>>)>)
+ (<OR <==? .PTYP VECTOR> <==? .PTYP TUPLE>>
+ <COND (.BIND
+ <SET TEM <OFFPTR 0 .D1 VECTOR>>
+ <BINDUP .S2 <DATUM .TEM .TEM>>)
+ (ELSE
+ <COND (<NOT .ET>
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM <DATTYP .D2>>
+ (<ADDRSYM .A1>)>>)>
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM <DATVAL .D2>>
+ 1
+ (<ADDRSYM .A1>)>>)>)
+ (<OR <==? .PTYP UVECTOR> <==? .PTYP STORAGE>>
+ <COND (.BIND
+ <SET TEM <OFFPTR -1 .D1 .PTYP>>
+ <BINDUP .S2
+ <COND (.ET <DATUM .ET .TEM>) (ELSE <DATUM .TEM .TEM>)>>)
+ (ELSE
+ <COND (<NOT .ET>
+ <EMIT <INSTRUCTION `HLRE
+ <ACSYM <DATTYP .D2>>
+ <ADDRSYM .A1>>>
+ <EMIT <INSTRUCTION `SUBM
+ <ACSYM .A1>
+ <ADDRSYM <DATTYP .D2>>>>
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM <DATTYP .D2>>
+ (<ADDRSYM <DATTYP .D2>>)>>)>
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM <DATVAL .D2>>
+ (<ADDRSYM .A1>)>>)>)
+ (<OR <==? .PTYP STRING> <==? .PTYP BYTES>>
+ <COND (.BIND
+ <COND (<TYPE? <DATTYP .D1> AC> <PUT <DATTYP .D1> ,ACPROT T>)>
+ <COND (<TYPE? <DATVAL .D1> AC> <PUT <DATVAL .D1> ,ACPROT T>)>
+ <SET A1 <GETREG <>>>
+ <EMIT <INSTRUCTION `ILDB <ACSYM .A1> !<ADDR:VALUE .D1>>>
+ <EMIT <INSTRUCTION `SOS !<ADDR:TYPE .D1>>>
+ <BINDUP .S2 <SET D2 <DATUM <COND (<==? .PTYP STRING> CHARACTER)
+ (ELSE FIX)> .A1>>>
+ <SET BIND <>>
+ <PUT .S2 ,INACS .D2>
+ <COND (<TYPE? <DATTYP .D1> AC> <PUT <DATTYP .D1> ,ACPROT <>>)>
+ <COND (<TYPE? <DATVAL .D1> AC> <PUT <DATVAL .D1> ,ACPROT <>>)>)
+ (ELSE
+ <EMIT <INSTRUCTION `ILDB
+ <ACSYM <DATVAL .D2>>
+ !<ADDR:VALUE .D1>>>
+ <EMIT <INSTRUCTION `SOS !<ADDR:TYPE .D1>>>)>)>)>
+ <COND (<NOT .BIND>
+ <COND (<TYPE? <DATTYP .D2> AC>
+ <PUT <SET A1 <DATTYP .D2>>
+ ,ACRESIDUE
+ (.S2 !<ACRESIDUE .A1>)>)>
+ <COND (<TYPE? <DATVAL .D2> AC>
+ <PUT <SET A1 <DATVAL .D2>>
+ ,ACRESIDUE
+ (.S2 !<ACRESIDUE .A1>)>)>
+ <PUT .S2 ,STORED <>>
+ <RET-TMP-AC .D2>)>>
+
+<DEFINE IISET (TYP SYM DAT R?
+ "AUX" (TT <ISTYPE-GOOD? <1 <DECL-SYM .SYM>>>)
+ (ETYP
+ <TYPE-AND <1 <DECL-SYM .SYM>>
+ <GET-ELE-TYPE .TYP ALL .R?>>) AC)
+ #DECL ((SYM) SYMTAB (DAT) DATUM)
+ <COND (<TYPE? <ADDR-SYM .SYM> TEMPV>
+ <SET TT <CREATE-TMP .TT>>
+ <PUT .SYM
+ ,ADDR-SYM
+ <CHTYPE (.BSTB
+ .TT
+ <COND (<=? .AC-HACK '(FUNNY-STACK)>
+ <* <TOTARGS .FCN> -2>)
+ (ELSE 0)>
+ !.TMPS)
+ TEMPV>>)>
+ <PUT .SYM
+ ,INACS
+ <SET DAT
+ <MOVE:ARG .DAT
+ <DATUM <COND (<ISTYPE-GOOD? .ETYP>) (ELSE ANY-AC)>
+ ANY-AC>>>>
+ <COND (<TYPE? <SET AC <DATTYP .DAT>> AC>
+ <PUT .AC ,ACRESIDUE (.SYM !<ACRESIDUE .AC>)>)>
+ <PUT <SET AC <DATVAL .DAT>> ,ACRESIDUE (.SYM !<ACRESIDUE .AC>)>
+ <PUT .SYM ,STORED <>>
+ <RET-TMP-AC .DAT>>
+
+<DEFINE DO-EVEN-FUNNIER-HACK (D1 S N FAP NN LV
+ "AUX" (COD <NODE-SUBR .FAP>)
+ (LMOD <RESULT-TYPE .NN>)
+ (MOD <RESULT-TYPE .N>) ACSY
+ (D2 <LADDR .S <> <>>))
+ #DECL ((D1 D2 D3) DATUM (N FAP NN) NODE (COD) FIX)
+ <SET MOD <OR <AND <==? .MOD FIX> 1> 2>>
+ <AND <==? .MOD 2> <==? .LMOD FIX> <SET D1 <GENFLOAT .D1>>>
+ <SET ACSY <ACSYM <DATVAL .D1>>>
+ <RET-TMP-AC .D1>
+ <EMIT <INSTRUCTION <NTH <NTH ,MINS .MOD> .COD>
+ .ACSY
+ !<ADDR:VALUE .D2>>>
+ <COND (<L? .COD 3>
+ <COND (<TYPE? <DATVAL .D2> AC>
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM <DATVAL .D2>>
+ <ADDRSYM <DATVAL .D1>>>>)
+ (ELSE
+ <EMIT <INSTRUCTION `MOVEM .ACSY !<ADDR:VALUE
+ .D2>>>)>)>>
+
+\\f
+
+<DEFINE HMAPFR (MNOD WHERE K
+ "AUX" XX (NTSLOTS .NTSLOTS)
+ (NTMPS
+ <COND (.PRE .TMPS) (<STACK:L .STK .BSTB>) (ELSE (0))>)
+ TEM (NSLOTS 0) (SPECD <>) STB (DTEM <DATUM FIX ANY-AC>)
+ (STKOFFS <>) (FAP <1 .K>) (INRAP <2 .K>) F? (POFF 0)
+ (ANY? <>) (NARG <LENGTH <SET K <REST .K 2>>>) START:TAG
+ (R? <==? <NODE-SUBR .MNOD> ,MAPR>) STRV (FF? <>)
+ (MAPEND <ILIST .NARG '<MAKE:TAG "MAP">>) (OSTK .STK)
+ (MAPLP <MAKE:TAG "MAP">) (MAPL2 <MAKE:TAG "MAP">) MAP:OFF
+ (SUBRC <AP? .FAP>) STOP (STK (0 !.STK)) (TMPS .TMPS) BTP
+ (BASEF .BASEF) (FRMS .FRMS) (MAYBE-FALSE <>) (OPRE .PRE)
+ (OTAG ()) DEST CD (AC-HACK .AC-HACK)
+ (EXIT <MAKE:TAG "MAPEX">) (APPLTAG <MAKE:TAG "MAPAP">) TT
+ GMF (OUTD .WHERE) OUTSAV CHF (FLS <==? .WHERE FLUSHED>)
+ (RTAG <MAKE:TAG "MAP">) (NEED-INT T) FSYM OS NS (DOIT T)
+ RV GSTK)
+ #DECL ((NTSLOTS) <SPECIAL LIST> (DTEM) DATUM
+ (SPECD) <SPECIAL <OR FALSE ATOM>> (TEM) <OR ATOM DATUM> (OFFS) FIX
+ (TMPS) <SPECIAL LIST> (POFF NSLOTS NARG) <SPECIAL FIX> (FAP) NODE
+ (BASEF MNOD INRAP) <SPECIAL NODE> (K) <LIST [REST NODE]>
+ (MAPEND) <LIST [REST ATOM]> (MAP:OFF) ATOM
+ (EXIT MAPLP RTAG APPLTAG) <SPECIAL ATOM> (OSTK) LIST
+ (DEST CD) <SPECIAL <OR ATOM DATUM>> (FRMS) <SPECIAL LIST>
+ (STOP STRV STB BTP STK GSTK) <SPECIAL LIST>
+ (AC-HACK START:TAG) <SPECIAL ANY>
+ (GMF MAYBE-FALSE ANY?) <SPECIAL ANY> (FSYM) SYMTAB)
+ <PUT .INRAP ,SPECS-START <- <SPECS-START .INRAP> .TOT-SPEC>>
+ <PROG ((PRE .PRE))
+ #DECL ((PRE) <SPECIAL ANY>)
+ <COND (<AND <NOT <EMPTY? .K>>
+ <MAPF <>
+ <FUNCTION (Z)
+ <AND <TYPE-OK? <RESULT-TYPE .Z>
+ '<PRIMTYPE LIST>>
+ <MAPLEAVE <>>>
+ T>
+ .K>>
+ <SET NEED-INT <>>)>
+ <COND (<AND <NOT <AND <EMPTY? .K> <NODE-NAME .FAP>>>
+ <OR <==? <NODE-NAME .FAP> <>>
+ <AND <==? <NODE-TYPE .FAP> ,MFIRST-CODE>
+ <N==? <NODE-SUBR .FAP> 5>>
+ .SUBRC>
+ <OR <EMPTY? .K>
+ <==? <NAME-SYM <1 <BINDING-STRUCTURE .INRAP>>>
+ DUMMY-MAPF>>>
+ <SET GMF T>)
+ (ELSE <SET GMF <>>)>
+ <COND (<AND <NOT <EMPTY? .K>>
+ <L=? <MAPF ,MIN
+ <FUNCTION (N)
+ #DECL ((N) NODE)
+ <MINL <RESULT-TYPE .N>>>
+ .K>
+ 0>>
+ <SET CHF T>)
+ (ELSE <SET CHF <>>)>
+ <SET DEST <SET OUTD <COND (.FLS FLUSHED) (ELSE <GOODACS .MNOD .WHERE>)>>>
+ <OR .PRE <EMIT-PRE <NOT <OR <ACTIVATED .INRAP> <0? <SSLOTS .BASEF>>>>>>
+ <SET STOP .STK>
+ <SET STK (0 !.STK)>
+ <SET F?
+ <DO-FIRST-SETUP
+ .FAP
+ .DEST
+ <COND (.GMF
+ <SET FSYM <1 <BINDING-STRUCTURE .INRAP>>>
+ <PUT .INRAP ,BINDING-STRUCTURE <REST <BINDING-STRUCTURE .INRAP>>>
+ .FSYM)>
+ .CHF
+ <1? .NARG>
+ .FLS>>
+ <AND .GMF <NOT .FLS> <INACS .FSYM> <SET OUTD <INACS .FSYM>>>
+ <OR .F? <SET FF? <==? <NODE-TYPE .FAP> ,MFIRST-CODE>>>
+ <COND (<AND .GMF .CHF <NOT .FLS>> <PREFER-DATUM .WHERE>)>
+ <SET ANY? <PUSH-STRUCS .K T .GMF <BINDING-STRUCTURE .INRAP> .WHERE>>
+ <COND (.GMF <KEEP-IN-ACS <BINDING-STRUCTURE .INRAP> .K .R?>)>
+ <COND (<AND .GMF .CHF <NOT .FLS>> <UNPREFER>)>
+ <DO-FIRST-SETUP-2 .FAP .DEST <COND (.GMF .FSYM)> .CHF <1? .NARG> .FLS>
+ <BEGIN-FRAME <TMPLS .INRAP> <ACTIVATED .INRAP> <PRE-ALLOC .INRAP>>
+ <SET TMPS <COND (.PRE .NTMPS) (ELSE <STACK:L .STK <2 .FRMS>>)>>
+ <SET STK (0 !.STK)>
+ <SET STB .STK>
+ <SET STK (0 !.STK)>
+ <COND (.F? <SET MAYBE-FALSE <DO-FINAL-SETUP .FAP .SUBRC>>)>
+ <PROG-START-AC .INRAP>
+ <LABEL:TAG .MAPLP>
+ <COND (<AND .F? <NOT .GMF>>
+ <SET STKOFFS
+ <FIND-FIRST-STRUC
+ .DTEM .STB <AND <NOT .PRE> <NOT <ACTIVATED .INRAP>>>>>)>
+ <AND <ACTIVATED .INRAP> <ACT:INITIAL> <ADD:STACK 2>>
+ <SET STK (0 !.STK)>
+ <SET STRV .STK>
+ <OR .PRE
+ <AND .GMF <1? .NARG>>
+ <PROG ()
+ <SALLOC:SLOTS <TMPLS .INRAP>>
+ <ADD:STACK <TMPLS .INRAP>>
+ <COND (<NOT .PRE>
+ <SET NTSLOTS (<FORM GVAL <TMPLS .INRAP>> !.NTSLOTS)>)>
+ <COND (.GMF <SET GSTK .STK> <SET STK (0 !.STK)>)>>>
+ <AND .PRE .GMF <NOT <1? .NARG>> <SET GSTK .STK> <SET STK (0 !.STK)>>
+ <SET POFF <COND (.MAYBE-FALSE -2) (.F? -1) (ELSE 0)>>
+ <COND (<AND .GMF <OR .CHF <NOT <1? .NARG>>> <NOT .FLS>> <LVAL-UP .FSYM>)>
+ <REPEAT ((KK .K) (BS <BINDING-STRUCTURE .INRAP>)
+ (BST
+ <COND
+ (<EMPTY? .BS> ())
+ (ELSE
+ <MAPR <>
+ <FUNCTION (S)
+ #DECL ((S) <LIST SYMTAB>)
+ <COND (<N==? <NAME-SYM <1 .S>> DUMMY-MAPF>
+ <MAPLEAVE .S>)
+ (ELSE ())>>
+ .BS>)>) (OFFSET (<- 1 <* .NARG 2>> ())) TEM
+ (TOFF (0 ())) (GOFF '(0)))
+ #DECL ((BST) <LIST [REST SYMTAB]> (TOFF OFFSET) <LIST FIX LIST>
+ (KK) <LIST [REST NODE]>)
+ <COND
+ (<EMPTY? .KK>
+ <AND .GMF <NOT <1? .NARG>> <NOT .FF?> <NOT .FLS> <RET-TMP-AC .OUTD>>
+ <COND (<AND .F? <NOT .STKOFFS>> <RET-TMP-AC .DTEM>)>
+ <MAPF <>
+ <FUNCTION (SYM)
+ #DECL ((SYM) SYMTAB)
+ <APPLY <NTH ,MBINDERS <CODE-SYM .SYM>> .SYM>>
+ .BST>
+ <RETURN>)
+ (ELSE
+ <SET RV <TYPE? <ADDR-SYM <1 .BST>> TEMPV>>
+ <COND (.GMF)
+ (.F?
+ <COND (.STKOFFS
+ <SET TEM
+ <ADDRESS:C .STKOFFS
+ <COND (.AC-HACK `(FRM) ) (`(TB) )>
+ <COND (.AC-HACK 1) (ELSE 0)>>>
+ <OR .RV <SET STKOFFS <+ .STKOFFS 2>>>)
+ (ELSE
+ <SET TEM
+ <SPEC-OFFPTR <1 .OFFSET>
+ .DTEM
+ VECTOR
+ (!<2 .OFFSET>
+ !<STACK:L .STK .STRV>)>>
+ <SET OFFSET
+ <STFIXIT .OFFSET
+ (2
+ <- <1 .TOFF>>
+ <FORM - 0 !<2 .TOFF>>)>>)>)
+ (ELSE
+ <SET TEM
+ <ADDRESS:C <FORM - <1 .OFFSET> !<STACK:L .STK .STRV>>
+ '`(TP)
+ !<2 .OFFSET>>>
+ <SET OFFSET <STFIXIT .OFFSET (2)>>)>
+ <IF <==? <CODE-SYM <1 .BST>> 4>
+ <MESSAGE ERROR "NOT IMPLEMENTED MAPF/R TUPLES ">>
+ <SET OTAG
+ ((<1 .MAPEND>
+ <COND (.GMF (<FORM + !.GOFF>))
+ ((<FORM - 0 <1 .TOFF> !<2 .TOFF>>
+ <1 <SET TOFF <STFIXIT (0 ()) <STACK:L .STK .STRV>>>>
+ !<2 .TOFF>))>)
+ !.OTAG)>
+ <COND (.GMF
+ <ISET <RESULT-TYPE <1 .KK>>
+ <1 .BS>
+ <1 .BST>
+ .R?
+ <1 .MAPEND>
+ .CHF
+ .NARG
+ .MAPL2>
+ <SET BS <REST .BS>>
+ <SET GOFF <STACK:L .STK .GSTK>>)
+ (.RV
+ <RETURN-UP .INRAP .STK>
+ <IISET <RESULT-TYPE <1 .KK>>
+ <1 .BST>
+ <STACKM <1 .KK> <DATUM .TEM .TEM> .R? <1 .MAPEND> .POFF>
+ .R?>)
+ (ELSE
+ <BINDUP <1 .BST>
+ <STACKM <1 .KK>
+ <DATUM .TEM .TEM>
+ .R?
+ <1 .MAPEND>
+ .POFF>>)>
+ <SET MAPEND <REST .MAPEND>>
+ <SET KK <REST .KK>>
+ <SET BST <REST .BST>>)>>
+ <COND
+ (<AND .GMF <OR .CHF <NOT <1? .NARG>>> <NOT .FLS> <NOT .FF?>>
+ <PROG ((S .FSYM))
+ <PUT .S ,STORED T>
+ <COND (<INACS .S>
+ <COND (<TYPE? <DATTYP <INACS .S>> AC>
+ <FLUSH-RESIDUE <DATTYP <INACS .S>> .S>)>
+ <COND (<TYPE? <DATVAL <INACS .S>> AC>
+ <FLUSH-RESIDUE <DATVAL <INACS .S>> .S>)>
+ <PUT .S ,INACS <>>)>>)>
+ <COND (<AND .GMF <NOT .CHF> <1? .NARG> <NOT .FLS>> <LVAL-UP .FSYM>)>
+ <OR .PRE
+ <0? <SET NSLOTS <SSLOTS .INRAP>>>
+ <PROG ()
+ <SALLOC:SLOTS .NSLOTS>
+ <ADD:STACK .NSLOTS>
+ <EMIT-PRE <SET PRE T>>>>
+ <AND <ACTIVATED .INRAP> <ACT:FINAL>>
+ <SET BTP .STK>
+ <OR .OPRE <SET BASEF .INRAP>>
+ <SET STK (0 !.STK)>
+ <AND .NEED-INT <CALL-INTERRUPT>>
+ <COND
+ (<AND .R?
+ <NOT .F?>
+ <NOT .FF?>
+ .FLS
+ <1? .NARG>
+ <BLT-HACK <KIDS .INRAP>
+ <BINDING-STRUCTURE .INRAP>
+ <MINL <RESULT-TYPE <1 .K>>>>>
+ <SET DOIT <>>)
+ (<OR .F? .FF?>
+ <SET TEM <SEQ-GEN <KIDS .INRAP> <GOODACS .INRAP DONT-CARE> T>>)
+ (<NOT .FLS>
+ <SET TEM
+ <SEQ-GEN
+ <KIDS .INRAP>
+ <COND (.GMF .OUTD)
+ (ELSE
+ <DATUM <SET TT
+ <ADDRESS:C <FORM -
+ -1
+ <* 2 .NARG>
+ !<STACK:L .STK .STRV>>
+ '`(TP) >>
+ .TT>)>
+ T>>
+ <SET OUTD .TEM>)
+ (ELSE <RET-TMP-AC <SET TEM <SEQ-GEN <KIDS .INRAP> FLUSHED T>>>)>
+ <COND
+ (<AND .DOIT <N==? .TEM ,NO-DATUM>>
+ <COND (<ACTIVATED .INRAP> <PROG:END> <LABEL:OFF .MAP:OFF>)
+ (<OR .OPRE .F?>
+ <AND .SPECD
+ <OR .OPRE <SET TEM <MOVE:ARG .TEM <DATUM ,AC-A ,AC-B>>>>>
+ <POP:LOCS .STK .STRV>
+ <UNBIND:FUNNY <SPECS-START .INRAP> !.NTSLOTS>)
+ (ELSE <UNBIND:LOCS .STK .STB>)>
+ <COND
+ (.F? <DO-STACK-ARGS .MAYBE-FALSE .TEM>)
+ (<AND .GMF .FF?>
+ <OR .PRE
+ <PROG ()
+ <SET NTSLOTS <REST <SET NS .NTSLOTS>>>
+ <SET OS .STK>
+ <SET STK .STB>>>
+ <DO-EVEN-FUNNIER-HACK .TEM
+ .FSYM
+ .MNOD
+ .FAP
+ .INRAP
+ <LOOP-VARS .INRAP>>)
+ (<AND .GMF <NOT .FLS>>
+ <OR .PRE
+ <PROG ()
+ <SET NTSLOTS <REST <SET NS .NTSLOTS>>>
+ <SET STK .STB>>>
+ <RET-TMP-AC .TEM>
+ <PUT .FSYM ,INACS .TEM>
+ <PUT .FSYM ,STORED <>>
+ <COND (<TYPE? <DATTYP .TEM> AC>
+ <PUT <DATTYP .TEM>
+ ,ACRESIDUE
+ (.FSYM !<ACRESIDUE <DATTYP .TEM>>)>)>
+ <PUT <DATVAL .TEM> ,ACRESIDUE (.FSYM !<ACRESIDUE <DATVAL .TEM>>)>
+ <PUT .FSYM ,STORED <>>
+ <COND
+ (<NOT <MEMQ .FSYM <LOOP-VARS .INRAP>>>
+ <REPEAT ((L <LOOP-VARS .INRAP>) LL)
+ #DECL ((L) LIST (LL) DATUM)
+ <COND (<EMPTY? .L> <RETURN>)>
+ <COND (<TYPE? <DATVAL <SET LL <LINACS-SLOT .L>>> AC>
+ <PUT <DATVAL .LL> ,ACPROT T>)>
+ <COND (<TYPE? <DATTYP .LL> AC>
+ <PUT <DATTYP .LL> ,ACPROT T>)>
+ <SET L <REST .L ,LOOPVARS-LENGTH>>>
+ <PUT
+ .INRAP
+ ,LOOP-VARS
+ (.FSYM
+ <PROG (R R2 D)
+ <SET D
+ <DATUM
+ <COND (<ISTYPE-GOOD? <RESULT-TYPE .MNOD>>)
+ (<AND <TYPE? .WHERE DATUM>
+ <TYPE? <SET R <DATTYP .WHERE>> AC>
+ <NOT <ACPROT .R>>>
+ <PUT <COND (<==? .R <DATVAL .TEM>> .R)
+ (ELSE <SGETREG .R <>>)>
+ ,ACPROT
+ T>)
+ (ELSE <PUT <SET R <GETREG <>>> ,ACPROT T>)>
+ <COND (<AND <TYPE? .WHERE DATUM>
+ <TYPE? <SET R2 <DATVAL .WHERE>> AC>
+ <NOT <ACPROT .R2>>>
+ <COND (<==? .R2 <DATVAL .TEM>> .R2)
+ (ELSE <SGETREG .R2 <>>)>)
+ (ELSE <SET R2 <GETREG <>>>)>>>
+ <COND (<AND <ASSIGNED? R>>
+ <TYPE? .R AC>
+ <PUT .R ,ACPROT <>>)>
+ .D>
+ !<LOOP-VARS .INRAP>)>
+ <REPEAT ((L <LOOP-VARS .INRAP>) LL)
+ #DECL ((L) LIST (LL) DATUM)
+ <COND (<EMPTY? .L> <RETURN>)>
+ <COND (<TYPE? <DATVAL <SET LL <LINACS-SLOT .L>>> AC>
+ <PUT <DATVAL .LL> ,ACPROT <>>)>
+ <COND (<TYPE? <DATTYP .LL> AC>
+ <PUT <DATTYP .LL> ,ACPROT <>>)>
+ <SET L <REST .L ,LOOPVARS-LENGTH>>>)>)
+ (.FF? <DO-FUNNY-HACK .TEM (<* .NARG -2> ()) .MNOD .FAP .INRAP>)>
+ <COND (.ANY? <EMIT <INSTRUCTION `SETZM .POFF '`(P) >>)>
+ <OR .PRE
+ <AND .GMF <NOT .FLS>>
+ <AND .GMF .FF?>
+ <PROG ()
+ <SET NTSLOTS <REST <SET NS .NTSLOTS>>>
+ <SET STK .STB>>>)>
+ <COND
+ (.DOIT
+ <AGAIN-UP .INRAP <AND .GMF <1? .NARG>>>
+ <LABEL:TAG .RTAG>
+ <COND (.GMF
+ <REST-STRUCS <BINDING-STRUCTURE .INRAP>
+ .K
+ <LOOP-VARS .INRAP>
+ .NARG
+ .MAPL2
+ .R?>)>
+ <COND (<NOT <AND .GMF <1? .NARG>>> <BRANCH:TAG .MAPLP>)>
+ <GEN-TAGS .OTAG .SPECD>
+ <COND (<AND .GMF <NOT .PRE>> <SET STK .GSTK> <SET NTSLOTS .NS>)>
+ <COND (<AND .GMF <NOT <1? .NARG>>>
+ <COND (<OR .OPRE .F?>
+ <POP:LOCS .STK .STRV>
+ <UNBIND:FUNNY <SPECS-START .INRAP> !.NTSLOTS>)
+ (ELSE <UNBIND:LOCS .STK .STB>)>)>
+ <MAPF <>
+ <FUNCTION (N)
+ #DECL ((N) NODE)
+ <COND (<NOT <ISTYPE? <STRUCTYP <RESULT-TYPE .N>>>>
+ <EMIT '<`SETZM |DSTORE >>
+ <MAPLEAVE>)>>
+ .K>)
+ (ELSE <GEN-TAGS .OTAG .SPECD>)>
+ <CLEANUP-STATE .INRAP>
+ <LABEL:TAG .APPLTAG>
+ <COND
+ (<TYPE? .DEST DATUM>
+ <SET CD
+ <COND (.F? <DO-LAST .SUBRC .MAYBE-FALSE <DATUM !.DEST>>)
+ (<AND .FF? .GMF>
+ <MOVE:ARG <LADDR .FSYM <> <>> <DATUM !.DEST>>)
+ (.FF? <DO-FUNNY-LAST .FAP <- -1 <* 2 .NARG>> <DATUM !.DEST>>)
+ (.GMF <MOVE:ARG .OUTD <DATUM !.DEST>>)
+ (ELSE
+ <MOVE:ARG
+ <DATUM <SET TT <ADDRESS:C <- -1 <* 2 .NARG>> '`(TP) >> .TT>
+ <DATUM !.DEST>>)>>
+ <ACFIX .DEST .CD>
+ <AND <ISTYPE? <DATTYP .DEST>>
+ <TYPE? <DATTYP .CD> AC>
+ <RET-TMP-AC <DATTYP .CD> .CD>>)
+ (.F? <DO-LAST .SUBRC .MAYBE-FALSE <FUNCTION:VALUE>>)
+ (<AND .FF? .GMF> <MOVE:ARG .OUTD <FUNCTION:VALUE>>)
+ (<AND .GMF .FF?> <MOVE:ARG .OUTD <FUNCTION:VALUE>>)
+ (.FF? <DO-FUNNY-LAST .FAP <- -1 <* 2 .NARG>> <FUNCTION:VALUE>>)>
+ <POP:LOCS .STB .STOP>
+ <LABEL:TAG .EXIT>>
+ <COND (<ASSIGNED? CD>
+ <AND <TYPE? <DATTYP .DEST> AC> <FIX-ACLINK <DATTYP .DEST> .DEST .CD>>
+ <AND <TYPE? <DATVAL .DEST> AC>
+ <FIX-ACLINK <DATVAL .DEST> .DEST .CD>>)>
+ <SET STK .OSTK>
+ <SET XX <MOVE:ARG .DEST .WHERE>>
+ <END-FRAME>
+ .XX>
+
+<DEFINE BLT-HACK (K B LN "AUX" N N1 AC EA D1 D2 TY TT (TG <MAKE:TAG>))
+ <COND (<AND <==? <LENGTH .K> 1>
+ <==? <NODE-TYPE <SET N <1 .K>>> ,PUT-CODE>
+ <==? <LENGTH <SET K <KIDS .N>>> 3>
+ <==? <NODE-TYPE <SET N1 <2 .K>>> ,QUOTE-CODE>
+ <==? <NODE-NAME .N1> 1>
+ <==? <NODE-TYPE <SET N1 <1 .K>>> ,LVAL-CODE>
+ <MEMQ <NODE-NAME .N1> .B>
+ <OR <==? <SET TT <STRUCTYP <RESULT-TYPE .N>>> UVECTOR>
+ <==? .TT VECTOR>>
+ <SET TY
+ <COND (<==? .TT VECTOR>
+ <SET TT T>
+ <OR <ISTYPE? <RESULT-TYPE <3 .K>>> ANY>)
+ (ELSE
+ <SET TT <>>
+ <ISTYPE? <RESULT-TYPE <3 .K>>>)>>
+ <OR <==? <NODE-TYPE <3 .K>> ,QUOTE-CODE>
+ <==? <NODE-TYPE <3 .K>> ,GVAL-CODE>
+ <AND <G=? <LENGTH <3 .K>> <INDEX ,SIDE-EFFECTS>>
+ <NOT <SIDE-EFFECTS <3 .K>>>
+ <NO-INTERFERE <3 .K> .B>>>>
+ <SET D1
+ <GEN .N1
+ <DATUM <COND (<ISTYPE? <RESULT-TYPE .N1>>)
+ (ELSE ANY-AC)>
+ ANY-AC>>>
+ <SET D2 <GEN <3 .K> DONT-CARE>>
+ <MOVE:ARG .D2
+ <DATUM <COND (<AND .TT
+ <ISTYPE-GOOD?
+ <GET-ELE-TYPE
+ <RESULT-TYPE .N1> ALL>>>)
+ (.TT <OFFPTR 0 .D1 VECTOR>)
+ (ELSE .TY)>
+ <OFFPTR <COND (.TT 0) (ELSE -1)>
+ .D1
+ <COND (.TT VECTOR) (ELSE UVECTOR)>>>>
+ <RET-TMP-AC .D2>
+ <DATTYP-FLUSH .D1>
+ <PUT .D1 ,DATTYP <COND (.TT VECTOR) (ELSE UVECTOR)>>
+ <TOACV .D1>
+ <PUT <SET AC <DATVAL .D1>> ,ACPROT T>
+ <MUNG-AC .AC .D1>
+ <SET EA <GETREG <>>>
+ <PUT .AC ,ACPROT <>>
+ <EMIT <INSTRUCTION `HLRE <ACSYM .EA> !<ADDR:VALUE .D1>>>
+ <EMIT <INSTRUCTION `SUBM <ACSYM .AC> <ADDRSYM .EA>>>
+ <COND (<G? .LN 1>
+ <EMIT <INSTRUCTION `HRLI <ACSYM .AC> (<ADDRSYM .AC>)>>
+ <EMIT <INSTRUCTION `ADDI
+ <ACSYM .AC>
+ <COND (.TT 2) (ELSE 1)>>>)
+ (.TT
+ <EMIT <INSTRUCTION `ADD <ACSYM .AC> '[<2 (2)>]>>
+ <EMIT <INSTRUCTION `JUMPGE <ACSYM .AC> .TG>>
+ <EMIT <INSTRUCTION `HRLI
+ <ACSYM .AC>
+ -2
+ (<ADDRSYM .AC>)>>)
+ (ELSE
+ <EMIT <INSTRUCTION `AOBJP <ACSYM .AC> .TG>>
+ <EMIT <INSTRUCTION `HRLI
+ <ACSYM .AC>
+ -1
+ (<ADDRSYM .AC>)>>)>
+ <EMIT <INSTRUCTION `BLT <ACSYM .AC> -1 (<ADDRSYM .EA>)>>
+ <LABEL:TAG .TG>
+ <RET-TMP-AC .D1>
+ T)>>
+
+<DEFINE NO-INTERFERE (N B) #DECL ((N) NODE (B) <LIST [REST SYMTAB]>)
+ <COND (<AND <==? <NODE-TYPE .N> ,LVAL-CODE>
+ <MEMQ <NODE-NAME .N> .B>>
+ <>)
+ (<MEMQ <NODE-TYPE .N> ,SNODES> T)
+ (<AND <==? <NODE-TYPE .N> ,COND-CODE>
+ <NOT <NO-INTERFERE <PREDIC .N> .B>>> <>)
+ (ELSE
+ <MAPF <>
+ <FUNCTION (N) #DECL ((N) NODE)
+ <COND (<NO-INTERFERE .N .B> T)
+ (ELSE <MAPLEAVE <>>)>> <KIDS .N>>)>>
+
+\\f
+
+<DEFINE GEN-TAGS (TGS SPECD)
+ #DECL ((TGS) LIST (MNOD) NODE)
+ <MAPR <>
+ <FUNCTION (LL "AUX" (L <1 .LL>) (TG <1 .L>) (OFF <2 .L>))
+ #DECL ((LL) <LIST LIST> (L) LIST (TG) ATOM (OFF) LIST)
+ <LABEL:TAG .TG>
+ <EMIT <INSTRUCTION DEALLOCATE .OFF>>
+ <COND
+ (<EMPTY? <REST .LL>>
+ <COND
+ (.SPECD
+ <COND (.PRE <UNBIND:FUNNY <SPECS-START <2 <KIDS .MNOD>>> !.NTSLOTS>)
+ (ELSE <EMIT '<`PUSHJ `P* |SSPECS >>)>)>)>>
+ .TGS>>
+
+<DEFINE MOPTG (SYM) #DECL ((SYM) SYMTAB) <BINDUP .SYM <INIT-SYM .SYM>>>
+
+<DEFINE MOPTG2 (SYM) #DECL ((SYM) SYMTAB) <BINDUP .SYM <REFERENCE:UNBOUND>>>
+
+<DEFINE NOTIMP (ARG) <MESSAGE ERROR "NOT IMPLEMENTED MAPF/R TUPLES">>
+
+<DEFINE MAPLEAVE-GEN (N W)
+ #DECL ((N) NODE (CD) DATUM (DEST) <OR DATUM ATOM>)
+ <COND (<ACTIVATED <2 <KIDS .MNOD>>>
+ <RET-TMP-AC <GEN <1 <KIDS .N>> .DEST>>
+ <VAR-STORE>
+ <PROG:END>)
+ (ELSE
+ <COND (<==? .DEST FLUSHED>
+ <RET-TMP-AC <GEN <1 <KIDS .N>> FLUSHED>>
+ <MAP:UNBIND .STOP .STOP>
+ <RETURN-UP .INRAP>)
+ (ELSE
+ <SET CD <GEN <1 <KIDS .N>> <DATUM !.DEST>>>
+ <MAP:UNBIND .STOP .STOP>
+ <RETURN-UP .INRAP>
+ <RET-TMP-AC .CD>
+ <ACFIX .DEST .CD>)>
+ <BRANCH:TAG .EXIT>)>
+ ,NO-DATUM>
+
+<DEFINE MAP:UNBIND (STOP STOP1)
+ #DECL ((MNOD) NODE)
+ <COND (.PRE
+ <POP:LOCS .STK .STOP1>
+ <UNBIND:FUNNY <SPECS-START <2 <KIDS .MNOD>>> !.NTSLOTS>)
+ (ELSE <UNBIND:LOCS .STK .STOP1>)>>
+
+\\f
+
+<DEFINE MAPRET-STOP-GEN (N W
+ "AUX" (STA <STACKS .N>) (SG <SEGS .N>) (DWN '(0))
+ (K <KIDS .N>) (LN <LENGTH .K>) (UNK <>) TEM DAT
+ (FAP <1 <KIDS .MNOD>>) FTG
+ (FF? <==? <NODE-TYPE .FAP> ,MFIRST-CODE>)
+ (LEAVE <==? <NODE-SUBR .N> ,MAPSTOP>) (OS .STK)
+ (FUZZY <* -2 .NARG>) (STK (0 !.STK)) AC-SY
+ (OOS .STK) (NS .NTSLOTS))
+ #DECL ((N) NODE (K) <LIST [REST NODE]> (LN FUZZY STA) FIX (DWN) LIST
+ (DAT) DATUM (STK) <SPECIAL LIST> (OS) LIST)
+ <COND
+ (<AND <NOT .SG> <L? .LN 2>>
+ <OR <0? .LN> <SET DAT <GEN <1 .K> <GOODACS <1 .K> DONT-CARE>>>>
+ <MAP:UNBIND .STB .STRV>
+ <COND
+ (<NOT <0? .LN>>
+ <COND (<AND .GMF .FF?>
+ <SET NTSLOTS <REST .NTSLOTS>>
+ <SET STK .STB>
+ <DO-EVEN-FUNNIER-HACK
+ .DAT
+ <1 <BINDING-STRUCTURE .INRAP>>
+ .MNOD
+ .FAP
+ .INRAP
+ <LOOP-VARS .INRAP>>)
+ (.FF? <DO-FUNNY-HACK .DAT (.FUZZY ()) .MNOD .FAP <1 .K>>)
+ (ELSE <DO-STACK-ARGS .MAYBE-FALSE .DAT>)>)>)
+ (.FF? <DO-FUNNY-MAPRET .N .FUZZY .K .FAP>)
+ (ELSE
+ <MAPF <>
+ <FUNCTION (NOD "AUX" TG)
+ #DECL ((NOD) NODE)
+ <COND (<==? <NODE-TYPE .NOD> ,SEGMENT-CODE>
+ <RET-TMP-AC <GEN <1 <KIDS .NOD>> <FUNCTION:VALUE>>>
+ <REGSTO T>
+ <COND (.MAYBE-FALSE
+ <SET TG <MAKE:TAG>>
+ <EMIT '<`SKIPGE -1 `(P) >>
+ <BRANCH:TAG .TG>)>
+ <SEGMENT:STACK </ .STA 2> .UNK>
+ <COND (<NOT .UNK>
+ <ADD:STACK <- .STA>>
+ <ADD:STACK PSTACK>
+ <SET UNK T>)>
+ <AND .MAYBE-FALSE <LABEL:TAG .TG>>)
+ (ELSE
+ <COND (.MAYBE-FALSE
+ <SET TG <MAKE:TAG>>
+ <EMIT '<`SKIPGE -1 `(P) >>
+ <BRANCH:TAG .TG>)>
+ <RET-TMP-AC <STACK:ARGUMENT <GEN .NOD DONT-CARE>>>
+ <ADD:STACK 2>
+ <AND .MAYBE-FALSE <LABEL:TAG .TG>>)>>
+ .K>
+ <COND (<OR <ACTIVATED <2 <KIDS .MNOD>>>
+ <NOT <SET TEM <STACK:L .OS .STRV>>>>
+ <MESSAGE ERROR " NOT IMLEMENTED HAIRY MAPRET/STOP " .N>)
+ (ELSE
+ <COND (.SPECD <UNBIND:FUNNY <SPECS-START <2 <KIDS .MNOD>>>>)>
+ <COND (.MAYBE-FALSE
+ <SET FTG <MAKE:TAG>>
+ <EMIT '<`SKIPGE -1 `(P) >>
+ <BRANCH:TAG .FTG>)>
+ <SET AC-SY <GETREG <>>>
+ <COND (.UNK <EMIT <INSTRUCTION `POP `P* <ADDRSYM .AC-SY>>>)
+ (ELSE <EMIT <INSTRUCTION `MOVEI <ACSYM .AC-SY> </ .STA 2>>>)>
+ <EMIT <INSTRUCTION `ADDM <ACSYM .AC-SY> `(P) >>
+ <COND (<NOT <=? <SET DWN .TEM> '(0)>>
+ <EMIT <INSTRUCTION `ASH <ACSYM .AC-SY> 1>>
+ <EMIT <INSTRUCTION `HRLI <ACSYM .AC-SY> (<ADDRSYM .AC-SY>)>>
+ <EMIT <INSTRUCTION `SUBM `TP* <ADDRSYM .AC-SY>>>
+ <EMIT <INSTRUCTION `HRLI
+ <ACSYM .AC-SY>
+ <FORM - !.DWN>
+ '`(A) >>
+ <EMIT <INSTRUCTION `BLT
+ <ACSYM .AC-SY>
+ <FORM - !.DWN>
+ '`(TP) >>
+ <EMIT <INSTRUCTION `SUB `TP* [<FORM !.DWN .DWN>]>>)>)>
+ <AND .MAYBE-FALSE <LABEL:TAG .FTG>>)>
+ <OR .PRE <AND .GMF .FF?> <PROG () <SET NTSLOTS <REST .NTSLOTS>> <SET STK .STB>>>
+ <COND (.ANY? <EMIT <INSTRUCTION `SETZM .POFF '`(P) >>)>
+ <COND (.LEAVE <RETURN-UP .INRAP>) (<AGAIN-UP .INRAP>)>
+ <SET STK .OOS>
+ <SET NTSLOTS .NS>
+ <BRANCH:TAG <COND (.LEAVE .APPLTAG) (.GMF .RTAG) (ELSE .MAPLP)>>
+ ,NO-DATUM>
+
+\\f
+
+<DEFINE DO-FUNNY-MAPRET (N OFFS K FAP "AUX" (NOFFS (.OFFS ())))
+ #DECL ((N FAP) NODE (K) <LIST [REST NODE]> (OFFS) FIX)
+ <SET NOFFS
+ <STFIXIT .NOFFS (<FORM - 0 !<STACK:L .STK .STB>>)>>
+ <MAPF <>
+ <FUNCTION (NN "AUX" TG1 TG2 TT DAT (ANY? <>))
+ #DECL ((NN) NODE (TG1 TG2) ATOM (DAT) DATUM (TT) ADDRESS:C)
+ <COND (<==? <NODE-TYPE .NN> ,SEG-CODE>
+ <SET ANY? <PUSH-STRUCS <KIDS .NN> <> <> () <>>>
+ <LABEL:TAG <SET TG1 <MAKE:TAG>>>
+ <SET DAT
+ <STACKM <1 <KIDS .NN>>
+ <DATUM <SET TT <ADDRESS:C -1 '`(TP) >> .TT>
+ <>
+ <SET TG2 <MAKE:TAG>>
+ 0>>
+ <DO-FUNNY-HACK .DAT <STFIXIT .NOFFS '(-2)> .MNOD .FAP .N>
+ <AND .ANY? <EMIT '<`SETZM `(P) >>>
+ <BRANCH:TAG .TG1>
+ <LABEL:TAG .TG2>
+ <AND .ANY? <EMIT '<`SUB `P* [<1 (1)>]>>>
+ <COND (<NOT <STRUCTYP <RESULT-TYPE <1 <KIDS .NN>>>>>
+ <EMIT '<`SETZM |DSTORE>>)>
+ <EMIT '<`SUB `TP* [<(2) 2>]>>)
+ (ELSE
+ <SET DAT <GEN .NN DONT-CARE>>
+ <VAR-STORE>
+ <DO-FUNNY-HACK .DAT .NOFFS .MNOD .FAP .NN>)>>
+ .K>
+ <MAP:UNBIND .STB .STRV>>
+
+
+\f
+<DEFINE AP? (N "AUX" AT)
+ #DECL ((N) NODE)
+ <AND <==? <NODE-TYPE .N> ,GVAL-CODE>
+ <==? <NODE-TYPE <SET N <1 <KIDS .N>>>> ,QUOTE-CODE>
+ <SET AT <NODE-NAME .N>>
+ <OR .REASONABLE
+ <AND <GASSIGNED? .AT> <TYPE? ,.AT SUBR RSUBR RSUBR-ENTRY>>
+ <AND <GASSIGNED? .AT>
+ <TYPE? ,.AT FUNCTION>
+ <OR <==? .AT .FCNS>
+ <AND <TYPE? .FCNS LIST> <MEMQ .AT .FCNS>>>>>
+ .AT>>
+
+<ENDPACKAGE>
--- /dev/null
+<PACKAGE "MAPPS1">
+
+<ENTRY PMAPF-R>
+
+<USE "PASS1" "CHKDCL" "COMPDEC" "ADVMESS">
+
+<DEFINE PMAPF-R (OB AP
+ "AUX" (NAME <1 .OB>) TT ITRF OBJ (RQRG 0)
+ (LN <LENGTH <SET OBJ <REST .OB>>>) FINALF TAPL (APL ())
+ (DCL #DECL ()) (ARGL ()) (HATOM <>) (NN 0) TEM L2 L3
+ (TRG 0))
+ #DECL ((OBJ OB) <PRIMTYPE LIST> (LN NN) FIX
+ (DCL) DECL (ARGL APL) LIST (ITRF FINALF TT) NODE
+ (TRG RQRG) <SPECIAL FIX>)
+ <PROG ()
+ <AND <SEG? <REST .OBJ>>
+ <COND (.VERBOSE
+ <VMESS "MAPF/MAPR cannot be open compiled due to SEGMENT."
+ .OB> T)(ELSE T)>
+ <RETURN <PSUBR-C .OB .AP>>>
+ <AND <L? .LN 2>
+ <MESSAGE ERROR "TOO FEW ARGS TO " .NAME .OBJ>>
+ <SET TT <NODEFM ,MAP-CODE .PARENT <> .NAME () .AP>>
+ <SET FINALF <PCOMP <1 .OBJ> .TT>>
+ <COND
+ (<OR <TYPE? <SET TAPL <2 .OBJ>> FUNCTION>
+ <AND <TYPE? .TAPL FORM>
+ <NOT <EMPTY? <SET APL <CHTYPE .TAPL LIST>>>>
+ <TYPE? <SET TEM <1 .APL>> ATOM>
+ <GASSIGNED? .TEM>
+ <==? ,.TEM ,FUNCTION>
+ <SET TAPL <REST .APL>>>>
+ <AND <EMPTY? <SET APL <CHTYPE .TAPL LIST>>>
+ <MESSAGE ERROR "EMPTY FUNCTION IN MAPF " .OBJ>>
+ <AND <TYPE? <1 .APL> ATOM>
+ <SET HATOM <1 .APL>>
+ <SET APL <REST .APL>>>
+ <AND <EMPTY? .APL>
+ <MESSAGE ERROR "MAPF FUNCTION HAS NO ARG LIST " .OBJ>>
+ <SET ARGL <1 .APL>>
+ <REPEAT ((I <+ <LENGTH <REST .OBJ 2>> 1>))
+ <COND (<L? <SET I <- .I 1>> 0> <RETURN>)>
+ <SET ARGL (DUMMY-MAPF !.ARGL)>>
+ <SET APL <REST .APL>>
+ <AND <NOT <EMPTY? .APL>>
+ <TYPE? <1 .APL> DECL>
+ <SET DCL <1 .APL>>
+ <SET APL <REST .APL>>>
+ <AND <EMPTY? .APL>
+ <MESSAGE ERROR "MAPF FUNCTION HAS NO BODY " .OBJ>>
+ <PROG ((VARTBL .VARTBL)) #DECL ((VARTBL) <SPECIAL SYMTAB>)
+ <SET ITRF
+ <NODEPR ,MFCN-CODE
+ .TT
+ <OR <FIND:DECL VALUE .DCL> ANY>
+ <>
+ ()
+ <>
+ <2 <GEN-D .ARGL .DCL .HATOM <>>>
+ .HATOM
+ .VARTBL>>
+ <COND
+ (<ACT-FIX .ITRF <BINDING-STRUCTURE .ITRF>>
+ <SET L3 <SET L2 ()>>
+ <PUT
+ .ITRF
+ ,BINDING-STRUCTURE
+ <REPEAT ((L <BINDING-STRUCTURE .ITRF>) (LL .L) (L1 .L) SYM)
+ #DECL ((L L1 LL) <LIST [REST SYMTAB]>)
+ <AND <EMPTY? .L> <RETURN .L1>>
+ <COND (<==? <CODE-SYM <SET SYM <1 .L>>> 1>
+ <SET L2 ("ACT" <NAME-SYM .SYM> !.L2)>
+ <SET L3
+ ((<NAME-SYM .SYM>)
+ <COND (<SPEC-SYM .SYM>
+ <FORM SPECIAL <1 <DECL-SYM .SYM>>>)
+ (ELSE
+ <FORM UNSPECIAL <1 <DECL-SYM .SYM>>>)>
+ !.L3)>
+ <COND (<==? .L .L1> <SET L1 <REST .L1>>)
+ (ELSE <PUTREST .LL <REST .L>>)>)>
+ <SET L <REST <SET LL .L>>>>>
+ <SET APL (<FORM PROG .L2 <CHTYPE .L3 DECL> !.APL>)>)>
+ <PUT .ITRF
+ ,KIDS
+ <MAPF ,LIST <FUNCTION (O) <PCOMP .O .ITRF>> .APL>>>)
+ (<OR <AND <TYPE? .TAPL FIX> <==? .LN 3>>
+ <AND <TYPE? .TAPL FORM>
+ <==? <LENGTH <SET APL <CHTYPE .TAPL LIST>>> 2>
+ <TYPE? <SET TEM <1 .APL>> ATOM>
+ <==? ,.TEM ,GVAL>
+ <TYPE? <SET TEM <2 .APL>> ATOM>
+ <GASSIGNED? .TEM>
+ <OR <NOT <TYPE? ,.TEM FUNCTION>>
+ <==? .TEM .FCNS>
+ <AND <TYPE? .FCNS LIST> <MEMQ .TEM .FCNS>>>>>
+ <PUT .IND PTHIS-OBJECT ,PMARGS>
+ <SET ITRF
+ <COND (<TYPE? .TAPL FIX> <PCOMP <FORM NTH .IND .TAPL> .TT>)
+ (ELSE
+ <PCOMP <FORM <2 .APL> !<ILIST <- .LN 2> '.IND>> .TT>)>>
+ <PUT .IND PTHIS-OBJECT>
+ <MAPF <>
+ <FUNCTION (N)
+ #DECL ((N) NODE)
+ <AND <==? <NODE-TYPE .N> ,MARGS-CODE>
+ <PUT .N ,NODE-NAME <SET NN <+ .NN 1>>>>>
+ <KIDS .ITRF>>
+ <SET ITRF <NODEFM ,MPSBR-CODE .TT <> <> (.ITRF) <>>>)
+ (ELSE <SET ITRF <PCOMP .TAPL .TT>>)>
+ <PUT .TT
+ ,KIDS
+ (.FINALF
+ .ITRF
+ !<MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> <REST .OBJ 2>>)>
+ .TT>>
+
+\\f
+
+<DEFINE PMARGS (O) #DECL ((VALUE) NODE) <NODEFM ,MARGS-CODE .PARENT <> <> () <>>>
+
+<PUT ,MAPF PAPPLY-OBJECT ,PMAPF-R>
+
+<PUT ,MAPR PAPPLY-OBJECT ,PMAPF-R>
+
+<ENDPACKAGE>
--- /dev/null
+<PACKAGE "MMQGEN">
+
+<ENTRY MEMQ-GEN>
+
+<USE "CODGEN" "COMCOD" "CACS" "CHKDCL" "COMPDEC">
+
+
+<DEFINE MEMQ-GEN (N W
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
+ "AUX" (STR <2 <KIDS .N>>) (THING <1 <KIDS .N>>)
+ (TYP <RESULT-TYPE .STR>) (TPS <STRUCTYP .TYP>)
+ (TYP1 <COND (<ISTYPE? .TYP>) (ELSE .TPS)>)
+ (FLS <==? .W FLUSHED>) (SDIR .DIR)
+ (TTYP <RESULT-TYPE .THING>) (TAC <>)
+ (ETY <GET-ELE-TYPE .TYP ALL>)
+ (TWIN <TYPESAME .ETY .TTYP>)
+ (B2
+ <COND (<AND .FLS .BRANCH> .BRANCH) (ELSE <MAKE:TAG>)>)
+ SAC NAC STRD NUMD DEAD (TWOW <>) TEM TY DAC DCOD
+ (B3 <MAKE:TAG>) (RW .W) (FC <0? <MINL .TYP>>)
+ (LP <MAKE:TAG>) B4 (DEADV <>))
+ #DECL ((N STR THING) NODE (STRD NUMD) DATUM (DAC SAC NAC) AC (DCOD) FIX
+ (TPS TYP1 B2 B3 B4) ATOM (DEAD) <PRIMTYPE LIST>
+ (NK FLS DIR SDIR NOTF BRANCH) <OR FALSE ATOM>)
+ <SET W <GOODACS .N .W>>
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <COND (<OR <==? .TPS STRING> <==? .TPS BYTES>> <SET TWOW T>)>
+ <SET TEM
+ <COND (<TYPE? .W DATUM> <GOODACS .N .W>)
+ (<AND .TWOW
+ <OR <AND <==? <NODE-TYPE .STR> ,LVAL-CODE>
+ <==? <LENGTH <SET DEAD <TYPE-INFO .STR>>> 2>
+ <NOT <2 .DEAD>>
+ <SET DEADV T>>
+ .FLS>>
+ DONT-CARE)
+ (.TWOW <DATUM ANY-AC ANY-AC>)
+ (ELSE <DATUM .TYP1 ANY-AC>)>>
+ <COND (<AND <NOT <SIDE-EFFECTS .N>>
+ <NOT <MEMQ <NODE-TYPE .STR> ,SNODES>>
+ <MEMQ <NODE-TYPE .THING> ,SNODES>>
+ <SET STRD <GEN .STR .TEM>>
+ <SET NUMD <GEN .THING DONT-CARE>>)
+ (ELSE
+ <SET NUMD
+ <GEN .THING
+ <COND (<AND <NOT <==? <NODE-TYPE .STR> ,QUOTE-CODE>>
+ <NOT .TWOW>
+ <SIDE-EFFECTS .STR>>
+ <GOODACS .THING <DATUM ANY-AC ANY-AC>>)
+ (ELSE DONT-CARE)>>>
+ <SET STRD <GEN .STR .TEM>>)>
+ <VAR-STORE <>>
+ <COND
+ (<NOT .TWIN>
+ <COND
+ (<SET TY <ISTYPE? .ETY>>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O !<ADDR:TYPE .NUMD>>>
+ <EMIT <INSTRUCTION `CAIE `O <FORM TYPE-CODE!-OP!-PACKAGE .TY>>>
+ <BRANCH:TAG <COND (.DIR .B3) (ELSE .B2)>>
+ <SET TWIN T>)
+ (<==? .TPS UVECTOR>
+ <EMIT <INSTRUCTION `HLRE
+ <ACSYM <SET SAC <GETREG <>>>>
+ !<ADDR:VALUE .STRD>>>
+ <PUT .SAC ,ACPROT T>
+ <TOACV .STRD>
+ <EMIT <INSTRUCTION `SUBM <ACSYM <DATVAL .STRD>> <ADDRSYM .SAC>>>
+ <PUT .SAC ,ACPROT <>>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE
+ <ACSYM .SAC>
+ (<ADDRSYM .SAC>)>>
+ <COND (<SET TEM <ISTYPE? .TTYP>>
+ <EMIT <INSTRUCTION `CAIE
+ <ACSYM .SAC>
+ <FORM TYPE-CODE!-OP!-PACKAGE .TEM>>>)
+ (ELSE
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O !<ADDR:TYPE .NUMD>>>
+ <EMIT <INSTRUCTION `CAIE `O (<ADDRSYM .SAC>)>>)>
+ <BRANCH:TAG <COND (.DIR .B3) (ELSE .B2)>>
+ <SET TWIN T>)>)>
+ <COND (<NOT .TWOW>
+ <TOACV .STRD>
+ <COND (<ISTYPE-GOOD? .TPS>
+ <DATTYP-FLUSH .STRD>
+ <PUT .STRD ,DATTYP .TPS>)>)>
+ <COND (<TYPE? <DATVAL .STRD> AC>
+ <PUT <SET SAC <DATVAL .STRD>> ,ACPROT T>)>
+ <COND (<NOT .TWOW>
+ <TOACV .NUMD>
+ <PUT <SET NAC <DATVAL .NUMD>> ,ACPROT T>)>
+ <COND (<ASSIGNED? SAC> <MUNG-AC .SAC .STRD>)>
+ <AND <TYPE? <DATTYP .STRD> AC>
+ <MUNG-AC <DATTYP .STRD> .STRD>>
+ <COND (<AND <NOT <ISTYPE? .TTYP>>
+ <NOT .TY>
+ <N==? .TPS UVECTOR>
+ <NOT .TWOW>>
+ <PUT <SET TAC <GETREG <>>> ,ACPROT T>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE
+ <ACSYM .TAC>
+ !<ADDR:TYPE .NUMD>>>)>
+ <COND (<ASSIGNED? SAC> <PUT .SAC ,ACPROT <>>)>
+ <COND (<NOT .TWOW> <PUT .NAC ,ACPROT <>>)>
+ <COND (<AND .BRANCH <NOT .FLS> .DIR <NOT .NOTF> <=? .W .STRD>>
+ <SET B2 .BRANCH>)>
+ <COND
+ (<==? .TPS LIST>
+ <COND (<G=? <SET DCOD <MIN <DEFERN .ETY> <DEFERN .TTYP>>> 1>
+ <SET DAC <GETREG <>>>)>
+ <COND (.FC
+ <EMIT <INSTRUCTION `JUMPE
+ <ACSYM .SAC>
+ <COND (.DIR .B3) (ELSE .B2)>>>)>
+ <LABEL:TAG .LP>
+ <COND (<0? .DCOD> <SET DAC .SAC>)
+ (<1? .DCOD>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .DAC> 1 (<ADDRSYM .SAC>)>>)
+ (ELSE
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O (<ADDRSYM .SAC>)>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .DAC> <ADDRSYM .SAC>>>
+ <EMIT '<`CAIN `O TDEFER!-OP!-PACKAGE>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .DAC> 1 (<ADDRSYM .DAC>)>>)>
+ <CHECK-VAL 1
+ .NAC
+ .DAC
+ .TAC
+ .TTYP
+ <COND (.DIR .B2) (ELSE .B3)>
+ .TWIN>
+ <EMIT <INSTRUCTION `HRRZ <ACSYM .SAC> (<ADDRSYM .SAC>)>>
+ <EMIT <INSTRUCTION `JUMPN <ACSYM .SAC> .LP>>)
+ (<==? .TPS UVECTOR>
+ <COND (.FC
+ <EMIT <INSTRUCTION `JUMPGE
+ <ACSYM .SAC>
+ <COND (.DIR .B3) (ELSE .B2)>>>)>
+ <LABEL:TAG .LP>
+ <CHECK-VAL 0
+ .NAC
+ .SAC
+ .TAC
+ .TTYP
+ <COND (.DIR .B2) (ELSE .B3)>
+ .TWIN>
+ <EMIT <INSTRUCTION `AOBJN <ACSYM .SAC> .LP>>)
+ (<NOT .TWOW>
+ <COND (.FC
+ <EMIT <INSTRUCTION `JUMPGE
+ <ACSYM .SAC>
+ <COND (.DIR .B3) (ELSE .B2)>>>)>
+ <LABEL:TAG .LP>
+ <CHECK-VAL 1
+ .NAC
+ .SAC
+ .TAC
+ .TTYP
+ <COND (.DIR .B2) (ELSE .B3)>
+ .TWIN>
+ <EMIT <INSTRUCTION `ADD <ACSYM .SAC> '[<2 (2)>]>>
+ <EMIT <INSTRUCTION `JUMPL <ACSYM .SAC> .LP>>)
+ (.FLS
+ <COND (<TYPE? <DATTYP .STRD> AC>
+ <COND (<AND <ACRESIDUE <SET SAC <DATTYP .STRD>>>
+ <G? <FREE-ACS T> 0>>
+ <EMIT <INSTRUCTION `MOVEI
+ <SET SAC <GETREG <>>>
+ (<ADDRSYM <DATTYP .STRD>>)>>)
+ (ELSE
+ <MUNG-AC .SAC .STRD>
+ <EMIT <INSTRUCTION `MOVEI <ACSYM .SAC> (<ADDRSYM .SAC>)>>)>)
+ (ELSE
+ <SET SAC <GETREG <>>>
+ <EMIT <INSTRUCTION `HRRZ <ACSYM .SAC> !<ADDR:TYPE .STRD>>>)>
+ <PUT .SAC ,ACPROT T>
+ <OR .DEADV
+ <TYPE? <DATVAL .STRD> TEMP>
+ <SET STRD <TOACV .STRD>>>
+ <PUT .SAC ,ACPROT <>>
+ <COND (.FC
+ <EMIT <INSTRUCTION `JUMPE
+ <ACSYM .SAC>
+ <COND (.DIR .B3) (ELSE .B2)>>>)>
+ <LABEL:TAG .LP>
+ <EMIT <INSTRUCTION `ILDB `O !<ADDR:VALUE .STRD>>>
+ <IMCHK (`CAMN `CAIN ) `O <DATVAL .NUMD>>
+ <BRANCH:TAG <COND (.DIR .B2) (ELSE .B3)>>
+ <EMIT <INSTRUCTION `SOJG <ACSYM .SAC> .LP>>)
+ (ELSE
+ <LABEL:TAG .LP>
+ <COND (<TYPE? <DATTYP .STRD> AC>
+ <EMIT <INSTRUCTION `TRNN <ACSYM <SET SAC <DATTYP .STRD>>> -1>>
+ <BRANCH:TAG <COND (.DIR .B3) (ELSE .B2)>>)
+ (ELSE
+ <EMIT <INSTRUCTION `HRRZ `O !<ADDR:TYPE .STRD>>>
+ <EMIT <INSTRUCTION `JUMPE `O <COND (.DIR .B3) (ELSE .B2)>>>)>
+ <EMIT <INSTRUCTION `MOVE `O !<ADDR:VALUE .STRD>>>
+ <EMIT '<`ILDB `O `O >>
+ <IMCHK '(`CAMN `CAIN ) `O <DATVAL .NUMD>>
+ <BRANCH:TAG <COND (.DIR .B2) (ELSE .B3)>>
+ <EMIT <INSTRUCTION `IBP !<ADDR:VALUE .STRD>>>
+ <COND (<TYPE? <DATTYP .STRD> AC>
+ <EMIT <INSTRUCTION `SOJA <ACSYM .SAC> .LP>>)
+ (ELSE
+ <EMIT <INSTRUCTION `SOS !<ADDR:TYPE .STRD>>>
+ <BRANCH:TAG .LP>)>)>
+ <AND .TAC <PUT .TAC ,ACPROT <>>>
+ <RET-TMP-AC .TAC>
+ <RET-TMP-AC .NUMD>
+ <COND (<AND .BRANCH .FLS>
+ <COND (<NOT .DIR> <BRANCH:TAG .B2> <LABEL:TAG .B3>)
+ (ELSE <LABEL:TAG .B3>)>
+ <RET-TMP-AC .STRD>)
+ (<OR .NOTF <NOT <==? <NOT .BRANCH> <NOT .DIR>>>>
+ <RET-TMP-AC .STRD>
+ <COND (<AND .NOTF .DIR> <BRANCH:TAG .B3>)>
+ <LABEL:TAG .B2>
+ <MOVE:ARG <REFERENCE .SDIR> .W>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B3>)
+ (ELSE
+ <COND (.BRANCH
+ <COND (<==? .B2 .BRANCH>
+ <LABEL:TAG .B3>
+ <SET W <MOVE:ARG .STRD .W>>)
+ (ELSE
+ <BRANCH:TAG .B3>
+ <LABEL:TAG .B2>
+ <SET W <MOVE:ARG .STRD .W>>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B3>)>)
+ (ELSE
+ <RET-TMP-AC .STRD>
+ <LABEL:TAG .B2>
+ <RET-TMP-AC <SET W <MOVE:ARG <REFERENCE <>> .W>>>
+ <COND (<TYPE? <DATTYP .STRD> AC>
+ <PUT <DATTYP .STRD> ,ACLINK (.STRD)>)>
+ <COND (<TYPE? <DATVAL .STRD> AC>
+ <PUT <DATVAL .STRD> ,ACLINK (.STRD)>)>
+ <COND (<=? .W .STRD>
+ <LABEL:TAG .B3>
+ <SET W <MOVE:ARG .STRD .W>>)
+ (ELSE
+ <BRANCH:TAG <SET B4 <MAKE:TAG>>>
+ <LABEL:TAG .B3>
+ <SET W <MOVE:ARG .STRD .W>>
+ <LABEL:TAG .B4>)>)>)>
+ <MOVE:ARG .W .RW>>
+
+<DEFINE CHECK-VAL (OFFS VAC SAC TAC TTYP BR TWIN)
+ #DECL ((OFFS) FIX (SAC VAC) AC (TAC) <OR AC FALSE>)
+ <COND (.TWIN
+ <EMIT <INSTRUCTION `CAMN <ACSYM .VAC> .OFFS (<ADDRSYM .SAC>)>>
+ <BRANCH:TAG .BR>)
+ (ELSE
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE
+ `O*
+ <- .OFFS 1>
+ (<ADDRSYM .SAC>)>>
+ <EMIT <INSTRUCTION
+ `CAIN
+ `O*
+ <COND (<SET TTYP <ISTYPE? .TTYP>>
+ <FORM TYPE-CODE!-OP!-PACKAGE .TTYP>)
+ (ELSE (<ADDRSYM .TAC>))>>>
+ <EMIT <INSTRUCTION `CAME <ACSYM .VAC> .OFFS (<ADDRSYM .SAC>)>>
+ <EMIT '<`SKIPA >>
+ <BRANCH:TAG .BR>)>>
+
+<ENDPACKAGE>
+\f\ 3\ 3
\ No newline at end of file
--- /dev/null
+<BLOAT 150000 5000 100 1500 100>
+<SET REDEFINE T>
+<RSUBR-LINK <>>
+<GC-MON T>
+
+<USE "MLOAD">
+
+<SETG DUMMY-FILE!-IMLOAD!-MLOAD!-PACKAGE "PS:<MDLLIB>DUMMY.NBIN">
+
+<SETG LOAD-GBINS? T>
+
+<USE "MCLEAN">
+
+<OR <LOOKUP "GLUE" <ROOT>>
+ <INSERT "GLUE" <ROOT>>>
+<SET GLUE T>
+
+<FLOAD "PS:<MDLLIB>ELMER.FBIN">
+<USE "GLUE">
+<SETG GLUE-MAX-SPACE T>
+
+<SETG L-SEARCH-PATH (["SRC:<MDL.COMP>"] !,L-SEARCH-PATH)>
+<FLOAD "SRC:<MDL.COMP>HELP.COMPIL">
+
+<GUNASSIGN L-LOADER>
+
+<MOBY-LOAD "SRC:<MDL.COMP>SYMANA.NBIN">
+
+
+<MOBY-CLEAN SYMANA <>>
+
+<USE "CLEAN" "PURITY">
+<CLEANUP>
+<FLUSH-CLEANUP>
+<KILL:PURITY>
+
+<SETG PKGS ("SYMANA" "CARANA" "MAPANA" "NOTANA" "STRANA" "BITANA"
+ "BACKAN" "ADVMESS")>
+
+<PRINT <GC 0 T>>
+<PRINT <GC 0 T>>
+
+<SETG SURVIVERS (SPEC-FLUSH!-ISYMANA!-SYMANA!-PACKAGE
+ TYPE-OK?!-CHKDCL!-PACKAGE
+SUBR-ANA!-ISYMANA!-SYMANA!-PACKAGE
+QUOTE-ANA!-ISYMANA!-SYMANA!-PACKAGE
+FUNC-ANA!-ISYMANA!-SYMANA!-PACKAGE
+SEGMENT-ANA!-ISYMANA!-SYMANA!-PACKAGE
+FORM-AN!-ISYMANA!-SYMANA!-PACKAGE
+PRG-REP-ANA!-ISYMANA!-SYMANA!-PACKAGE
+SUBR-ANA!-ISYMANA!-SYMANA!-PACKAGE
+COND-ANA!-ISYMANA!-SYMANA!-PACKAGE
+COPY-AN!-ISYMANA!-SYMANA!-PACKAGE
+RSUBR-ANA!-ISYMANA!-SYMANA!-PACKAGE
+ISTRUC-ANA!-ISYMANA!-SYMANA!-PACKAGE
+ISTRUC2-ANA!-ISYMANA!-SYMANA!-PACKAGE
+READ-ANA!-ISYMANA!-SYMANA!-PACKAGE
+READ2-ANA!-ISYMANA!-SYMANA!-PACKAGE
+GET-ANA!-ISYMANA!-SYMANA!-PACKAGE
+GET2-ANA!-ISYMANA!-SYMANA!-PACKAGE
+MAPPER-AN!-ISYMANA!-SYMANA!-PACKAGE
+MARGS-ANA!-ISYMANA!-SYMANA!-PACKAGE
+ARITH-ANA!-ISYMANA!-SYMANA!-PACKAGE
+ARITHP-ANA!-ISYMANA!-SYMANA!-PACKAGE
+ARITHP-ANA!-ISYMANA!-SYMANA!-PACKAGE
+ARITHP-ANA!-ISYMANA!-SYMANA!-PACKAGE
+ARITH-ANA!-ISYMANA!-SYMANA!-PACKAGE
+ABS-ANA!-ISYMANA!-SYMANA!-PACKAGE
+FIX-ANA!-ISYMANA!-SYMANA!-PACKAGE
+FLOAT-ANA!-ISYMANA!-SYMANA!-PACKAGE
+MOD-ANA!-ISYMANA!-SYMANA!-PACKAGE
+LENGTH-ANA!-ISYMANA!-SYMANA!-PACKAGE
+EMPTY?-ANA!-ISYMANA!-SYMANA!-PACKAGE
+NTH-ANA!-ISYMANA!-SYMANA!-PACKAGE
+REST-ANA!-ISYMANA!-SYMANA!-PACKAGE
+PUT-ANA!-ISYMANA!-SYMANA!-PACKAGE
+PUTREST-ANA!-ISYMANA!-SYMANA!-PACKAGE
+UNWIND-ANA!-ISYMANA!-SYMANA!-PACKAGE
+FORM-F-ANA!-ISYMANA!-SYMANA!-PACKAGE
+COPY-AN!-ISYMANA!-SYMANA!-PACKAGE
+BACK-ANA!-ISYMANA!-SYMANA!-PACKAGE
+TOP-ANA!-ISYMANA!-SYMANA!-PACKAGE
+SUBSTRUC-ANA!-ISYMANA!-SYMANA!-PACKAGE
+DEFAULT-GEN!-ICODGEN!-CODGEN!-PACKAGE
+FORM-GEN!-ICODGEN!-CODGEN!-PACKAGE
+PROG-REP-GEN!-ICODGEN!-CODGEN!-PACKAGE
+SUBR-GEN!-ICODGEN!-CODGEN!-PACKAGE
+COND-GEN!-ICODGEN!-CODGEN!-PACKAGE
+LVAL-GEN!-ICODGEN!-CODGEN!-PACKAGE
+SET-GEN!-ICODGEN!-CODGEN!-PACKAGE
+OR-GEN!-ICODGEN!-CODGEN!-PACKAGE
+AND-GEN!-ICODGEN!-CODGEN!-PACKAGE
+RETURN-GEN!-ICODGEN!-CODGEN!-PACKAGE
+COPY-GEN!-ICODGEN!-CODGEN!-PACKAGE
+AGAIN-GEN!-ICODGEN!-CODGEN!-PACKAGE
+GO-GEN!-ICODGEN!-CODGEN!-PACKAGE
+ARITH-GEN!-ICODGEN!-CODGEN!-PACKAGE
+RSUBR-GEN!-ICODGEN!-CODGEN!-PACKAGE
+0-TEST!-ICODGEN!-CODGEN!-PACKAGE
+NOT-GEN!-ICODGEN!-CODGEN!-PACKAGE
+1?-GEN!-ICODGEN!-CODGEN!-PACKAGE
+TEST-GEN!-ICODGEN!-CODGEN!-PACKAGE
+==-GEN!-ICODGEN!-CODGEN!-PACKAGE
+TYPE?-GEN!-ICODGEN!-CODGEN!-PACKAGE
+LNTH-GEN!-ICODGEN!-CODGEN!-PACKAGE
+MT-GEN!-ICODGEN!-CODGEN!-PACKAGE
+REST-GEN!-ICODGEN!-CODGEN!-PACKAGE
+NTH-GEN!-ICODGEN!-CODGEN!-PACKAGE
+PUT-GEN!-ICODGEN!-CODGEN!-PACKAGE
+PUTREST-GEN!-ICODGEN!-CODGEN!-PACKAGE
+FLVAL-GEN!-ICODGEN!-CODGEN!-PACKAGE
+FSET-GEN!-ICODGEN!-CODGEN!-PACKAGE
+FGVAL-GEN!-ICODGEN!-CODGEN!-PACKAGE
+FSETG-GEN!-ICODGEN!-CODGEN!-PACKAGE
+STACKFORM-GEN!-ICODGEN!-CODGEN!-PACKAGE
+MIN-MAX!-ICODGEN!-CODGEN!-PACKAGE
+CHTYPE-GEN!-ICODGEN!-CODGEN!-PACKAGE
+FIX-GEN!-ICODGEN!-CODGEN!-PACKAGE
+FLOAT-GEN!-ICODGEN!-CODGEN!-PACKAGE
+ABS-GEN!-ICODGEN!-CODGEN!-PACKAGE
+MOD-GEN!-ICODGEN!-CODGEN!-PACKAGE
+ID-GEN!-ICODGEN!-CODGEN!-PACKAGE
+ASSIGNED?-GEN!-ICODGEN!-CODGEN!-PACKAGE
+ISTRUC-GEN!-ICODGEN!-CODGEN!-PACKAGE
+ISTRUC-GEN!-ICODGEN!-CODGEN!-PACKAGE
+BITS-GEN!-ICODGEN!-CODGEN!-PACKAGE
+GETBITS-GEN!-ICODGEN!-CODGEN!-PACKAGE
+BITLOG-GEN!-ICODGEN!-CODGEN!-PACKAGE
+PUTBITS-GEN!-ICODGEN!-CODGEN!-PACKAGE
+ISUBR-GEN!-ICODGEN!-CODGEN!-PACKAGE
+ID-GEN!-ICODGEN!-CODGEN!-PACKAGE
+READ2-GEN!-ICODGEN!-CODGEN!-PACKAGE
+SUBR-GEN!-ICODGEN!-CODGEN!-PACKAGE
+IPUT-GEN!-ICODGEN!-CODGEN!-PACKAGE
+IREMAS-GEN!-ICODGEN!-CODGEN!-PACKAGE
+GET-GEN!-ICODGEN!-CODGEN!-PACKAGE
+GET2-GEN!-ICODGEN!-CODGEN!-PACKAGE
+IRSUBR-GEN!-ICODGEN!-CODGEN!-PACKAGE
+MAPFR-GEN!-ICODGEN!-CODGEN!-PACKAGE
+MPARGS-GEN!-ICODGEN!-CODGEN!-PACKAGE
+MAPLEAVE-GEN!-ICODGEN!-CODGEN!-PACKAGE
+MAPRET-STOP-GEN!-ICODGEN!-CODGEN!-PACKAGE
+UNWIND-GEN!-ICODGEN!-CODGEN!-PACKAGE
+GVAL-GEN!-ICODGEN!-CODGEN!-PACKAGE
+SETG-GEN!-ICODGEN!-CODGEN!-PACKAGE
+TAG-GEN!-ICODGEN!-CODGEN!-PACKAGE
+PRINT-GEN!-ICODGEN!-CODGEN!-PACKAGE
+MEMQ-GEN!-ICODGEN!-CODGEN!-PACKAGE
+LENGTH?-GEN!-ICODGEN!-CODGEN!-PACKAGE
+FORM-F-GEN!-ICODGEN!-CODGEN!-PACKAGE
+INFO-GEN!-ICODGEN!-CODGEN!-PACKAGE
+OBLIST?-GEN!-ICODGEN!-CODGEN!-PACKAGE
+AS-NXT-GEN!-ICODGEN!-CODGEN!-PACKAGE
+ASSOC-FIELD-GET!-ICODGEN!-CODGEN!-PACKAGE
+ALL-REST-GEN!-ICODGEN!-CODGEN!-PACKAGE
+LIST-BUILD!-ICODGEN!-CODGEN!-PACKAGE
+SPEC-PUT-GEN!-ICODGEN!-CODGEN!-PACKAGE
+BACK-GEN!-ICODGEN!-CODGEN!-PACKAGE
+TOP-GEN!-ICODGEN!-CODGEN!-PACKAGE
+SUBSTRUC-GEN!-ICODGEN!-CODGEN!-PACKAGE
+ROT-GEN!-ICODGEN!-CODGEN!-PACKAGE
+LSH-GEN!-ICODGEN!-CODGEN!-PACKAGE
+BIT-TEST-GEN!-ICODGEN!-CODGEN!-PACKAGE
+ENTROPY!-SYMANA!-PACKAGE
+NORM-BAN!-SYMANA!-PACKAGE
+NAUX-BAN!-SYMANA!-PACKAGE
+TUP-BAN!-SYMANA!-PACKAGE
+ARGS-BAN!-SYMANA!-PACKAGE
+MENTROPY!-MAPANA!-PACKAGE
+MAUX!-MAPANA!-PACKAGE
+MAUX1!-MAPANA!-PACKAGE
+MTUPLE!-MAPANA!-PACKAGE
+MBAD!-MAPANA!-PACKAGE
+MOPT!-MAPANA!-PACKAGE
+MOPT2!-MAPANA!-PACKAGE
+MNORM!-MAPANA!-PACKAGE
+)>
+
+
+<REPEAT ((A <ASSOCIATIONS>) RSB)
+ <COND (<==? <INDICATOR .A> ANALYSIS!-SYMANA!-PACKAGE>
+ <COND (<TYPE? <SET RSB <AVALUE .A>> RSUBR RSUBR-ENTRY>
+ <COND (<NOT <MEMQ <3 .RSB> ,SURVIVERS>>
+ <SETG SURVIVERS (<3 .RSB> !,SURVIVERS)>)>)>)>
+ <OR <SET A <NEXT .A>> <RETURN>>>
+
+
+
+<GROUP-GLUE SYMANA
+ <>
+ .OUTCHAN
+ ,PKGS
+ ,SURVIVERS>
+
+<MOBY-CLEAN SYMANA>
+
--- /dev/null
+
+<FLOAD "PS:<COMPIL>MUDREF.NBIN">
+
+<DEFINE BEGIN-MHACK ()
+ <SET READ-TABLE <SETG READ-TABLE
+ <COND (<GASSIGNED? READ-TABLE> ,READ-TABLE)
+ (ELSE <IVECTOR 128 0>)>>>
+ <PUT .READ-TABLE <+ <ASCII !"|> 1> ,MUDREFIN>
+ <PRINTTYPE MUDREF!-OP ,OUTPUT-MUDREF>
+ T>
+
+<DEFINE END-MHACK ()
+ <PUT ,READ-TABLE <+ <ASCII !"|> 1> 0>
+ <PRINTTYPE MUDREF!-OP ,PRINT>
+ T>
+
+ \f
\ No newline at end of file
--- /dev/null
+
+ <NEWTYPE MUDREF!-OP WORD>
+
+
+ <TITLE MUDREFIN>
+ <DECLARE ("VALUE" MUDREF!-OP CHARACTER)>
+ <PUSH TP* (AB)>
+ <PUSH TP* 1(AB)>
+ <PUSHJ P* MUDR1>
+ <JRST FINIS>
+
+ <INTERNAL-ENTRY MUDR1 1>
+ <SUBM M* (P)>
+ <SUB TP* [<2 (2)>]> ; "CLEAN OFF USELESS ARGUMENT"
+ <PUSH P* [0]> ; "NUMBER OF ARGUMENTS TO STRING"
+ <MOVSI A* <TYPE-CODE ATOM>> ; "GET CHANNEL AND PUSH IT"
+ <MOVE B* <MQUOTE INCHAN>>
+ <PUSHJ P* CILVAL>
+ <PUSH TP* A>
+ <PUSH TP* B>
+ <PUSH P* [0]>
+LP1 <MOVE A* -1(TP)>
+ <MOVE B* (TP)>
+ <PUSHJ P* CNXTC1>
+ <CAIE B* <ASCII !"$>>
+ <CAIN B* <ASCII !".>>
+ <JRST LP3>
+ <CAIN B* <ASCII !"%>>
+ <JRST LP3>
+ <CAIG B* *132*> ; "Between 0 and Z?"
+ <CAIGE B* *57*>
+ <JRST LP2>
+ <CAILE B* *71*> ; "Skip if digit."
+ <CAILE B* *100*> ; "Skip if an upper case letter."
+LP3 <SKIPA B* (TP)> ; "GET BACK CHANNEL"
+ <JRST LP2>
+ <PUSHJ P* CREDC1>
+ <MOVE A* (P)>
+ <TLNE A* *770000*>
+ <JRST LP1>
+ <LSH A* 6>
+ <SUBI B* *40*>
+ <DPB B* [<(*000600* ) A>]>
+ <MOVEM A* (P)>
+ <JRST LP1>
+LP2
+ISYM <MOVSI C* (<CHTYPE <* *50* *50* *50* *50* *50* *50*> OPCODE>)>
+ <MOVEI B* 0>
+ <MOVE E* [<(*440600*) (P)>]>
+
+ISYM0 <ILDB A* E>
+ <JUMPE A* ISYM0>
+ <SUBI A* <- <ASCII !"0> 33>>
+ <CAIL A* <- <ASCII !"A> <ASCII !"0> -1>>
+ <SUBI A* <- <ASCII !"A> <ASCII !"0> *12*>>
+ <JUMPGE A* ISYM2>
+ <ADDI A* *61*>
+ <CAIN A* *60*>
+ <MOVEI A* *45*>
+ISYM2 <IDIVI C* *50*>
+ <IMUL A* C>
+ <ADDM A* B>
+ <TLNE E* *770000*>
+ <JRST ISYM0>
+
+ISYM3 <MOVSI A* <TYPE-CODE MUDREF!-OP >>
+ <SUB P* [<2 (2)>]>
+ <JRST MPOPJ>
+
+
+
+ <SUB-ENTRY OUTPUT-MUDREF ("VALUE" ANY MUDREF!-OP )>
+ <PUSH TP* (AB)>
+ <PUSH TP* 1 (AB)>
+ <PUSHJ P* IOUT>
+ <JRST FINIS>
+
+ <INTERNAL-ENTRY IOUT 1>
+ <SUBM M* (P)>
+ <MOVSI A* <TYPE-CODE ATOM>>
+ <MOVE B* <MQUOTE OUTCHAN>>
+ <PUSHJ P* CILVAL>
+ <PUSH TP* A>
+ <PUSH TP* B>
+ <GETYP E* A>
+ <CAIE E* <TYPE-CODE CHANNEL>>
+ <JRST STARTP>
+ <MOVE E* 27 (B)>
+ <ADDI E* 7>
+ <CAMGE E* 25 (B)>
+ <JRST STARTP>
+ <MOVEI D* 13> ; "Carriage ret lf first"
+ <PUSHJ P* CPCH>
+ <MOVEI D* 10>
+ <MOVSI A* <TYPE-CODE CHANNEL>>
+ <MOVE B* (TP)>
+ <PUSHJ P* CPCH>
+ <MOVSI A* <TYPE-CODE CHANNEL>>
+ <MOVE B* (TP)>
+
+STARTP <MOVEI D* <ASCII !"|>>
+ <PUSHJ P* CPCH>
+LPS <MOVE D* -2 (TP)>
+ <PUSHJ P* SPT1>
+ <POP TP* B>
+ <POP TP* A>
+ <MOVEI D* <ASCII !" >>
+ <PUSHJ P* CPCH>
+LEAVE <SUB TP* [<2 (2)>]>
+ <JRST MPOPJ>
+
+SPT1 <SUBM M* (P)>
+SPT2 <IDIVI D* *50*>
+ <HRLM E* (P)>
+ <JUMPE D* SPT3>
+ <JUMPE E* SPT2>
+ <PUSHJ P* SPT1>
+SPT3 <HLRE D* (P)>
+ <ADDI D* <- <ASCII !"0> 1>>
+ <CAILE D* <ASCII !"9>>
+ <ADDI D* <- <ASCII !"A> <ASCII !"9> 1>>
+ <CAILE D* <ASCII !"Z>>
+ <SUBI D* <- <ASCII !"Z> <ASCII !"#> -1>>
+ <CAIN D* <ASCII !"#>>
+ <MOVEI D* <ASCII !".>>
+ <CAIN D* <ASCII !"/>>
+SPC <MOVEI D* *40*>
+ <MOVE A* -1 (TP)>
+ <MOVE B* (TP)>
+ <PUSHJ P* CPCH>
+ <HRROS (P)>
+ <JRST MPOPJ>
+
+
+\f\ 3\ 3
\ No newline at end of file
--- /dev/null
+
+<PACKAGE "FCOMPIL">
+
+<BLOCK (<ROOT>)>
+
+COMPILE
+
+STATUS
+
+<ENDBLOCK>
+
+<ENTRY
+PACKAGE-MODE
+SURVIVORS
+CAREFUL
+REDO
+SOURCE
+GROUP-MODE
+NILOBL
+FAST-OUT
+PRECOMPILED
+TEMPNAME
+EXCLUSIVE
+DISOWN
+MAX-SPACE
+MACRO-COMPILE
+MACRO-FLUSH
+DESTROY
+ERROR-LOGOUT
+FCOMP
+FILE-COMPILE>
+
+<USE "COMPDEC">
+
+<DEFINE MODES-INIT ()
+ <SET DEBUG-COMPILE <>>
+ <SET PACKAGE-MODE <>>
+ <SET SURVIVORS <>>
+ <SET REASONABLE T>
+ <SET GLUE T>
+ <SET CAREFUL T>
+ <SET REDO ()>
+ <SET SPECIAL <>>
+ <SET SOURCE <>>
+ <SET GROUP-MODE <>>
+ <SET NILOBL <>>
+ <SET FAST-OUT T>
+ <SET EXPFLOAD <>>
+ <UNASSIGN PRECOMPILED>
+ <UNASSIGN TEMPNAME>
+ <GUNASSIGN EXCLUSIVE>
+ <SET DISOWN T>
+ <SET MAX-SPACE <>>
+ <SET HAIRY-ANALYSIS T>
+ <SET MACRO-COMPILE <>>
+ <SET MACRO-FLUSH <>>
+ <SET DESTROY T>
+ <SET ERROR-LOGOUT T>>
+
+
+
+<FLOAD "COMFIL.MUD">
+
+<MODES-INIT>
+<ENDPACKAGE>
\ No newline at end of file
--- /dev/null
+
+ <TITLE NEWCOMP>
+
+ <PSEUDO <SETG *SSNAM *400016*>>
+ <PSEUDO <SETG *RSNAM *16*>>
+
+ <SETZB A* B>
+ <*SETM2 A*>
+ <MOVE A* [<*CLOSE >]>
+ <MOVEI O* *20*>
+
+LP <XCT A>
+ <ADD A* [<A*>]>
+ <SOJN O* LP>
+ <*SUSET [<(*RSNAM)A>]>
+ <MOVE B* [<SIXBIT "SYS1">]>
+ <*SUSET [<(*SSNAM)B>]>
+ <*OPEN A* MUDOPN>
+ <*VALUE>
+SELFLD <*SUSET [<(*SSNAM)A>]>
+ <MOVSI P* STUFF>
+ <BLT P* P>
+ <JRST 1>
+
+MUDOPN <SIXBIT " $DSK">
+ <SIXBIT "TS ">
+ <SIXBIT "NPCOMP">
+
+STUFF <SIXBIT "NCOMP ">
+ <*CORE 1>
+ <*VALUE>
+ <*CALL *10*>
+ <*VALUE >
+ <*IOT A* A>
+ <*CLOSE A*>
+ <JRST @ A>
+
+ <SETZ>
+ <SIXBIT "LOAD">
+ <(*1000*) *777777*>
+ <SETZI 1>
+
+\f\ 3\ 3
\ No newline at end of file
--- /dev/null
+;"Define symbolic opcodes"
+
+<PACKAGE "OP" "IOP" 199 5>
+
+<BLOCK (<GET OP!-PACKAGE!- OBLIST>)>
+
+<NEWTYPE!- MUDREF WORD!->
+<NEWTYPE!- ADDRESS WORD!->
+<NEWTYPE!- OPCODE WORD!->
+
+<SETG!- MCALL* #OPCODE *2000000000*> ;"Define UUO's"
+<SETG!- ACALL* #OPCODE *3000000000*>
+
+
+
+;"Assembler psuedo-ops; defined in the assembler (CODING)"
+PSEUDO MQUOTE DECLARE SUB-ENTRY GETYP MCALL ACALL TYPE-CODE
+*INSERT SYMDEF TYPE-WORD ENTER INTGO VARIABLE ADDR HERE
+
+
+
+
+\f<ENDBLOCK!->
+
+
+
+\f;"Define ac's"
+
+
+
+"Set up MUDDLE oblist:
+ Global symbols are, in general, internal MUDDLE addresses;
+ therefore they need to be 'fixed up' upon every loading"
+
+
+
+<COND (<LOOKUP "TTP" <GET MUDDLE OBLIST>>
+ <INSERT <REMOVE "TTP" <GET MUDDLE OBLIST>> <GET OP!-PACKAGE OBLIST>>
+ <INSERT <REMOVE "TDEFER" <GET MUDDLE OBLIST>> <GET OP!-PACKAGE OBLIST>>)>
+
+<MAPF <> <FUNCTION (L) <MAPF <> ,REMOVE .L> > <1 .OBLIST>>
+<PUT IOP!-OP!-PACKAGE!- OBLIST>
+<PUT <1 .OBLIST> OBLIST>
+<ENDPACKAGE>
+
+
+
+\f\ 3\ 3
\ No newline at end of file
--- /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
--- /dev/null
+<NEWTYPE TOKEN VECTOR>
+
+<PUT SYMBOL DECL '<OR SYMTAB COMMON TEMP>>
+
+<REMOVE MUDREF!-OP!-PACKAGE>
+
+<NEWTYPE COMMON VECTOR '<VECTOR [4 ANY]>>
+
+<NEWTYPE MUDREF!-OP!-PACKAGE WORD>
+
+<SET REASONABLE T>
+<SET HELP-COMPIL T>
+<NEWTYPE SAVED-STATE
+ LIST
+ '<LIST [REST
+ <LIST AC
+ <OR FALSE <LIST [REST SYMTAB]>>
+ [REST <LIST SYMTAB ANY>]>]>>
+
+<NEWTYPE TEMPV LIST>
+
+
+<OR <GASSIGNED? DISPATCH> <DEFINE DISPATCH ("ARGS" FOO) []>>
+<SET GLUE!- T>
+
+<SETG IF!- ,AND>
+<SETG TEMPLATE-NTH T>
+<SETG TEMPLATE-PUT T>
+<SETG IF-NOT!- ,OR>
+<BLOCK (!.OBLIST <GET PACKAGE OBLIST>)>
+<FLOAD "CMP:BOPHAC">
+<FLOAD "CMP:MUDHAK">
+<BEGIN-HACK "COMPIL">
+<BEGIN-MHACK>
+<FLOAD "CMP:NN">
+\f
\ No newline at end of file
--- /dev/null
+
+<SET REASONABLE!- T>
+
+<SETG INSTRUCTION ,FORM>
+
+<NEWTYPE TRANS
+ VECTOR
+ '<<PRIMTYPE VECTOR> NODE
+ <UVECTOR [7 FIX]>
+ <UVECTOR [7 FIX]>>>
+<NEWTYPE IRSUBR LIST>
+
+<NEWTYPE NODE
+ VECTOR
+ '<VECTOR FIX
+ ANY
+ ANY
+ ANY
+ <LIST [REST NODE]>
+ FIX
+ <OR FALSE ATOM>
+ [REST
+ LIST
+ ANY
+ ANY
+ LIST
+ FIX
+ SYMTAB
+ FIX
+ FIX
+ <OR FALSE ATOM>
+ ATOM
+ ANY
+ LIST
+ LIST
+ ANY
+ ANY
+ ANY
+ ANY
+ ANY
+ ANY
+ ANY
+ <PRIMTYPE LIST>
+ FIX
+ FIX]>>
+
+"Offsets into pass 1 structure entities and functions to create same."
+
+<SETG NODE-TYPE 1> ; "Code specifying the node type."
+<SETG PARENT 2> ; "Pointer to parent node."
+<SETG RESULT-TYPE 3> ; "Type expression for result returned by code
+ generated by this node."
+<SETG NODE-NAME 4> ; "Usually name of SUBR associated with this node."
+<SETG KIDS 5> ; "List of sub-nodes for this node."
+<SETG STACKS 6> ; "Amount of stack needed by this node."
+<SETG SEGS 7> ; "Predicate: any segments among kids?"
+<SETG TYPE-INFO 8> ; "Points to transient type info for this node."
+<SETG SIDE-EFFECTS 9> ; "General info about side effects (format not yet firm.)"
+<SETG RSUBR-DECLS 10> ; "Function only: final rsubr decls."
+<SETG BINDING-STRUCTURE 11>
+ ; "Partially compiled arg list."
+<SETG SPECS-START 12> ; "Offset to 1st special."
+<SETG SYMTAB 13> ; "Pointer to local symbol table."
+<SETG SSLOTS 14> ; "Number of specials."
+<SETG USLOTS 15> ; "Number of unspecials."
+<SETG ACTIVATED 16> ; "Predicate: any named activation?"
+<SETG TMPLS 17> ; "Offset to unamed temps."
+<SETG PRE-ALLOC 18> ; "Variable slots allocated in advance."
+<SETG STK-B 19> ; "Base of stack at entry."
+<SETG BTP-B 20> ; "Base of stack after bindings."
+<SETG SPCS-X 21> ; "Predicate: any specials bound?"
+<SETG DST 22> ; "Destination spec for value of node."
+<SETG CDST 23> ; "Current destination used."
+<SETG ATAG 24> ; "Label for local againing."
+<SETG RTAG 25> ; "Label for local Returning."
+<SETG ASSUM 26> ; "Node type assumptions."
+<SETG AGND 27> ; "Predicate: Again possible?"
+<SETG ACS 28> ; "Predicate: AC call possible? (if not false
+ ac structure)"
+<SETG TOTARGS 29> ; "Total number of args (including optional)."
+<SETG REQARGS 30> ; "Required arguemnts."
+
+<SETG CLAUSES ,KIDS> ; "For COND clauses."
+
+<SETG NODE-SUBR ,RSUBR-DECLS>
+ ; "For many nodes, the SUBR (not its name)."
+
+<SETG PREDIC ,NODE-NAME>; "For cond clause nodes, the predicate."
+
+<SETG ACCUM-TYPE ,DST> ; "Accumulated type from all returns etc."
+<SETG DEAD-VARS ,CDST>
+<SETG LIVE-VARS ,TYPE-INFO>
+<SETG VSPCD ,ATAG>
+<SETG INIT-DECL-TYPE ,RTAG>
+<SETG LOOP-VARS 31>
+
+"Variables kept in acs thru loop."
+
+<SETG AGAIN-STATES 32>
+
+"States at agains"
+
+<SETG RETURN-STATES 33>
+
+"States at repeats."
+
+<SETG PROG-VARS 34>
+
+"Vars handled in this prog/repeat."
+
+;"Information used for merging states with prog-nodes"
+<SETG USAGE-SYM 19>
+
+"How a variable is used in a loop."
+
+<NEWTYPE SYMTAB
+ VECTOR
+ '<VECTOR <PRIMTYPE VECTOR>
+ ATOM
+ <OR FALSE ATOM>
+ FIX
+ <OR ATOM FIX>
+ <OR FALSE ATOM>
+ LIST
+ ANY
+ ANY
+ FIX
+ <OR FALSE NODE>
+ <OR FALSE 'T>
+ <OR FALSE DATUM LIST>
+ <OR FALSE 'T>
+ <OR FALSE 'T>
+ LIST
+ ANY
+ ANY>>
+
+
+<SETG NEXT-SYM 1> ; "Pointer to next symbol table entry."
+<SETG NAME-SYM 2> ; "Name of variable."
+<SETG SPEC-SYM 3> ; "Predicate: special?"
+<SETG CODE-SYM 4> ; "Code specifying whether AUX, OPTIONAL etc."
+<SETG ARGNUM-SYM 5> ; "If an argument, which one."
+<SETG PURE-SYM 6> ; "Predicate: unchanged in function?"
+<SETG DECL-SYM 7> ; "Decl for this variable."
+<SETG ADDR-SYM 8> ; "Where do I live?"
+<SETG INIT-SYM 9> ; "Predicate: initial value? if so what."
+<SETG FRMNO 10> ; "ID of my frame."
+<SETG RET-AGAIN-ONLY 11>; "Predicate: used only in AGAIN/RETURN?"
+<SETG ASS? 12> ; "Predicate: used in ASSIGNED?"
+<SETG INACS 13> ; "Predicate: currently in some AC?"
+<SETG STORED 14> ; "Predicate: stored in slot?"
+<SETG USED-AT-ALL 15>
+<SETG DEATH-LIST 16>
+<SETG CURRENT-TYPE 17>
+<SETG COMPOSIT-TYPE 18>
+<SETG PROG-AC ,CURRENT-TYPE>
+
+<SETG NUM-SYM ,COMPOSIT-TYPE>
+
+<SETG POTLV ,USED-AT-ALL>
+
+
+<SETG GNEXT-SYM 1> ; "Next global symbol."
+<SETG GNAME-SYM 2>
+<SETG GDECL-SYM 3>
+
+<PUT CHANNEL DECL '<CHANNEL [12 ANY] [4 FIX]>>
+
+<PUT STRING DECL '<STRING [REST CHARACTER]>>
+
+<PUT OBLIST DECL '<UVECTOR [REST <LIST [REST ATOM]>]>>
+
+<PROG ((N 1)) <SETG CODVEC <MAPF ,UVECTOR <FUNCTION (ATM) <SETG .ATM .N> <SET N
+<+ .N 1>> .ATM> ![FUNCTION-CODE QUOTE-CODE SEGMENT-CODE FORM-CODE PROG-CODE
+SUBR-CODE COND-CODE BRANCH-CODE RSUBR-CODE LVAL-CODE SET-CODE OR-CODE AND-CODE
+RETURN-CODE COPY-CODE GO-CODE AGAIN-CODE ARITH-CODE 0-TST-CODE NOT-CODE 1?-CODE
+TEST-CODE EQ-CODE TY?-CODE LNTH-CODE MT-CODE NTH-CODE REST-CODE PUT-CODE
+PUTR-CODE FLVAL-CODE FSET-CODE FGVAL-CODE FSETG-CODE MIN-MAX-CODE STACKFORM-CODE
+CHTYPE-CODE ABS-CODE FIX-CODE FLOAT-CODE MOD-CODE ID-CODE ASSIGNED?-CODE
+ISTRUC-CODE ISTRUC2-CODE BITS-CODE BITL-CODE GETBITS-CODE PUTBITS-CODE MAP-CODE
+MFCN-CODE ISUBR-CODE READ-EOF-CODE READ-EOF2-CODE EOF-CODE GET-CODE GET2-CODE
+IPUT-CODE IREMAS-CODE IRSUBR-CODE MARGS-CODE MPSBR-CODE MAPLEAVE-CODE
+MAPRET-STOP-CODE UNWIND-CODE GVAL-CODE SETG-CODE SEG-CODE LENGTH?-CODE TAG-CODE
+MFIRST-CODE PRINT-CODE MEMQ-CODE FORM-F-CODE INFO-CODE
+OBLIST?-CODE AS-NXT-CODE AS-IT-IND-VAL-CODE
+ ALL-REST-CODE
+ CASE-CODE SUBSTRUC-CODE BACK-CODE TOP-CODE COPY-LIST-CODE
+ PUT-SAME-CODE ROT-CODE LSH-CODE BIT-TEST-CODE SPARE1-CODE
+ SPARE2-CODE
+ SPARE3-CODE
+ SPARE4-CODE!]>> <SETG COMP-TYPES .N>>
+
+<SETG PREDV <IUVECTOR ,COMP-TYPES 0>>
+
+<MAPF <> <FUNCTION (N) <PUT ,PREDV .N 1>> ![,0-TST-CODE ,1?-CODE ,NOT-CODE ,
+TEST-CODE ,EQ-CODE ,TY?-CODE ,MT-CODE ,OR-CODE ,AND-CODE ,ASSIGNED?-CODE ,
+ISUBR-CODE ,NTH-CODE ,MEMQ-CODE ,LENGTH?-CODE ,OBLIST?-CODE ,AS-NXT-CODE!]>
+
+<GDECL (REGS ATIME) FIX (ALLACS) <UVECTOR [5 AC] [REST AC]>
+ (ACO AC-A AC-B AC-C AC-D AC-E AC-F AC-G AC-H LAST-AC LAST-AC-1) AC>
+
+<SETG COMMON-DATUM 5>
+
+<MANIFEST TMPFRM TMPNO THOME TUSERS DATTYP DATVAL ADDRSYM ACSYM ACLINK ACAGE
+ ACNUM ACPROT AC1SYM ACRESIDUE ACPREF ACINUSE TMPAC COMMON-DATUM
+ POTLV>
+
+<MAPF <> ,MANIFEST ,CODVEC>
+
+<MANIFEST TOT-MODES RESTS RMODES COMP-TYPES
+GDECL-SYM GNAME-SYM GNEXT-SYM FRMNO INIT-SYM ADDR-SYM TOTARGS REQARGS
+DECL-SYM PURE-SYM ARGNUM-SYM CODE-SYM SPEC-SYM NAME-SYM NEXT-SYM PREDIC
+NODE-SUBR CLAUSES ACS TMPLS ACTIVATED USLOTS SSLOTS SYMTAB SPECS-START
+BINDING-STRUCTURE RSUBR-DECLS SEGS STACKS KIDS NODE-NAME RESULT-TYPE PARENT
+NODE-TYPE SIDE-EFFECTS RET-AGAIN-ONLY ASS? INACS STORED DST CDST ACCUM-TYPE
+INIT-DECL-TYPE VSPCD AGND ASSUM RTAG ATAG SPCS-X BTP-B STK-B PRE-ALLOC
+USED-AT-ALL CURRENT-TYPE DEATH-LIST COMPOSIT-TYPE AGAIN-STATES RETURN-STATES
+PROG-VARS LOOP-VARS PROG-AC NUM-SYM TYPE-INFO USAGE-SYM LIVE-VARS
+DEAD-VARS>
+
+<GDECL (DOITS) <UVECTOR [9 ANY]> (RDOIT SDOIT) <UVECTOR [7 ANY]>
+ (BANALS) <UVECTOR [13 ANY]> (ANALYZERS) VECTOR
+ (BINDERS) UVECTOR (GENERATORS) VECTOR>
+
+
+
+
+
+
+<SETG DATTYP 1>
+
+<SETG DATVAL 2>
+
+
+<NEWTYPE TEMP VECTOR '<VECTOR SCL FIX>>
+
+<NEWTYPE SAVED-STATE
+ LIST
+ '<LIST [REST
+ <LIST AC
+ <OR FALSE <LIST [REST SYMTAB]>>
+ [REST <LIST SYMTAB ANY>]>]>>
+
+<SETG TMPNO 1>
+
+<SETG TUSERS 2>
+
+<SETG DATTYP 1>
+
+<SETG DATVAL 2>
+
+<SETG ADDRSYM 1>
+
+<SETG ACSYM 2>
+
+<SETG ACLINK 3>
+
+<SETG ACAGE 4>
+
+<SETG ACNUM 5>
+
+<SETG ACPROT 6>
+
+<SETG AC1SYM 7>
+
+<SETG ACRESIDUE 8>
+
+<SETG ACPREF 9>
+
+<SETG ACINUSE 10>
+
+<NEWTYPE AC
+ VECTOR
+ '<VECTOR <PRIMTYPE WORD>
+ <PRIMTYPE WORD>
+ <OR <LIST [REST DATUM]> FALSE>
+ FIX
+ FIX
+ <OR FALSE ATOM>
+ <PRIMTYPE WORD>
+ <OR LIST FALSE>
+ <OR FALSE ATOM>
+ <OR FALSE ATOM>>>
+
+
+<NEWTYPE DATUM LIST '<<PRIMTYPE LIST>
+ <OR ATOM <PRIMTYPE LIST> <PRIMTYPE VECTOR>>
+ <OR ATOM <PRIMTYPE LIST> <PRIMTYPE VECTOR>>>>
+
+<NEWTYPE OFFPTR LIST '<LIST FIX DATUM ATOM>>
+
+<NEWTYPE ADDRESS:PAIR LIST>
+
+<SETG ALLACS
+ <MAPF ,UVECTOR
+ <FUNCTION (N1 N2 N N+1 NAME)
+ <SETG .NAME <CHTYPE [.N1 .N2 <> 0 .N <> .N+1 <> <> <>] AC>>>
+ ![`A `B `C `D `E!]
+ ![`A* `B* `C* `D* `E*!]
+ ![1 2 3 4 5!]
+ ![`B* `C* `D* `E* `PVP*!]
+ ![AC-A AC-B AC-C AC-D AC-E!]>>
+
+<COND (<NOT <GASSIGNED? DATUM>>
+ <SETG DATUM <RSUBR [#CODE ![] DATUM #DECL ("VALUE" DATUM ANY ANY)]>>)>
+
+<COND (<NOT <GASSIGNED? GEN>>
+ <SETG GEN <RSUBR [#CODE ![] GEN #DECL ("VALUE" DATUM NODE <OR ATOM DATUM>)]>>)>
+
+<COND (<NOT <GASSIGNED? GETREG>>
+ <SETG GETREG <RSUBR [#CODE ![] GETREG #DECL ("VALUE" AC ANY)]>>)>
+
+<COND (<NOT <GASSIGNED? SGETREG>>
+ <SETG SGETREG <RSUBR [#CODE ![] SGETREG #DECL ("VALUE" AC AC ANY)]>>)>
+
+<COND (<NOT <GASSIGNED? MINL>>
+ <SETG MINL <RSUBR [#CODE ![] MINL #DECL ("VALUE"FIX ANY)]>>)>
+
+<COND (<NOT <GASSIGNED? TOACV>>
+ <SETG TOACV <RSUBR [#CODE ![] TOACV #DECL ("VALUE" DATUM DATUM)]>>)>
+
+<COND (<NOT <GASSIGNED? TOACT>>
+ <SETG TOACT <RSUBR [#CODE ![] TOACT #DECL ("VALUE" DATUM DATUM)]>>)>
+
+<GDECL (INS1) UVECTOR
+(ASTATE) <UVECTOR [REST <UVECTOR [REST FIX]>]> (SNODES SNODES1) <UVECTOR [REST FIX]>
+(CMSUBRS 0SUBRS) <UVECTOR ATOM [REST ATOM]>
+(SKIPS) <UVECTOR [REST <LIST [REST <PRIMTYPE WORD>]>]>
+(0JMPS) <UVECTOR [REST <PRIMTYPE WORD>]>>
+
+
+\f\ 3\ 3
\ No newline at end of file
--- /dev/null
+<SETG ANALYZERS
+ <DISPATCH ,SUBR-ANA
+ (,QUOTE-CODE ,QUOTE-ANA)
+ (,FUNCTION-CODE ,FUNC-ANA)
+ (,SEGMENT-CODE ,SEGMENT-ANA)
+ (,FORM-CODE ,FORM-AN)
+ (,PROG-CODE ,PRG-REP-ANA)
+ (,SUBR-CODE ,SUBR-ANA)
+ (,COND-CODE ,COND-ANA)
+ (,COPY-CODE ,COPY-AN)
+ (,RSUBR-CODE ,RSUBR-ANA)
+ (,ISTRUC-CODE ,ISTRUC-ANA)
+ (,ISTRUC2-CODE ,ISTRUC2-ANA)
+ (,READ-EOF-CODE ,READ-ANA)
+ (,READ-EOF2-CODE ,READ2-ANA)
+ (,GET-CODE ,GET-ANA)
+ (,GET2-CODE ,GET2-ANA)
+ (,MAP-CODE ,MAPPER-AN)
+ (,MARGS-CODE ,MARGS-ANA)
+ (,ARITH-CODE ,ARITH-ANA)
+ (,TEST-CODE ,ARITHP-ANA)
+ (,0-TST-CODE ,ARITHP-ANA)
+ (,1?-CODE ,ARITHP-ANA)
+ (,MIN-MAX-CODE ,ARITH-ANA)
+ (,ABS-CODE ,ABS-ANA)
+ (,FIX-CODE ,FIX-ANA)
+ (,FLOAT-CODE ,FLOAT-ANA)
+ (,MOD-CODE ,MOD-ANA)
+ (,LNTH-CODE ,LENGTH-ANA)
+ (,MT-CODE ,EMPTY?-ANA)
+ (,NTH-CODE ,NTH-ANA)
+ (,REST-CODE ,REST-ANA)
+ (,PUT-CODE ,PUT-ANA)
+ (,PUTR-CODE ,PUTREST-ANA)
+ (,UNWIND-CODE ,UNWIND-ANA)
+ (,FORM-F-CODE ,FORM-F-ANA)>>
+<SETG GENERATORS
+ <DISPATCH ,DEFAULT-GEN
+ (,FORM-CODE ,FORM-GEN)
+ (,PROG-CODE ,PROG-REP-GEN)
+ (,SUBR-CODE ,SUBR-GEN)
+ (,COND-CODE ,COND-GEN)
+ (,LVAL-CODE ,LVAL-GEN)
+ (,SET-CODE ,SET-GEN)
+ (,OR-CODE ,OR-GEN)
+ (,AND-CODE ,AND-GEN)
+ (,RETURN-CODE ,RETURN-GEN)
+ (,COPY-CODE ,COPY-GEN)
+ (,AGAIN-CODE ,AGAIN-GEN)
+ (,GO-CODE ,GO-GEN)
+ (,ARITH-CODE ,ARITH-GEN)
+ (,RSUBR-CODE ,RSUBR-GEN)
+ (,0-TST-CODE ,0-TEST)
+ (,NOT-CODE ,NOT-GEN)
+ (,1?-CODE ,1?-GEN)
+ (,TEST-CODE ,TEST-GEN)
+ (,EQ-CODE ,==-GEN)
+ (,TY?-CODE ,TYPE?-GEN)
+ (,LNTH-CODE ,LNTH-GEN)
+ (,MT-CODE ,MT-GEN)
+ (,REST-CODE ,REST-GEN)
+ (,NTH-CODE ,NTH-GEN)
+ (,PUT-CODE ,PUT-GEN)
+ (,PUTR-CODE ,PUTREST-GEN)
+ (,FLVAL-CODE ,FLVAL-GEN)
+ (,FSET-CODE ,FSET-GEN)
+ (,FGVAL-CODE ,FGVAL-GEN)
+ (,FSETG-CODE ,FSETG-GEN)
+ (,STACKFORM-CODE ,STACKFORM-GEN)
+ (,MIN-MAX-CODE ,MIN-MAX)
+ (,CHTYPE-CODE ,CHTYPE-GEN)
+ (,FIX-CODE ,FIX-GEN)
+ (,FLOAT-CODE ,FLOAT-GEN)
+ (,ABS-CODE ,ABS-GEN)
+ (,MOD-CODE ,MOD-GEN)
+ (,ID-CODE ,ID-GEN)
+ (,ASSIGNED?-CODE ,ASSIGNED?-GEN)
+ (,ISTRUC-CODE ,ISTRUC-GEN)
+ (,ISTRUC2-CODE ,ISTRUC-GEN)
+ (,BITS-CODE ,BITS-GEN)
+ (,GETBITS-CODE ,GETBITS-GEN)
+ (,BITL-CODE ,BITLOG-GEN)
+ (,PUTBITS-CODE ,PUTBITS-GEN)
+ (,ISUBR-CODE ,ISUBR-GEN)
+ (,EOF-CODE ,ID-GEN)
+ (,READ-EOF2-CODE ,READ2-GEN)
+ (,READ-EOF-CODE ,SUBR-GEN)
+ (,IPUT-CODE ,IPUT-GEN)
+ (,IREMAS-CODE ,IREMAS-GEN)
+ (,GET-CODE ,GET-GEN)
+ (,GET2-CODE ,GET2-GEN)
+ (,IRSUBR-CODE ,IRSUBR-GEN)
+ (,MAP-CODE ,MAPFR-GEN)
+ (,MARGS-CODE ,MPARGS-GEN)
+ (,MAPLEAVE-CODE ,MAPLEAVE-GEN)
+ (,MAPRET-STOP-CODE ,MAPRET-STOP-GEN)
+ (,UNWIND-CODE ,UNWIND-GEN)
+ (,GVAL-CODE ,GVAL-GEN)
+ (,SETG-CODE ,SETG-GEN)
+ (,TAG-CODE ,TAG-GEN)
+ (,PRINT-CODE ,PRINT-GEN)
+ (,MEMQ-CODE ,MEMQ-GEN)
+ (,LENGTH?-CODE ,LENGTH?-GEN)
+ (,FORM-F-CODE ,FORM-F-GEN)
+ (,INFO-CODE ,INFO-GEN)
+ (,OBLIST?-CODE ,OBLIST?-GEN)
+ (,AS-NXT-CODE ,AS-NXT-GEN)
+ (,AS-IT-IND-VAL-CODE ,ASSOC-FIELD-GET)
+ (,ALL-REST-CODE ,ALL-REST-GEN)>>
+\f\ 3
\ No newline at end of file
--- /dev/null
+<PACKAGE "NOTANA">
+
+<ENTRY NOT-ANA TYPE?-ANA ==?-ANA>
+
+<USE "SYMANA" "CHKDCL" "COMPDEC" "CARANA" "ADVMESS">
+
+
+" This module contains analysis and generation functions for
+NOT, TYPE? and ==?. See SYMANA for more details about ANALYSIS and
+CODGEN for more detali abour code generation.
+"
+
+"Analyze NOT usage make sure arg can be FALSE."
+
+<DEFINE NOT-ANA (NOD RTYP
+ "AUX" TEM (FLG <==? .PRED <PARENT .NOD>>) (STR .TRUTH)
+ (SUNT .UNTRUTH))
+ #DECL ((NOD) NODE)
+ <PROG ((PRED <AND .FLG .NOD>) (TRUTH ()) (UNTRUTH ()))
+ #DECL ((PRED) <SPECIAL ANY> (TRUTH UNTRUTH) <SPECIAL LIST>)
+ <COND (<SET TEM <SEGFLUSH .NOD .RTYP>> <SET FLG <>>)
+ (ELSE
+ <OR <1? <LENGTH <KIDS .NOD>>>
+ <MESSAGE ERROR "WRONG NUMBER OF ARGS TO NOT " .NOD>>
+ <SET TEM <ANA <1 <KIDS .NOD>> ANY>>
+ <PUT .NOD ,NODE-TYPE ,NOT-CODE>
+ <SET TEM
+ <COND (<==? <ISTYPE? .TEM> FALSE>
+ <TYPE-OK? ATOM .RTYP>)
+ (<TYPE-OK? .TEM FALSE>
+ <TYPE-OK? '<OR FALSE ATOM> .RTYP>)
+ (ELSE <TYPE-OK? FALSE .RTYP>)>>
+ <SET STR .UNTRUTH>
+ <SET SUNT .TRUTH>)>>
+ <COND (.FLG
+ <SET TRUTH (!.STR !.TRUTH)>
+ <SET UNTRUTH (!.SUNT !.UNTRUTH)>)>
+ .TEM>
+
+<PUT ,NOT ANALYSIS ,NOT-ANA>
+
+" Analyze N==? and ==? usage. Complain if types differ such that
+ the args can never be ==?."
+
+<DEFINE ==?-ANA (NOD RTYP
+ "AUX" (K <KIDS .NOD>)
+ (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>) (WHO ())
+ (GLN .NOD) (GLE ()))
+ #DECL ((NOD) NODE (K) <LIST [REST NODE]> (WHON GLN) <SPECIAL NODE>
+ (WHO GLE) <SPECIAL LIST>)
+ <COND (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <ARGCHK 2 <LENGTH .K> ==?>
+ <ANA <1 .K> ANY>
+ <ANA <2 .K> ANY>
+ <PUT .NOD ,NODE-TYPE ,EQ-CODE>
+ <COND (<AND <==? <ISTYPE? <RESULT-TYPE <1 .K>>> FIX>
+ <==? <ISTYPE? <RESULT-TYPE <2 .K>>> FIX>>
+ <PUT .NOD ,NODE-TYPE ,TEST-CODE>
+ <HACK-BOUNDS .WHO .GLE .NOD .K>)>
+ <TYPE-OK? '<OR FALSE ATOM> .RTYP>)>>
+
+<PUT ,==? ANALYSIS ,==?-ANA>
+
+<PUT ,N==? ANALYSIS ,==?-ANA>
+
+" Ananlyze TYPE? usage warn about any potential losers by using
+TYPE-OK?. "
+
+<DEFINE TYPE?-ANA (NOD RTYP
+ "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) ITYP (ALLGOOD T)
+ (WHO ()) (FTYP ()) (FNOK <>)
+ (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>) TTYP)
+ #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX (ITYP) ANY
+ (ALLGOOD) <OR FALSE ATOM> (WHON) <SPECIAL <OR NODE FALSE>>
+ (WHO) <SPECIAL LIST> (FTYP) LIST)
+ <COND
+ (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <OR <G? .LN 1>
+ <MESSAGE ERROR "TOO FEW ARGS TO TYPE? " .NOD>>
+ <SET ITYP <EANA <1 .K> ANY TYPE?>>
+ <MAPF <>
+ <FUNCTION (N "AUX" FLG)
+ #DECL ((N) NODE)
+ <PROG ()
+ <EANA .N ATOM TYPE?>
+ <OR <==? <NODE-TYPE .N> ,QUOTE-CODE>
+ <RETURN <SET ALLGOOD <>>>>
+ <OR <MEMQ <NODE-NAME .N> <ALLTYPES>>
+ <MESSAGE ERROR
+ "ARG TO TYPE? NOT A TYPE "
+ .NOD>>
+ <AND <TYPE-OK? <NODE-NAME .N> .ITYP>
+ <SET FTYP (<NODE-NAME .N> !.FTYP)>>>>
+ <REST .K>>
+ <COND (<AND .ALLGOOD <NOT <EMPTY? .FTYP>>>
+ <SET TTYP
+ <COND (<EMPTY? <REST .FTYP>> <1 .FTYP>)
+ (ELSE <CHTYPE (OR !.FTYP) FORM>)>>
+ <PUT .NOD ,NODE-TYPE ,TY?-CODE>
+ <SET FNOK <NOT <TYPE-OK? <FORM NOT .TTYP> .ITYP>>>
+ <MAPF <>
+ <FUNCTION (L "AUX" (FLG <1 .L>) (SYM <2 .L>))
+ #DECL ((L) <LIST <OR ATOM FALSE> SYMTAB> (SYM) SYMTAB)
+ <SET TRUTH
+ <ADD-TYPE-LIST .SYM
+ .TTYP
+ .TRUTH
+ .FLG
+ <REST .L 2>>>
+ <OR .FNOK
+ <SET UNTRUTH
+ <ADD-TYPE-LIST .SYM
+ <FORM NOT .TTYP>
+ .UNTRUTH
+ .FLG
+ <REST .L 2>>>>>
+ .WHO>)
+ (.ALLGOOD <PUT .NOD ,NODE-TYPE ,TY?-CODE>)
+ (ELSE
+ <AND .VERBOSE <ADDVMESS .NOD ("Not open compiled.")>>
+ <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>)>
+ <TYPE-OK? <COND (<NOT .ALLGOOD> '<OR FALSE ATOM>)
+ (<EMPTY? .FTYP> FALSE)
+ (.FNOK ATOM)
+ (ELSE '<OR FALSE ATOM>)>
+ .RTYP>>
+
+<PUT ,TYPE? ANALYSIS ,TYPE?-ANA>
+\f
+<ENDPACKAGE>\ 3\ 3\ 3\ 3
\ No newline at end of file
--- /dev/null
+<PACKAGE "NOTGEN">
+
+<ENTRY NOT-GEN TYPE?-GEN ==-GEN>
+
+<USE "CODGEN" "COMCOD" "CHKDCL" "CACS" "COMPDEC">
+
+
+" Generate NOT code. This is done in a variety of ways.
+ 1) If NOTs arg is a predicate itself and this is a predicate usage
+ (flagged by BRANCH arg), just pass through setting the NOTF arg.
+ 2) If NOTs arg is a predicate but a value is needed,
+ set up a predicate like situation and return NOT of the normal
+ value.
+ 3) Else just compile and complement result."
+
+<DEFINE NOT-GEN (NOD WHERE
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR T)
+ "AUX" (P <1 <KIDS .NOD>>) (RW .WHERE)
+ (PF <PRED? <NODE-TYPE .P>>) T1 T2 TT (FLG <>))
+ #DECL ((NOD P) NODE (TT) DATUM)
+ <SET WHERE <GOODACS .NOD .WHERE>>
+ <SET NOTF <NOT .NOTF>>
+ <COND (<AND .BRANCH .PF>
+ <SET WHERE
+ <APPLY <NTH ,GENERATORS <NODE-TYPE .P>>
+ .P
+ <COND (<==? .RW FLUSHED> FLUSHED) (ELSE .WHERE)>
+ .NOTF
+ .BRANCH
+ .DIR>>)
+ (<AND .BRANCH <==? .RW FLUSHED>>
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <SET WHERE <GEN .P .WHERE>>
+ <VAR-STORE <>>
+ <D:B:TAG .BRANCH .WHERE .DIR <RESULT-TYPE .P>>)
+ (.BRANCH
+ <SET TT <GEN .P DONT-CARE>>
+ <VAR-STORE <>>
+ <SET T1 <MAKE:TAG>>
+ <D:B:TAG .T1 .TT .DIR <RESULT-TYPE .P>>
+ <RET-TMP-AC .TT>
+ <SET WHERE <MOVE:ARG <REFERENCE .DIR> .WHERE>>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .T1>)
+ (<==? .RW FLUSHED> <SET WHERE <GEN .P FLUSHED>>)
+ (<OR <SET FLG <==? <ISTYPE? <RESULT-TYPE .NOD>> FALSE>>
+ <NOT <TYPE-OK? <RESULT-TYPE .NOD> FALSE>>>
+ <GEN .P FLUSHED>
+ <SET WHERE <MOVE:ARG <REFERENCE <NOT .FLG>> .WHERE>>)
+ (.PF
+ <SET T1 <MAKE:TAG>>
+ <SET T2 <MAKE:TAG>>
+ <APPLY <NTH ,GENERATORS <NODE-TYPE .P>>
+ .P
+ FLUSHED
+ .NOTF
+ .T1
+ .DIR>
+ <MOVE:ARG <REFERENCE <>> .WHERE>
+ <BRANCH:TAG .T2>
+ <LABEL:TAG .T1>
+ <RET-TMP-AC .WHERE>
+ <MOVE:ARG <REFERENCE T> .WHERE>
+ <LABEL:TAG .T2>)
+ (ELSE
+ <SET T1 <MAKE:TAG>>
+ <SET T2 <MAKE:TAG>>
+ <SET TT <GEN .P DONT-CARE>>
+ <VAR-STORE <>>
+ <D:B:TAG .T1 .TT T <RESULT-TYPE .P>>
+ <RET-TMP-AC .TT>
+ <MOVE:ARG <REFERENCE T> .WHERE>
+ <BRANCH:TAG .T2>
+ <LABEL:TAG .T1>
+ <RET-TMP-AC .WHERE>
+ <MOVE:ARG <REFERENCE <>> .WHERE>
+ <LABEL:TAG .T2>)>
+ <MOVE:ARG .WHERE .RW>>
+
+<DEFINE PRED? (N) #DECL ((N) FIX) <1? <NTH ,PREDV .N>>>
+
+" Generate code for ==?. If types are the same then just compare values,
+otherwise generate a full comparison."
+
+<DEFINE ==-GEN (NOD WHERE
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
+ "AUX" (K <KIDS .NOD>) REG REG2 B2 T2OK T2 T1
+ (T1OK <ISTYPE? <RESULT-TYPE <1 .K>>>)
+ (TYPSAM
+ <AND <==? .T1OK
+ <SET T2OK <ISTYPE? <RESULT-TYPE <2 .K>>>>>
+ .T1OK>) (RW .WHERE) (SDIR .DIR)
+ (FLS <==? .RW FLUSHED>) INA)
+ #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
+ <COND (<==? <NODE-SUBR .NOD> ,N==?> <SET NOTF <NOT .NOTF>>)>
+ <AND <NOT .TYPSAM>
+ .T1OK
+ .T2OK
+ <MESSAGE WARNING
+ " ARGS CAN NEVER BE EQUAL "
+ <NODE-NAME .NOD>
+ " "
+ .NOD>>
+ <COND (<OR <==? <NODE-TYPE <SET T1 <1 .K>>> ,QUOTE-CODE>
+ <AND <NOT <SIDE-EFFECTS .NOD>>
+ <N==? <NODE-TYPE <SET T2 <2 .K>>> ,QUOTE-CODE>
+ <MEMQ <NODE-TYPE .T1> ,SNODES>
+ <OR <N==? <NODE-TYPE .T2> ,LVAL-CODE>
+ <AND <==? <NODE-TYPE .T1> ,LVAL-CODE>
+ <SET INA <INACS <NODE-NAME .T2>>>
+ <TYPE? <DATVAL .INA> AC>>>>>
+ <PUT .K 1 <2 .K>>
+ <PUT .K 2 .T1>
+ <SET T1 .T1OK>
+ <SET T1OK .T2OK>
+ <SET T2OK .T1>)>
+ <SET WHERE <UPDATE-WHERE .NOD .WHERE>>
+ <SET REG
+ <COND (<ISTYPE-GOOD? .T1OK> <DATUM .T1OK ANY-AC>)
+ (ELSE <DATUM ANY-AC ANY-AC>)>>
+ <SET REG2 DONT-CARE>
+ <COND (.BRANCH
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <GEN-EQTST .REG
+ .REG2
+ <1 .K>
+ <2 .K>
+ .T1OK
+ .T2OK
+ <COND (.FLS .DIR) (ELSE <NOT .DIR>)>
+ .TYPSAM
+ <COND (.FLS .BRANCH) (ELSE <SET B2 <MAKE:TAG>>)>>
+ <COND (<NOT .FLS>
+ <SET RW
+ <MOVE:ARG <MOVE:ARG <REFERENCE .SDIR> .WHERE> .RW>>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B2>
+ .RW)>)
+ (ELSE
+ <SET BRANCH <MAKE:TAG>>
+ <GEN-EQTST .REG
+ .REG2
+ <1 .K>
+ <2 .K>
+ .T1OK
+ .T2OK
+ .NOTF
+ .TYPSAM
+ .BRANCH>
+ <MOVE:ARG <REFERENCE T> .WHERE>
+ <RET-TMP-AC .WHERE>
+ <BRANCH:TAG <SET B2 <MAKE:TAG>>>
+ <LABEL:TAG .BRANCH>
+ <MOVE:ARG <REFERENCE <>> .WHERE>
+ <LABEL:TAG .B2>
+ <MOVE:ARG .WHERE .RW>)>>
+
+<DEFINE GEN-EQTST (R11 R21 N1 N2 T1 T2 DIR TYPS BR "AUX" (TMP <>) AC R1 R2)
+ #DECL ((N1 N2) NODE (R1 R2) DATUM (AC) AC)
+ <SET R1 <GEN .N1 .R11>>
+ <SET R2 <GEN .N2 .R21>>
+ <VAR-STORE <>>
+ <COND (<TYPE? <DATVAL .R1> AC>)
+ (<TYPE? <DATVAL .R2> AC>
+ <SET R11 .R1>
+ <SET R1 .R2>
+ <SET R2 .R11>
+ <SET R11 .T1>
+ <SET T1 .T2>
+ <SET T2 .R11>)>
+ <TOACV .R1>
+ <AND <TYPE? <DATVAL .R2> AC>
+ <PUT <SET TMP <DATVAL .R2>> ,ACPROT T>>
+ <PUT <DATVAL .R1> ,ACPROT T>
+ <COND (.TYPS
+ <IMCHK <COND (.DIR '(`CAMN `CAIN )) (ELSE '(`CAME `CAIE ))>
+ <ACSYM <DATVAL .R1>>
+ <DATVAL .R2>>)
+ (ELSE
+ <COND (.T2
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O !<ADDR:TYPE .R1>>>)
+ (.T1
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O !<ADDR:TYPE .R2>>>)
+ (ELSE
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O !<ADDR:TYPE .R2>>>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE
+ <ACSYM <SET AC <GETREG <>>>>
+ !<ADDR:TYPE .R1>>>)>
+ <IMCHK '(`CAMN `CAIN ) <ACSYM <DATVAL .R1>> <DATVAL .R2>>
+ <EMIT <INSTRUCTION
+ `CAIE
+ `O
+ <COND (.T1 <FORM TYPE-CODE!-OP!-PACKAGE .T1>)
+ (.T2 <FORM TYPE-CODE!-OP!-PACKAGE .T2>)
+ (ELSE (<ADDRSYM .AC>))>>>
+ <AND .DIR <EMIT '<`SKIPA >>>)>
+ <BRANCH:TAG .BR>
+ <RET-TMP-AC .R1>
+ <RET-TMP-AC .R2>
+ <AND <TYPE? .TMP AC> <PUT .TMP ,ACPROT <>>>>
+
+" Generate TYPE? code for all various cases."
+
+<DEFINE TYPE?-GEN (NOD WHERE
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
+ "AUX" B2 REG (RW .WHERE) (K <KIDS .NOD>) (SDIR .DIR)
+ (FLS <==? .RW FLUSHED>) B3 (TEST? T))
+ #DECL ((NOD) NODE (K) <LIST [REST NODE]> (REG) DATUM
+ (WHERE BRANCH B2 B3) ANY)
+ <COND (<==? <RESULT-TYPE .NOD> FALSE>
+ <MESSAGE WARNING "TYPE? NEVER TRUE " .NOD>
+ <SET TEST? #FALSE (1)>)
+ (<NOT <TYPE-OK? <RESULT-TYPE .NOD> FALSE>>
+ <MESSAGE WARNING "TYPE? ALWAYS TRUE " .NOD>
+ <SET TEST? #FALSE (2)>)>
+ ;"Type of false indicates always true or false"
+ <SET REG
+ <GEN <1 .K> <COND (<AND <NOT .TEST?> .FLS> FLUSHED) (ELSE DONT-CARE)>>>
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <SET K <REST .K>>
+ <VAR-STORE <>>
+ <COND (<OR .TEST?
+ <AND <NOT .FLS> <NOT <EMPTY? <REST .K>>> <==? <1 .TEST?> 2>>>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O* !<ADDR:TYPE .REG>>>)>
+ <RET-TMP-AC .REG>
+ <COND
+ (<AND .BRANCH .FLS> ;"In a COND, OR or AND?"
+ <AND <NOT <EMPTY? <REST .K>>> <NOT .DIR> <SET B2 <MAKE:TAG>>>
+ <REPEAT ()
+ <COND
+ (<EMPTY? <REST .K>>
+ <COND (.TEST? <TYPINS .DIR <1 .K>>)>
+ <COND (<OR .TEST?
+ <AND .DIR <==? <1 .TEST?> 2>>
+ <AND <NOT .DIR> <==? <1 .TEST?> 1>>>
+ <BRANCH:TAG .BRANCH>)>
+ <AND <ASSIGNED? B2> <LABEL:TAG .B2>>
+ <RETURN>)
+ (ELSE
+ <COND (.TEST?
+ <TYPINS <> <1 .K>>
+ <TYPINS T <2 .K>>
+ <BRANCH:TAG <COND (.DIR .BRANCH) (ELSE .B2)>>)>
+ <COND (<EMPTY? <SET K <REST .K 2>>>
+ <COND (<OR <AND <NOT .DIR> .TEST?>
+ <AND <NOT .TEST?>
+ <OR <AND .DIR <==? <1 .TEST?> 2>>
+ <AND <NOT .DIR>
+ <==? <1 .TEST?> 1>>>>>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B2>)>
+ <RETURN>)>)>>)
+ (<AND .FLS <NOT .TEST?> <NOT .BRANCH>>)
+ (<OR .NOTF <NOT <==? <NOT .BRANCH> <NOT .DIR>>>>
+ <SET WHERE <GOODACS .NOD .WHERE>>
+ <SET B2 <MAKE:TAG>>
+ <SET B3 <MAKE:TAG>>
+ <COND (.TEST?
+ <REPEAT ()
+ <COND (<EMPTY? <REST .K>>
+ <TYPINS <COND (.BRANCH <NOT .DIR>) (ELSE .DIR)>
+ <1 .K>>
+ <RETURN>)
+ (ELSE
+ <TYPINS <> <1 .K>>
+ <TYPINS T <2 .K>>
+ <COND (<EMPTY? <SET K <REST .K 2>>>
+ <AND <N==? <NOT .BRANCH> .DIR>
+ <EMIT '<`SKIPA >>>
+ <RETURN>)>)>
+ <BRANCH:TAG <OR <AND .BRANCH .NOTF .B3> .B2>>>
+ <BRANCH:TAG .B2>
+ <LABEL:TAG .B3>
+ <COND (.BRANCH
+ <MOVE:ARG <REFERENCE .SDIR> .WHERE>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B2>)
+ (ELSE <TRUE-FALSE .NOD .BRANCH .WHERE>)>)
+ (ELSE
+ <COND (.BRANCH
+ <COND (<OR <AND .DIR <==? <1 .TEST?> 2>>
+ <AND <NOT .DIR> <==? <1 .TEST?> 1>>>
+ <MOVE:ARG <REFERENCE .SDIR> .WHERE>
+ <BRANCH:TAG .BRANCH>)>)
+ (ELSE <MOVE:ARG <==? <1 .TEST?> 2> .WHERE>)>)>)
+ (ELSE
+ <SET WHERE <GOODACS .NOD .WHERE>>
+ <SET B2 <MAKE:TAG>>
+ <SET REG <REG? ATOM .WHERE>>
+ <COND
+ (<OR .TEST? <AND <G=? <LENGTH .K> 2> <==? <1 .TEST?> 2>>>
+ <MAPR <>
+ <FUNCTION (TYL "AUX" (TY <1 .TYL>))
+ <COND (<NOT <AND <NOT .TEST?> <EMPTY? <REST .TYL>>>>
+ <TYPINS <> .TY>
+ <BRANCH:TAG <SET B3 <MAKE:TAG>>>)>
+ <MOVE:ARG <REFERENCE <NODE-NAME .TY>> .REG>
+ <COND (<EMPTY? <REST .TYL>>
+ <LABEL:TAG .B2>
+ <RET-TMP-AC <MOVE:ARG .REG .WHERE>>
+ <COND (.BRANCH
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B3>)
+ (ELSE
+ <BRANCH:TAG <SET B2 <MAKE:TAG>>>
+ <LABEL:TAG .B3>
+ <MOVE:ARG <REFERENCE <>> .WHERE>
+ <LABEL:TAG .B2>)>)
+ (ELSE
+ <RET-TMP-AC .REG>
+ <BRANCH:TAG .B2>
+ <LABEL:TAG .B3>)>>
+ .K>)
+ (ELSE
+ <COND
+ (.BRANCH
+ <COND (<OR <AND .DIR <==? <1 .TEST?> 2>>
+ <AND <NOT .DIR> <==? <1 .TEST?> 1>>>
+ <MOVE:ARG <REFERENCE <AND .DIR <NODE-NAME <1 .K>>>> .WHERE>
+ <BRANCH:TAG .BRANCH>)>)
+ (ELSE <MOVE:ARG <REFERENCE <AND .DIR <NODE-NAME <1 .K>>>> .WHERE>)>)>)>
+ <MOVE:ARG .WHERE .RW>>
+
+<DEFINE TYPINS (DIR N)
+ #DECL ((N) NODE)
+ <EMIT <INSTRUCTION <COND (.DIR `CAIN ) (ELSE `CAIE )>
+ <FORM TYPE-CODE!-OP!-PACKAGE <NODE-NAME .N>>>>>
+\f
+<ENDPACKAGE>
+\ 3\ 3
\ No newline at end of file
--- /dev/null
+<PACKAGE "NPRINT">
+
+<ENTRY NODE-COMPLAIN NODE-PRINT>
+
+<USE "COMPDEC">
+
+<DEFINE NODE-COMPLAIN (N "OPTIONAL" (MAX 80) "AUX" (P .N) TEM)
+ #DECL ((N) NODE (MAX) FIX (P) <OR VECTOR NODE>)
+ <REPEAT ((OPP .P))
+ <AND <EMPTY? .OPP> <RETURN>>
+ <OR <NODE-PRINT .OPP .N .MAX T> <RETURN>>
+ <OR <TYPE? <SET TEM <PARENT <SET P .OPP>>> NODE>
+ <RETURN>>
+ <OR <MEMQ .OPP <KIDS <SET OPP .TEM>>>
+ <RETURN>>>
+ <NODE-PRINT .P .N .MAX>>
+
+<DEFINE NODE-PRINT (N
+ "OPTIONAL" (LOSER <>) (MAX 80) (FLAT <>)
+ "AUX" (OUTC .OUTCHAN)
+ (OUTCHAN
+ <OPEN "PRINT" "INT:" <COND (.FLAT ,NF) (ELSE ,NP)>>)
+ (NCHS 0))
+ #DECL ((MAX) <SPECIAL FIX> (NCHS) <SPECIAL ANY>
+ (OUTCHAN OUTC) <SPECIAL CHANNEL>
+ (LOSER) <SPECIAL <OR FALSE NODE>>)
+ <PUT .OUTCHAN 13 <- <13 .OUTC> 2>>
+ <COND (<PROG NACT ()
+ #DECL ((NACT) <SPECIAL ACTIVATION>)
+ <NPRINT .N>
+ <>>
+ <OR .FLAT <PRINC " ..." .OUTC>>
+ <SET NCHS <>>)>
+ <OR .FLAT <TERPRI .OUTC>>
+ <CLOSE .OUTCHAN>
+ .NCHS>
+
+<DEFINE NF (CH)
+ <COND (<L? <SET MAX <- .MAX 1>> 0> <RETURN T .NACT>)>
+ <SET NCHS <+ .NCHS 1>>>
+
+<DEFINE NP (CH) #DECL ((CH) CHARACTER)
+ <COND (<L? <SET MAX <- .MAX 1>> 0> <RETURN T .NACT>)>
+ <PRINC .CH .OUTC>>
+
+<DEFINE NPRINT (N "AUX" (COD <NODE-TYPE .N>) TC (FLG <==? .N .LOSER>))
+ #DECL ((N) NODE (COD TC) FIX)
+ <AND .FLG <PRINC " **** ">>
+ <COND (<OR <==? .COD ,FUNCTION-CODE> <==? .COD ,MFCN-CODE>>
+ <PRINC "<FUNCTION ">
+ <PRNARGL <BINDING-STRUCTURE .N> <RESULT-TYPE .N> <>>
+ <PRINC " ">
+ <SEQ-PRINT <KIDS .N>>
+ <PRINC ">">)
+ (<==? .COD ,PROG-CODE>
+ <PRINC "<">
+ <PRIN1 <NODE-NAME .N>>
+ <PRINC " ">
+ <PRNARGL <BINDING-STRUCTURE .N> <RESULT-TYPE .N> T>
+ <PRINC " ">
+ <SEQ-PRINT <KIDS .N>>
+ <PRINC ">">)
+ (<==? .COD ,MFIRST-CODE>
+ <PRINC <NTH ,MAP-SPEC-PRINT <NODE-SUBR .N>>>)
+ (<==? .COD ,MPSBR-CODE>
+ <PRINC ",">
+ <OR <AND <EMPTY? <KIDS .N>> some-subr>
+ <PRIN1 <NODE-NAME <1 <KIDS .N>>>>>)
+ (<==? .COD ,COPY-CODE>
+ <PRINC <NTH ,ST-CHRS
+ <SET TC
+ <LENGTH <MEMQ <NODE-NAME .N>
+ '![UVECTOR VECTOR LIST!]>>>>>
+ <SEQ-PRINT <KIDS .N>>
+ <PRINC <NTH ,EN-CHRS .TC>>)
+ (<OR <==? .COD ,SEG-CODE> <==? .COD ,SEGMENT-CODE>>)
+ (<==? .COD ,BRANCH-CODE>
+ <PRINC "(">
+ <NPRINT <PREDIC .N>>
+ <COND (<NOT <EMPTY? <CLAUSES .N>>>
+ <PRINC " ">
+ <SEQ-PRINT <CLAUSES .N>>)>
+ <PRINC ")">)
+ (<==? .COD ,QUOTE-CODE>
+ <AND <TYPE? <NODE-NAME .N> VECTOR UVECTOR LIST FORM>
+ <PRINC !"'>>
+ <PRIN1 <NODE-NAME .N>>)
+ (<OR <==? .COD ,SET-CODE> <==? .COD ,FSET-CODE>>
+ <PRINC "<">
+ <PRIN1 SET>
+ <PRINC " ">
+ <SEQ-PRINT <KIDS .N>>
+ <PRINC ">">)
+ (<OR <MEMQ .COD ,LGV>
+ <AND <==? .COD ,SUBR-CODE>
+ <OR <AND <==? <NODE-SUBR .N> ,LVAL>
+ <SET COD ,FLVAL-CODE>>
+ <AND <==? <NODE-SUBR .N> ,GVAL>
+ <SET COD ,FGVAL-CODE>>>>>
+ <COND (<OR <==? .COD ,LVAL-CODE> <==? .COD ,FLVAL-CODE>>
+ <PRINC !".>)
+ (ELSE <PRINC !",>)>
+ <COND (<TYPE? <NODE-NAME .N> SYMTAB>
+ <PRIN1 <NAME-SYM <NODE-NAME .N>>>)
+ (ELSE <OR <AND <EMPTY? <KIDS .N>> some-atom>
+ <NPRINT <1 <KIDS .N>>>>)>)
+ (<==? <NODE-NAME .N> INTH>
+ <PRINC "<">
+ <OR <EMPTY? <KIDS .N>> <NPRINT <2 <KIDS .N>>>>
+ <PRINC " ">
+ <OR <EMPTY? <KIDS .N>> <NPRINT <1 <KIDS .N>>>>
+ <PRINC ">">)
+ (ELSE
+ <PRINC "<">
+ <PRINC <NODE-NAME .N>>
+ <PRINC " ">
+ <SEQ-PRINT <KIDS .N>>
+ <PRINC ">">)>
+ <AND .FLG <PRINC " **** ">>>
+
+<SETG MAP-SPEC-PRINT [",+" ",-" ",*" ",/" ",LIST"]>
+
+<SETG LGV
+ ![,LVAL-CODE ,FLVAL-CODE ,GVAL-CODE ,FGVAL-CODE!]>
+
+<SETG ST-CHRS ["(" "[" "!["]>
+
+<SETG EN-CHRS [")" "]" "!]"]>
+
+<DEFINE SEQ-PRINT (L) #DECL ((L) <LIST [REST NODE]>)
+ <COND (<NOT <EMPTY? .L>>
+ <NPRINT <1 .L>>
+ <COND (<NOT <EMPTY? <SET L <REST .L>>>>
+ <MAPF <>
+ <FUNCTION (N)
+ #DECL ((N) NODE)
+ <PRINC " ">
+ <NPRINT .N>>
+ .L>)>)>>
+
+<DEFINE PRNARGL (B R "OPTIONAL" (INAUX <>) "AUX" (INOPT <>) (DC ()) (FIRST T))
+ #DECL ((B) <LIST [REST SYMTAB]> (DC) LIST)
+ <PRINC "(">
+ <MAPF <>
+ <FUNCTION (SYM "AUX" (COD <CODE-SYM .SYM>))
+ #DECL ((SYM) SYMTAB (COD) FIX)
+ <OR .FIRST <PRINC " ">>
+ <SET FIRST <>>
+ <COND (<==? .COD 1>
+ <PRINC "\"NAME\" ">
+ <PRIN1 <NAME-SYM .SYM>>)
+ (<L=? .COD 3>
+ <COND (<NOT .INAUX>
+ <SET INAUX T>
+ <PRINC "\"AUX\" ">)>
+ <COND (<==? .COD 2>
+ <PRINC "(">
+ <PRIN1 <NAME-SYM .SYM>>
+ <PRINC " ">
+ <NPRINT <INIT-SYM .SYM>>
+ <PRINC ")">)
+ (ELSE <PRIN1 <NAME-SYM .SYM>>)>)
+ (<==? .COD 4>
+ <PRINC "\"TUPLE\" ">
+ <PRIN1 <NAME-SYM .SYM>>)
+ (<==? .COD 5>
+ <PRINC "\"ARGS\" ">
+ <PRIN1 <NAME-SYM .SYM>>)
+ (<L=? .COD 9>
+ <COND (<NOT .INOPT>
+ <SET INOPT T>
+ <PRINC "\"OPTIONAL\" ">)>
+ <COND (<L=? .COD 7>
+ <PRINC "(">
+ <AND <==? .COD 6> <PRINC "'">>
+ <PRIN1 <NAME-SYM .SYM>>
+ <PRINC " ">
+ <NPRINT <INIT-SYM .SYM>>
+ <PRINC ")">)
+ (ELSE
+ <AND <==? .COD 8> <PRINC "'">>
+ <PRIN1 <NAME-SYM .SYM>>)>)
+ (<==? .COD 10>
+ <PRINC "\"CALL\" ">
+ <PRIN1 <NAME-SYM .SYM>>)
+ (<==? .COD 11>
+ <PRINC "\"BIND\" ">
+ <PRIN1 <NAME-SYM .SYM>>)
+ (ELSE
+ <AND <==? .COD 12> <PRINC "'">>
+ <PRIN1 <NAME-SYM .SYM>>)>
+ <COND (<N==? <1 <DECL-SYM .SYM>> ANY>
+ <SET DC
+ ((<NAME-SYM .SYM>)
+ <1 <DECL-SYM .SYM>>
+ !.DC)>)>>
+ .B>
+ <COND (<AND .R <N==? .R ANY>> <SET DC ('(VALUE) .R !.DC)>)>
+ <PRINC ")">
+ <COND (<NOT <EMPTY? .DC>> <PRINC " "> <PRIN1 <CHTYPE .DC DECL>>)>>
+
+
+
+
+
+<ENDPACKAGE>
+\ 3
\ No newline at end of file
--- /dev/null
+<PACKAGE "PASS1">
+
+<ENTRY PASS1 PCOMP PMACRO PAPPLY-OBJECT PAPPLY-TYPE PTHIS-OBJECT PTHIS-TYPE
+ GEN-D ACT-FIX FIND:DECL SEG? PSUBR-C>
+
+<USE "CHKDCL" "COMPDEC" "CDRIVE">
+
+
+" This file contains the first pass of the MUDDLE compiler.
+The functions therein take a MUDDLE function and build a more detailed
+model of it. Each entity in the function is represented by an object
+of type NODE. The entire function is represented by the functions node
+and it points to the rest of the nodes for the function."
+
+" Nodes vary in complexity and size depending on what they represent.
+A function or prog/repeat node is contains more information than a node
+for a quoted object. All nodes have some fields in common to allow
+general programs to traverse the model."
+
+" The model built by PASS1 is used by the analyzer (SYMANA), the
+variable allocator (VARANA) and the code generator (CODGEN). In some
+cases the analyzers and generators for certain classes of SUBRs are
+together in their own files (e.g. CARITH, STRUCT, ISTRUC)."
+
+" This the top level program for PASS1. It takes a function as
+input and returns the data structure representing the model."
+
+<DEFINE PASS1 (FUNC
+ "OPTIONAL" (NAME <>) (JUSTDCL <>) (RNAME .NAME)
+ "AUX" RESULT (VARTBL ,LVARTBL) (DCL #DECL ()) (ARGL ())
+ (HATOM <>) (TT ()) (FCN .FUNC) TEM (RQRG 0) (TRG 0) INAME)
+ #DECL ((FUNC) FUNCTION (VARTBL) <SPECIAL SYMTAB>
+ (RQRG TRG) <SPECIAL FIX> (FCN) <PRIMTYPE LIST> (ARGL TT) LIST
+ (RESULT) <SPECIAL NODE> (INAME) <UVECTOR [REST ATOM]>)
+ <AND <EMPTY? .FCN> <MESSAGE ERROR " EMPTY FUNCTION ">>
+ <AND <TYPE? <1 .FCN> ATOM>
+ <SET HATOM <1 .FCN>>
+ <SET FCN <REST .FCN>>>
+ <AND <EMPTY? .FCN> <MESSAGE ERROR " NO ARG LIST ">>
+ <SET ARGL <1 .FCN>>
+ <SET FCN <REST .FCN>>
+ <COND (<AND <NOT <EMPTY? .FCN>> <TYPE? <1 .FCN> DECL>>
+ <SET DCL <1 .FCN>>
+ <SET FCN <REST .FCN>>)>
+ <AND <EMPTY? .FCN> <MESSAGE ERROR " NO BODY ">>
+ <COND (<SET TEM <GET .RNAME .IND>>
+ <SET RESULT .TEM>
+ <SET VARTBL <SYMTAB .RESULT>>)
+ (ELSE
+ <SET TT <GEN-D .ARGL .DCL .HATOM>>
+ <SET INAME
+ <IUVECTOR <- .TRG .RQRG -1> '<MAKE:TAG <PNAME .NAME>>>>
+ <SET RESULT
+ <NODEF ,FUNCTION-CODE
+ ()
+ <FIND:DECL VALUE .DCL>
+ .INAME
+ ()
+ <1 .TT>
+ <2 .TT>
+ .HATOM
+ .VARTBL
+ <COND (<==? <LENGTH .TT> 3> <3 .TT>)>
+ .TRG
+ .RQRG>>
+ <ACT-FIX .RESULT <2 .TT>>
+ <PUT .RNAME .IND .RESULT>
+ <PUT .RESULT
+ ,RSUBR-DECLS
+ ("VALUE" <RESULT-TYPE .RESULT> !<RSUBR-DECLS .RESULT>)>)>
+ <OR .JUSTDCL
+ <PUT .RESULT
+ ,KIDS
+ <MAPF ,LIST <FUNCTION (O) <PCOMP .O .RESULT>> .FCN>>>
+ .RESULT>
+
+" This function (and others on this page) take an arg list and
+decls and parses them producing 3 things.
+
+ 1) An RSUBR decl list.
+
+ 2) A machine readable binding specification.
+
+ 3) Possibly an AC call spec.
+
+Atoms are also entered into the symbol table."
+
+<DEFINE GEN-D (ARGL DCL HATOM "OPTIONAL" (ACS:TOP <COND (.GLUE '(() STACK)) (T (()))>)
+ "AUX" (SVTBL .VARTBL) (ACS:BOT <CHTYPE .ACS:TOP LIST>) (NACS 1)
+ (RES:TOP (())) (RES:BOT .RES:TOP) (ARGN 1) (BNDL:TOP (()))
+ (BNDL:BOT .BNDL:TOP) (MODE ,TOT-MODES) (DOIT ,INIT-D)
+ (ST <>) T T1 SVT (IX 0) TIX VIX)
+ #DECL ((ACS:BOT RES:BOT BNDL:TOP BNDL:BOT) <SPECIAL LIST> (RES:TOP) LIST
+ (ACS:TOP) <SPECIAL <PRIMTYPE LIST>> (NACS ARGN) <SPECIAL FIX>
+ (VIX) <VECTOR [REST STRING]> (MODE) <SPECIAL <VECTOR [REST STRING]>>
+ (IX) FIX (DOIT) <SPECIAL ANY> (ARGL) LIST (SVTBL SVT) SYMTAB
+ (DCL) <SPECIAL <PRIMTYPE LIST>>)
+ <REPEAT ()
+ <AND <EMPTY? .ARGL> <RETURN>>
+ <COND (<SET T1 <TYPE? <SET T <1 .ARGL>> ATOM FORM LIST>>
+ <SET ST <>>
+ <APPLY .DOIT .T .T1>)
+ (<TYPE? .T STRING>
+ <AND .ST <MESSAGE ERROR " TWO DECL STRINGS IN A ROW ">>
+ <SET ST T>
+ <OR <SET TIX <MEMBER .T .MODE>>
+ <MESSAGE ERROR " UNRECOGNIZED STRING IN DECL " .T>>
+ <SET VIX .TIX>
+ <SET MODE <REST .MODE <NTH ,RESTS <SET IX <LENGTH .VIX>>>>>
+ <SET DOIT <NTH ,DOITS .IX>>
+ <COND (<OR <L? .IX 5> <G? .IX 8>>)
+ (ELSE <PUT-RES (<COND (<=? <1 .ARGL> "OPT">
+ "OPTIONAL")
+ (ELSE <1 .ARGL>)>)>)>)
+ (ELSE <MESSAGE ERROR " BAD THING IN DECL " .T>)>
+ <SET ARGL <REST .ARGL>>>
+ <AND .HATOM <ACT-D .HATOM <TYPE .HATOM>>>
+ <REPEAT (DC DC1)
+ #DECL ((DC1) FORM (DC) ANY (VARTBL) <SPECIAL SYMTAB>)
+ <COND (<EMPTY? .DCL> <RETURN>)
+ (<EMPTY? <REST .DCL>> <MESSAGE ERROR "DECL LIST AT END OF DECL">)>
+ <SET DC <2 .DCL>>
+ <COND (<AND <TYPE? .DC FORM>
+ <SET DC1 .DC>
+ <==? <LENGTH .DC1> 2>
+ <OR <==? <1 .DC1> SPECIAL> <==? <1 .DC1> UNSPECIAL>>>
+ <SET DC <2 .DC1>>)>
+ <MAPF <>
+ <FUNCTION (ATM)
+ <OR <==? .ATM VALUE>
+ <SRCH-SYM .ATM>
+ <ADDVAR .ATM T -1 0 T (.DC) <> <>>>>
+ <CHTYPE <1 .DCL> LIST>>
+ <SET DCL <REST .DCL 2>>>
+ <SET SVT .VARTBL>
+ <SET VARTBL .SVTBL>
+ <COND (<N==? .SVTBL .SVT>
+ <REPEAT ((SV .SVT))
+ #DECL ((SV) SYMTAB)
+ <COND (<==? <NEXT-SYM .SV> .SVTBL>
+ <PUT .SV ,NEXT-SYM .VARTBL>
+ <SET VARTBL .SVT>
+ <RETURN>)
+ (ELSE <SET SV <NEXT-SYM .SV>>)>>)>
+ <AND <L? <SET TRG <- .ARGN 1>> 0> <SET RQRG -1>>
+ <COND (<OR <NOT .ACS:TOP> <=? .ACS:TOP '(() STACK)>>
+ <REPEAT ((BB ()) B (CHNG T) (N1 0) (N2 0) TEM)
+ #DECL ((BB B) <LIST [REST SYMTAB]> (N1 N2) FIX (TEM) SYMTAB)
+ <COND (<EMPTY? .BB>
+ <OR .CHNG <RETURN>>
+ <SET CHNG <>>
+ <SET N1 0>
+ <SET B .BNDL:TOP>
+ <SET BB <REST .B>>
+ <AGAIN>)>
+ <COND (<NOT <0? <SET N2 <ARGNUM-SYM <SET TEM <1 .BB>>>>>>
+ <COND (<G? .N1 .N2>
+ <PUT .BB 1 <1 .B>>
+ <PUT .B 1 .TEM>
+ <SET CHNG T>)
+ (ELSE <SET N1 .N2>)>)
+ (ELSE <SET BB ()> <AGAIN>)>
+ <SET B <REST .B>>
+ <SET BB <REST .BB>>>)>
+ (<REST .RES:TOP>
+ <REST .BNDL:TOP>
+ !<COND (.ACS:TOP (<REST .ACS:TOP>)) (ELSE ())!>)>
+
+
+<DEFINE SRCH-SYM (ATM "AUX" (TB .VARTBL))
+ #DECL ((ATM) ATOM (TB) <PRIMTYPE VECTOR>)
+ <REPEAT ()
+ <AND <EMPTY? .TB> <RETURN <>>>
+ <AND <==? .ATM <NAME-SYM .TB>> <RETURN .TB>>
+ <SET TB <NEXT-SYM .TB>>>>
+
+"Vector of legal strings in decl list."
+
+<SETG TOT-MODES
+ ["BIND"
+ "CALL"
+ "OPT"
+ "OPTIONAL"
+ "ARGS"
+ "TUPLE"
+ "AUX"
+ "EXTRA"
+ "ACT"
+ "NAME"]>
+
+"Amount to rest off decl vector after each encounter."
+
+<SETG RESTS ![1 2 1 2 1 2 1 2 1 1!]>
+
+"This function used for normal args when \"BIND\" and \"CALL\" still possible."
+
+<DEFINE INIT-D (OBJ TYP) #DECL ((MODE) <VECTOR STRING>)
+ <SET MODE <REST .MODE>> <INIT1-D .OBJ .TYP>>
+
+"This function for normal args when \"CALL\" still possible."
+
+<DEFINE INIT1-D (OBJ TYP)
+ #DECL ((MODE) <VECTOR STRING>)
+ <SET MODE <REST .MODE>>
+ <SET DOIT ,NORM-D>
+ <NORM-D .OBJ .TYP>>
+\f
+"Handle a normal argument or quoted normal argument."
+
+<DEFINE NORM-D (OBJ TYP) #DECL ((TYP) ATOM (RQRG ARGN) FIX (DCL) DECL)
+ <AND <==? .TYP LIST>
+ <MESSAGE ERROR " LIST NOT IN OPT OR AUX " .OBJ>>
+ <SET RQRG <+ .RQRG 1>>
+ <COND (<==? .TYP ATOM>
+ <PUT-RES (<PUT-DCL 13 .OBJ <><FIND:DECL .OBJ .DCL> T>)>)
+ (<SET OBJ <QUOTCH .OBJ>>
+ <PUT-RES ("QUOTE" <PUT-DCL 12 .OBJ <> <FIND:DECL .OBJ .DCL> T>)>)>
+ <SET ARGN <+ .ARGN 1>>>
+
+"Handle \"BIND\" decl."
+
+<DEFINE BIND-D (OBJ TYP "AUX" DC) #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
+ <SET ACS:TOP <>>
+ <OR <==? .TYP ATOM> <MESSAGE ERROR " BAD BIND " .OBJ>>
+ <SET DC <PUT-DCL 11 .OBJ <> <FIND:DECL .OBJ .DCL> T>>
+ <TYPE-ATOM-OK? .DC ENVIRONMENT .OBJ>
+ <SET DOIT ,INIT1-D>>
+
+"Handle \"CALL\" decl."
+
+<DEFINE CALL-D (OBJ TYP "AUX" DC) #DECL ((TYP) ATOM (RQRG ARGN) FIX (DCL) DECL)
+ <SET RQRG <+ .RQRG 1>>
+ <OR <==? .TYP ATOM> <MESSAGE ERROR " BAD CALL " .OBJ>>
+ <PUT-RES (<SET DC <PUT-DCL 10 .OBJ <> <FIND:DECL .OBJ .DCL> T>>)>
+ <TYPE-ATOM-OK? .DC FORM .OBJ>
+ <SET ARGN <+ .ARGN 1>>
+ <SET DOIT ,ERR-D>>
+
+"Flush on extra atoms after \"CALL\", \"ARGS\" etc."
+
+<DEFINE ERR-D (OBJ TYPE) <MESSAGE ERROR " BAD SYNTAX ARGLIST " .OBJ>>
+
+"Handle \"OPTIONAL\" decl."
+
+<DEFINE OPT-D (OBJ TYP "AUX" DC OBJ1)
+ #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
+ <COND (.ACS:TOP <SET ACS:TOP '(() STACK)>)> ;"Temporary until know how to win."
+ <COND (<==? .TYP ATOM>
+ <PUT-RES (<PUT-DCL 9 .OBJ <><FIND:DECL .OBJ .DCL> <>>)>)
+ (<==? .TYP FORM>
+ <SET OBJ <QUOTCH .OBJ>>
+ <PUT-RES ("QUOTE" <PUT-DCL 8 .OBJ <> <FIND:DECL .OBJ .DCL> <>>)>)
+ (<TYPE? <SET OBJ1 <LISTCH .OBJ>> ATOM>
+ <PUT-RES (<PAUX .OBJ1 <2 <CHTYPE .OBJ LIST>> <FIND:DECL .OBJ1 .DCL> 7>)>)
+ (<TYPE? .OBJ1 FORM>
+ <SET OBJ1 <QUOTCH .OBJ1>>
+ <PUT-RES ("QUOTE"
+ <PAUX .OBJ1 <2 <CHTYPE .OBJ LIST>> <FIND:DECL .OBJ1 .DCL> 6>)>)
+ (ELSE <MESSAGE ERROR "BAD USE OF OPTIONAL " .OBJ>)>
+ <SET ARGN <+ .ARGN 1>>>
+
+"Handle \"ARGS\" decl."
+
+<DEFINE ARGS-D (OBJ TYP "AUX" DC)
+ #DECL ((TYP) ATOM (RQRG ARGN) FIX (DCL) DECL (BNDL:BOT) <LIST SYMTAB>)
+ <COND (.ACS:TOP <SET ACS:TOP '(() STACK)>)> ;"Temporary until know how to win."
+ <OR <==? .TYP ATOM> <MESSAGE ERROR " BAD ARGS " .OBJ>>
+ <PUT-RES (<SET DC <PUT-DCL 5 .OBJ <> <FIND:DECL .OBJ .DCL> <>>>)>
+ <TYPE-ATOM-OK? .DC LIST .OBJ>
+ <SET DOIT ,ERR-D>
+ <SET ARGN <+ .ARGN 1>>>
+
+"Handle \"TUPLE\" decl."
+
+<DEFINE TUP-D (OBJ TYP "AUX" DC)
+ #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
+ <OR <==? .TYP ATOM> <MESSAGE ERROR " BAD TUPLE " .OBJ>>
+ <COND (<1? .ARGN> <SET ARGN 0> <SET ACS:TOP '(() STACK)>)
+ (ELSE <SET ACS:TOP <>>)>
+ <PUT-RES (<SET DC <PUT-DCL 4 .OBJ <> <FIND:DECL .OBJ .DCL> <>>>)>
+ <TYPE-ATOM-OK? .DC TUPLE .OBJ>
+ <SET DOIT ,ERR-D>>
+
+\f
+"Handle \"AUX\" decl."
+
+<DEFINE AUX-D (OBJ TYP "AUX" DC OBJ1)
+ #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
+ <AND <==? .TYP FORM> <MESSAGE ERROR " QUOTED AUX " .OBJ>>
+ <COND (<==? .TYP ATOM>
+ <PUT-DCL 3 .OBJ <> <FIND:DECL .OBJ .DCL> <>>)
+ (<TYPE? <SET OBJ1 <LISTCH .OBJ>> ATOM>
+ <PAUX .OBJ1 <2 .OBJ> <FIND:DECL .OBJ1 .DCL> 2>)
+ (ELSE <MESSAGE ERROR " QUOTED AUX " .OBJ>)>>
+
+"Handle \"NAME\" and \"ACT\" decl."
+
+<DEFINE ACT-D (OBJ TYP "AUX" DC)
+ #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
+ <OR <==? .TYP ATOM>
+ <MESSAGE ERROR " BAD ACTIVATION " .OBJ>>
+ <SET DC <PUT-DCL 1 .OBJ <> <FIND:DECL .OBJ .DCL> <>>>
+ <TYPE-ATOM-OK? .DC ACTIVATION .OBJ>>
+
+"Fixup activation atoms after node generated."
+
+<DEFINE ACT-FIX (N L "AUX" (FLG <>)) #DECL ((N) NODE (L) <LIST [REST SYMTAB]>)
+ <REPEAT (SYM) #DECL ((SYM) SYMTAB)
+ <AND <EMPTY? .L> <RETURN .FLG>>
+ <COND (<AND <==? <CODE-SYM <SET SYM <1 .L>>> 1>
+ <SET FLG T>
+ <NOT <SPEC-SYM .SYM>>>
+ <PUT .SYM ,RET-AGAIN-ONLY .N>)>
+ <SET L <REST .L>>>>
+
+"Table of varius decl handlers."
+
+<SETG DOITS
+ ![,ACT-D ,ACT-D ,AUX-D ,AUX-D ,TUP-D ,ARGS-D ,OPT-D ,OPT-D ,CALL-D
+ ,BIND-D!]>
+
+<GDECL (DOITS) UVECTOR (TOT-MODES) <VECTOR [REST STRING]> (RESTS) <UVECTOR [REST FIX]>>
+
+"Check for quoted arguments."
+
+<DEFINE QUOTCH (OB) #DECL ((OB) FORM (VALUE) ATOM)
+ <COND (<AND <==? <LENGTH .OB> 2>
+ <==? <1 .OB> QUOTE>
+ <TYPE? <2 .OB> ATOM>>
+ <2 .OB>)
+ (ELSE <MESSAGE ERROR " BAD FORM IN ARGLIST " .OB> T)>>
+
+"Chech for (arg init) or ('arg init)."
+
+<DEFINE LISTCH (OB) #DECL ((OB) LIST)
+ <COND (<AND <==? <LENGTH .OB> 2>
+ <OR <TYPE? <1 .OB> ATOM>
+ <AND <TYPE? <1 .OB> FORM> <QUOTCH <1 .OB>>>>>
+ <1 .OB>)
+ (ELSE <MESSAGE ERROR " BAD LIST IN ARGLIST " .OB> T)>>
+
+"Add a decl to RSUBR decls and update AC call spec."
+
+<DEFINE PUT-RES (L "AUX" TY)
+ #DECL ((L) LIST (NACS) FIX (ACS:BOT RES:BOT) LIST)
+ <PROG ()
+ <SET RES:BOT <REST <PUTREST .RES:BOT .L> <LENGTH .L>>>
+ <COND (<AND .ACS:TOP <OR <G? .NACS 5> <=? .ACS:TOP '(() STACK)>>>
+ <SET ACS:TOP '(() STACK)> <RETURN>)>
+ <COND (<AND .ACS:TOP
+ <REPEAT ()
+ <COND (<EMPTY? .L><RETURN <>>)
+ (<TYPE? <SET TY <1 .L>> STRING>
+ <SET L <REST .L>>)
+ (ELSE <RETURN T>)>>>
+ <COND (<SET TY <ISTYPE-GOOD? .TY>>
+ <SET ACS:BOT <REST <PUTREST .ACS:BOT
+ ((.TY <NTH ,ALLACS .NACS>))>>>
+ <SET NACS <+ .NACS 1>>)
+ (<L? <SET NACS <+ .NACS 2>> 7>
+ <SET ACS:BOT <REST <PUTREST .ACS:BOT
+ ((<NTH ,ALLACS <- .NACS 2>>
+ <NTH ,ALLACS <- .NACS 1>>))>>>)
+ (ELSE <SET ACS:TOP '(() STACK)>)>)>
+ T>>
+
+"Add code to set up a certain kind of argument."
+
+<DEFINE PUT-DCL (COD ATM VAL DC COM "AUX" SPC DC1 TT SYM)
+ #DECL ((DC1) FORM (ATM) ATOM (BNDL:BOT BNDL:TOP TT) LIST (COD) FIX
+ (SYM) SYMTAB)
+ <COND (<AND <TYPE? .DC FORM>
+ <SET DC1 .DC>
+ <==? <LENGTH .DC1> 2>
+ <OR <SET SPC <==? <1 .DC1> SPECIAL>>
+ <==? <1 .DC1> UNSPECIAL>>>
+ <SET DC <2 .DC1>>)
+ (ELSE <SET SPC .GLOSP>)>
+ <SET SYM <ADDVAR .ATM .SPC .COD .ARGN T (.DC) <> .VAL>>
+ <COND (<AND .COM <NOT <SPEC-SYM .SYM>>> ;"Can specials commute?"
+ <SET TT <REST .BNDL:TOP>>
+ <PUTREST .BNDL:TOP (.SYM !.TT)>
+ <AND <EMPTY? .TT> <SET BNDL:BOT <REST .BNDL:TOP>>>)
+ (ELSE <SET BNDL:BOT <REST <PUTREST .BNDL:BOT (.SYM)>>>)>
+ .DC>
+
+"Find decl associated with a variable, if none, use ANY."
+
+<DEFINE FIND:DECL (ATM "OPTIONAL" (DC .DECLS))
+ #DECL ((DC) <PRIMTYPE LIST> (ATM) ATOM)
+ <REPEAT (TT)
+ #DECL ((TT) LIST)
+ <AND <OR <EMPTY? .DC> <EMPTY? <SET TT <REST .DC>>>>
+ <RETURN ANY>>
+ <COND (<NOT <TYPE? <1 .DC> LIST>>
+ <MESSAGE ERROR " BAD DECL LIST " .DC>)>
+ <AND <MEMQ .ATM <CHTYPE <1 .DC> LIST>> <RETURN <1 .TT>>>
+ <SET DC <REST .TT>>>>
+
+"Add an AUX variable spec to structure."
+
+<DEFINE PAUX (ATM OBJ DC NTUP "AUX" EV TT)
+ #DECL ((EV TT) NODE (TUP NTUP) FIX (ATM) ATOM)
+ <COND (<AND <TYPE? .OBJ FORM>
+ <NOT <EMPTY? .OBJ>>
+ <OR <==? <1 .OBJ> TUPLE> <==? <1 .OBJ> ITUPLE>>>
+ <SET TT
+ <NODEFM <COND (<==? <1 .OBJ> TUPLE> ,COPY-CODE)
+ (ELSE ,ISTRUC-CODE)>
+ ()
+ TUPLE
+ <1 .OBJ>
+ ()
+ ,<1 .OBJ>>>
+ <COND (<==? <NODE-TYPE .TT> ,ISTRUC-CODE>
+ <SET EV
+ <PCOMP <COND (<==? <LENGTH .OBJ> 3> <3 .OBJ>)
+ (ELSE #LOSE *000000000000*)>
+ .TT>>
+ <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
+ <SET EV <PCOMP <NODE-NAME .EV> .TT>>
+ ;"Reanalyze it."
+ <PUT .TT ,NODE-TYPE ,ISTRUC2-CODE>)>
+ <PUT .TT ,KIDS (<PCOMP <2 .OBJ> .TT> .EV)>)
+ (ELSE
+ <PUT .TT
+ ,KIDS
+ <MAPF ,LIST
+ <FUNCTION (O) <PCOMP .O .TT>>
+ <REST .OBJ>>>)>)
+ (ELSE <SET TT <PCOMP .OBJ ()>>)>
+ <PUT-DCL .NTUP .ATM .TT .DC <>>>
+
+"Main dispatch function during pass1."
+
+<DEFINE PCOMP (OBJ PARENT)
+ #DECL ((PARENT) <SPECIAL ANY> (VALUE) NODE)
+ <APPLY <OR <GET .OBJ PTHIS-OBJECT>
+ <GET <TYPE .OBJ> PTHIS-TYPE>
+ ,PDEFAULT>
+ .OBJ>>
+
+"Build a node for <> or #FALSE ()."
+
+<DEFINE FALSE-QT (O)
+ #DECL ((VALUE) NODE)
+ <NODE1 ,QUOTE-CODE .PARENT FALSE <> ()>>
+
+<PUT '<> PTHIS-OBJECT ,FALSE-QT>
+
+"Build a node for ()."
+
+<DEFINE NIL-QT (O) #DECL ((VALUE) NODE)
+ <NODE1 ,QUOTE-CODE .PARENT LIST () ()>>
+
+<PUT () PTHIS-OBJECT ,NIL-QT>
+
+"Build a node for a LIST, VECTOR or UVECTOR."
+
+<DEFINE PCOPY (OBJ "AUX" (TT <NODEFM ,COPY-CODE .PARENT <TYPE .OBJ> <TYPE .OBJ> () <>>))
+ #DECL ((VALUE) NODE (TT) NODE)
+ <PUT .TT ,KIDS
+ <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> .OBJ>>>
+
+<PUT VECTOR PTHIS-TYPE ,PCOPY>
+
+<PUT UVECTOR PTHIS-TYPE ,PCOPY>
+
+<PUT LIST PTHIS-TYPE ,PCOPY>
+
+"Build a node for unknown things."
+
+<DEFINE PDEFAULT (OBJ) #DECL ((VALUE) NODE)
+ <NODE1 ,QUOTE-CODE .PARENT <TYPE .OBJ> .OBJ ()>>
+
+"Further analyze a FORM and build appropriate node."
+
+<DEFINE PFORM (OBJ) #DECL ((OBJ) <FORM ANY> (VALUE) NODE)
+ <PROG APPLICATION ((APPLY <1 .OBJ>))
+ #DECL ((APPLICATION) <SPECIAL ACTIVATION>
+ (APPLY) <SPECIAL ANY>)
+ <APPLY <OR <GET .APPLY PAPPLY-OBJECT>
+ <GET <TYPE .APPLY> PAPPLY-TYPE>
+ ,PAPDEF>
+ .OBJ .APPLY>>>
+
+<PUT FORM PTHIS-TYPE ,PFORM>
+
+"Build a SEGMENT node."
+
+<DEFINE SEG-FCN (OBJ "AUX" (TT <NODE1 ,SEGMENT-CODE .PARENT <> <> ()>))
+ #DECL ((TT VALUE PARENT) NODE)
+ <PUT .TT ,KIDS (<PFORM <CHTYPE .OBJ FORM>>)>>
+
+<PUT SEGMENT PTHIS-TYPE ,SEG-FCN>
+
+"Analyze a form or the form <ATM .....>"
+
+<DEFINE ATOM-FCN (OB AP) #DECL ((AP) ATOM (VALUE) NODE)
+ <COND (<GASSIGNED? .AP>
+ <SET APPLY ,.AP>
+ <AGAIN .APPLICATION>)
+ (<ASSIGNED? .AP>
+ <MESSAGE WARNING " LOCAL VALUE USED FOR " .AP>
+ <SET APPLY ..AP>
+ <AGAIN .APPLICATION>)
+ (.REASONABLE
+ <PSUBR-C .OB DUMMY>)
+ (ELSE <MESSAGE WARNING " NO VALUE FOR " .AP>
+ <PAPDEF .OB .AP>)>>
+
+<PUT ATOM PAPPLY-TYPE ,ATOM-FCN>
+
+"Expand MACRO and process result."
+
+<DEFINE PMACRO (OBJ AP "AUX" ERR TEM)
+ <SET ERR <ON "ERROR" ,MACROERR 100>> ;"Turn On new Error"
+ <SET TEM <PROG MACACT ()
+ #DECL ((MACACT) <SPECIAL ACTIVATION>)
+ <SETG MACACT .MACACT>
+ <EXPAND .OBJ>>>
+ <OFF .ERR> ;"Turn OFF new Error"
+ <COND (<TYPE? .TEM FUNNY>
+ <MESSAGE ERROR " MACRO EXPANSION LOSSAGE " !.TEM>)
+ (ELSE
+ <PCOMP .TEM .PARENT>)>>
+
+<NEWTYPE FUNNY VECTOR>
+<PROG (X) ;"Find the real Valret Subr"
+ <COND (<TYPE? ,VALRET SUBR> <SETG REAL-VALRET ,VALRET>)
+ (<AND <GASSIGNED? <SET X <PARSE "OVALRET!-COMBAT!-">>>
+ <TYPE? ,.X SUBR>>
+ <SETG REAL-VALRET ,.X>)
+ (<NOT <GASSIGNED? REAL-VALRET>> <ERROR ',VALRET COMPILE>)>>
+<PUT MACRO PAPPLY-TYPE ,PMACRO>
+
+<DEFINE MACROERR (FR "TUPLE" T)
+ #DECL ((T) TUPLE)
+ <COND (<AND <GASSIGNED? MACACT> <LEGAL? ,MACACT>>
+ <DISMISS <CHTYPE [!.T] FUNNY> ,MACACT>)
+ (ELSE <REAL-VALRET " ">)>>
+
+"Build a node for a form whose 1st element is a form (could be NTH)."
+
+<DEFINE PFORM-FORM (OBJ AP "AUX" TT)
+ #DECL ((TT) NODE (VALUE) NODE (OBJ) FORM)
+ <COND (<AND <==? <LENGTH .OBJ> 2> <NOT <SEG? .OBJ>>>
+ <SET TT <NODEFM ,FORM-F-CODE .PARENT <> .OBJ () .AP>>
+ <PUT .TT ,KIDS
+ <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> .OBJ>>)
+ (ELSE <PAPDEF .OBJ .AP>)>>
+
+<PUT FORM PAPPLY-TYPE ,PFORM-FORM>
+
+"Build a node for strange forms."
+
+<DEFINE PAPDEF (OBJ AP) #DECL ((VALUE) NODE)
+ <MESSAGE WARNING " FORM NOT BEING COMPILED " .OBJ>
+ <SPECIALIZE .OBJ>
+ <NODEFM ,FORM-CODE .PARENT <> .OBJ () .AP>>
+
+"For objects that require EVAL, make sure all atoms used are special."
+
+<DEFINE SPECIALIZE (OBJ "AUX" T1 T2 SYM OB)
+ #DECL ((T1) FIX (OB) FORM (T2) <OR FALSE SYMTAB>)
+ <COND (<AND <TYPE? .OBJ FORM SEGMENT>
+ <SET OB <CHTYPE .OBJ FORM>>
+ <OR <AND <==? <SET T1 <LENGTH .OB>> 2>
+ <==? <1 .OB> LVAL>
+ <TYPE? <SET SYM <2 .OB>> ATOM>>
+ <AND <==? .T1 3>
+ <==? <1 .OB> SET>
+ <TYPE? <SET SYM <2 .OB>> ATOM>>>
+ <SET T2 <SRCH-SYM .SYM>>>
+ <COND (<NOT <SPEC-SYM .T2>>
+ <MESSAGE NOTE " REDCLARED SPECIAL " .SYM>
+ <PUT .T2 ,SPEC-SYM T>)>)>
+ <COND (<MEMQ <PRIMTYPE .OBJ> '![FORM LIST UVECTOR VECTOR!]>
+ <MAPF <> ,SPECIALIZE .OBJ>)>>
+
+"Build a SUBR call node."
+
+<DEFINE PSUBR-C (OBJ AP "AUX" (TT <NODEFM ,SUBR-CODE .PARENT <>
+ <SUBR-NAME .AP <1 .OBJ>> () .AP>))
+ #DECL ((TT) NODE (VALUE) NODE (OBJ) FORM)
+ <PUT .TT ,KIDS
+ <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> <REST .OBJ>>>>
+
+<PUT SUBR PAPPLY-TYPE ,PSUBR-C>
+
+<FLOAD "SBRNAM" "NBIN">
+
+<DEFINE SUBR-NAME (THING DEFAULT)
+ <COND (<TYPE? .THING SUBR> <HACK-NAME .THING>)
+ (<TYPE? .THING RSUBR RSUBR-ENTRY> <2 .THING>)
+ (ELSE .DEFAULT)>>
+
+<DEFINE FIX-FCN (OBJ AP "AUX" TT (LN <LENGTH .OBJ>))
+ #DECL ((TT VALUE) NODE (OBJ) FORM)
+ <OR <==? .LN 2> <==? .LN 3>
+ <MESSAGE ERROR " BAD APPLICATION OF A NUMBER ">>
+ <SET TT <NODEFM ,SUBR-CODE .PARENT <> <COND (<==? .LN 2> INTH)(ELSE IPUT)>
+ () <COND (<==? .LN 2> ,NTH) (ELSE ,PUT)>>>
+ <PUT .TT ,KIDS (<PCOMP <2 .OBJ> .TT><PCOMP .AP .TT>
+ !<COND (<==? .LN 2> ()) (ELSE (<PCOMP <3 .OBJ> .TT>))>)>>
+
+<PUT FIX PAPPLY-TYPE ,FIX-FCN>
+
+<PUT OFFSET PAPPLY-TYPE ,FIX-FCN>
+
+"PROG/REPEAT node."
+
+<DEFINE PPROG-REPEAT (OBJ AP
+ "AUX" (NAME <1 .OBJ>) TT (DCL #DECL ()) (HATOM <>) ARGL
+ (VARTBL .VARTBL))
+ #DECL ((OBJ) <PRIMTYPE LIST> (TT) NODE (VALUE) NODE (DCL) DECL
+ (ARGL) LIST (VARTBL) <SPECIAL SYMTAB>)
+ <AND <EMPTY? <SET OBJ <REST .OBJ>>>
+ <MESSAGE ERROR " EMPTY " .NAME>>
+ <AND <TYPE? <1 .OBJ> ATOM>
+ <SET HATOM <1 .OBJ>>
+ <SET OBJ <REST .OBJ>>>
+ <SET ARGL <1 .OBJ>>
+ <SET OBJ <REST .OBJ>>
+ <AND <NOT <EMPTY? .OBJ>>
+ <TYPE? <1 .OBJ> DECL>
+ <SET DCL <1 .OBJ>>
+ <SET OBJ <REST .OBJ>>>
+ <AND <EMPTY? .OBJ> <MESSAGE ERROR " NO DODY FOR " .NAME>>
+ <SET TT
+ <NODEPR ,PROG-CODE
+ .PARENT
+ <FIND:DECL VALUE .DCL>
+ .NAME
+ ()
+ .AP
+ <2 <GEN-D <COND (<AND <NOT <EMPTY? .ARGL>>
+ <TYPE? <1 .ARGL> STRING>>
+ .ARGL)
+ (ELSE ("AUX" !.ARGL))>
+ .DCL
+ .HATOM>>
+ .HATOM
+ .VARTBL>>
+ <ACT-FIX .TT <BINDING-STRUCTURE .TT>>
+ <PUT .TT
+ ,KIDS
+ <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> .OBJ>>
+ .TT>
+
+<PUT ,PROG PAPPLY-OBJECT ,PPROG-REPEAT>
+
+<PUT ,REPEAT PAPPLY-OBJECT ,PPROG-REPEAT>
+
+<PUT ,BIND PAPPLY-OBJECT ,PPROG-REPEAT>
+
+"Unwind compiler."
+
+<DEFINE UNWIND-FCN (OBJ AP "AUX" (TT <NODEFM ,UNWIND-CODE .PARENT <>
+ <1 .OBJ> () .AP>))
+ #DECL ((PARENT VALUE TT) NODE (OBJ) FORM)
+ <COND (<==? <LENGTH .OBJ> 3>
+ <PUT .TT ,KIDS (<PCOMP <2 .OBJ> .TT> <PCOMP <3 .OBJ> .TT>)>)
+ (ELSE <MESSAGE ERROR "WRONG # OF ARGS TO UNWIND " .OBJ>)>>
+
+<PUT ,UNWIND PAPPLY-OBJECT ,UNWIND-FCN>
+
+"Build a node for a COND."
+
+<DEFINE COND-FCN (OBJ AP "AUX" (PARENT <NODECOND ,COND-CODE .PARENT <> COND ()>))
+ #DECL ((PARENT) <SPECIAL NODE> (OBJ) <FORM ANY> (VALUE) NODE)
+ <PUT .PARENT ,KIDS
+ <MAPF ,LIST
+ <FUNCTION (CLA "AUX" (TT <NODEB ,BRANCH-CODE .PARENT <> <> ()>))
+ #DECL ((TT) NODE)
+ <COND (<AND <TYPE? .CLA LIST> <NOT <EMPTY? .CLA>>>
+ <PUT .TT ,PREDIC <PCOMP <1 .CLA> .TT>>
+ <PUT .TT ,CLAUSES
+ <MAPF ,LIST
+ <FUNCTION (O) <PCOMP .O .TT>>
+ <REST .CLA>>>)
+ (ELSE <MESSAGE ERROR "BAD COND" .OBJ>)>>
+ <REST .OBJ>>>>
+
+<PUT ,COND PAPPLY-OBJECT ,COND-FCN>
+
+<PUT ,AND PAPPLY-OBJECT <GET SUBR PAPPLY-TYPE>>
+
+<PUT ,OR PAPPLY-OBJECT <GET SUBR PAPPLY-TYPE>>
+
+<PUT ,STACKFORM PAPPLY-OBJECT <GET SUBR PAPPLY-TYPE>>
+
+"Build a node for '<\b-object>\b-."
+
+<DEFINE QUOTE-FCN (OBJ AP "AUX" (TT <NODE1 ,QUOTE-CODE .PARENT <> () ()>))
+ #DECL ((TT VALUE) NODE (OBJ) FORM)
+ <COND (<NOT <EMPTY? <REST .OBJ>>>
+ <PUT .TT ,RESULT-TYPE <TYPE <2 .OBJ>>>
+ <PUT .TT ,NODE-NAME <2 .OBJ>>)>>
+
+<PUT ,QUOTE PAPPLY-OBJECT ,QUOTE-FCN>
+
+"Build a node for a call to an RSUBR."
+
+<DEFINE RSUBR-FCN (OBJ AP "AUX" (PARENT <NODEFM ,RSUBR-CODE .PARENT <><1 .OBJ> () .AP>))
+ #DECL ((OBJ) FORM (AP) <OR RSUBR-ENTRY RSUBR> (PARENT) <SPECIAL NODE>
+ (VALUE) NODE)
+ <COND (<AND <G? <LENGTH .AP> 2>
+ <TYPE? <3 .AP> DECL>>
+ <PUT .PARENT ,KIDS <PRSUBR-C <1 .OBJ> .OBJ <3 .AP>>>
+ <PUT .PARENT ,TYPE-INFO
+ <MAPF ,LIST
+ <FUNCTION (X) <RESULT-TYPE .X>> <KIDS .PARENT>>>)
+ (ELSE <PSUBR-C .OBJ .AP>)>>
+
+<PUT RSUBR PAPPLY-TYPE ,RSUBR-FCN>
+
+<PUT RSUBR-ENTRY PAPPLY-TYPE <GET RSUBR PAPPLY-TYPE>>
+
+<DEFINE INTERNAL-RSUBR-FCN (OBJ AP
+ "AUX" (PARENT <NODEFM ,IRSUBR-CODE .PARENT <>
+ <1 .OBJ> () .AP>))
+ #DECL ((OBJ) FORM (AP) IRSUBR (PARENT) <SPECIAL NODE>)
+ <PUT .PARENT ,KIDS <PRSUBR-C <1 .OBJ> .OBJ <1 .AP>>>
+ <PUT .PARENT ,TYPE-INFO
+ <MAPF ,LIST
+ <FUNCTION (X) <RESULT-TYPE .X>> <KIDS .PARENT>>>>
+
+<PUT IRSUBR PAPPLY-TYPE ,INTERNAL-RSUBR-FCN>
+
+"Predicate: any segments in this object?"
+
+<DEFINE SEG? (OB) #DECL ((OB) <PRIMTYPE LIST>)
+ <REPEAT ()
+ <AND <EMPTY? .OB> <RETURN <>>>
+ <AND <TYPE? <1 .OB> SEGMENT> <RETURN T>>
+ <SET OB <REST .OB>>>>
+
+
+"Analyze a call to an RSUBR with decls checking number of args and types wherever
+ possible."
+
+<DEFINE PRSUBR-C (NAME OBJ RDCL
+ "AUX" (DOIT ,INIT-R) (SEGSW <>) (SGD '<>) (SGP '(1)) SGN
+ (IX 0) DC (RM ,RMODES) (ARG-NUMBER 0) (KDS (()))
+ (TKDS .KDS) RMT (OB <REST .OBJ>) (ST <>))
+ #DECL ((TKDS KDS) <SPECIAL LIST> (OB) LIST (OBJ) <SPECIAL <PRIMTYPE LIST>>
+ (RM) <SPECIAL <VECTOR [REST STRING]>> (ARG-NUMBER) FIX
+ (RDCL) <SPECIAL <PRIMTYPE LIST>> (DOIT SEGSW) <SPECIAL ANY> (IX) FIX
+ (NAME) <SPECIAL ANY> (SGD) FORM (SGP) <LIST ANY> (SGN) NODE)
+ <REPEAT RSB ()
+ #DECL ((RSB) <SPECIAL ACTIVATION>)
+ <COND
+ (<NOT <EMPTY? .RDCL>>
+ <COND (<NOT <EMPTY? .RM>>
+ <SET DC <1 .RDCL>>
+ <SET RDCL <REST .RDCL>>)>
+ <COND
+ (<TYPE? .DC STRING>
+ <COND (<=? .DC "OPT"> <SET DC "OPTIONAL">)>
+ <OR <SET RMT <MEMBER .DC .RM>>
+ <MESSAGE ERROR "BAD STRING IN RSUBR DECL " .NAME>>
+ <SET RM .RMT>
+ <SET DOIT <NTH ,RDOIT <SET IX <LENGTH .RM>>>>
+ <SET ST <APPLY <NTH ,SDOIT .IX> .ST>>
+ <COND (<EMPTY? .RM> ;"TUPLE seen."
+ <SET DC <GET-ELE-TYPE <1 .RDCL> ALL>>)>)
+ (<COND
+ (<EMPTY? .OB>
+ <AND <L? <LENGTH .RM> 4> <RETURN <REST .TKDS>>>
+ <MESSAGE ERROR " TOO FEW ARGS TO " .NAME>)
+ (.SEGSW
+ <SET ST <>>
+ <COND (<EMPTY? .RM>
+ <PUTREST .SGP ([REST .DC])>
+ <PUT .SGN ,RESULT-TYPE <TYPE-AND <RESULT-TYPE .SGN> .SGD>>
+ <RETURN <REST .TKDS>>)
+ (ELSE <SET SGP <REST <PUTREST .SGP (.DC)>>>)>)
+ (<TYPE? <1 .OB> SEGMENT>
+ <SET KDS
+ <REST <PUTREST .KDS (<SET SGN <SEGCHK <1 .OB>>>)>>>
+ <COND
+ (<EMPTY? <REST .OB>>
+ <COND (<EMPTY? .RM>
+ <PUT .SGN
+ ,RESULT-TYPE
+ <SEGCH1 .DC <RESULT-TYPE .SGN> <1 .OB>>>
+ <RETURN <REST .TKDS>>)
+ (ELSE <SET SEGSW T>)>)
+ (ELSE
+ <PUTREST
+ .KDS
+ <MAPF ,LIST
+ <FUNCTION (O "AUX" TT)
+ <SET TT <PCOMP .O .PARENT>>
+ <COND
+ (<EMPTY? .RM>
+ <COND
+ (<==? <NODE-TYPE .TT> ,SEGMENT-CODE>
+ <OR <TYPE-OK? <RESULT-TYPE <1 <KIDS .TT>>>
+ <FORM STRUCTURED [REST .DC]>>
+ <MESSAGE ERROR "BAD ARG TO " .NAME .OB>>)
+ (ELSE
+ <OR <TYPE-OK? <RESULT-TYPE .TT> .DC>
+ <MESSAGE ERROR "BAD ARG TO " .NAME .OB>>
+ <OR <RESULT-TYPE .TT> <PUT .TT ,RESULT-TYPE .DC>>)>)>
+ .TT>
+ <REST .OB>>>
+ <RETURN <REST .TKDS>>)>
+ <SET SGP
+ <REST <CHTYPE <SET SGD <FORM STRUCTURED .DC>> LIST>>>
+ <SET ST <>>
+ <AGAIN>)
+ (<SET KDS <REST <PUTREST .KDS (<APPLY .DOIT .DC .OB>)>>>
+ <SET OB <REST .OB>>
+ <SET ARG-NUMBER <+ .ARG-NUMBER 1>>
+ <SET ST <>>)>)>)
+ (<EMPTY? .OB> <RETURN <REST .TKDS>>)
+ (.SEGSW
+ <PUT .SGN
+ ,RESULT-TYPE
+ <COND (<RESULT-TYPE .SGN> <TYPE-AND <RESULT-TYPE .SGN> .SGD>)
+ (ELSE .SGD)>>
+ <RETURN <REST .TKDS>>)
+ (ELSE <MESSAGE ERROR " TOO MANY ARGS TO " .NAME>)>>>
+\f
+
+<DEFINE SQUOT (F) T>
+
+"Flush one possible decl away."
+
+<DEFINE CHOPPER (F) #DECL ((RM) <VECTOR [REST STRING]>)
+ <AND .F <MESSAGE ERROR " 2 STRINGS IN ROW IN DCL ">>
+ <SET RM <REST .RM>>
+ T>
+
+"Handle Normal arg when \"VALUE\" still possible."
+
+<DEFINE INIT-R (DC OB)
+ #DECL ((RM) <VECTOR [REST STRING]>)
+ <SET RM <REST .RM 2>> <SET DOIT ,INIT1-R> <INIT1-R .DC .OB>>
+
+"Handle Normal arg when \"CALL\" still possible."
+
+<DEFINE INIT2-R (DC OB)
+ #DECL ((RM) <VECTOR [REST STRING]>)
+ <SET RM <REST .RM>> <SET DOIT ,INIT1-R> <INIT1-R .DC .OB>>
+
+"Handle normal arg."
+
+<DEFINE INIT1-R (DC OB "AUX" TT) #DECL ((TT) NODE (OB) LIST)
+ <OR <TYPE-OK?
+ <RESULT-TYPE
+ <SET TT <PCOMP <1 .OB> .PARENT>>> .DC>
+ <MESSAGE ERROR "BAD ARG TO " .NAME>>
+ <OR <RESULT-TYPE .TT><PUT .TT ,RESULT-TYPE .DC>>
+ .TT>
+
+"Handle \"QUOTE\" arg."
+
+<DEFINE QINIT-R (DC OB "AUX" TT) #DECL ((TT) NODE (OB) LIST)
+ <OR <TYPE-OK?
+ <RESULT-TYPE
+ <SET TT
+ <NODE1 ,QUOTE-CODE .PARENT <TYPE <1 .OB>>
+ <1 .OB> ()>>> .DC>
+ <MESSAGE ERROR "BAD ARG TO " .NAME>>
+ <SET DOIT ,INIT1-R>
+ .TT>
+
+"Handle \"CALL\" decl."
+
+<DEFINE CAL-R (DC OB "AUX" TT) #DECL ((TKDS KDS) LIST (TT) NODE)
+ <OR <TYPE-OK?
+ <RESULT-TYPE
+ <SET TT
+ <NODE1 ,QUOTE-CODE .PARENT FORM .OBJ ()>>> .DC>
+ <MESSAGE ERROR "BAD ARG TO " .NAME>>
+ <PUTREST .KDS (.TT)>
+ <RETURN <REST .TKDS> .RSB>>
+
+"Handle \"ARGS\" decl."
+
+<DEFINE ARGS-R (DC OB "AUX" TT) #DECL ((TT) NODE (KDS TKDS) LIST)
+ <OR <TYPE-OK?
+ <RESULT-TYPE
+ <SET TT
+ <NODE1 ,QUOTE-CODE .PARENT LIST .OB ()>>> .DC>
+ <MESSAGE "BAD CALL TO " .NAME>>
+ <PUTREST .KDS (.TT)>
+ <RETURN <REST .TKDS> .RSB>>
+
+"Handle \"TUPLE\" decl."
+
+<DEFINE TUPL-R (DC OB "AUX" TT) #DECL ((OB) LIST (TT) NODE)
+ <OR <TYPE-OK? <RESULT-TYPE <SET TT <PCOMP <1 .OB> .PARENT>>> .DC>
+ <MESSAGE ERROR "BAD ARG TO " .NAME>>
+ <OR <RESULT-TYPE .TT> <PUT .TT ,RESULT-TYPE .DC>>
+ .TT>
+
+"Handle stuff with segments in arguments."
+
+<DEFINE SEGCHK (OB "AUX" TT) #DECL ((TT) NODE)
+ <OR <TYPE-OK? <RESULT-TYPE <SET TT <PCOMP .OB .PARENT>>> STRUCTURED>
+ <MESSAGE ERROR "BAD SEGMENT GOODIE. " .OB>>
+ .TT>
+
+
+<DEFINE SEGCH1 (DC RT OB)
+ <OR <TYPE-AND .RT <FORM STRUCTURED [REST .DC]>>
+ <MESSAGE ERROR "BAD ARG TO " .NAME .OB>>>
+
+"Handle \"VALUE\" chop decl and do the rest."
+
+<DEFINE VAL-R (F) #DECL ((RDCL) <PRIMTYPE LIST> (PARENT) NODE)
+ <CHOPPER .F>
+ <PUT .PARENT ,RESULT-TYPE <1 .RDCL>>
+ <SET DOIT ,INIT2-R>
+ <SET F <TYPE? <1 .RDCL> STRING>>
+ <SET RDCL <REST .RDCL>> .F>
+
+<DEFINE ERR-R (DC OB)
+ <MESSAGE INCONISTANCY "SHOULDN'T GET HERE ">>
+
+<SETG RMODES ["VALUE" "CALL" "QUOTE" "OPTIONAL" "QUOTE" "ARGS" "TUPLE"]>
+
+<SETG RDOIT ![,TUPL-R ,ARGS-R ,QINIT-R ,INIT1-R ,QINIT-R ,CAL-R ,ERR-R!]>
+
+<SETG SDOIT ![,CHOPPER ,CHOPPER ,SQUOT ,CHOPPER ,SQUOT ,CHOPPER ,VAL-R!]>
+
+<GDECL (RMODES) <VECTOR [REST STRING]> (RDOIT SDOIT) UVECTOR>
+
+"Create a node for a call to a function."
+
+<DEFINE PFUNC (OB AP "AUX" TEM NAME)
+ #DECL ((OB) <PRIMTYPE LIST> (VALUE) NODE)
+ <COND (<TYPE? <1 .OB> ATOM>
+ <COND (<OR <==? <1 .OB> .FCNS>
+ <AND <TYPE? .FCNS LIST> <MEMQ <1 .OB> <CHTYPE .FCNS LIST>>>>
+ <RSUBR-CALL2 ,<1 .OB> <1 .OB> .OB>)
+ (<SET TEM <GET <1 .OB> RSUB-DEC>>
+ <RSUBR-CALL3 .TEM <1 .OB> .OB>)
+ (.REASONABLE <PSUBR-C .OB DUMMY>)
+ (ELSE
+ <MESSAGE WARNING "UNCOMPILED FUNCTION CALLED " <1 .OB>>
+ <PAPDEF .OB ,<1 .OB>>)>)
+ (<TYPE? <1 .OB> FUNCTION>
+ <SET NAME <MAKE:TAG "ANONF">>
+ <ANONF .NAME <1 .OB>>
+ <RSUBR-CALL1 ,.NAME .NAME .OB>)>>
+
+"Call compiler recursively to compile anonymous function."
+
+<DEFINE ANONF (NAME BODY "AUX" (INT? <>) T GROUP-NAME)
+ #DECL ((INT? GROUP-NAME) <SPECIAL <OR FALSE ATOM>> (VALUE) NODE)
+ <MESSAGE NOTE " COMPILING ANONYMOUS FUNCTION ">
+ <SETG .NAME .BODY>
+ <APPLY ,COMP2 .NAME T> ; "Use APPLY to avoid compilation probs."
+ <SET T ,.NAME>
+ <MESSAGE NOTE " FINISHED ANONYMOUS FUNCTION ">
+ <GUNASSIGN .NAME>
+ <NODE1 ,QUOTE-CODE .PARENT RSUBR .T ()>>
+
+"#FUNCTION (....) compiler -- call ANONF."
+
+<DEFINE FCN-FCN (OB "AUX" (NAME <MAKE:TAG "ANONF">)) <ANONF .NAME .OB>>
+
+<PUT FUNCTION PTHIS-TYPE ,FCN-FCN>
+
+<PUT FUNCTION PAPPLY-TYPE ,PFUNC>
+
+"<FUNCTION (..) ....> compiler -- call ANONF."
+
+<DEFINE FCN-FCN1 (OB AP "AUX" (NAME <MAKE:TAG "ANONF">))
+ #DECL ((OB) <PRIMTYPE LIST>)
+ <ANONF .NAME <CHTYPE <REST .OB> FUNCTION>>>
+
+<PUT ,FUNCTION PAPPLY-OBJECT ,FCN-FCN1>
+
+"Handle RSUBR that is really a function."
+
+<DEFINE RSUBR-CALL2 (BODY NAME OBJ "AUX" ACF
+ (PARENT <NODEFM ,RSUBR-CODE .PARENT <> .NAME () .BODY>))
+ #DECL ((PARENT) <SPECIAL NODE> (VALUE) NODE)
+ <PUT .PARENT
+ ,KIDS
+ <PRSUBR-C .NAME .OBJ <RSUBR-DECLS <SET ACF <PASS1 .BODY .NAME T .NAME>>>>>
+ <PUT .PARENT ,TYPE-INFO
+ <MAPF ,LIST
+ <FUNCTION (X) <RESULT-TYPE .X>> <KIDS .PARENT>>>>
+
+"Handle an RSUBR that is already an RSUBR."
+
+<DEFINE RSUBR-CALL1 (BODY NAME OBJ "AUX"
+ (PARENT <NODEFM ,RSUBR-CODE .PARENT <> .NAME () .BODY>))
+ #DECL ((BODY) <PRIMTYPE LIST> (PARENT) <SPECIAL NODE>
+ (VALUE) NODE)
+ <PUT .PARENT ,KIDS <PRSUBR-C .NAME .OBJ <3 .BODY>>>
+ <PUT .PARENT ,TYPE-INFO
+ <MAPF ,LIST
+ <FUNCTION (X) <RESULT-TYPE .X>> <KIDS .PARENT>>>>
+
+<DEFINE RSUBR-CALL3 (DC NAME OBJ "AUX"
+ (PARENT <NODEFM ,RSUBR-CODE .PARENT <> .NAME () FOO>))
+ #DECL ((PARENT) <SPECIAL NODE>
+ (VALUE) NODE)
+ <PUT .PARENT ,KIDS <PRSUBR-C .NAME .OBJ .DC>>
+ <PUT .PARENT ,TYPE-INFO
+ <MAPF ,LIST
+ <FUNCTION (X) <RESULT-TYPE .X>> <KIDS .PARENT>>>>
+
+\f
+;"ILIST, ISTRING, IVECTOR AND IUVECTOR"
+
+<DEFINE PLIST (O A) <PSTRUC .O .A ILIST LIST>>
+
+<PUT ,ILIST PAPPLY-OBJECT ,PLIST>
+
+<DEFINE PIVECTOR (O A) <PSTRUC .O .A IVECTOR VECTOR>>
+
+<PUT ,IVECTOR PAPPLY-OBJECT ,PIVECTOR>
+
+<DEFINE PISTRING (O A) <PSTRUC .O .A ISTRING STRING>>
+
+<PUT ,ISTRING PAPPLY-OBJECT ,PISTRING>
+
+<DEFINE PIUVECTOR (O A) <PSTRUC .O .A IUVECTOR UVECTOR>>
+
+<PUT ,IUVECTOR PAPPLY-OBJECT ,PIUVECTOR>
+
+<DEFINE PIFORM (O A) <PSTRUC .O .A IFORM FORM>>
+
+<PUT ,IFORM PAPPLY-OBJECT ,PIFORM>
+
+<DEFINE PIBYTES (O A) <PSTRUC .O .A IBYTES BYTES>>
+
+<PUT ,IBYTES PAPPLY-OBJECT ,PIBYTES>
+
+<DEFINE PSTRUC (OBJ AP NAME TYP "AUX" (TT <NODEFM ,ISTRUC-CODE .PARENT .TYP .NAME
+ () ,.NAME>)
+ (LN <LENGTH .OBJ>) N EV SIZ)
+ #DECL ((VALUE N EV TT) NODE (LN) FIX (OBJ) <PRIMTYPE LIST>)
+ <COND (<SEG? .OBJ><PSUBR-C .OBJ .AP>)
+ (ELSE
+ <COND (<==? .NAME IBYTES>
+ <COND (<L=? .LN 2> <ARGCHK 2 3 .NAME>)
+ (<G? .LN 4> <ARGCHK .LN 4 .NAME>)>)
+ (<1? .LN><ARGCHK 1 2 .NAME>)
+ (<G? .LN 3><ARGCHK .LN 3 .NAME>)>
+ <COND (<==? .NAME IBYTES>
+ <SET SIZ <PCOMP <2 .OBJ> .TT>>
+ <SET OBJ <REST .OBJ>>
+ <SET LN <- .LN 1>>)>
+ <SET N <PCOMP <2 .OBJ> .TT>>
+ <SET EV <PCOMP <COND (<==? .LN 3> <3 .OBJ>)
+ (<==? .TYP STRING> <ASCII 0>)
+ (<==? .TYP BYTES> 0)
+ (ELSE #LOSE 0)> .TT>>
+ <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
+ <SET EV <PCOMP <NODE-NAME .EV> .TT>> ;"Reanalyze it."
+ <PUT .TT ,NODE-TYPE ,ISTRUC2-CODE>)>
+ <PUT .TT ,RESULT-TYPE .TYP>
+ <COND (<ASSIGNED? SIZ> <PUT .TT ,KIDS (.SIZ .N .EV)>)
+ (ELSE <PUT .TT ,KIDS (.N .EV)>)>)>>
+
+\f
+
+"READ, READCHR, READSTRING, NEXTCHR, READB, GET, GETL, GETPROP, GETPL"
+
+<PUT ,READ PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A READ 2 ANY>>>
+
+<PUT ,GC-READ PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A GC-READ 2 ANY>>>
+
+<PUT ,READCHR PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A READCHR 2 ANY>>>
+
+<PUT ,NEXTCHR PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A NEXTCHR 2 ANY>>>
+
+<PUT ,READB PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A READB 3 ANY>>>
+
+<PUT ,READSTRING
+ PAPPLY-OBJECT
+ <FUNCTION (O A) <CHANFCNS .O .A READSTRING 4 ANY>>>
+
+<DEFINE CHANFCNS (OBJ AP NAME ARGN TYP "AUX" TT (LN <LENGTH .OBJ>) N (TEM 0))
+ #DECL ((VALUE) NODE (TT) NODE (N) <LIST [REST NODE]>
+ (LN) FIX (TEM ARGN) FIX (OBJ) <PRIMTYPE LIST>)
+ <COND (<OR <SEG? .OBJ> <L? <- .LN 1> .ARGN>>
+ <PSUBR-C .OBJ .AP>)
+ (ELSE
+ <SET TT <NODEFM ,READ-EOF-CODE .PARENT .TYP .NAME () ,.NAME>>
+ <SET N
+ <MAPF ,LIST
+ <FUNCTION (OB "AUX" (EV <PCOMP .OB .TT>))
+ #DECL ((EV) NODE)
+ <COND (<==? <SET TEM <+ .TEM 1>> .ARGN>
+ <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
+ <SET EV <PCOMP <NODE-NAME .EV> .TT>>
+ <PUT .TT ,NODE-TYPE ,READ-EOF2-CODE>)>
+ <SET EV
+ <NODE1 ,EOF-CODE .TT
+ <RESULT-TYPE .EV> <> (.EV)>>)>
+ .EV>
+ <REST .OBJ>>>
+ <PUT .TT ,KIDS .N>)>>
+
+<PUT ,GET PAPPLY-OBJECT <FUNCTION (O A) <GETFCNS .O .A GET>>>
+
+<PUT ,GETL PAPPLY-OBJECT <FUNCTION (O A) <GETFCNS .O .A GETL>>>
+
+<PUT ,GETPROP PAPPLY-OBJECT <FUNCTION (O A) <GETFCNS .O .A GETPROP>>>
+
+<PUT ,GETPL PAPPLY-OBJECT <FUNCTION (O A) <GETFCNS .O .A GETPL>>>
+
+<DEFINE GETFCNS (OBJ AP NAME "AUX" EV TEM T2 (LN <LENGTH .OBJ>) TT)
+ #DECL ((OBJ) FORM (LN) FIX (TT VALUE TEM T2 EV) NODE)
+ <COND (<OR <AND <N==? .LN 4>
+ <N==? .LN 3>> <SEG? .OBJ>>
+ <PSUBR-C .OBJ .AP>)
+ (ELSE
+ <SET TT <NODEFM ,GET-CODE .PARENT ANY .NAME () ,.NAME>>
+ <SET TEM <PCOMP <2 .OBJ> .TT>>
+ <SET T2 <PCOMP <3 .OBJ> .TT>>
+ <COND (<==? .LN 3>
+ <PUT .TT ,NODE-TYPE ,GET2-CODE>
+ <PUT .TT ,KIDS (.TEM .T2)>)
+ (ELSE
+ <SET EV <PCOMP <4 .OBJ> .TT>>
+ <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
+ <SET EV <PCOMP <NODE-NAME .EV> .TT>>
+ <PUT .TT ,NODE-TYPE ,GET2-CODE>)>
+ <PUT .TT ,KIDS (.TEM .T2 .EV)>)>
+ .TT)>>
+
+<DEFINE ARGCHK (GIV REQ NAME "AUX" (HI .REQ) (LO .REQ))
+ #DECL ((GIV) FIX (REQ HI LO) <OR <LIST FIX FIX> FIX>)
+ <COND (<TYPE? .REQ LIST>
+ <SET HI <2 .REQ>>
+ <SET LO <1 .REQ>>)>
+ <COND (<L? .GIV .LO>
+ <MESSAGE ERROR "TOO FEW ARGS TO " .NAME>)
+ (<G? .GIV .HI>
+ <MESSAGE ERROR "TOO MANY ARGS TO " .NAME>)> T>
+
+<ENDPACKAGE>
+
--- /dev/null
+<SNAME "MDL.COMP">
+
+<LINK '<ERRET T> "\ 5" <ROOT>>
+
+<PACKAGE "COMPDEC">
+<OR <ASSIGNED? PURE!-> <SET PURE!- T>>
+<ENTRY BEGIN-HACK BEGIN-MHACK>
+<LINK OP!-PACKAGE!- "OP" <2 .OBLIST>>
+
+<FLOAD "PS:<COMPIL>NEWOP.MUD">
+<FLOAD "PS:<COMPIL>BOPHAC.MUD">
+<FLOAD "PS:<COMPIL>MUDHAK.MUD">
+
+<BEGIN-HACK "BTB">
+
+<BEGIN-MHACK>
+
+<REMOVE "OP" <1 .OBLIST>>
+
+<ENDPACKAGE>
+
+<BLOCK (<ROOT>)>
+
+<SETG EXPERIMENTAL T>
+<SET TEMPLATE-DATA T>
+
+GLUE PGLUE
+
+<COND (<NOT <ASSIGNED? SILENT!->><SET SILENT!- <>>)>
+
+<COND (<NOT .SILENT> <PRINC " LOADING MUDDLE COMPILER "> <TERPRI>)>
+<ENDBLOCK>
+
+<BLOAT 100000 5000 100 1500 100>
+
+<PROG ((GLUE <COND (<ASSIGNED? GLUE> .GLUE)>)) #DECL ((GLUE) <SPECIAL ANY>)
+<FLOAD "PS:<COMPIL>ASSEM.FBIN">>
+
+<PACKAGE "CODING" "IC">
+
+<FLOAD "PS:<COMPIL>ATOSQ.NBIN">
+<SETG ONLY-FAST-OUTPUT T>
+
+<ENDPACKAGE>
+
+<SETG L-NOISY <>>
+<SETG L-NO-DEFER T>
+
+<FLOAD "PS:<COMPIL>CONNECT-DIR.NBIN">
+
+<CONNECT-DIR "PS:<COMPIL>">
+
+<USE "MACROS" "SORTX" "DOW" "DATIME" "TIMFCN" "NOW" "DFL" "FINDATOM">
+
+<CONNECT-DIR "SRC:<MDL.COMP>">
+
+<PACKAGE "COMPDEC">
+
+<LINK ASSEMBLE1!-CODING!-PACKAGE "ASSEMBLE1" <1 .OBLIST>>
+
+<FLOAD "PS:<COMPIL>WOFCH.FBIN">
+<FLOAD "PS:<COMPIL>POPWR2.FBIN">
+
+<SETG DEATH T>
+
+<ENDPACKAGE>
+
+<FLOAD "COMPDE.FBIN">
+<FLOAD "BIGANA.FBIN">
+
+<USE "PASS1" "CODGEN" "SYMANA" "CHKDCL" "MAPPS1" "CUP" "MAPANA" "MAPGEN"
+ "VARANA" "CARANA" "NEWREP" "BACKAN" "CBACK" "COMSUB" "CARGEN" "CONFOR"
+ "CDRIVE" "CPRINT" "COMTEM" "NOTANA" "NOTGEN" "STRANA" "STRGEN" "ALLR"
+ "LNQGEN" "MMQGEN" "ISTRUC" "INFCMP" "BITTST" "BITANA" "BITSGEN" "BUILDL"
+ "SPCGEN" "ADVMES" "CACS" "COMCOD" "NPRINT" "CASE" "PEEPH">
+
+
+<MAPF <> <FUNCTION (ATM "AUX" (O <OBLIST? .ATM>)) <INSERT <REMOVE .ATM> .O>>
+ '(LOGOUT ERROR ERRET QUIT COND AGAIN REP TAG REDEFINE VALRET T)>
+
+<PACKAGE "DUMP-C">
+
+<USE "COMPDEC">
+
+<DEFINE DUMP-COMP!- (N
+ "OPTIONAL" (GCQ T) (SN <SNAME>) UNM
+ "AUX" CH (SR .READ-TABLE))
+ <UNASSIGN <GUNASSIGN READ-TABLE>>
+ <SETG OQ ,QUIT>
+ <SNAME "">
+ <COND (<=? <FSAVE .N .GCQ> "SAVED">
+ <SNAME .SN>
+ <SET READ-TABLE <SETG READ-TABLE .SR>>)
+ (<AND <OR <=? <SET UNM <UNAME>> "CLR">
+ <=? .UNM "BTB">
+ <=? .UNM "BKD">
+ <=? .UNM "LIM">
+ <=? .UNM "TAA">>
+ <OR <=? <SET SN <SNAME>> "COMPIL">
+ <=? .SN "MDL.COMP">>>
+ <BEGIN-HACK "COMPIL"><BEGIN-MHACK> <RSUBR-LINK <>>
+ <PRINC "` and | hacks enabled. Rsubr-Link <>"> <CRLF>)
+ (ELSE
+ <SET SN <SNAME>>
+ <COND (<SET CH <OPEN "READ" <COND (<=? .UNM "COMBAT">
+ "PCOMP.PLAN.-2")
+ ("PCOMP.PLAN")>>>
+ <LOAD .CH>
+ <QUIT>)
+ (ELSE
+ <CRLF>)>)>
+ <PRINC "MUDDLE COMPILER NOW READY.">
+ <CRLF>
+ T>
+
+<ENDPACKAGE>
+
+<INSERT <REMOVE COMPILE> <ROOT>>
+
+<INSERT <REMOVE COMPILE-GROUP> <ROOT>>
+
+<PACKAGE "COMPDEC">
+
+<ENTRY DC UDC>
+<LINK '<DC> "\ 1" <ROOT>>
+
+<DEFINE DC ()
+<USE-TOTAL "PASS1" "CODGEN" "SYMANA" "CHKDCL" "MAPPS1" "CUP" "MAPANA" "MAPGEN"
+ "VARANA" "CARANA" "NEWREP" "BACKAN" "CBACK" "COMSUB" "CARGEN" "CONFOR"
+ "CDRIVE" "CPRINT" "COMTEM" "NOTANA" "NOTGEN" "STRANA" "STRGEN" "ALLR"
+ "LNQGEN" "MMQGEN" "ISTRUC" "INFCMP" "BITTST" "BITANA" "BITSGEN" "BUILDL"
+ "SPCGEN" "ADVMES" "CACS" "COMCOD" "NPRINT" "CASE" "PEEPH" "COMPDEC">>
+
+<DC>
+
+<DEFINE C ("OPTIONAL" (N 0)) <PRT <REST .CODE:TOP .N>>>
+
+<PRIN-SET>
+
+
+<FLOAD "PS:<COMPIL>PRIMHK.NBIN">
+
+<FLOAD "PS:<COMPIL>PRNTYP">
+
+<SETG EXPERIMENTAL T>
+
+<DEFINE UDC ()
+<DROP "PASS1" "CODGEN" "SYMANA" "CHKDCL" "MAPPS1" "CUP" "MAPANA" "MAPGEN"
+ "VARANA" "CARANA" "NEWREP" "BACKAN" "CBACK" "COMSUB" "CARGEN" "CONFOR"
+ "CDRIVE" "CPRINT" "COMTEM" "NOTANA" "NOTGEN" "STRANA" "STRGEN" "ALLR"
+ "LNQGEN" "MMQGEN" "ISTRUC" "INFCMP" "BITTST" "BITANA" "BITSGEN" "BUILDL"
+ "SPCGEN" "ADVMES" "CACS" "COMCOD" "NPRINT" "CASE" "PEEPH" "COMPDEC">>
+
+<ENDPACKAGE>
+
+<FLOAD "NCOMFI.MUD">
+
+<PROG () <PRINC "Peep Hole optimizer enabled?">
+ <SET PEEP!-PEEPH!-PACKAGE <ERROR>>
+ <CRLF>
+ <PRINC "KILL-COMP disabled">
+ <CRLF>
+ <SETG KILL-COMP!-IFCOMPIL!-FCOMPIL!-PACKAGE ,TIME>>
+
+<DROP "MACROS" "SORTX" "DOW" "DATIME" "TIMFCN">
+
+<DROP "PASS1" "CODGEN" "SYMANA" "CHKDCL" "MAPPS1" "CUP" "MAPANA" "MAPGEN"
+ "VARANA" "CARANA" "NEWREP" "BACKAN" "CBACK" "COMSUB" "CARGEN" "CONFOR"
+ "CDRIVE" "CPRINT" "COMTEM" "NOTANA" "NOTGEN" "STRANA" "STRGEN" "ALLR"
+ "LNQGEN" "MMQGEN" "ISTRUC" "INFCMP" "BITTST" "BITANA" "BITSGEN" "BUILDL"
+ "SPCGEN" "ADVMES" "CACS" "COMCOD" "NPRINT" "CASE" "PEEPH">
+
+<RSUBR-LINK <>>
+<USE "FCOMPIL">
+<SET DISOWN <>>
+\f
\ No newline at end of file
--- /dev/null
+PGLUE!-
+<SET PURE!- <SET SILENT!- <SET GLUE T>>>
+<FLOAD "CMP:PCOMP.LOAD">
+<CONNECT-DIR "PS:<CLR>">
+<FLOAD "<CLR>CLEAN.MUD">
+<USE "CLEAN" "PURITY">
+<CLEANUP>
+<CONNECT-DIR "SRC:<MDL.COMP>">
+<PROG ((FOO ,PURELST) (OUTCHAN <OPEN "PRINT" "FOO.OUT">))
+ <GROUP-PURIFY FOO>
+ <UNASSIGN <REMOVE FOO>>
+ <FLUSH-CLEANUP>
+ <KILL:PURITY>>
--- /dev/null
+CONN CMP:
+
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "CODGEN.NBIN">\e
+<QUIT>\e
+RES .
+
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "STRGEN.NBIN">\e
+<QUIT>\e
+RES .
+
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "INFCMP.NBIN">\e
+<QUIT>\e
+RES .
+
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "NEWREP.NBIN">\e
+<QUIT>\e
+RES .
--- /dev/null
+CONN CMP:
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "ADVMES.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "ALLR.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "BACKAN.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "BITANA.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "BITSGE.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "BITTST.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "BUILDL.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "CACS.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "CACS.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "CARANA.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "CARGEN.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "CASE.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "CBACK.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "CDUP.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "CHKDCL.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "CODGEN.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "COMCOD.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "COMPDE.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "COMSUB.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "CUP.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "CUP.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "GETORD.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "INFCMP.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "INFCMP.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "ISTRUC.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "LNQGEN.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "MAPANA.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "MAPGEN.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "MAPPS1.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "MMQGEN.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "MMQGEN.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "NEWREP.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "NOTANA.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "NOTGEN.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "NPRINT.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "PASS1.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "PEEPH.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "PRCOD.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "PRNTYP.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "PUREQ.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "SBRNAM.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "STRANA.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "STRGEN.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "SUBRTY.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "SYMANA.NBIN">\e
+<QUIT>\e
+RES .
+
+MDL105
+<RESTORE "PDMP">\e
+<DUMP-EM "VARANA.NBIN">\e
+<QUIT>\e
+RES .
+
+
--- /dev/null
+<PACKAGE "PEEPH">
+
+<ENTRY PEEP PRT>
+
+<USE "COMPDEC">
+
+"PEEPHOLE OPTIMIZER: IT WILL DO SEVERAL TYPES OF OPTIMIZATIONS ON THE
+ CODE OUTPUT BY THE COMPILER. THIS INCLUDES REMOVING UNREACHABLE CODE
+ REMOVE THE COPYING OF SIMILAR CODE AND OTHER MINOR OPTIMIZATIONS."
+
+<SETG INSTRUCTION ,FORM>
+
+<BLOCK (<ROOT>)>
+
+TMP
+
+<ENDBLOCK>
+
+<SETG SKIP-TBL ![4 5 6 7 0 1 2 3!]>
+
+<SETG TEST-TBL ![2 3 0 1!]>
+
+<MANIFEST SKIP-TBL TEST-TBL>
+
+<NEWTYPE LNODE VECTOR '<VECTOR LIST LIST <OR FALSE TUPLE> ATOM>>
+
+<SETG LABLS-LN 1>
+
+<SETG JUMPS-LN 2>
+
+<SETG CODE-LN 3>
+
+<SETG NAME-LN 4>
+
+<NEWTYPE NULL LIST>
+
+<SETG NULL-INST <CHTYPE () NULL>>
+
+<NEWTYPE JUMP-INS
+ LIST
+ '<LIST <PRIMTYPE WORD> FIX <OR 'T FALSE> <OR FALSE LNODE>>>
+
+<SETG INS-JMP 1>
+
+<SETG COND-JMP 2>
+
+<SETG UNCON-JMP 3>
+
+<SETG WHERE-JMP 4>
+
+<NEWTYPE SKIP-INS LIST '<LIST <PRIMTYPE WORD>
+ FIX
+ <OR 'T FALSE>
+ <OR 'T FALSE>>>
+
+<SETG INS-SKP 1>
+
+<SETG COND-SKP 2>
+
+<SETG TEST-SKP 3>
+
+<SETG UNCON-SKP 4>
+
+<MANIFEST LABLS-LN
+ JUMPS-LN
+ CODE-LN
+ NAME-LN
+ NULL-INST
+ INS-JMP
+ COND-JMP
+ UNCON-JMP
+ WHERE-JMP
+ INS-SKP
+ COND-SKP
+ TEST-SKP
+ UNCON-SKP>
+
+"CODE RANGES"
+
+<SETG JRST1 172>
+
+<SETG LOW-SKP1 192>
+
+<SETG HI-SKP1 207>
+
+<SETG LOW-JMP1 208>
+
+<SETG HI-JMP1 215>
+
+<SETG LO-SKP2 216>
+
+<SETG HI-SKP2 223>
+
+<SETG LO-JMP2 224>
+
+<SETG HI-JMP2 255>
+
+<SETG LO-TST1 384>
+
+<SETG HI-TST1 447>
+
+<MANIFEST JRST1
+ LOW-SKP1
+ HI-SKP1
+ LOW-JMP1
+ HI-JMP1
+ LO-SKP2
+ HI-SKP2
+ LO-JMP2
+ HI-JMP2
+ LO-TST1
+ HI-TST1>
+
+\\f
+
+"PEEP STARTS BY BUILDING A CODE STRUCTURE WITH SKIPS AND JUMPS REPLACED BY THERE
+ EXPANDED INS-TYPES AND WITH JUMPS AND THIER LABELS LINKED UP WITH THE USE OF LNODES."
+
+<DEFINE PEEP (XCOD
+ "TUPLE" COD
+ "AUX" QXD (MODLN (())) NNCOD (LABNUM 0) (NUMLABS 0) (NNUMLABS 0)
+ NLN (LN <LENGTH .COD>) XD QD (SLABS ()) (TOPCOD .COD)
+ TEMP)
+ #DECL ((XCOD) LIST (SLABS MODLN) <SPECIAL LIST> (LABNUM) <SPECIAL FIX>
+ (NLN LN) FIX (NUMLABS NNUMLABS) <SPECIAL FIX>)
+ <REPEAT TG-FND ((CPTR .COD) AT)
+ #DECL ((CPTR) TUPLE)
+ <COND (<EMPTY? .CPTR> <RETURN>)
+ (<OR <TYPE? <SET AT <1 .CPTR>> ATOM>
+ <AND <TYPE? .AT FORM>
+ <==? <1 .AT> INTERNAL-ENTRY!-OP!-PACKAGE>
+ <SET AT <2 .AT>>>
+ <SET AT <PSEUDO? .AT>>>
+ <PUTREST <REST .MODLN <- <LENGTH .MODLN> 1>>
+ (<SET AT <CHTYPE [(.AT) () .CPTR .AT] LNODE>>)>
+ <SET NUMLABS <+ .NUMLABS 1>>
+ <REPEAT (IN)
+ <AND <EMPTY? <SET CPTR <REST .CPTR>>>
+ <RETURN T .TG-FND>>
+ <COND (<TYPE? <SET IN <1 .CPTR>> ATOM>
+ <PUT .AT ,LABLS-LN (.IN !<LABLS-LN .AT>)>
+ <SET NNUMLABS <+ .NNUMLABS 1>>
+ <PUT .CPTR 1 ,NULL-INST>)
+ (<RETURN>)>>)
+ (<SET CPTR <REST .CPTR>>)>>
+ <SET MODLN <REST .MODLN>>
+ <MAPR <>
+ <FUNCTION (RCOD "AUX" QD (INST <1 .RCOD>))
+ #DECL ((QD) <OR FALSE LNODE> (RCOD) TUPLE)
+ <COND
+ (<TYPE? .INST FORM>
+ <SET INST <INSTYPE .INST>>
+ <COND (<TYPE? .INST JUMP-INS>
+ <SET XD <FIND-LAB <REST .INST 4>>>
+ <SET QD <COND (.XD <FIND-NOD .MODLN .XD>)>>
+ <AND .XD
+ <PROG FFA ()
+ <COND (.QD
+ <PUT .INST ,WHERE-JMP .QD>
+ <PUT .RCOD 1 .INST>
+ <PUT .QD
+ ,JUMPS-LN
+ <ADDON (.RCOD) <JUMPS-LN .QD>>>)
+ (<SET QD <CHTYPE [(.XD) () <> .XD] LNODE>>
+ <SET MODLN (.QD !.MODLN)>
+ <AGAIN .FFA>)>>>)
+ (ELSE
+ <COND (<AND <SET XD <NFIND-LAB .INST>>
+ <SET XD <FIND-NOD .MODLN .XD>>>
+ <SET INST <MUNG-LAB .INST <NAME-LN .XD>>>
+ <SET SLABS (.XD !.SLABS)>)>
+ <PUT .RCOD 1 .INST>)>)>>
+ .COD>
+ <PROG REOPT ((NLABLS ()) (REDO <>))
+ #DECL ((NLABLS) <SPECIAL LIST> (REDO) <SPECIAL <OR STRING FALSE ATOM>>)
+ <MAPR <>
+ <FUNCTION (NCOD "AUX" QD (INST <1 .NCOD>) (NNCOD .NCOD))
+ #DECL ((NNCOD NCOD) TUPLE)
+ <COND
+ (<TYPE? .INST JUMP-INS>
+ <REPEAT (TMP AOJ-FLG NEWLAB)
+ <COND (<NOT <SET TMP <CODE-LN <WHERE-JMP .INST>>>> <RETURN>)>
+ <SET QD <NEXTS .TMP>>
+ <COND
+ (<AND <NOT <G? <INS-JMP .INST> ,LO-JMP2>>
+ <REPEAT ((NC .NNCOD))
+ <COND (<==? .NC .TOPCOD> <RETURN>)>
+ <SET NC <BACK .NC>>
+ <COND (<NOT <TYPE? <1 .NC> ATOM NULL>>
+ <RETURN <NOT <SKIPPABLE <1 .NC>>>>)>>
+ <REPEAT ((NC .NNCOD))
+ <COND (<EMPTY? <SET NC <REST .NC>>> <RETURN <>>)
+ (<==? .TMP .NC> <RETURN>)
+ (<NOT <TYPE? <1 .NC> ATOM NULL>>
+ <RETURN <==? .NC .TMP>>)>>>
+ <DEL-JUMP-LN .NNCOD>
+ <PUT .NNCOD 1 ,NULL-INST>
+ <SET REDO "REMOVED JUMP CHAINING">
+ <RETURN>)
+ (<AND <TYPE? .QD JUMP-INS> <UNCON-JMP .QD>>
+ <COND (<NOT <AND <SET AOJ-FLG <G? <INS-JMP .QD> ,LO-JMP2>>
+ <OR <G? <INS-JMP .INST> ,LO-JMP2>
+ <NOT <UNCON-JMP .INST>>>>>
+ <DEL-JUMP-LN .NNCOD>
+ <SET NEWLAB <ADDON (.NNCOD) <JUMPS-LN <WHERE-JMP .QD>>>>
+ <COND (.AOJ-FLG
+ <PUT .NNCOD
+ 1
+ <SET INST <CHTYPE <SUBSTRUC .QD> JUMP-INS>>>)
+ (ELSE
+ <PUT .INST ,WHERE-JMP <WHERE-JMP .QD>>
+ <PUT <WHERE-JMP .QD> ,JUMPS-LN .NEWLAB>)>
+ <SET REDO "REMOVED JUMP CHAINING">)
+ (<RETURN>)>)
+ (<RETURN>)>>
+ <COND
+ (<AND
+ <NOT <UNCON-JMP .INST>>
+ <REPEAT ((NC .NCOD))
+ <COND
+ (<EMPTY? .NC> <RETURN <>>)
+ (<TYPE? <1 <SET NC <REST .NC>>> NULL>)
+ (<AND <TYPE? <1 <SET TEMP .NC>> JUMP-INS>
+ <==? <INS-JMP <1 .NC>> ,JRST1>>
+ <RETURN <==? <NEXTS <REST .NC> T>
+ <NEXTS <CODE-LN <WHERE-JMP .INST>> T>>>)
+ (ELSE <RETURN <>>)>>
+ <NOT <SKIPPABLE <BACKS .NCOD .TOPCOD <> 1>>>>
+ <DEL-JUMP-LN .NCOD>
+ <PUT .INST ,WHERE-JMP <WHERE-JMP <1 .TEMP>>>
+ <DEL-JUMP-LN .TEMP>
+ <PUT .TEMP 1 ,NULL-INST>
+ <PUT <WHERE-JMP .INST>
+ ,JUMPS-LN
+ <ADDON (.NCOD) <JUMPS-LN <WHERE-JMP .INST>>>>
+ <PUT .INST ,COND-JMP <NTH ,SKIP-TBL <+ <COND-JMP .INST> 1>>>
+ <SET REDO "OPTIMIZED CONDITIONAL JUMP/NON-COND JUMP">)>)
+ (<TYPE? .INST SKIP-INS>
+ <AND
+ <NOT <UNCON-SKP .INST>>
+ <REPEAT ()
+ <COND
+ (<EMPTY? <SET NCOD <REST .NCOD>>> <RETURN>)
+ (<AND <OR <AND <TYPE? <SET QD <1 .NCOD>> SKIP-INS>
+ <NOT <TEST-SKP .QD>>
+ <UNCON-SKP .QD>
+ <NOT <TYPE? <BACKS .NCOD .TOPCOD <> 2>
+ SKIP-INS>>>
+ <AND <TYPE? .QD JUMP-INS>
+ <==? <INS-JMP .QD> ,JRST1>
+ <==? <REST <CODE-LN <WHERE-JMP .QD>>>
+ <NEXTS <REST .NCOD> T 2>>
+ <NOT <TYPE? <BACKS .NCOD .TOPCOD <> 2> SKIP-INS>>
+ <DEL-JUMP-LN .NCOD>>>
+ <PUT <BACKS .NCOD .TOPCOD T 1> 1 ,NULL-INST>
+ <PUT .NCOD 1 .INST>
+ <CHANGE-COND .INST>
+ <SET REDO "SKIP-CHAIN OPTIMIZATION">
+ <RETURN>>)
+ (<NOT <TYPE? .QD NULL>> <RETURN>)>>>
+ <AND <TYPE? <SET XD <1 .NCOD>> JUMP-INS>
+ <NOT <TYPE? <BACKS .NCOD .TOPCOD <> 2> SKIP-INS>>
+ <UNCON-JMP .XD>
+ <SET QXD <WHERE-JMP .XD>>
+ <TYPE? <NEXTS <REST .NCOD>> SKIP-INS>
+ <TYPE? <SET XD <NEXTS <REST .NCOD> <> 2>> JUMP-INS>
+ <UNCON-JMP .XD>
+ <==? <WHERE-JMP .XD> .QXD>
+ <DEL-JUMP-LN .NCOD>
+ <PUT .NCOD 1 ,NULL-INST>
+ <CHANGE-COND .INST>
+ <SET REDO "OPTIMIZING CONDITIONAL JUMPS">>)
+ (<AND
+ <TYPE? .INST FORM>
+ <OR <==? <1 .INST> `ADDI > <==? <1 .INST> `SUBI >>
+ <==? <LENGTH .INST> 3>
+ <==? <3 .INST> 1>
+ <REPEAT (TEM)
+ <COND (<EMPTY? .NCOD> <RETURN>)>
+ <SET NCOD <REST .NCOD>>
+ <COND
+ (<TYPE? <SET QD <1 .NCOD>> JUMP-INS>
+ <COND
+ (<OR <==? <INS-JMP .QD> ,JRST1>
+ <AND <G=? <INS-JMP .QD> ,LOW-JMP1>
+ <L=? <INS-JMP .QD> ,HI-JMP1>
+ <G=? <LENGTH .QD> 5>
+ <==? <2 .INST> <5 .QD>>>>
+ <PUT <BACK .NCOD> 1 ,NULL-INST>
+ <PUT
+ .NCOD
+ 1
+ <SET TEM
+ <INSTYPE
+ <INSTRUCTION
+ <COND
+ (<==? <INS-JMP .QD> ,JRST1>
+ <COND (<==? <1 .INST> `ADDI > `AOJA ) (ELSE `SOJA )>)
+ (<==? <1 .INST> `ADDI >
+ <CHTYPE <PUTBITS 0
+ <BITS 9 27>
+ <+ <CHTYPE <INS-JMP .QD> FIX> 16>>
+ OPCODE!-OP!-PACKAGE>)
+ (ELSE
+ <CHTYPE <PUTBITS 0
+ <BITS 9 27>
+ <+ <CHTYPE <INS-JMP .QD> FIX> 32>>
+ OPCODE!-OP!-PACKAGE>)>
+ <2 .INST>
+ <OR <AND <WHERE-JMP .QD> <NAME-LN <WHERE-JMP .QD>>>
+ <NFIND-LAB <REST .QD 4>>>>>>>
+ <PUT .TEM ,WHERE-JMP <WHERE-JMP .QD>>
+ <SET REDO "ADDI OR SUBI FOLLOWED BY A JUMP">
+ <RETURN <>>)
+ (<RETURN>)>)
+ (<TYPE? .QD NULL>)
+ (<RETURN>)>>>
+ <SET NCOD .NNCOD>
+ <REPEAT ()
+ <AND <==? .NCOD .TOPCOD> <RETURN>>
+ <SET NCOD <BACK .NCOD>>
+ <COND
+ (<TYPE? <SET QD <1 .NCOD>> NULL>)
+ (<TYPE? .QD ATOM>
+ <SET QD <FIND-NOD .MODLN .QD>>
+ <COND
+ (<MAPF <>
+ <FUNCTION (X)
+ <COND (<NOT <OR <TYPE? <1 .X> NULL>
+ <==? <INS-JMP <1 .X>> ,JRST1>>>
+ <MAPLEAVE <>>)
+ (T)>>
+ <JUMPS-LN .QD>>
+ <SET REDO "JUMP TO AN ADDI OR SUBI">
+ <PUT .NCOD 1 <1 .NNCOD>>
+ <PUT .NNCOD 1 <NAME-LN .QD>>
+ <MAPF <>
+ <FUNCTION (X
+ "AUX" (IT
+ <COND (<==? <1 .INST> `ADDI > `AOJA )
+ (ELSE `SOJA )>))
+ <PUT
+ .X
+ 1
+ <PUT <INSTYPE <INSTRUCTION
+ .IT <2 .INST> <NAME-LN .QD>>>
+ ,WHERE-JMP
+ .QD>>>
+ <JUMPS-LN .QD>>)>
+ <RETURN>)
+ (<RETURN>)>>)
+ (<AND <TYPE? .INST FORM>
+ <==? <1 .INST> DEALLOCATE>
+ <TYPE? <SET XD <1 <REST .NCOD>>> FORM>
+ <==? <1 .XD> DEALLOCATE>>
+ <PUT .NCOD 1 ,NULL-INST>
+ <PUT .XD 2 (!<2 .XD> !<2 .INST>)>)>>
+ .COD>
+ <MAPF <>
+ <FUNCTION (LN "AUX" (COMPS <JUMPS-LN .LN>))
+ #DECL ((LN) LNODE)
+ <COND
+ (<NOT <EMPTY? .COMPS>>
+ <SET COMPS
+ <MAPF ,LIST
+ <FUNCTION (CMP)
+ #DECL ((CMP) TUPLE)
+ <COND (<AND <UNCON-JMP <1 .CMP>>
+ <==? <INS-JMP <1 .CMP>> ,JRST1>>
+ <MAPRET .CMP>)
+ (<MAPRET>)>>
+ .COMPS>>
+ <AND <CODE-LN .LN> <CROSS-OPT .TOPCOD <CODE-LN .LN> !.COMPS>>
+ <SET COMPS <JUMPS-LN .LN>>
+ <SET COMPS
+ <MAPF ,LIST
+ <FUNCTION (CMP)
+ #DECL ((CMP) TUPLE)
+ <COND (<AND <UNCON-JMP <1 .CMP>>
+ <==? <INS-JMP <1 .CMP>> ,JRST1>>
+ <MAPRET .CMP>)
+ (<MAPRET>)>>
+ .COMPS>>
+ <MAPR <>
+ <FUNCTION (CMP)
+ #DECL ((CMP) LIST)
+ <CROSS-OPT .TOPCOD <1 .CMP> !<REST .CMP>>>
+ .COMPS>)>>
+ .MODLN>
+ <SET MODLN <CLEAN-IT-UP .MODLN>>
+ <MAPR <>
+ <FUNCTION (NCOD "AUX" (INST <1 .NCOD>))
+ #DECL ((NCOD) TUPLE)
+ <COND
+ (<AND <OR <AND <TYPE? .INST JUMP-INS> <UNCON-JMP .INST>>
+ <AND <TYPE? .INST FORM>
+ <==? <1 .INST> `JRST >
+ <NOT <=? <2 .INST> '.HERE!-OP!-PACKAGE>>>>
+ <REPEAT ((NC <BACK .NCOD>))
+ <COND (<TYPE? <1 .NC> ATOM NULL>
+ <COND (<==? .NC .TOPCOD> <RETURN T>)
+ (<SET NC <BACK .NC>>)>)
+ (<RETURN <NOT <SKIPPABLE <1 .NC>>>>)>>>
+ <REPEAT ()
+ <COND
+ (<EMPTY? <SET NCOD <REST .NCOD>>> <RETURN>)
+ (<OR
+ <TYPE? <SET QD <1 .NCOD>> ATOM>
+ <AND <TYPE? .QD FORM>
+ <OR <==? <1 .QD> INTERNAL-ENTRY!-OP!-PACKAGE>
+ <PSEUDO? .QD>
+ <AND <TYPE? <1 .QD> ATOM>
+ <OR <FIND-NOD .MODLN <1 .QD>>
+ <NOT <GASSIGNED? <1 .QD>>>>>>>
+ <MAPF <>
+ <FUNCTION (LN)
+ #DECL ((LN) LNODE)
+ <COND (<AND <NOT <EMPTY? <JUMPS-LN .LN>>>
+ <==? <CODE-LN .LN> .NCOD>>
+ <MAPLEAVE>)>>
+ .MODLN>>
+ <RETURN>)
+ (<TYPE? .QD NULL>)
+ (ELSE
+ <COND (<TYPE? <1 .NCOD> JUMP-INS> <DEL-JUMP-LN .NCOD>)>
+ <PUT .NCOD 1 ,NULL-INST>
+ <SET REDO "FLUSH UNREACHABLE CODE">)>>)>>
+ .COD>
+ <SET MODLN <FLUSH-LABELS .MODLN>>
+ <REPEAT FFY ((PTR1 <REST .COD <- <LENGTH .COD> 1>>)
+ (PTR2 <REST .COD <- <LENGTH .COD> 1>>) XD)
+ #DECL ((PTR2 PTR1) TUPLE)
+ <MAPF <>
+ <FUNCTION (X) <COND (<==? <2 .X> .PTR1> <PUT .X 2 .PTR2>)>>
+ .NLABLS>
+ <COND (<TYPE? <SET XD <1 .PTR1>> NULL>)
+ (<PUT .PTR2 1 .XD>
+ <COND (<TYPE? .XD ATOM>
+ <AND <SET XD <FIND-NOD .MODLN .XD>>
+ <PUT .XD ,CODE-LN .PTR2>>)
+ (<TYPE? .XD JUMP-INS>
+ <PUT <MEMQ .PTR1 <JUMPS-LN <WHERE-JMP .XD>>>
+ 1
+ .PTR2>)>
+ <SET PTR2 <BACK .PTR2>>)>
+ <COND (<==? .PTR1 .TOPCOD>
+ <REPEAT ()
+ <COND (<==? .PTR2 .TOPCOD>
+ <PUT .PTR2 1 ,NULL-INST>
+ <RETURN T .FFY>)
+ (<PUT .PTR2 1 ,NULL-INST>
+ <SET PTR2 <BACK .PTR2>>)>>)
+ (<SET PTR1 <BACK .PTR1>>)>>
+ <REPEAT (P1 (PTR1 .COD) (PTR2 .COD))
+ <COND (<EMPTY? .PTR1>
+ <MAPR <> <FUNCTION (X) <PUT .X 1 ,NULL-INST>> .PTR2>
+ <RETURN>)>
+ <MAPF <>
+ <FUNCTION (X)
+ <COND (<==? <2 .X> .PTR1>
+ <SET NNUMLABS <- .NNUMLABS 1>>
+ <PUT .PTR2 1 <1 .X>>
+ <PUT <FIND-NOD .MODLN <1 .X>> ,CODE-LN .PTR2>
+ <SET PTR2 <REST .PTR2>>)>>
+ .NLABLS>
+ <COND (<TYPE? <SET P1 <1 .PTR1>> NULL>)
+ (ELSE
+ <COND (<NOT .REDO> <PUT .PTR2 1 <INSFIX .P1>>)
+ (<PUT .PTR2 1 .P1>)>
+ <COND (<TYPE? .P1 ATOM>
+ <AND <SET XD <FIND-NOD .MODLN .P1>>
+ <PUT .XD ,CODE-LN .PTR2>>)
+ (<TYPE? .P1 JUMP-INS>
+ <PUT <MEMQ .PTR1 <JUMPS-LN <WHERE-JMP .P1>>>
+ 1
+ .PTR2>)>
+ <SET PTR2 <REST .PTR2>>)>
+ <SET PTR1 <REST .PTR1>>>
+ <COND (.REDO <SET NLABLS ()> <SET REDO <>> <AGAIN .REOPT>)
+ (ELSE
+ <SET NLN
+ <REPEAT ((N 0))
+ <COND (<EMPTY? .COD> <RETURN .N>)
+ (<TYPE? <1 .COD> NULL>)
+ (ELSE
+ <PUT .XCOD 1 <1 .COD>>
+ <SET NNCOD .XCOD>
+ <SET XCOD <REST .XCOD>>
+ <SET N <+ .N 1>>)>
+ <SET COD <REST .COD>>>>
+ <OR <EMPTY? .NNCOD> <PUTREST .NNCOD ()>>)>>
+ <COND (<AND <ASSIGNED? PEEP> .PEEP>
+ <PEEP-PRINT .LN .NLN .NUMLABS .NNUMLABS>)>>
+
+\\f
+
+<DEFINE INSTYPE (INST "AUX" AT QX QY)
+ #DECL ((QX) <PRIMTYPE WORD>)
+ <COND
+ (<AND <TYPE? .INST FORM>
+ <TYPE? <SET AT <1 .INST>> OPCODE!-OP!-PACKAGE>
+ <SET QX <CHTYPE <GETBITS .AT <BITS 9 27>> FIX>>
+ <OR <==? .QX ,JRST1>
+ <AND <G=? .QX ,LOW-SKP1> <L=? .QX ,HI-JMP2>>>>
+ <SET QY <CHTYPE <GETBITS .QX <BITS 6 3>> FIX>>
+ <COND (<AND <OR <==? .QX ,JRST1> <AND <N==? .QY 24> <0? <MOD .QY 2>>>>
+ <NOT <0? <SET QY <CHTYPE <GETBITS .QX <BITS 3>> FIX>>>>>
+ <CHTYPE (.QX .QY <==? .QY 4> <> !<REST .INST>) JUMP-INS>)
+ (<NOT <0? <SET QY <CHTYPE <GETBITS .QX <BITS 3>> FIX>>>>
+ <CHTYPE (.QX .QY <> <==? .QY 4> !<REST .INST>) SKIP-INS>)
+ (.INST)>)
+ (<AND <ASSIGNED? QX>
+ <G=? .QX ,LO-TST1>
+ <L=? .QX ,HI-TST1>
+ <NOT <0? <SET QY <CHTYPE <GETBITS .QX <BITS 2 1>> FIX>>>>>
+ <CHTYPE (.QX .QY T <==? .QY 2> !<REST <CHTYPE .INST LIST>>)
+ SKIP-INS>)
+ (.INST)>>
+
+<DEFINE NFIND-LAB (INST)
+ <COND (<TYPE? .INST ATOM> .INST)
+ (<MONAD? .INST> <>)
+ (<MAPF <>
+ <FUNCTION (X)
+ <COND (<SET X <NFIND-LAB .X>> <MAPLEAVE .X>)>>
+ .INST>)>>
+
+<DEFINE FIND-NOD (MD AT)
+ #DECL ((MD) LIST (AT) ATOM)
+ <MAPF <>
+ <FUNCTION (X)
+ #DECL ((X) LNODE)
+ <COND (<MEMQ .AT <LABLS-LN .X>> <MAPLEAVE .X>)>>
+ .MD>>
+
+<DEFINE INSFIX (X "AUX" XD)
+ <COND
+ (<TYPE? .X JUMP-INS>
+ <INSTRUCTION
+ <CHTYPE <PUTBITS #WORD *000000000000*
+ <BITS 9 27>
+ <CHTYPE <ORB <ANDB <INS-JMP .X> 504> <COND-JMP .X>> FIX>>
+ OPCODE!-OP!-PACKAGE>
+ !<COND (<==? <LENGTH <SET XD <REST .X 4>>> 2>
+ (<1 .XD> <NAME-LN <WHERE-JMP .X>>))
+ (ELSE (<NAME-LN <WHERE-JMP .X>>))>>)
+ (<TYPE? .X SKIP-INS>
+ <INSTRUCTION
+ <COND (<TEST-SKP .X>
+ <CHTYPE <PUTBITS #WORD *000000000000*
+ <BITS 9 27>
+ <CHTYPE <ORB <ANDB <INS-SKP .X> 505>
+ <* <COND-SKP .X> 2>>
+ FIX>>
+ OPCODE!-OP!-PACKAGE>)
+ (ELSE
+ <CHTYPE <PUTBITS #WORD *000000000000*
+ <BITS 9 27>
+ <CHTYPE <ORB <ANDB <INS-SKP .X> 504>
+ <COND-SKP .X>>
+ FIX>>
+ OPCODE!-OP!-PACKAGE>)>
+ !<REST .X 4>>)
+ (ELSE .X)>>
+
+<DEFINE PRT (X)
+ #DECL ((X) STRUCTURED)
+ <MAPF <>
+ <FUNCTION (X)
+ <COND (<TYPE? .X ATOM>) (ELSE <PRINC " ">)>
+ <PRIN1 .X>
+ <CRLF>>
+ .X>>
+
+<DEFINE CROSS-OPT (TOPCOD NCOD "TUPLE" COMPS "AUX" NEWLN)
+ #DECL ((TOPCOD NCOD) TUPLE (COMPS) TUPLE (MODLN NLABS) LIST)
+ <REPEAT (QD LABL (CNT 0) (NEEDLABEL T))
+ #DECL ((CNT) FIX (COMPS) TUPLE)
+ <AND <==? .NCOD .TOPCOD> <RETURN>>
+ <SET NCOD <BACK .NCOD>>
+ <MAPR <>
+ <FUNCTION (XD "AUX" (XR <1 .XD>))
+ #DECL ((XD) TUPLE (XR) <OR TUPLE NULL>)
+ <COND (<TYPE? .XR NULL>)
+ (<==? .XR .TOPCOD>)
+ (ELSE
+ <REPEAT ()
+ <PUT .XD 1 <SET XR <BACK .XR>>>
+ <SET CNT -1>
+ <COND (<TYPE? <1 .XR> NULL>) (<RETURN>)>>)>>
+ .COMPS>
+ <COND (<0? .CNT> <RETURN>) (<SET CNT 0>)>
+ <COND (.NEEDLABEL <SET LABL <MAKE:LABEL>> <SET NEEDLABEL <>>)>
+ <SET NEWLN <CHTYPE [(.LABL) () .NCOD .LABL] LNODE>>
+ <SET QD <1 .NCOD>>
+ <COND (<OR <SKIPPABLE <1 <BACK .NCOD>>> <SKIPPABLE <1 .NCOD>>> <RETURN>)>
+ <MAPR <>
+ <FUNCTION (NPCOD "AUX" (NNCOD <1 .NPCOD>) ITEM)
+ #DECL ((NPCOD) TUPLE (NNCOD) <OR NULL TUPLE>)
+ <COND (<TYPE? .NNCOD NULL>)
+ (<SET ITEM <1 .NNCOD>>
+ <COND (<AND <N==? .NCOD .NNCOD> <=? .ITEM .QD>>
+ <SET NEEDLABEL T>
+ <COND (<TYPE? <1 .NNCOD> JUMP-INS>
+ <DEL-JUMP-LN .NNCOD>)>
+ <COND (<==? .NCOD <NEXTS <REST .NNCOD> T>>
+ <PUT .NNCOD 1 ,NULL-INST>)
+ (ELSE
+ <PUT .NNCOD
+ 1
+ <CHTYPE (,JRST1 4 T .NEWLN .LABL)
+ JUMP-INS>>
+ <PUT .NEWLN
+ ,JUMPS-LN
+ (.NNCOD !<JUMPS-LN .NEWLN>)>)>
+ <SET REDO "CROSS-OPTIMIZATION">
+ <SET CNT -1>)
+ (<PUT .NPCOD 1 ,NULL-INST>)>)>>
+ .COMPS>
+ <COND (<NOT <0? .CNT>>
+ <SET NLABLS ((.LABL .NCOD) !.NLABLS)>
+ <SET MODLN (.NEWLN !.MODLN)>)>
+ <COND (<0? .CNT> <RETURN>) (<SET CNT 0>)>>>
+
+<DEFINE FF (X) #DECL ((X) STRUCTURED) <MAPF <> ,& .X> <CRLF>>
+
+"ROUTINE TO DETERMINE WHETHER AN INSTRUCTION CAN SKIP"
+
+<DEFINE HACK-PRINT (X) <PRIN1 <INSFIX .X>>>
+
+<DEFINE SKIPPABLE (INST)
+ <OR <TYPE? .INST SKIP-INS>
+ <AND <TYPE? .INST FORM>
+ <OR <==? <1 .INST> `XCT >
+ <==? <1 .INST> `PUSHJ >
+ <AND <G=? <LENGTH .INST> 2>
+ <MEMBER '.HERE!-OP!-PACKAGE .INST>>>>>>
+
+"ROUTINE TO DELETE A JUMP-LN FROM AN LNODE."
+
+<DEFINE DEL-JUMP-LN (COD "AUX" XD QD (JMP <1 .COD>))
+ #DECL ((JMP) JUMP-INS (COD) TUPLE (XD QD) <OR FALSE LIST>)
+ <COND (<SET XD <MEMQ .COD
+ <SET QD <JUMPS-LN <CHTYPE <WHERE-JMP .JMP>
+ LNODE>>>>>
+ <COND (<==? .QD .XD> <PUT <CHTYPE <WHERE-JMP .JMP> LNODE>
+ ,JUMPS-LN <REST .XD>>)
+ (ELSE
+ <PUTREST <REST .QD <- <LENGTH .QD> <LENGTH .XD> 1>>
+ <REST .XD>>)>
+ T)>>
+
+<DEFINE CHANGE-COND (INST)
+ #DECL ((INST) SKIP-INS)
+ <PUT .INST
+ ,COND-SKP
+ <COND (<TEST-SKP .INST> <NTH ,TEST-TBL <+ <COND-SKP .INST> 1>>)
+ (<NTH ,SKIP-TBL <+ <COND-SKP .INST> 1>>)>>>
+
+<DEFINE MAKE:LABEL ("AUX" XX) #DECL ((LABNUM) FIX)
+ <OR <LOOKUP <SET XX
+ <STRING "OPT" <UNPARSE <SET LABNUM <+ .LABNUM 1>>>>>
+ <GET TMP OBLIST>>
+ <INSERT .XX <GET TMP OBLIST>>>>
+
+<DEFINE NEXTS (XX "OPTIONAL" (XT <>) (NN 1) "AUX" XR)
+ #DECL ((XX) TUPLE (NN) FIX)
+ <REPEAT ()
+ <COND (<TYPE? <SET XR <1 .XX>> NULL ATOM>)
+ (<0? <SET NN <- .NN 1>>> <RETURN .XR>)>
+ <AND <EMPTY? <SET XX <REST .XX>>>
+ <SET XX <BACK .XX>>
+ <RETURN .XR>>>
+ <COND (.XT .XX) (ELSE .XR)>>
+
+<DEFINE BACKS (XX TOPCOD "OPTIONAL" (XT <>) (NN 1) "AUX" XR)
+ #DECL ((XX TOPCOD) TUPLE (NN) FIX)
+ <REPEAT ()
+ <AND <==? <SET XX <BACK .XX>> .TOPCOD> <RETURN .XR>>
+ <COND (<TYPE? <SET XR <1 .XX>> NULL ATOM>)
+ (<0? <SET NN <- .NN 1>>> <RETURN .XR>)>>
+ <COND (.XT .XX)(ELSE .XR)>>
+
+
+<DEFINE ADDON (AD OB)
+ #DECL ((AD OB) <PRIMTYPE LIST>)
+ <COND (<EMPTY? .OB> .AD)
+ (ELSE <PUTREST <REST .OB <- <LENGTH .OB> 1>> .AD> .OB)>>
+
+<DEFINE FIND-LAB (INST)
+ <MAPF <>
+ <FUNCTION (X) <COND (<TYPE? .X ATOM> <MAPLEAVE .X>)>>
+ .INST>>
+
+<DEFINE PSEUDO? (AT)
+ #DECL ((VALUE) <OR ATOM FALSE>)
+ <AND <TYPE? .AT FORM>
+ <==? <1 .AT> PSEUDO!-OP!-PACKAGE>
+ <==? <LENGTH .AT> 2>
+ <TYPE? <SET AT <2 .AT>> FORM>
+ <==? <LENGTH .AT> 3>
+ <==? <1 .AT> SETG>
+ <=? <3 .AT> '<ANDB 262143 <CHTYPE .HERE!-OP!-PACKAGE FIX>>>
+ <2 .AT>>>
+
+<DEFINE MUNG-LAB (INST ATM)
+ <COND (<TYPE? .INST ATOM> .ATM)
+ (<MONAD? .INST> <>)
+ (ELSE
+ <MAPR <>
+ <FUNCTION (IN "AUX" (OB <1 .IN>))
+ <COND (<SET OB <MUNG-LAB .OB .ATM>>
+ <PUT .IN 1 .OB>
+ <MAPLEAVE <>>)>>
+ .INST>
+ .INST)>>
+
+<PRINTTYPE SKIP-INS ,HACK-PRINT>
+
+<PRINTTYPE JUMP-INS ,HACK-PRINT>
+
+<DEFINE PEEP-PRINT (LN NLN NUMLABS NNUMLABS)
+ <COND (<NOT <ASSIGNED? OUTL>>
+ <PRINC "Peephole ">
+ <SET LN <- .LN .NUMLABS>>
+ <SET NLN <- .NLN .NUMLABS <- .NNUMLABS>>>
+ <PRIN1 <FIX <* 100 </ <FLOAT <- .LN .NLN>> .LN>>>>
+ <PRINC "% ">
+ <PRIN1 .LN>
+ <PRINC "/">
+ <PRIN1 .NLN>)
+ (ELSE
+ <PRINLC "Peephole ">
+ <SET LN <- .LN .NUMLABS>>
+ <SET NLN <- .NLN .NUMLABS <- .NNUMLABS>>>
+ <PRINL1 <FIX <* 100 </ <FLOAT <- .LN .NLN>> .LN>>>>
+ <PRINLC "% ">
+ <PRINL1 .LN>
+ <PRINLC "/">
+ <PRINL1 .NLN>)>>
+\f
+<DEFINE CLEAN-IT-UP (MDLN)
+ #DECL ((MDLN) <LIST [REST LNODE]>)
+ <MAPF <>
+ <FUNCTION (LND "AUX" JMP FIN-LNODE)
+ #DECL ((LND) LNODE)
+ <COND
+ (<OR <AND <TYPE? <SET JMP <1 <CODE-LN .LND>>> JUMP-INS>
+ <UNCON-JMP .JMP>
+ <SET FIN-LNODE <FIND-END-OF-CHAIN .JMP>>>
+ <AND <TYPE? <SET JMP <1 <BACK <CODE-LN .LND>>>> ATOM>
+ <SET JMP <FIND-NOD .MDLN .JMP>>
+ <==? <CODE-LN .JMP> <BACK <CODE-LN .LND>>>
+ <SET FIN-LNODE .JMP>>>
+ <MAPF <>
+ <FUNCTION (JMPL "AUX" JMP)
+ #DECL ((JMPL) TUPLE (JMP) JUMP-INS)
+ <DEL-JUMP-LN .JMPL>
+ <SET JMP <1 .JMPL>>
+ <PUT .JMP ,WHERE-JMP .FIN-LNODE>
+ <PUT .FIN-LNODE
+ ,JUMPS-LN
+ <ADDON (.JMPL) <JUMPS-LN .FIN-LNODE>>>>
+ <JUMPS-LN .LND>>)>>
+ .MDLN>
+ <FLUSH-LABELS .MDLN>>
+
+<DEFINE FIND-END-OF-CHAIN (JMP "AUX" (DEFAULT <WHERE-JMP .JMP>))
+ #DECL ((JMP) JUMP-INS)
+ <REPEAT (NJMP)
+ <COND (<TYPE? <SET NJMP <1 <CODE-LN <WHERE-JMP .JMP>>>>
+ JUMP-INS>
+ <SET DEFAULT <WHERE-JMP .JMP>>
+ <SET JMP .NJMP>)
+ (<RETURN .DEFAULT>)>>>
+
+<DEFINE FLUSH-LABELS (MODLN "AUX" (TEM ()))
+ #DECL ((MODLN) LIST (SLABS) <LIST [REST LNODE]> (NLABLS) <LIST [REST LIST]>
+ (NNUMLABS) FIX)
+ <MAPR <>
+ <FUNCTION (Y "AUX" (X <1 .Y>)) #DECL ((Y) <LIST LNODE [REST LNODE]>
+ (X) LNODE)
+ <COND (<AND <NOT <MEMQ .X .SLABS>>
+ <EMPTY? <JUMPS-LN .X>>
+ <CODE-LN .X>>
+ <REPEAT ((N .NLABLS) N1 (LL <LABLS-LN .X>))
+ #DECL ((N1 N) <LIST [REST LIST]>
+ (LL) <LIST [REST ATOM]>)
+ <AND <EMPTY? .N> <RETURN>>
+ <COND (<MEMQ <1 <1 .N>> .LL>
+ <COND (<==? .N .NLABLS>
+ <SET NLABLS <REST .NLABLS>>)
+ (ELSE <PUTREST .N1 <REST .N>>)>
+ <RETURN>)>
+ <SET N <REST <SET N1 .N>>>>
+ <COND (<==? .Y .MODLN> <SET MODLN <REST .MODLN>>)
+ (ELSE <PUTREST .TEM <REST .Y>> <SET Y .TEM>)>
+ <COND (<==? <NAME-LN .X> <1 <CODE-LN .X>>>
+ <PUT <CODE-LN .X> 1 ,NULL-INST>
+ <SET NNUMLABS <+ .NNUMLABS 1>>)>
+ <SET REDO "FLUSH REDUNDANT LABELS">)>
+ <SET TEM .Y>>
+ .MODLN>
+ .MODLN>
+\f
+<ENDPACKAGE>
+\ 3
\ No newline at end of file
--- /dev/null
+Compilation record for: SRC:<MDL.COMP>PEEPH.MUD.92;P777752;ADM
+Output file: SRC:<MDL.COMP>PEEPH.NBIN.92
+File loaded.
+Functions ordered.
+COMPILING INSTYPE!-IPEEPH!-PEEPH!-PACKAGE
+===== Computed decl of variable: QX!-IPEEPH!-PEEPH!-PACKAGE is: FIX
+===== Computed decl of variable: QY!-IPEEPH!-PEEPH!-PACKAGE is: FIX
+Peephole 3% 144/139
+Job done in: 12 / 22
+ COMPILING NFIND-LAB!-IPEEPH!-PEEPH!-PACKAGE
+===== Non-specific structure for MAPF/R: **** .INST!-IPEEPH!-PEEPH!-PACKAGE **
+**
+ type is: STRUCTURED
+ **** <MAPF #FALSE () <FUNCTION ("AUX" X) #DECL ((VALUE) FALSE) <COND (<SET X
+ ...
+Peephole 4% 67/64
+Job done in: 5 / 9
+ COMPILING FIND-NOD!-IPEEPH!-PEEPH!-PACKAGE
+Peephole 0% 45/45
+Job done in: 5 / 7
+COMPILING INSFIX!-IPEEPH!-PEEPH!-PACKAGE
+===== Computed decl of variable: XD!-IPEEPH!-PEEPH!-PACKAGE is: LIST
+===== Not open compiled because type is: <OR FALSE
+LNODE!-IPEEPH!-PEEPH!-PACKAGE>
+<LIST <1 .XD!-IPEEPH!-PEEPH!-PACKAGE> **** <NTH <4 .X> 4> **** >
+===== Not open compiled because type is: <OR FALSE
+LNODE!-IPEEPH!-PEEPH!-PACKAGE>
+(ELSE <LIST **** <NTH <4 .X> 4> **** >)
+Peephole 0% 112/111
+Job done in: 7 / 9
+ COMPILING PRT!-PEEPH!-PACKAGE
+===== Non-specific structure for MAPF/R: **** .X ****
+ type is: STRUCTURED
+ **** <MAPF #FALSE () <FUNCTION ("AUX" X) #DECL ((VALUE) ATOM) <COND (<TYPE? .
+ ...
+===== External variable being referenced: OUTCHAN
+<COND (<TYPE? .X ATOM>) (ELSE <PRINC " " **** .OUTCHAN **** >)>
+===== External variable being referenced: OUTCHAN
+<PRIN1 .X **** .OUTCHAN **** >
+===== External variable being referenced: OUTCHAN
+<CRLF **** .OUTCHAN **** >
+Peephole 0% 66/66
+Job done in: 6 / 7
+ COMPILING FF!-IPEEPH!-PEEPH!-PACKAGE
+===== Non-specific structure for MAPF/R: <MAPF #FALSE () ,& **** .X **** >
+ type is: STRUCTURED
+ **** <MAPF #FALSE () ,& .X> ****
+===== External variable being referenced: OUTCHAN
+<CRLF **** .OUTCHAN **** >
+Peephole 0% 44/44
+Job done in: 2 / 3
+ COMPILING HACK-PRINT!-IPEEPH!-PEEPH!-PACKAGE
+===== External variable being referenced: OUTCHAN
+<FUNCTION (X) <PRIN1 <INSFIX .X> **** .OUTCHAN **** >>
+Peephole 0% 26/26
+Job done in: 1 / 2
+ COMPILING SKIPPABLE!-IPEEPH!-PEEPH!-PACKAGE
+Peephole 8% 61/56
+Job done in: 6 / 7
+ COMPILING DEL-JUMP-LN!-IPEEPH!-PEEPH!-PACKAGE
+===== Computed decl of variable: QD!-IPEEPH!-PEEPH!-PACKAGE is: LIST
+Peephole 0% 79/79
+Job done in: 6 / 8
+COMPILING CHANGE-COND!-IPEEPH!-PEEPH!-PACKAGE
+Peephole 2% 42/41
+Job done in: 2 / 3
+ COMPILING MAKE:LABEL!-IPEEPH!-PEEPH!-PACKAGE
+===== Computed decl of variable: XX!-IPEEPH!-PEEPH!-PACKAGE is: STRING
+===== External variable being referenced: LABNUM!-IPEEPH!-PEEPH!-PACKAGE
+<+ **** .LABNUM!-IPEEPH!-PEEPH!-PACKAGE **** 1>
+===== External variable being SET: LABNUM!-IPEEPH!-PEEPH!-PACKAGE
+ **** <SET LABNUM!-IPEEPH!-PEEPH!-PACKAGE <+ .LABNUM!-IPEEPH!-PEEPH!-PACKAGE 1
+ ...
+Peephole 0% 66/66
+Job done in: 2 / 3
+ COMPILING NEXTS!-IPEEPH!-PEEPH!-PACKAGE
+Peephole 1% 62/61
+Job done in: 5 / 7
+ COMPILING CROSS-OPT!-IPEEPH!-PEEPH!-PACKAGE
+===== Computed decl of variable: NEWLN!-IPEEPH!-PEEPH!-PACKAGE is:
+LNODE!-IPEEPH!-PEEPH!-PACKAGE
+===== Computed decl of variable: LABL!-IPEEPH!-PEEPH!-PACKAGE is: ATOM
+===== Computed decl of variable: NEEDLABEL!-IPEEPH!-PEEPH!-PACKAGE is: <OR
+ATOM FALSE>
+===== External variable being SET: REDO
+ **** <SET REDO "CROSS-OPTIMIZATION"> ****
+===== External variable being referenced: NLABLS!-IPEEPH!-PEEPH!-PACKAGE
+ **** .NLABLS!-IPEEPH!-PEEPH!-PACKAGE ****
+===== External variable being SET: NLABLS!-IPEEPH!-PEEPH!-PACKAGE
+ **** <SET NLABLS!-IPEEPH!-PEEPH!-PACKAGE (<LIST .LABL!-IPEEPH!-PEEPH!-PACKAGE
+ ...
+===== External variable being referenced: MODLN!-IPEEPH!-PEEPH!-PACKAGE
+ **** .MODLN!-IPEEPH!-PEEPH!-PACKAGE ****
+===== External variable being SET: MODLN!-IPEEPH!-PEEPH!-PACKAGE
+ **** <SET MODLN!-IPEEPH!-PEEPH!-PACKAGE <LIST .NEWLN!-IPEEPH!-PEEPH!-PACKAGE
+ ...
+===== Frame being generated.
+ **** <FUNCTION (TOPCOD!-IPEEPH!-PEEPH!-PACKAGE NCOD!-IPEEPH!-PEEPH!-PACKAGE
+" ...
+Peephole 3% 300/290
+Job done in: 44 / 59
+ COMPILING BACKS!-IPEEPH!-PEEPH!-PACKAGE
+Peephole 5% 59/56
+Job done in: 2 / 3
+ COMPILING ADDON!-IPEEPH!-PEEPH!-PACKAGE
+Peephole 0% 33/33
+Job done in: 5 / 7
+ COMPILING FIND-LAB!-IPEEPH!-PEEPH!-PACKAGE
+===== Non-specific structure for MAPF/R: **** .INST!-IPEEPH!-PEEPH!-PACKAGE **
+**
+ type is: STRUCTURED
+ **** <MAPF #FALSE () <FUNCTION ("AUX" X) #DECL ((VALUE) FALSE) <COND (<TYPE?
+ ...
+Peephole 7% 53/49
+Job done in: 2 / 3
+ COMPILING PSEUDO?!-IPEEPH!-PEEPH!-PACKAGE
+Peephole 13% 97/84
+Job done in: 6 / 7
+COMPILING MUNG-LAB!-IPEEPH!-PEEPH!-PACKAGE
+===== Non-specific structure for MAPF/R: **** .INST!-IPEEPH!-PEEPH!-PACKAGE **
+**
+ type is: STRUCTURED
+ **** <MAPR #FALSE () <FUNCTION ("AUX" IN (OB!-IPEEPH!-PEEPH!-PACKAGE <NTH .IN
+ ...
+===== Not open compiled because type is: <STRUCTURED ANY>
+ **** <NTH .IN 1> ****
+===== Not open compiled because type is: <STRUCTURED ANY>
+ **** <PUT .IN 1 .OB!-IPEEPH!-PEEPH!-PACKAGE> ****
+Peephole 1% 86/85
+Job done in: 6 / 11
+ COMPILING PEEP-PRINT!-IPEEPH!-PEEPH!-PACKAGE
+===== External reference to LVAL: OUTL!-IPEEPH!-PEEPH!-PACKAGE
+<NOT **** <ASSIGNED? OUTL!-IPEEPH!-PEEPH!-PACKAGE> **** >
+===== External variable being referenced: OUTCHAN
+<PRINC "Peephole " **** .OUTCHAN **** >
+===== Arithmetic can't open compile because: <- **** .LN!-IPEEPH!-PEEPH!-PACKA
+GE **** .NUMLABS!-IPEEPH!-PEEPH!-PACKAGE>
+ is of type: <OR FIX FLOAT>
+ **** <- .LN!-IPEEPH!-PEEPH!-PACKAGE .NUMLABS!-IPEEPH!-PEEPH!-PACKAGE> ****
+===== Arithmetic can't open compile because: <- .LN!-IPEEPH!-PEEPH!-PACKAGE **
+** .NUMLABS!-IPEEPH!-PEEPH!-PACKAGE **** >
+ is of type: <OR FIX FLOAT>
+ **** <- .LN!-IPEEPH!-PEEPH!-PACKAGE .NUMLABS!-IPEEPH!-PEEPH!-PACKAGE> ****
+===== Arithmetic can't open compile because: **** .NLN!-IPEEPH!-PEEPH!-PACKAGE
+ ****
+ is of type: <OR FIX FLOAT>
+ **** <- .NLN!-IPEEPH!-PEEPH!-PACKAGE .NUMLABS!-IPEEPH!-PEEPH!-PACKAGE <- .
+NNU ...
+===== Arithmetic can't open compile because: **** .NUMLABS!-IPEEPH!-PEEPH!-PAC
+KAGE ****
+ is of type: <OR FIX FLOAT>
+ **** <- .NLN!-IPEEPH!-PEEPH!-PACKAGE .NUMLABS!-IPEEPH!-PEEPH!-PACKAGE <- .
+NNU ...
+===== Arithmetic can't open compile because: **** <- .NNUMLABS!-IPEEPH!-PEEPH!
+-PACKAGE> ****
+ is of type: <OR FIX FLOAT>
+ **** <- .NLN!-IPEEPH!-PEEPH!-PACKAGE .NUMLABS!-IPEEPH!-PEEPH!-PACKAGE <- .
+NNU ...
+===== Arithmetic can't open compile because: <- **** .LN!-IPEEPH!-PEEPH!-PACKA
+GE **** .NLN!-IPEEPH!-PEEPH!-PACKAGE>
+ is of type: <OR FIX FLOAT>
+ **** <- .LN!-IPEEPH!-PEEPH!-PACKAGE .NLN!-IPEEPH!-PEEPH!-PACKAGE> ****
+===== Arithmetic can't open compile because: <- .LN!-IPEEPH!-PEEPH!-PACKAGE **
+** .NLN!-IPEEPH!-PEEPH!-PACKAGE **** >
+ is of type: <OR FIX FLOAT>
+ **** <- .LN!-IPEEPH!-PEEPH!-PACKAGE .NLN!-IPEEPH!-PEEPH!-PACKAGE> ****
+===== Arithmetic can't open compile because: **** .LN!-IPEEPH!-PEEPH!-PACKAGE
+****
+ is of type: <OR FIX FLOAT>
+ **** </ <FLOAT <- .LN!-IPEEPH!-PEEPH!-PACKAGE .NLN!-IPEEPH!-PEEPH!-PACKAGE>>
+ ...
+===== Arithmetic can't open compile because: **** </ <FLOAT <- .LN!-IPEEPH!-PE
+EPH!-PACKAGE .NLN!-IPEEPH!-PEEPH!-PACKAGE>>
+ ...
+ is of type: <OR FIX FLOAT>
+ **** <* 100 </ <FLOAT <- .LN!-IPEEPH!-PEEPH!-PACKAGE .
+NLN!-IPEEPH!-PEEPH!-PAC ...
+===== External variable being referenced: OUTCHAN
+ **** .OUTCHAN ****
+===== External variable being referenced: OUTCHAN
+<PRINC "% " **** .OUTCHAN **** >
+===== External variable being referenced: OUTCHAN
+<PRIN1 .LN!-IPEEPH!-PEEPH!-PACKAGE **** .OUTCHAN **** >
+===== External variable being referenced: OUTCHAN
+<PRINC "/" **** .OUTCHAN **** >
+===== External variable being referenced: OUTCHAN
+<PRIN1 .NLN!-IPEEPH!-PEEPH!-PACKAGE **** .OUTCHAN **** >
+===== Arithmetic can't open compile because: <- **** .LN!-IPEEPH!-PEEPH!-PACKA
+GE **** .NUMLABS!-IPEEPH!-PEEPH!-PACKAGE>
+ is of type: <OR FIX FLOAT>
+ **** <- .LN!-IPEEPH!-PEEPH!-PACKAGE .NUMLABS!-IPEEPH!-PEEPH!-PACKAGE> ****
+===== Arithmetic can't open compile because: <- .LN!-IPEEPH!-PEEPH!-PACKAGE **
+** .NUMLABS!-IPEEPH!-PEEPH!-PACKAGE **** >
+ is of type: <OR FIX FLOAT>
+ **** <- .LN!-IPEEPH!-PEEPH!-PACKAGE .NUMLABS!-IPEEPH!-PEEPH!-PACKAGE> ****
+===== Arithmetic can't open compile because: **** .NLN!-IPEEPH!-PEEPH!-PACKAGE
+ ****
+ is of type: <OR FIX FLOAT>
+ **** <- .NLN!-IPEEPH!-PEEPH!-PACKAGE .NUMLABS!-IPEEPH!-PEEPH!-PACKAGE <- .
+NNU ...
+===== Arithmetic can't open compile because: **** .NUMLABS!-IPEEPH!-PEEPH!-PAC
+KAGE ****
+ is of type: <OR FIX FLOAT>
+ **** <- .NLN!-IPEEPH!-PEEPH!-PACKAGE .NUMLABS!-IPEEPH!-PEEPH!-PACKAGE <- .
+NNU ...
+===== Arithmetic can't open compile because: **** <- .NNUMLABS!-IPEEPH!-PEEPH!
+-PACKAGE> ****
+ is of type: <OR FIX FLOAT>
+ **** <- .NLN!-IPEEPH!-PEEPH!-PACKAGE .NUMLABS!-IPEEPH!-PEEPH!-PACKAGE <- .
+NNU ...
+===== Arithmetic can't open compile because: <- **** .LN!-IPEEPH!-PEEPH!-PACKA
+GE **** .NLN!-IPEEPH!-PEEPH!-PACKAGE>
+ is of type: <OR FIX FLOAT>
+ **** <- .LN!-IPEEPH!-PEEPH!-PACKAGE .NLN!-IPEEPH!-PEEPH!-PACKAGE> ****
+===== Arithmetic can't open compile because: <- .LN!-IPEEPH!-PEEPH!-PACKAGE **
+** .NLN!-IPEEPH!-PEEPH!-PACKAGE **** >
+ is of type: <OR FIX FLOAT>
+ **** <- .LN!-IPEEPH!-PEEPH!-PACKAGE .NLN!-IPEEPH!-PEEPH!-PACKAGE> ****
+===== Arithmetic can't open compile because: **** .LN!-IPEEPH!-PEEPH!-PACKAGE
+****
+ is of type: <OR FIX FLOAT>
+ **** </ <FLOAT <- .LN!-IPEEPH!-PEEPH!-PACKAGE .NLN!-IPEEPH!-PEEPH!-PACKAGE>>
+ ...
+===== Arithmetic can't open compile because: **** </ <FLOAT <- .LN!-IPEEPH!-PE
+EPH!-PACKAGE .NLN!-IPEEPH!-PEEPH!-PACKAGE>>
+ ...
+ is of type: <OR FIX FLOAT>
+ **** <* 100 </ <FLOAT <- .LN!-IPEEPH!-PEEPH!-PACKAGE .
+NLN!-IPEEPH!-PEEPH!-PAC ...
+Peephole 0% 180/180
+Job done in: 15 / 18
+ COMPILING FIND-END-OF-CHAIN!-IPEEPH!-PEEPH!-PACKAGE
+===== Computed decl of variable: DEFAULT is: <OR FALSE
+LNODE!-IPEEPH!-PEEPH!-PACKAGE>
+===== Not open compiled because type is: <OR FALSE
+LNODE!-IPEEPH!-PEEPH!-PACKAGE>
+<NTH **** <NTH <4 .JMP!-IPEEPH!-PEEPH!-PACKAGE> 3> **** 1>
+===== Not open compiled because type is: STRUCTURED
+ **** <NTH <NTH <4 .JMP!-IPEEPH!-PEEPH!-PACKAGE> 3> 1> ****
+Peephole 4% 46/44
+Job done in: 6 / 7
+ COMPILING FLUSH-LABELS!-IPEEPH!-PEEPH!-PACKAGE
+===== Computed decl of variable: TEM!-IPEEPH!-PEEPH!-PACKAGE is: LIST
+===== External variable being referenced: SLABS!-IPEEPH!-PEEPH!-PACKAGE
+<NOT <MEMQ .X **** .SLABS!-IPEEPH!-PEEPH!-PACKAGE **** >>
+===== External variable being referenced: NLABLS!-IPEEPH!-PEEPH!-PACKAGE
+ **** .NLABLS!-IPEEPH!-PEEPH!-PACKAGE ****
+===== External variable being referenced: NLABLS!-IPEEPH!-PEEPH!-PACKAGE
+<==? .N!-IPEEPH!-PEEPH!-PACKAGE **** .NLABLS!-IPEEPH!-PEEPH!-PACKAGE **** >
+===== External variable being referenced: NLABLS!-IPEEPH!-PEEPH!-PACKAGE
+<REST **** .NLABLS!-IPEEPH!-PEEPH!-PACKAGE **** 1>
+===== External variable being SET: NLABLS!-IPEEPH!-PEEPH!-PACKAGE
+ **** <SET NLABLS!-IPEEPH!-PEEPH!-PACKAGE <REST .
+NLABLS!-IPEEPH!-PEEPH!-PACKAG ...
+===== External variable being referenced: NNUMLABS!-IPEEPH!-PEEPH!-PACKAGE
+<+ **** .NNUMLABS!-IPEEPH!-PEEPH!-PACKAGE **** 1>
+===== External variable being SET: NNUMLABS!-IPEEPH!-PEEPH!-PACKAGE
+ **** <SET NNUMLABS!-IPEEPH!-PEEPH!-PACKAGE <+ .
+NNUMLABS!-IPEEPH!-PEEPH!-PACKA ...
+===== External variable being SET: REDO
+ **** <SET REDO "FLUSH REDUNDANT LABELS"> ****
+Peephole 0% 150/149
+Job done in: 18 / 21
+ COMPILING CLEAN-IT-UP!-IPEEPH!-PEEPH!-PACKAGE
+===== Not open compiled because type is: <OR FALSE TUPLE>
+ **** <NTH <3 .LND!-IPEEPH!-PEEPH!-PACKAGE> 1> ****
+===== Not open compiled because type is: STRUCTURED
+ **** <NTH <BACK <3 .LND!-IPEEPH!-PEEPH!-PACKAGE> 1> 1> ****
+===== Not open compiled because type is: STRUCTURED
+ **** <NTH .FIN-LNODE!-IPEEPH!-PEEPH!-PACKAGE 2> ****
+===== Not open compiled because type is: #FALSE ()
+ **** <PUT .FIN-LNODE!-IPEEPH!-PEEPH!-PACKAGE 2 <ADDON <LIST .
+JMPL!-IPEEPH!-PE ...
+Peephole 0% 164/164
+Job done in: 13 / 15
+
\ No newline at end of file
--- /dev/null
+<PACKAGE "PRNTYP">
+
+<ENTRY SYMTAB-PRINT AC-PRINT>
+
+<USE "COMPDEC">
+
+<DEFINE SYMTAB-PRINT (SYM "AUX" TT TEM (OUTCHAN .OUTCHAN))
+ #DECL ((SYM) SYMTAB)
+ <PRINC "#SYMTAB [">
+ <PRIN1 <NAME-SYM .SYM>>
+ <PRINC " ">
+ <COND (<SET TT <INACS .SYM>>
+ <PRINC "#DATUM (">
+ <COND (<TYPE? <SET TEM <DATTYP .TT>> AC>
+ <PRIN1 <ACSYM .TEM>>)
+ (<TYPE? .TEM ATOM> <PRIN1 .TEM>)
+ (<TYPE? .TEM TEMP>
+ <PRIN1 <TMPNO .TEM>>)
+ (ELSE <ERROR LOSING-SYMTAB!-ERRORS>)>
+ <PRINC " ">
+ <COND (<TYPE? <SET TEM <DATVAL .TT>> AC>
+ <PRIN1 <ACSYM .TEM>>)
+ (ELSE <ERROR LOSING-SYMTAB!-ERRORS>)>
+ <PRINC ")">)>
+ <PRINC "]">>
+
+<DEFINE AC-PRINT (AC "AUX" TT TEM (OUTCHAN .OUTCHAN))
+ #DECL ((AC) AC)
+ <PRINC "#AC [">
+ <PRIN1 <ACSYM .AC>>
+ <PRINC " ">
+ <OR <ACLINK .AC> <DATUM-PRINT <ACLINK .AC>>>
+ <MAPF <> <FUNCTION (S)
+ <PRINC " ">
+ <COND (<TYPE? .S SYMTAB> <PRIN1 <NAME-SYM .S>>)
+ (ELSE <PRIN1 <TYPE .S>>)>>
+ <ACRESIDUE .AC>>
+ <PRINC "]">>
+
+<DEFINE DATUM-PRINT (TT "AUX" TEM)
+ <COND (.TT
+ <PRINC "#DATUM (">
+ <COND (<TYPE? <SET TEM <DATTYP .TT>> AC>
+ <PRIN1 <ACSYM .TEM>>)
+ (<TYPE? .TEM ATOM> <PRIN1 .TEM>)
+ (<TYPE? .TEM TEMP>
+ <PRIN1 <TMPNO .TEM>>)
+ (ELSE <ERROR LOSING-SYMTAB!-ERRORS>)>
+ <PRINC " ">
+ <COND (<TYPE? <SET TEM <DATVAL .TT>> AC>
+ <PRIN1 <ACSYM .TEM>>)
+ (ELSE <ERROR LOSING-SYMTAB!-ERRORS>)>
+ <PRINC ")">)>>\f
+<PRINTTYPE AC ,AC-PRINT>
+
+<PRINTTYPE SYMTAB ,SYMTAB-PRINT>
+
+<ENDPACKAGE>
+\f\ 3
\ No newline at end of file
--- /dev/null
+
+
+ <TITLE REST-GEN>
+
+ <DECLARE ("VALUE" DATUM!-COMPDEC!-PACKAGE NODE!-COMPDEC!-PACKAGE ANY)>
+ <PUSH TP* (AB) >
+ <PUSH TP* (AB) 1>
+ <PUSH TP* (AB) 2>
+ <PUSH TP* (AB) 3>
+ <PUSHJ P* TAG1>
+ <JRST |FINIS >
+TAG1 <SUBM M* (P) > ; 6
+ <PUSH TP* [0]> ; [4]
+ <PUSH TP* [0]> ; [5]
+ <PUSH TP* [0]> ; [6]
+ <PUSH TP* [0]> ; [7]
+ <MOVE B* (TP) -6> ; (1)
+ <PUSH TP* <TYPE-WORD LIST>> ; [8]
+ <PUSH TP* (B) 9> ; [9]
+ <MOVE D* (TP) > ; (9)
+ <MOVE PVP* (D) 1>
+ <PUSH TP* (PVP) 4> ; [10]
+ <PUSH TP* (PVP) 5> ; [11]
+ <PUSH TP* (TP) -1> ; (10) [12]
+ <PUSH TP* (TP) -1> ; (11) [13]
+ <MCALL 1 STRUCTYP>
+ <PUSH TP* A> ; [12]
+ <PUSH TP* B> ; [13]
+ <MOVE B* (TP) -4> ; (9)
+ <HRRZ D* (B) >
+ <PUSH TP* <MQUOTE %<TYPE-W NODE!-COMPDEC!-PACKAGE VECTOR>>>; [14]
+ <PUSH TP* (D) 1> ; [15]
+ <PUSH TP* <MQUOTE %<TYPE-W NODE!-COMPDEC!-PACKAGE VECTOR>>>; [16]
+ <PUSH TP* (B) 1> ; [17]
+ <PUSH TP* (TP) -1> ; (16) [18]
+ <PUSH TP* (TP) -1> ; (17) [19]
+ <MCALL 1 NTH-REST-PUT?>
+ <PUSH TP* A> ; [18]
+ <PUSH TP* B> ; [19]
+ <MOVE B* (TP) -4> ; (15)
+ <MOVE D* (B) 1>
+ <CAIE D* 2 >
+ <JRST TAG2>
+ <MOVE PVP* <MQUOTE T> -1>
+ <MOVE TVP* <MQUOTE T>>
+ <JRST TAG3>
+TAG2 <MOVE PVP* <TYPE-WORD FALSE>> ; 41
+ <MOVEI TVP* 0>
+TAG3 <PUSH TP* PVP> ; 43 [20]
+ <PUSH TP* TVP> ; [21]
+ <SKIPL (TP) > ; (21)
+ <JRST TAG4>
+ <MOVE PVP* (B) 7>
+ <JRST TAG5>
+TAG4 <MOVEI PVP* 0> ; 49
+TAG5 <PUSH TP* <TYPE-WORD FIX>> ; 50 [22]
+ <PUSH TP* PVP> ; [23]
+ <PUSH TP* (B) 4> ; [24]
+ <PUSH TP* (B) 5> ; [25]
+ <MCALL 1 GET-RANGE>
+ <PUSH TP* A> ; [24]
+ <PUSH TP* B> ; [25]
+ <INTGO>
+ <PUSH TP* <MQUOTE %<TYPE-W NODE!-COMPDEC!-PACKAGE VECTOR>>>; [26]
+ <PUSH TP* (TP) -25> ; (1) [27]
+ <MCALL 1 FIND-COMMON>
+ <MOVEM A* (TP) -19> ; (6)
+ <MOVEM B* (TP) -18> ; (7)
+ <JUMPGE B* TAG6>
+ <PUSH TP* A> ; [26]
+ <PUSH TP* B> ; [27]
+ <MCALL 1 GET-COMMON-DATUM>
+ <PUSH TP* A> ; [26]
+ <PUSH TP* B> ; [27]
+ <PUSH TP* (TP) -25> ; (2) [28]
+ <PUSH TP* (TP) -25> ; (3) [29]
+ <MCALL 2 MOVE:ARG>
+ <MOVEM A* (TP) -21> ; (4)
+ <MOVEM B* (TP) -20> ; (5)
+ <JRST TAG7>
+TAG6 <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; 76 [26]
+ <PUSH TP* <MQUOTE COMMON-SUB>> ; [27]
+ <PUSH TP* <TYPE-WORD FALSE>> ; [28]
+ <PUSH TP* [0]> ; [29]
+ <PUSH TP* <MQUOTE (<OR FALSE COMMON!-COMPDEC!-PACKAGE>)> -1>; [30]
+ <PUSH TP* <MQUOTE (<OR FALSE COMMON!-COMPDEC!-PACKAGE>)>>; [31]
+ <PUSHJ P* |SPECBN >
+ <MOVE B* <MQUOTE %<RGLOC RESTERS T>>>
+ <ADD B* |GLOTOP 1>
+ <MOVE D* <MQUOTE %<RGLOC STYPES!-COMPDEC!-PACKAGE T>>>
+ <ADD D* |GLOTOP 1>
+ <MOVE PVP* <TYPE-WORD UVECTOR>>
+ <MOVE TVP* (D) 1>
+ <MOVE D* (TP) -18> ; (13)
+ <JUMPGE TVP* TAG8>
+TAG10 <CAMN D* (TVP) > ; 91
+ <JRST TAG9>
+ <AOBJN TVP* TAG10>
+TAG8 <MOVE D* <TYPE-WORD FALSE>> ; 94
+ <MOVEI PVP* 0>
+ <JRST TAG11>
+TAG9 <MOVE D* <TYPE-WORD UVECTOR>> ; 97
+ <MOVE PVP* TVP>
+TAG11 <HLRE D* PVP> ; 99
+ <MOVNS O* D>
+ <MOVE PVP* (B) 1>
+ <JUMPLE D* |CERR1 >
+ <ASH D* A>
+ <HRLI D* (D) 0>
+ <ADD D* PVP>
+ <CAILE D* -1 >
+ <JRST |CERR2 >
+ <PUSH TP* (D) -2> ; [32]
+ <PUSH TP* (D) -1> ; [33]
+ <PUSH TP* <MQUOTE %<TYPE-W NODE!-COMPDEC!-PACKAGE VECTOR>>>; [34]
+ <PUSH TP* (TP) -33> ; (1) [35]
+ <PUSH TP* (TP) -33> ; (2) [36]
+ <PUSH TP* (TP) -33> ; (3) [37]
+ <PUSH TP* (TP) -27> ; (10) [38]
+ <PUSH TP* (TP) -27> ; (11) [39]
+ <PUSH TP* (TP) -27> ; (12) [40]
+ <PUSH TP* (TP) -27> ; (13) [41]
+ <PUSH TP* (TP) -21> ; (20) [42]
+ <PUSH TP* (TP) -21> ; (21) [43]
+ <PUSH TP* (TP) -21> ; (22) [44]
+ <PUSH TP* (TP) -21> ; (23) [45]
+ <MOVE B* (TP) -36> ; (9)
+ <PUSH TP* <MQUOTE %<TYPE-W NODE!-COMPDEC!-PACKAGE VECTOR>>>; [46]
+ <PUSH TP* (B) 1> ; [47]
+ <PUSH TP* (TP) -33> ; (14) [48]
+ <PUSH TP* (TP) -33> ; (15) [49]
+ <PUSH TP* <MQUOTE T> -1> ; [50]
+ <PUSH TP* <MQUOTE T>> ; [51]
+ <PUSH TP* <TYPE-WORD FALSE>> ; [52]
+ <PUSH TP* [0]> ; [53]
+ <PUSH TP* (TP) -29> ; (24) [54]
+ <PUSH TP* (TP) -29> ; (25) [55]
+ <MCALL *14* APPLY>
+ <MOVE D* (TP) -3> ; (28)
+ <MOVE PVP* (TP) -2> ; (29)
+ <SUB TP* [<(6) 6>]>
+ <PUSHJ P* |SSPECS >
+ <MOVEM A* (TP) -21> ; (4)
+ <MOVEM B* (TP) -20> ; (5)
+ <MOVEM D* (TP) -19> ; (6)
+ <MOVEM PVP* (TP) -18> ; (7)
+TAG7 <PUSH TP* <MQUOTE REST> -1> ; 142 [26]
+ <PUSH TP* <MQUOTE REST>> ; [27]
+ <PUSH TP* (TP) -11> ; (16) [28]
+ <PUSH TP* (TP) -11> ; (17) [29]
+ <PUSH TP* (TP) -23> ; (6) [30]
+ <PUSH TP* (TP) -23> ; (7) [31]
+ <PUSH TP* (TP) -29> ; (2) [32]
+ <PUSH TP* (TP) -29> ; (3) [33]
+ <PUSH TP* (TP) -29> ; (4) [34]
+ <PUSH TP* (TP) -29> ; (5) [35]
+ <PUSH TP* (TP) -15> ; (20) [36]
+ <PUSH TP* (TP) -15> ; (21) [37]
+ <PUSH TP* (TP) -15> ; (22) [38]
+ <PUSH TP* (TP) -15> ; (23) [39]
+ <PUSH TP* (TP) -27> ; (12) [40]
+ <PUSH TP* (TP) -27> ; (13) [41]
+ <PUSH TP* (TP) -23> ; (18) [42]
+ <PUSH TP* (TP) -23> ; (19) [43]
+ <MCALL *11* HACK-COMMON>
+ <MOVE B* (TP) -20> ; (5)
+ <SUB TP* [<(26) 26>]>
+ <MOVE A* <MQUOTE %<TYPE-W DATUM!-COMPDEC!-PACKAGE LIST>>>
+ <JRST |MPOPJ >
+ <0>
+ <(*47*) -1>
+ <(6) 6>
+ <(26) 26>
+ <(2) 6>
+ <(*65523*) *200067*>
+ <0>
+ <(1) 2>
--- /dev/null
+<BLOCK (<ROOT>)>
+COMBAT
+<ENDBLOCK>
+
+<DEFINE COMBAT-HACKER ("AUX" CH)
+ <COND (<NOT <GASSIGNED? PLANNED!-COMBAT!->>
+ <REALTIMER 20>)
+ (<AND <=? ,PLANNED!-COMBAT!- "RIOT">
+ <SET CH <OPEN "READ" "MUDSYS;T.PRINT >">>>
+ <OFF "REALT">
+ <REALTIMER 0>
+ <CLOSE .CH>
+ <SETG FR& <FUNCTION ("TUPLE" T) T>>
+ <ERROR "Rioting is no longer available, please use Plans">)
+ (ELSE
+ <OFF "REALT">
+ <REALTIMER 0>)>>
+
+
+<DEFINE HACKER (A B)
+ <COND (<==? .A <ASCII 4>> <SETG DONT-HACK-ME T>)>
+ <QUITTER .A .B>>
+
+<DEFINE RHACK ()
+ <OFF "CHAR" ,INCHAN>
+ <COND (,DONT-HACK-ME
+ <SETG DONT-HACK-ME <>>
+ <ON "CHAR" ,QUITTER 8 0 ,INCHAN>
+ <REALTIMER 0>
+ <OFF "REALT">)
+ (ELSE
+ <REALTIMER 0>
+ <OFF "REALT">
+ <MPV-IN-GC>)>>
+
+
+
+<SETG MPV-IN-GC
+ <FIXUP!-RSUBRS '[
+#CODE ![23852220422 23852482567 23849036821 23852220423 268671802 23085677464
+10223615 -262143 6718806673 0 2!]
+ MPV-IN-GC
+ #DECL ("VALUE" ANY)
+ ""]
+ '(51
+ $TLOSE!-MUDDLE
+ 224256
+ (3)
+ GC
+ 236346
+ (5)
+ FINIS!-MUDDLE
+ 228248
+ (6))>>
+
+\f\ 3\ 3
\ No newline at end of file
--- /dev/null
+
+
+ <TITLE HACK-NAME>
+ <DECLARE ("VALUE" ATOM SUBR)>
+ <PUSH TP* (AB)>
+ <PUSH TP* 1(AB)>
+ <PUSHJ P* IHACK-NAME>
+ <JRST FINIS>
+
+ <INTERNAL-ENTRY IHACK-NAME 1>
+ <SUBM M* (P)>
+ <MOVSI A* <TYPE-CODE ATOM>>
+ <HRRZ B* (TP)>
+ <MOVE B* @ -1 (B)>
+ <SUB TP* [<2 (2)>]>
+ <JRST MPOPJ>
+
+
+
+\ 3\ 3
\ No newline at end of file
--- /dev/null
+<PACKAGE "STRANA">
+
+<ENTRY LENGTH-ANA EMPTY?-ANA LENGTH?-ANA NTH-ANA REST-ANA PUT-ANA PUTREST-ANA
+ MEMQ-ANA NTH-REST-ANA>
+
+<USE "SYMANA" "CHKDCL" "COMPDEC" "ADVMESS">
+
+"Structure hackers for the compiler (analyzers)"
+
+<DEFINE LNTH-MT-ANA (NOD RTYP COD
+ "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM (WHO ())
+ (WHON
+ <AND <OR <AND <==? .COD ,LNTH-CODE>
+ <ASSIGNED? GLN>
+ <ANCEST .GLN <PARENT .NOD>>>
+ <AND <==? .PRED <PARENT .NOD>>
+ <==? .COD ,MT-CODE>>>
+ .NOD>))
+ #DECL ((NOD) NODE (LN COD) FIX (K) <LIST [REST NODE]>
+ (WHO) <SPECIAL LIST> (WHON) <SPECIAL <OR NODE FALSE>>)
+ <COND (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <ARGCHK .LN 1 <NODE-NAME .NOD>>
+ <SET TEM <EANA <1 .K> STRUCTURED <NODE-NAME .NOD>>>
+ <COND (<SET TEM <STRUCTYP .TEM>> <PUT .NOD ,NODE-TYPE .COD>)
+ (ELSE
+ <COND (.VERBOSE
+ <ADDVMESS .NOD
+ ("Not open compiled because type is: "
+ <RESULT-TYPE <1 .K>>)>)>
+ <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>)>
+ <COND (<==? .COD ,MT-CODE>
+ <MAPF <>
+ <FUNCTION (L "AUX" (SYM <2 .L>) (FLG <1 .L>))
+ #DECL ((L) <LIST <OR FALSE ATOM> SYMTAB>
+ (SYM) SYMTAB)
+ '<SET TRUTH
+ <ADD-TYPE-LIST .SYM
+ '<STRUCTURED [REST
+ <NOT ANY>]>
+ .TRUTH
+ .FLG
+ <REST .L 2>>>
+ <SET UNTRUTH
+ <ADD-TYPE-LIST
+ .SYM
+ '<STRUCTURED ANY>
+ .UNTRUTH
+ .FLG
+ <REST .L 2>>>
+ T>
+ .WHO>)
+ (ELSE <SET GLE .WHO>)>
+ <TYPE-OK? <COND (<==? <NODE-SUBR .NOD> ,LENGTH> <FORM FIX (0 ,PLUSINF)>)
+ (ELSE '<OR FALSE ATOM>)>
+ .RTYP>>
+
+<DEFINE ANCEST (N1 N2)
+ #DECL ((N1 N2) NODE)
+ <REPEAT ()
+ <COND (<==? .N1 .N2> <RETURN>)>
+ <OR <==? <NODE-TYPE .N2> ,SET-CODE> <RETURN <>>>
+ <COND (<TYPE? <PARENT .N2> NODE> <SET N2 <PARENT .N2>>)
+ (ELSE <RETURN <>>)>>>
+
+<DEFINE LENGTH-ANA (N R) <LNTH-MT-ANA .N .R ,LNTH-CODE>>
+
+<PUT ,LENGTH ANALYSIS ,LENGTH-ANA>
+
+<DEFINE EMPTY?-ANA (N R) <LNTH-MT-ANA .N .R ,MT-CODE>>
+
+<PUT ,EMPTY? ANALYSIS ,EMPTY?-ANA>
+
+<DEFINE LENGTH?-ANA (NOD RTYP
+ "AUX" (K <KIDS .NOD>) TEM (WHO ())
+ (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>))
+ #DECL ((NOD) NODE (K) <LIST [REST NODE]> (WHON) <SPECIAL ANY>
+ (WHO) <SPECIAL LIST>)
+ <COND
+ (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <ARGCHK <LENGTH .K> 2 LENGTH?>
+ <SET TEM <EANA <1 .K> STRUCTURED LENGTH?>>
+ <SET WHON <>>
+ <EANA <2 .K> FIX LENGTH?>
+ <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> ;"Constant 2d arg?"
+ <MAPF <>
+ <FUNCTION (L "AUX" (SYM <2 .L>) (FLG <1 .L>))
+ #DECL ((L) <LIST ANY SYMTAB> (SYM) SYMTAB)
+ <SET UNTRUTH
+ <ADD-TYPE-LIST .SYM
+ <FORM STRUCTURED
+ [<NODE-NAME <2 .K>> ANY]>
+ .TRUTH
+ .FLG
+ <REST .L 2>>>>
+ .WHO>)>
+ <COND (<SET TEM <STRUCTYP .TEM>>
+ <PUT .NOD ,NODE-TYPE ,LENGTH?-CODE>)
+ (ELSE
+ <COND (.VERBOSE
+ <ADDVMESS .NOD
+ ("Not open compiled because type is: "
+ <RESULT-TYPE <1 .K>>)>)>
+ <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
+ <TYPE-OK? <FORM OR <FORM FIX
+ (0
+ <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <NODE-NAME .NOD>)
+ (ELSE ,PLUSINF)>)>
+ FALSE>
+ .RTYP>)>>
+
+<PUT ,LENGTH? ANALYSIS ,LENGTH?-ANA>
+
+<DEFINE NTH-REST-ANA (NOD RTYP COD
+ "OPTIONAL" (TF <>)
+ "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TS VAL TPS
+ (RV <OR .TF <==? <NODE-NAME .NOD> INTH>>)
+ (SVWHO ())
+ (NM <COND (.RV NTH) (ELSE <NODE-NAME .NOD>)>) XX
+ (OWHON <AND <==? .WHON <PARENT .NOD>> .NOD>) NUMB)
+ #DECL ((COD NUMB LN) FIX (NOD WHON PRED) NODE (K) <LIST [REST NODE]>
+ (WHO SVWHO) LIST)
+ <SET VAL
+ <PROG ((WHO ()) (WHON <>))
+ #DECL ((WHON) <SPECIAL ANY> (WHO) <SPECIAL LIST>)
+ <COND
+ (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <COND (<1? .LN>
+ <PUT .NOD
+ ,KIDS
+ <SET K (<1 .K> <NODE1 ,QUOTE-CODE .NOD FIX 1 ()>)>>)
+ (ELSE <ARGCHK .LN 2 <NODE-NAME .NOD>>)>
+ <COND (.RV
+ <OR .TF <SET TF <EANA <2 .K> '<OR FIX OFFSET> .NM>>>
+ <SET WHON .NOD>
+ <SET TS <EANA <1 .K> STRUCTURED .NM>>)
+ (ELSE
+ <SET WHON .NOD>
+ <SET TS <EANA <1 .K> STRUCTURED .NM>>
+ <SET WHON <>>
+ <OR .TF <SET TF <EANA <2 .K> '<OR FIX OFFSET> .NM>>>)>
+ <COND (<AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> <==? <ISTYPE? .TF> OFFSET>>
+ <SET TS <TYPE-AND .TS <GET-DECL <NODE-NAME <2 .K>>>>>
+ <PUT <1 .K> ,RESULT-TYPE .TS>)>
+ <SET TPS <STRUCTYP .TS>>
+ <COND (<AND .TPS <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
+ <SET SVWHO .WHO>)>
+ <COND
+ (<AND .TPS
+ <OR <==? <ISTYPE? .TF> FIX>
+ <AND <==? <ISTYPE? .TF> OFFSET>
+ <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>>
+ <N==? <ISTYPE? .TS> TEMPLATE>
+ <OR <NOT <==? .TPS TEMPLATE>>
+ <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> <ISTYPE? .TS>>>>
+ <PUT .NOD ,NODE-TYPE .COD>)
+ (ELSE
+ <AND <==? .COD ,NTH-CODE> <PUT .NOD ,NODE-NAME NTH>>
+ <COND (.VERBOSE
+ <ADDVMESS .NOD ("Not open compiled because type is: " .TS)>)>
+ <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
+ <TYPE-OK?
+ <GET-ELE-TYPE
+ .TS
+ <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <SET NUMB
+ <COND (<==? <ISTYPE? .TF> OFFSET>
+ <INDEX <NODE-NAME <2 .K>>>)
+ (ELSE <NODE-NAME <2 .K>>)>>)
+ (ELSE ALL)>
+ <==? <NODE-SUBR .NOD> ,REST>>
+ .RTYP>)>>>
+ <MAPF <>
+ <FUNCTION (L "AUX" (SYM <2 .L>) (FL <1 .L>) T1 T2)
+ #DECL ((L) <LIST ANY SYMTAB [REST ATOM FIX]> (SYM) SYMTAB)
+ <SET XX (.NM .NUMB !<REST .L 2>)>
+ <SET-CURRENT-TYPE
+ .SYM
+ <TYPE-AND <GET-CURRENT-TYPE .SYM> <TYPE-NTH-REST .VAL .XX>>>
+ <COND (.OWHON <SET WHO ((.FL .SYM !.XX) !.WHO)>)>
+ <COND (<AND <==? .PRED <PARENT .NOD>>
+ <SET T1 <TYPE-OK? .VAL FALSE>>
+ <SET T2 <TYPE-OK? .VAL '<NOT FALSE>>>>
+ <SET TRUTH <ADD-TYPE-LIST .SYM .T2 .TRUTH .FL .XX>>
+ <SET UNTRUTH
+ <ADD-TYPE-LIST .SYM .T1 .UNTRUTH .FL .XX>>)>>
+ .SVWHO>
+ <COND (<AND <==? .TPS LIST>
+ <OR <==? <NODE-TYPE <1 .K>> ,LVAL-CODE>
+ <==? <NODE-TYPE <1 .K>> ,SET-CODE>>
+ <LOOK-FOR .NOD <1 .K> <2 .K> <==? <NODE-SUBR .NOD> ,REST>>>
+ <PUT .NOD ,NODE-TYPE ,ALL-REST-CODE>)
+ (<AND <==? .TPS LIST>
+ <==? .COD ,REST-CODE>
+ <GASSIGNED? PUT-SAME-CODE>
+ <==? <NODE-TYPE <1 .K>> ,PUTR-CODE>
+ <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <==? .NUMB 1>>
+ <PUT .NOD ,NODE-TYPE ,PUTR-CODE>)>
+ .VAL>
+
+<DEFINE LOOK-FOR (MN N1 N RFLG "AUX" TT K (S ()) (SS (() () ())))
+ #DECL ((S) <LIST [REST NODE]> (N MN N1) NODE (TT) <OR FALSE NODE>
+ (K) <LIST [REST NODE]>)
+ <REPEAT ()
+ <COND (<==? <NODE-TYPE .N1> ,LVAL-CODE>
+ <SET S (.N1 !.S)>
+ <RETURN>)
+ (<==? <NODE-TYPE .N1> ,SET-CODE>
+ <SET S (.N1 !.S)>
+ <SET N1 <2 <KIDS .N1>>>)
+ (ELSE <RETURN>)>>
+ <AND <OR <AND .RFLG
+ <SET TT <SET-SEARCH .N ,ARITH-CODE .S .SS>>
+ <==? <NODE-SUBR <SET N .TT>> ,->
+ <==? <LENGTH <SET K <KIDS .N>>> 2>
+ <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <==? <NODE-NAME <2 .K>> 1>
+ <SET N <1 .K>>>
+ <NOT .RFLG>>
+ <SET TT <SET-SEARCH .N ,LNTH-CODE .S <REST .SS>>>
+ <SET TT
+ <SET-SEARCH <1 <KIDS .TT>> ,LVAL-CODE .S <REST .SS 2>>>
+ <SMEMQ <NODE-NAME .TT> .S>
+ <PUT .MN ,TYPE-INFO .SS>>>
+
+<DEFINE SET-SEARCH (N C S SS "AUX" (L ()))
+ #DECL ((N) NODE (C) FIX (S) <LIST [REST NODE]> (L SS) LIST)
+ <REPEAT ()
+ <COND (<==? .C <NODE-TYPE .N>> <PUT .SS 1 .L> <RETURN .N>)>
+ <COND (<OR <N==? <NODE-TYPE .N> ,SET-CODE>
+ <SMEMQ <NODE-NAME .N> .S>>
+ <RETURN <>>)>
+ <SET L (.N !.L)>
+ <SET N <2 <KIDS .N>>>>>
+
+<DEFINE SMEMQ (SYM L)
+ #DECL ((SYM) SYMTAB (L) LIST)
+ <MAPR <>
+ <FUNCTION (LL "AUX" (N <1 .LL>))
+ #DECL ((N) NODE)
+ <COND (<==? <NODE-NAME .N> .SYM> <MAPLEAVE .LL>)>>
+ .L>>
+
+<DEFINE NTH-ANA (N R) <NTH-REST-ANA .N .R ,NTH-CODE>>
+
+<PUT ,NTH ANALYSIS ,NTH-ANA>
+
+<DEFINE REST-ANA (N R) <NTH-REST-ANA .N .R ,REST-CODE>>
+
+<PUT ,REST ANALYSIS ,REST-ANA>
+
+<DEFINE PUT-ANA (NOD RTYP
+ "OPTIONAL" (TF <>)
+ "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) (TS ANY) TV (TPS <>) VAL
+ (SVWHO ()) WHICH NS TVO TEM (P ()) TFF NUMB
+ (RV <OR .TF <==? <NODE-NAME .NOD> IPUT>>)
+ (NM <COND (.RV PUT) (ELSE <NODE-NAME .NOD>)>))
+ #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN NUMB) FIX (WHO P SVWHO) LIST)
+ <SET VAL
+ <PROG ((WHO ()) (WHON <>))
+ #DECL ((WHO) <SPECIAL LIST> (WHON) <SPECIAL <OR FALSE NODE>>)
+ <COND
+ (<SEGFLUSH .NOD .RTYP>)
+ (<==? .LN 2>
+ <EANA <1 .K> ANY <NODE-NAME .NOD>>
+ <EANA <2 .K> ANY <NODE-NAME .NOD>>
+ <COND (<AND .VERBOSE <==? <NODE-SUBR .NOD> ,PUT>>
+ <ADDVMESS .NOD ("PUT being used to remove association.")>)>
+ <PUT .NOD ,NODE-TYPE ,IREMAS-CODE>)
+ (ELSE
+ <ARGCHK .LN 3 <NODE-NAME .NOD>>
+ <COND (.RV
+ <SET WHON <>>
+ <OR .TF <SET TF <SET TFF <ANA <2 .K> ANY>>>>
+ <SET WHON .NOD>
+ <SET TS <ANA <1 .K> <OR <AND .TF STRUCTURED> ANY>>>
+ <SET WHON <>>)
+ (ELSE
+ <SET WHON .NOD>
+ <SET TS <ANA <1 .K> ANY>>
+ <SET WHON <>>
+ <OR .TF <SET TFF <SET TF <ANA <2 .K> ANY>>>>)>
+ <SET TV <ANA <3 .K> ANY>>
+ <COND (<AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> <==? <ISTYPE? .TF> OFFSET>>
+ <SET TS <TYPE-AND .TS <GET-DECL <NODE-NAME <2 .K>>>>>
+ <PUT <1 .K> ,RESULT-TYPE .TS>)>
+ <AND <TYPE-OK? .TS '<NOT STRUCTURED>> <SET TS <>>>
+ <OR <AND <OR <==? <ISTYPE? .TF> FIX>
+ <AND <==? <ISTYPE? .TF> OFFSET>
+ <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>>
+ <==? <NODE-SUBR .NOD> ,PUT>>
+ <SET TF <>>>
+ <SET NS
+ <COND (<AND .TF .TS <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
+ <SET WHICH
+ <COND (<==? <ISTYPE? .TF> FIX> <NODE-NAME <2 .K>>)
+ (ELSE <INDEX <NODE-NAME <2 .K>>>)>>
+ <FORM STRUCTURED
+ !<COND (<1? .WHICH> (.TV))
+ (ELSE ([<- .WHICH 1> ANY] .TV))>>)
+ (ELSE <SET WHICH ALL> '<STRUCTURED [REST ANY]>)>>
+ <COND
+ (<AND .TS .TF <NOT <EMPTY? .WHO>>>
+ <SET NS
+ <MAPF ,TYPE-MERGE
+ <FUNCTION (L "AUX" (S <2 .L>) (ND <1 <DECL-SYM .S>>))
+ #DECL ((L) <LIST ANY SYMTAB> (S) SYMTAB)
+ <SET ND <DECL-DOWN .ND !<REST .L 2>>>
+ <OR <TYPE-OK? .ND .NS> <MESSAGE ERROR "BAD ARG TO PUT" .NOD>>
+ <SET ND
+ <TYPE-AND
+ <TYPE-AND
+ <GET-ELE-TYPE .ND .WHICH <> .TV>
+ <TOP-TYPE <DECL-DOWN <GET-CURRENT-TYPE .S> !<REST .L 2>>>>
+ .ND>>>
+ .WHO>>
+ <SET TV <TYPE-AND .TV <GET-ELE-TYPE .NS .WHICH>>>)
+ (<NOT <EMPTY? .WHO>> <SET TV ANY>)>
+ <AND .TS
+ <PUT <1 .K> ,RESULT-TYPE <SET TS <TYPE-AND <TOP-TYPE .NS> .TS>>>>
+ <COND (.TS
+ <SET TVO <GET-ELE-TYPE .TS .WHICH>>
+ <SET TS <GET-ELE-TYPE .TS .WHICH <> .TV>>)>
+ <COND (<AND .TS .TF <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
+ <SET SVWHO .WHO>)>
+ <COND (<AND .TS .TF>
+ <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>)>
+ <COND
+ (<AND .TS
+ .TF
+ <SET TPS <STRUCTYP .TS>>
+ <OR <==? <ISTYPE? .TF> FIX> <==? <ISTYPE? .TF> OFFSET>>
+ <N==? <ISTYPE? .TS> TEMPLATE>
+ <OR <NOT <==? .TPS TEMPLATE>>
+ <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> <ISTYPE? .TS>>>
+ <OR <NOT <==? .TPS LIST>>
+ <0? <SET TEM <DEFERN .TV>>>
+ <AND <==? .TEM 1> <1? <DEFERN .TVO>>>>>
+ <PUT .NOD ,NODE-TYPE ,PUT-CODE>
+ <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
+ <MESSAGE ERROR " ATTEMPT TO MUNG QUOTED OBJECT " .NOD>)>)
+ (ELSE
+ <COND
+ (<AND .VERBOSE <==? <NODE-SUBR .NOD> ,PUT>>
+ <ADDVMESS
+ .NOD
+ <COND
+ (.TF
+ <COND (<==? .TPS LIST> ("Not open compiled because of defer."))
+ (ELSE ("Not open compiled because type is: " .TS))>)
+ (<NOT <TYPE-OK? .TFF FIX>>
+ ("PUT used for association manipulation."))
+ (ELSE
+ ("PUT maybe structure or association. Type of 1st arg is: "
+ .TS
+ " and that of 2d arg is: "
+ .TFF))>>)>
+ <PUT .NOD ,NODE-TYPE ,IPUT-CODE>)>)>
+ <PUT-FLUSH <OR .TPS ALL>>
+ <TYPE-OK? <COND (.TS .TS) (ELSE ANY)> .RTYP>>>
+ <COND
+ (<==? <NODE-TYPE .NOD> ,PUT-CODE>
+ <MAPF <>
+ <FUNCTION (L "AUX" (SYM <2 .L>))
+ #DECL ((L) <LIST ANY SYMTAB [REST ATOM FIX]> (SYM) SYMTAB)
+ <SET-CURRENT-TYPE
+ .SYM
+ <PUT-TYPE-HACK <GET-CURRENT-TYPE .SYM>
+ .TS
+ <LPR <REST .L 2>>
+ .WHICH
+ 0>>>
+ .SVWHO>)>
+ <COND (<AND <==? <NODE-TYPE .NOD> ,PUT-CODE>
+ <GASSIGNED? PUT-SAME-CODE>
+ <MEMQ .TPS '![LIST VECTOR UVECTOR TUPLE!]>
+ <MAPF <>
+ <FUNCTION (N)
+ <COND (<AND <G=? <LENGTH .N>
+ <INDEX ,SIDE-EFFECTS>>
+ <SIDE-EFFECTS .N>>
+ <MAPLEAVE <>>)
+ (ELSE T)>>
+ .K>
+ <MEMQ <NODE-TYPE <3 .K>> ,HACK-NODES>
+ <==? <ISTYPE? <RESULT-TYPE <3 .K>>> FIX>
+ <NOT <EMPTY? <SET TEM <KIDS <3 .K>>>>>
+ <NOT <OR <==? <NODE-SUBR <3 .K>> ,/>
+ <AND <==? <NODE-SUBR <3 .K>> ,->
+ <NOT <AND <==? <LENGTH .TEM> 2>
+ <==? <NODE-NAME <2 .TEM>> 1>>>>>>
+ <MAPR <>
+ <FUNCTION (L "AUX" (N <1 .L>))
+ <COND (<AND <==? <NODE-TYPE .N> ,NTH-CODE>
+ <SAME-OBJ <1 .K> <1 <KIDS .N>>>
+ <SAME-OBJ <2 .K> <2 <KIDS .N>>>>
+ <COND (<NOT <EMPTY? .P>>
+ <PUTREST .P <REST .L>>
+ <SET TEM (.N !.TEM)>)>
+ <MAPLEAVE>)>
+ <SET P .L>
+ <>>
+ .TEM>>
+ <PUT <3 .K> ,KIDS .TEM>
+ <PUT .NOD ,NODE-TYPE ,PUT-SAME-CODE>)>
+ .VAL>
+
+<DEFINE PUT-TYPE-HACK (TY TS L WHICH EX)
+ #DECL ((L) <LIST [REST FIX ATOM]>)
+ <COND (<EMPTY? .L> .TS)
+ (<AND <EMPTY? <REST .L 2>> <==? <2 .L> REST>>
+ <GET-ELE-TYPE
+ .TY
+ <+ <1 .L> .WHICH>
+ <>
+ <PUT-TYPE-HACK <GET-ELE-TYPE .TS .WHICH>
+ .TS
+ <REST .L 2>
+ .WHICH
+ 0>>)
+ (<==? <2 .L> REST>
+ <PUT-TYPE-HACK .TY .TS <REST .L 2> .WHICH <1 .L>>)
+ (ELSE
+ <GET-ELE-TYPE
+ .TY
+ <+ <1 .L> .EX>
+ <>
+ <PUT-TYPE-HACK <GET-ELE-TYPE .TY <+ <1 .L> .EX>>
+ .TS
+ <REST .L 2>
+ .WHICH
+ 0>>)>>
+
+<DEFINE LPR (L)
+ #DECL ((L) LIST)
+ <COND (<EMPTY? .L> .L) (ELSE (!<LPR <REST .L>> <1 .L>))>>
+
+<SETG HACK-NODES ![,ABS-CODE ,ARITH-CODE!]>
+
+<PUT ,PUT ANALYSIS ,PUT-ANA>
+
+<PUT ,PUTPROP ANALYSIS ,PUT-ANA>
+
+<DEFINE SAME-OBJ (N1 N2)
+ #DECL ((N1 N2) NODE)
+ <COND (<==? <NODE-TYPE .N1> <NODE-TYPE .N2>>
+ <COND (<MEMQ <NODE-TYPE .N1> ,SNODES>
+ <==? <NODE-NAME .N1> <NODE-NAME .N2>>)
+ (ELSE
+ <MAPF <>
+ <FUNCTION (N3 N4)
+ <COND (<SAME-OBJ .N3 .N4>)
+ (ELSE <MAPLEAVE <>>)>>
+ <KIDS .N1>
+ <KIDS .N2>>)>)>>
+
+<DEFINE DECL-DOWN ("TUPLE" TUP "AUX" (ND <1 .TUP>) (LN <- <LENGTH .TUP> 1>))
+ #DECL ((TUP) TUPLE (LN) FIX)
+ <REPEAT ()
+ <COND (<L? .LN 2> <RETURN .ND>)
+ (ELSE
+ <SET ND
+ <GET-ELE-TYPE
+ .ND
+ <NTH .TUP <+ .LN 1>>
+ <==? <NTH .TUP .LN> REST>>>)>
+ <SET LN <- .LN 2>>>>
+
+<DEFINE DECL-UP (NX L)
+ #DECL ((L) LIST)
+ <REPEAT ((FIRST T) (NUM 0))
+ #DECL ((NUM) FIX (L) LIST)
+ <COND (<EMPTY? .L> <RETURN .NX>)>
+ <COND (<==? <1 .L> NTH>
+ <SET NX
+ <FORM STRUCTURED
+ !<COND (<0? <SET NUM <+ .NUM <2 .L> -1>>> ())
+ (<1? .NUM> (ANY))
+ (ELSE ([.NUM ANY]))>
+ .NX>>
+ <SET NUM 0>
+ <SET FIRST <>>)
+ (.FIRST <SET NX <REST-DECL .NX <2 .L>>>)
+ (ELSE <SET NUM <+ .NUM <2 .L>>>)>
+ <SET L <REST .L 2>>>>
+
+<DEFINE PUTREST-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) T1 T2)
+ #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
+ <COND (<==? <NODE-SUBR .NOD> ,REST> <REST-ANA .NOD .RTYP>)
+ (<SEGFLUSH .NOD .RTYP>
+ <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
+ <TYPE-OK? '<PRIMTYPE LIST> .RTYP>)
+ (ELSE
+ <ARGCHK <LENGTH .K> 2 PUTREST>
+ <SET T1 <EANA <1 .K> '<PRIMTYPE LIST> PUTREST>>
+ <SET T2 <EANA <2 .K> '<PRIMTYPE LIST> PUTREST>>
+ <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
+ <MESSAGE ERROR " ATTEMPT TO MUNG QUOTED OBJECT " .NOD>)>
+ <PUT .NOD ,NODE-TYPE ,PUTR-CODE>
+ <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
+ <TYPE-OK? .T1 .RTYP>)>>
+
+<PUT ,PUTREST ANALYSIS ,PUTREST-ANA>
+
+<DEFINE MEMQ-ANA (N R "AUX" (K <KIDS .N>) TYP VTYP STYP ETY)
+ #DECL ((N) NODE (K) <LIST [REST NODE]>)
+ <COND
+ (<SEGFLUSH .N .R>)
+ (ELSE
+ <ARGCHK <LENGTH .K> 2 MEMQ>
+ <SET VTYP <EANA <1 .K> ANY MEMQ>>
+ <SET TYP <EANA <2 .K> STRUCTURED MEMQ>>
+ <COND (<NOT <TYPE-OK? .VTYP <SET ETY <GET-ELE-TYPE .TYP ALL>>>>
+ <MESSAGE WARNING "MEMQ NEVER TRUE " .N>)>
+ <COND (<AND <SET STYP <STRUCTYP .TYP>> <N==? .STYP TEMPLATE>>
+ <PUT .N ,NODE-TYPE ,MEMQ-CODE>)
+ (ELSE
+ <COND (.VERBOSE <ADDVMESS .N ("Not open compiled because type is: "
+ .TYP)>)>
+ <PUT .N ,NODE-TYPE ,ISUBR-CODE>)>
+ <TYPE-OK? <TYPE-MERGE FALSE
+ <COND (<AND .ETY <N==? .ETY ANY>>
+ <FORM <COND (.STYP) (STRUCTURED)>
+ [REST .ETY]>)
+ (.STYP)
+ (STRUCTURED)>>
+ .R>)>>
+
+<PUT ,MEMQ ANALYSIS ,MEMQ-ANA>
+
+<ENDPACKAGE>
+
+\ 3\ 3
\ No newline at end of file
--- /dev/null
+<PACKAGE "STRGEN">
+
+<ENTRY NTH-GEN REST-GEN PUT-GEN LNTH-GEN MT-GEN PUTREST-GEN IPUT-GEN
+ IREMAS-GEN FLUSH-COMMON-SYMT COMMUTE-STRUC DEFER-IT PUT-COMMON-DAT
+ LIST-LNT-SPEC RCHK>
+
+<USE "CODGEN" "CACS" "COMCOD" "CHKDCL" "COMPDEC" "SPCGEN" "COMTEM" "CARGEN">
+
+<GDECL (PATTRNS)
+ <UVECTOR [REST <LIST [REST <OR ATOM LIST>]>]>
+ (RESTERS NTHERS PUTTERS)
+ VECTOR
+ (STYPES)
+ <UVECTOR [REST ATOM]>>
+
+<DEFINE PREG? (TYP TRY "AUX" (FTYP <ISTYPE? .TYP>))
+ <COND (.FTYP <REG? .FTYP .TRY>) (ELSE <REG? TUPLE .TRY>
+ ;"Fool REG? into not losing.")>>
+
+
+<DEFINE LIST-LNT-SPEC (N W NF BR DI NUM
+ "AUX" (K <KIDS .N>) REG RAC (FLS <==? .W FLUSHED>)
+ (B2 <COND (<AND .BR .FLS> .BR) (ELSE <MAKE:TAG>)>)
+ (SDIR .DI) (B3 <>) B4 F1 F2 F3
+ (SBR <NODE-NAME .N>) TT)
+ #DECL ((N) NODE (NUM) FIX (RAC) AC (K) <LIST [REST NODE]>)
+ <SET REG
+ <GEN <SET TT <1 <KIDS <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE> <2 .K>)
+ (ELSE <1 .K>)>>>>
+ <COND (<SET TT <ISTYPE? <RESULT-TYPE .TT>>> <DATUM .TT ANY-AC>)
+ (ELSE DONT-CARE)>>>
+ <SET RAC <DATVAL <SET REG <TOACV .REG>>>>
+ <DATTYP-FLUSH .REG>
+ <AND .NF <SET DI <NOT .DI>>>
+ <SET DI <COND (<AND .BR <NOT .FLS>> <NOT .DI>) (ELSE .DI)>>
+ <AND .DI <SET SBR <FLIP .SBR>>>
+ <VAR-STORE <>>
+ <SET F1 <MEMQ .SBR '![==? G? G=? 1? 0?!]>>
+ <SET F2 <MEMQ .SBR '![G? G=?!]>>
+ <SET F3 <MEMQ .SBR '![L? L=?!]>>
+ <COND (<OR <==? .SBR L=?> <==? .SBR G?>> <SET NUM <- .NUM 1>>)>
+ <COND (<L=? .NUM 2>
+ <REPEAT ((FLG T) (RAC1 .RAC))
+ <EMIT <INSTRUCTION
+ <COND (<OR <NOT <0? .NUM>> <NOT .F1>> `JUMPE )
+ (ELSE `JUMPN )>
+ <ACSYM .RAC>
+ <COND (<0? .NUM> .B2)
+ (.F3 .B2)
+ (<OR .F2 <NOT .F1>>
+ <OR .B3 <SET B3 <MAKE:TAG>>>)
+ (ELSE .B2)>>>
+ <COND (<L? <SET NUM <- .NUM 1>> 0>
+ <AND .B3 <LABEL:TAG .B3>>
+ <RETURN>)>
+ <COND (<AND .FLG <ACRESIDUE .RAC>
+ <G? <CHTYPE <FREE-ACS T> FIX> 0>>
+ <SET RAC <GETREG <>>>)
+ (.FLG <MUNG-AC .RAC .REG>)
+ (ELSE <SET RAC1 .RAC>)>
+ <SET FLG <>>
+ <EMIT <INSTRUCTION `HRRZ
+ <ACSYM .RAC>
+ (<ADDRSYM .RAC1>)>>>)
+ (ELSE
+ <MUNG-AC .RAC .REG>
+ <EMIT <INSTRUCTION `MOVEI
+ `O
+ <COND (<OR .F2 .F3> <+ .NUM 1>) (ELSE .NUM)>>>
+ <LABEL:TAG <SET B4 <MAKE:TAG>>>
+ <EMIT <INSTRUCTION `JUMPE
+ <ACSYM .RAC>
+ <COND (<AND <NOT .F3> <OR .F2 <NOT .F1>>>
+ <OR .B3 <SET B3 <MAKE:TAG>>>)
+ (ELSE .B2)>>>
+ <EMIT <INSTRUCTION `HRRZ <ACSYM .RAC> (<ADDRSYM .RAC>)>>
+ <EMIT <INSTRUCTION `SOJG `O .B4>>
+ <COND (<OR .F3 .F2> <AND .B3 <BRANCH:TAG .B2>>)
+ (ELSE
+ <EMIT <INSTRUCTION <COND (.F1 `JUMPN ) (ELSE `JUMPE )>
+ <ACSYM .RAC>
+ .B2>>)>
+ <COND (.B3 <LABEL:TAG .B3>)>)>
+ <PUT .RAC ,ACPROT <>>
+ <RET-TMP-AC .REG>
+ <COND (<NOT .BR> <TRUE-FALSE .N .B2 .W>)
+ (<NOT .FLS>
+ <SET W <MOVE:ARG <REFERENCE .SDIR> .W>>
+ <BRANCH:TAG .BR>
+ <LABEL:TAG .B2>
+ .W)>>
+
+<DEFINE LNTH-GEN (NOD WHERE
+ "AUX" (STRN <1 <KIDS .NOD>>) T1 T2 STR
+ (ITYP <RESULT-TYPE .STRN>) (TYP <STRUCTYP .ITYP>) RAC
+ REG (NEGOK <>) (*2OK <>) (HWOK <>) (SWOK <>) TR TRIN
+ TROUT (MUNG <>))
+ #DECL ((STRN NOD) NODE (K) <LIST [REST NODE]> (STR REG) DATUM (RAC) AC
+ (T1 T2) ATOM (TRIN TROUT) <UVECTOR [7 FIX]> (TRANSFORM) TRANS)
+ <COND (<AND <ASSIGNED? TRANSFORM>
+ <==? <PARENT .NOD> <1 <SET TR .TRANSFORM>>>>
+ <SET TROUT <3 .TR>>
+ <SET NEGOK <NOT <0? <1 <SET TRIN <2 .TR>>>>>>
+ <SET *2OK
+ <AND <OR <==? .TYP VECTOR> <==? .TYP TUPLE>>
+ <OR <1? <4 .TRIN>>
+ <AND <==? 2 <4 .TRIN>> <==? 2 <5 .TRIN>>>
+ <AND <NOT .NEGOK>
+ <==? 2 <4 .TRIN>>
+ <==? <5 .TRIN> -2>
+ <SET NEGOK T>>>>>
+ <SET HWOK <==? 2 <6 .TRIN>>>
+ <SET SWOK <NOT <0? <7 .TRIN>>>>)>
+ <SET STR <GEN .STRN DONT-CARE>>
+ <RET-TMP-AC <SET RAC <DATVAL <SET REG <REG? FIX .WHERE T>>>>
+ .REG>
+ <MUNG-AC .RAC .REG>
+ <COND
+ (<==? .TYP LIST>
+ <MOVE:ARG .STR .REG>
+ <RET-TMP-AC <DATTYP .REG> .REG>
+ <PUT .REG ,DATTYP FIX>
+ <EMIT '<`MOVSI 0 *400000*>>
+ <LABEL:TAG <SET T1 <MAKE:TAG>>>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM .RAC> <SET T2 <MAKE:TAG>>>>
+ <EMIT <INSTRUCTION `HRRZ <ACSYM .RAC> (<ADDRSYM .RAC>)>>
+ <EMIT <INSTRUCTION `AOBJN 0 .T1>>
+ <LABEL:TAG .T2>
+ <EMIT <INSTRUCTION `HRRZ <ACSYM .RAC> 0>>)
+ (<==? <TYPEPRIM .TYP> TEMPLATE>
+ <SGETREG .RAC .REG>
+ <PUT .RAC ,ACPROT T>
+ <GET:TEMPLATE:LENGTH <ISTYPE? .ITYP> .STR .RAC>
+ <RET-TMP-AC .STR>)
+ (<MEMQ .TYP '![UVECTOR VECTOR TUPLE STORAGE!]>
+ <SGETREG .RAC .REG>
+ <PUT .RAC ,ACPROT T>
+ <COND (.SWOK <PUT .TROUT 7 1> <PUT .TROUT 6 1>)
+ (.HWOK
+ <PUT .TROUT 6 1>
+ <SET MUNG T>
+ <EMIT <INSTRUCTION `HLRZ <ACSYM .RAC> !<ADDR:VALUE .STR>>>)
+ (ELSE
+ <EMIT <INSTRUCTION `HLRE <ACSYM .RAC> !<ADDR:VALUE .STR>>>
+ <SET MUNG T>)>
+ <COND (.NEGOK <COND (<N==? <5 .TRIN> -2> <PUT .TROUT 1 1>)>)
+ (ELSE
+ <COND (.MUNG <EMIT <INSTRUCTION `MOVNS <ADDRSYM .RAC>>>)
+ (ELSE
+ <EMIT <INSTRUCTION `MOVN
+ <ACSYM .RAC>
+ !<ADDR:VALUE .STR>>>)>
+ <SET MUNG T>)>
+ <OR <==? .TYP UVECTOR>
+ <==? .TYP STORAGE>
+ <COND (.*2OK
+ <PUT .TROUT 4 2>
+ <PUT .TROUT 5 <COND (<1? <4 .TRIN>> 2) (ELSE <5 .TRIN>)>>)
+ (ELSE
+ <COND (<NOT .MUNG>
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM .RAC>
+ !<ADDR:VALUE .STR>>>)>
+ <EMIT <INSTRUCTION `ASH <ACSYM .RAC> -1>>
+ <SET MUNG T>)>>
+ <COND (<NOT .MUNG>
+ <RET-TMP-AC .REG>
+ <DATTYP-FLUSH .STR>
+ <PUT .STR ,DATTYP FIX>
+ <SET REG .STR>)
+ (ELSE <RET-TMP-AC .STR>)>)
+ (ELSE
+ <SGETREG .RAC .REG>
+ <PUT .RAC ,ACPROT T>
+ <EMIT <INSTRUCTION `HRRZ <ACSYM .RAC> !<ADDR:TYPE .STR>>>
+ <RET-TMP-AC .STR>)>
+ <PUT .RAC ,ACPROT <>>
+ <MOVE:ARG .REG .WHERE>>
+
+
+<DEFINE MT-GEN (NOD WHERE
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
+ "AUX" (STRN <1 <KIDS .NOD>>) RAC STR (ITYP <RESULT-TYPE .STRN>)
+ (SDIR .DIR) (TYP <STRUCTYP .ITYP>)
+ (FLS <==? .WHERE FLUSHED>)
+ (B2 <COND (<AND .BRANCH .FLS> .BRANCH) (ELSE <MAKE:TAG>)>)
+ (TEMP? <==? <TYPEPRIM .TYP> TEMPLATE>))
+ #DECL ((STR) DATUM (STRN NOD) NODE (RAC) AC (B2) ATOM
+ (BRANCH) <OR ATOM FALSE>)
+ <COND (.TEMP?
+ <SET STR <GEN .STRN DONT-CARE>>
+ <TOACV .STR>
+ <PUT <CHTYPE <DATVAL .STR> AC> ,ACPROT T>
+ <GET:TEMPLATE:LENGTH <ISTYPE? .ITYP>
+ .STR
+ <SET RAC <GETREG <>>>>
+ <PUT <CHTYPE <DATVAL .STR> AC> ,ACPROT <>>
+ <RET-TMP-AC .STR>
+ <SET STR <DATUM FIX .RAC>>
+ <PUT .RAC ,ACLINK (.STR !<ACLINK .RAC>)>)
+ (<AND <SET ITYP <ISTYPE-GOOD? .ITYP>> <G? <CHTYPE <FREE-ACS T> FIX> 0>>
+ <SET STR <GEN .STRN <DATUM .ITYP ANY-AC>>>)
+ (ELSE <SET STR <GEN .STRN DONT-CARE>>)>
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <SET DIR
+ <COND (<AND .BRANCH <NOT .FLS>> <NOT .DIR>) (ELSE .DIR)>>
+ <VAR-STORE <>>
+ <COND (<AND <TYPE? <DATVAL .STR> AC> <N==? .TYP STRING> <N==? .TYP BYTES>>
+ <SET RAC <DATVAL .STR>>
+ <COND (<OR <==? .TYP LIST> .TEMP?>
+ <EMIT <INSTRUCTION <COND (.DIR `JUMPE ) (ELSE `JUMPN )>
+ <ACSYM .RAC>
+ .B2>>)
+ (ELSE
+ <EMIT <INSTRUCTION <COND (.DIR `JUMPGE ) (ELSE `JUMPL )>
+ <ACSYM .RAC>
+ .B2>>)>)
+ (<AND <TYPE? <DATTYP .STR> AC> <OR <==? .TYP STRING> <==? .TYP BYTES>>>
+ <SET RAC <DATTYP .STR>>
+ <EMIT <INSTRUCTION <COND (.DIR `TRNN ) (ELSE `TRNE )>
+ <ACSYM .RAC>
+ -1>>
+ <BRANCH:TAG .B2>)
+ (ELSE
+ <COND (<==? .TYP LIST>
+ <EMIT <INSTRUCTION <COND (.DIR `SKIPN ) (ELSE `SKIPE )>
+ !<ADDR:VALUE .STR>>>
+ <BRANCH:TAG .B2>)
+ (<OR <==? .TYP STRING> <==? .TYP BYTES>>
+ <EMIT <INSTRUCTION `HRRZ !<ADDR:TYPE .STR>>>
+ <EMIT <INSTRUCTION <COND (.DIR `JUMPE ) (ELSE `JUMPN )>
+ .B2>>)
+ (ELSE
+ <EMIT <INSTRUCTION <COND (.DIR `SKIPL ) (ELSE `SKIPGE )>
+ !<ADDR:VALUE .STR>>>
+ <BRANCH:TAG .B2>)>)>
+ <RET-TMP-AC .STR>
+ <COND (<NOT .BRANCH> <TRUE-FALSE .NOD .B2 .WHERE>)
+ (<NOT .FLS>
+ <SET WHERE <MOVE:ARG <REFERENCE .SDIR> .WHERE>>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B2>
+ .WHERE)>>
+
+
+<DEFINE REST-GEN (NOD WHERE
+ "AUX" (K <KIDS .NOD>) (TYP <RESULT-TYPE <1 .K>>)
+ (TPS <STRUCTYP .TYP>) (2ARG <2 .K>) (1ARG <1 .K>)
+ (NRP <NTH-REST-PUT? .1ARG>)
+ (NUMKN <==? <NODE-TYPE .2ARG> ,QUOTE-CODE>)
+ (NUM <COND (.NUMKN <NODE-NAME .2ARG>) (ELSE 0)>)
+ (NR <GET-RANGE <RESULT-TYPE .2ARG>>) W TEM)
+ #DECL ((NOD) NODE (K) <LIST NODE NODE> (TPS) ATOM (NUM) FIX)
+ <COND (<SET TEM <FIND-COMMON .NOD>>
+ <SET W <MOVE:ARG <GET-COMMON-DATUM .TEM> .WHERE>>)
+ (<PROG ((COMMON-SUB <>))
+ #DECL ((COMMON-SUB) <SPECIAL <OR FALSE COMMON>>)
+ <SET W
+ <APPLY <NTH ,RESTERS
+ <LENGTH <CHTYPE <MEMQ .TPS ,STYPES> UVECTOR>>>
+ .NOD
+ .WHERE
+ .TYP
+ .TPS
+ .NUMKN
+ .NUM
+ <1 .K>
+ .2ARG
+ T
+ <>
+ .NR>>
+ <SET TEM .COMMON-SUB>>)>
+ <HACK-COMMON REST
+ .1ARG
+ .TEM
+ .WHERE
+ .W
+ .NUMKN
+ .NUM
+ .TPS
+ .NRP>
+ .W>
+
+<DEFINE VEC-REST (NOD WHERE TYP TPS NUMKN NUM STRNOD NUMNOD R? RV NR
+ "AUX" (ML <MINL .TYP>) N SAC STR (MP <MPCNT .TPS>) NUMN
+ (ONO .NO-KILL) (NO-KILL .ONO) (LCAREFUL .CAREFUL)
+ (W2
+ <COND (.R? DONT-CARE)
+ (ELSE
+ <REG? <COND (<SET TYP <ISTYPE? .TYP>>)
+ (ELSE .TPS)>
+ .WHERE>)>))
+ #DECL ((NOD NUMNOD STRNOD) NODE (STR NUMN) DATUM (ML N MP NUM) FIX
+ (SAC) AC (NUMNK R? RV) <OR ATOM FALSE>
+ (NR) <OR FALSE <LIST FIX FIX>> (WHERE W2) <OR ATOM DATUM>
+ (NO-KILL) <SPECIAL LIST>)
+ <SET RV <COMMUTE-STRUC .RV .STRNOD .NUMNOD>>
+ <COND (.NUMKN
+ <COND (<L? .NUM 0>
+ <MESSAGE ERROR "ARG OUT OF RANGE " <NODE-NAME .NOD>>)
+ (<0? .NUM>
+ <SET STR <GEN .STRNOD .W2>>
+ <COND (<AND .LCAREFUL <NOT .R?> <0? .ML>>
+ <TOACV .STR>
+ <RCHK <DATVAL .STR> .R?>)>
+ <COND (<NOT <AND .TYP <NOT .R?>>>
+ <TOACV .STR>
+ <MUNG-AC <DATVAL .STR> .STR>)>)
+ (ELSE
+ <TOACV <SET STR <GEN .STRNOD .W2>>>
+ <MUNG-AC <SET SAC <DATVAL .STR>> .STR>
+ <EMIT <INSTRUCTION `ADD
+ <ACSYM .SAC>
+ [<FORM (<SET N <* .NUM .MP>>) .N>]>>
+ <AND .LCAREFUL
+ <COND (.R? <G? .NUM .ML>) (ELSE <G=? .NUM .ML>)>
+ <RCHK .SAC .R?>>)>)
+ (ELSE
+ <COND (.RV
+ <SET NUMN <GEN .NUMNOD <REG? FIX .WHERE>>>
+ <SET STR <GEN .STRNOD DONT-CARE>>)
+ (ELSE
+ <SET STR <GEN .STRNOD DONT-CARE>>
+ <SET NUMN <GEN .NUMNOD <REG? FIX .WHERE>>>)>
+ <DELAY-KILL .NO-KILL .ONO>
+ <TOACV .NUMN>
+ <PUT <SET SAC <DATVAL .NUMN>> ,ACPROT T>
+ <MUNG-AC .SAC .NUMN>
+ <PUT .SAC ,ACPROT T>
+ <TOACV .STR>
+ <AND .LCAREFUL
+ <NOT <AND .NR
+ <COND (.R? <G=? <1 .NR> 0>)
+ (ELSE <G? <1 .NR> 0>)>>>
+ <EMIT <INSTRUCTION <COND (.R? `JUMPL ) (ELSE `JUMPLE )>
+ <ACSYM .SAC>
+ |CERR1 >>>
+ <OR <1? .MP> <EMIT <INSTRUCTION `ASH <ACSYM .SAC> 1>>>
+ <EMIT <INSTRUCTION `HRLI <ACSYM .SAC> (<ADDRSYM .SAC>)>>
+ <EMIT <INSTRUCTION `ADD <ACSYM .SAC> !<ADDR:VALUE .STR>>>
+ <RET-TMP-AC <DATTYP .NUMN> .NUMN>
+ <PUT .NUMN ,DATTYP <DATTYP .STR>>
+ <COND (<TYPE? <DATTYP .STR> AC>
+ <PUT <DATTYP .STR>
+ ,ACLINK
+ (.NUMN !<ACLINK <DATTYP .STR>>)>)>
+ <RET-TMP-AC .STR>
+ <PUT .SAC ,ACPROT <>>
+ <SET STR .NUMN>
+ <AND .LCAREFUL
+ <NOT <AND .NR <L=? <2 .NR> .ML>>>
+ <RCHK .SAC T>>)>
+ <COND (<NOT <==? .TPS TUPLE>>
+ <COND (<OR .R? .TYP>
+ <RET-TMP-AC <DATTYP .STR> .STR>
+ <PUT .STR ,DATTYP <COND (.R? .TPS) (ELSE .TYP)>>)>)>
+ <MOVE:ARG .STR .WHERE>>
+
+<DEFINE LIST-REST (NOD WHERE TYP TPS NUMKN NUM STRNOD NUMNOD R? RV NR
+ "OPTIONAL" (PAC <>) PN (SAME? <>)
+ "AUX" (ONO .NO-KILL) (NO-KILL .ONO)
+ (RR
+ <AND .PAC <NOT .SAME?>
+ <COMMUTE-STRUC <> .PN .NUMNOD>
+ <COMMUTE-STRUC <> .PN .STRNOD>>) VN
+ (NNUMKN .NUMKN) (NUMK <>) (NCAREFUL .CAREFUL) (FLAC <>)
+ STR SAC SAC1 (TYP1 <COND (<ISTYPE? .TYP>) (ELSE LIST)>)
+ NUMN NAC (T1 <MAKE:TAG>) (T2 <MAKE:TAG>) NTHCASE TEM
+ (ONE-OR-TWO-HRRZS <>) (PSTR <>) HI LO (REDEF <>))
+ #DECL ((PN NOD STRNOD NUMNOD) NODE (STR NUMN VN) DATUM (T1 T2 TYP1 TPS) ATOM
+ (SAC SAC1 NAC) AC (NUM NTHCASE) FIX (NO-KILL) <SPECIAL LIST>
+ (R? RR RV NUMK NUMKN NNUMKN) <OR ATOM FALSE> (WHERE) <OR ATOM DATUM>
+ (PAC) <OR ATOM FALSE AC> (PSTR) <OR DATUM FALSE> (HI LO) FIX
+ (NR) <OR FALSE <LIST FIX FIX>>)
+ <COND (.PAC
+ <COND (<1? <CHTYPE <DEFERN <RESULT-TYPE .PN>> FIX>> <SET REDEF T>)
+ (<AND .NUMKN <1? <CHTYPE <DEFERN <GET-ELE-TYPE .TYP <+ .NUM 1>>> FIX>>>
+ <SET REDEF T>)
+ (<1? <CHTYPE <DEFERN <GET-ELE-TYPE .TYP ALL>> FIX>> <SET REDEF T>)>)>
+ <SET RV <AND <NOT .SAME?> <COMMUTE-STRUC .RV .NUMNOD .STRNOD>>>
+ <COND (.NR
+ <COND (<==? <SET LO <1 .NR>> <SET HI <2 .NR>>> <SET NUMKN T>)
+ (ELSE <SET NNUMKN T>)>
+ <SET NUM .HI>
+ <AND <NOT .NUMKN>
+ <L=? .NUM <MINL .TYP>>
+ <COND (.R? <G=? .LO 0>) (ELSE <G? .LO 0>)>
+ <SET NUMK T>>
+ <COND (<AND <G=? .LO 0> <L=? .NUM <MINL .TYP>>>
+ <SET NCAREFUL <>>)>)>
+ <SET NTHCASE
+ <+ <COND (.R? 0) (ELSE 12)>
+ <COND (<AND .NR <G? .LO 0> <G? .HI <MINL .TYP>>> 2)
+ (ELSE 0)>
+ <COND (<AND .NR
+ <OR <COND (.R? <G=? .LO 0>) (ELSE <G? .LO 0>)>
+ <L=? .NUM <MINL .TYP>>>>
+ 1)
+ (ELSE 0)>
+ <COND (<AND .NR
+ <L=? .NUM <MINL .TYP>>
+ <COND (.R? <L? .LO 0>) (ELSE <L=? .LO 0>)>>
+ 1)
+ (ELSE 0)>
+ <COND (<OR <AND <NOT .NUMK> <NOT .NUMKN>>
+ <AND .NCAREFUL
+ <G? <COND (.R? .NUM) (ELSE <+ .NUM 1>)>
+ <MINL .TYP>>>>
+ 0)
+ (ELSE 1)>
+ <COND (<NOT .NUMKN> 8)
+ (<AND <NOT .NUMK> <SET FLAC <0? .NUM>>> 0)
+ (<AND <NOT .NUMK> <SET FLAC <1? .NUM>>> 2)
+ (<AND <NOT .NUMK> <SET FLAC <==? .NUM 2>>> 4)
+ (ELSE 6)>>>
+ <COND (<OR <AND <G? .NTHCASE 1> <L? .NTHCASE 6>>
+ <AND <G? .NTHCASE 13> <L? .NTHCASE 18>>>
+ <SET ONE-OR-TWO-HRRZS T>)>
+ <COND
+ (.RR
+ <PREFER-DATUM .WHERE>
+ <SET VN
+ <GEN
+ .PN
+ <COND
+ (<SET TEM
+ <AND
+ <NOT .REDEF>
+ <OR <ISTYPE? <RESULT-TYPE .PN>>
+ <ISTYPE?
+ <TYPE-MERGE <GET-ELE-TYPE <RESULT-TYPE .STRNOD>
+ <COND (.NUMKN <+ .NUM 1>) (ELSE ALL)>>
+ <GET-ELE-TYPE <RESULT-TYPE .NOD>
+ <COND (.NUMKN <+ .NUM 1>)
+ (ELSE ALL)>>>>>>>
+ <DATUM .TEM ANY-AC>)
+ (ELSE <DATUM ANY-AC ANY-AC>)>>>
+ <SET PUT-COMMON-DAT .VN>)>
+ <COND (.RV
+ <OR .NUMKN
+ .FLAC
+ <SET NUMN <GEN .NUMNOD <DATUM FIX ANY-AC>>>>
+ <SET STR
+ <GEN .STRNOD
+ <COND (.PAC <PREG? .TYP .WHERE>)
+ (ELSE <REG? .TYP1 .WHERE>)>>>)
+ (ELSE
+ <SET STR
+ <GEN .STRNOD
+ <COND (.PAC <PREG? .TYP .WHERE>)
+ (ELSE <REG? .TYP1 .WHERE>)>>>
+ <OR .FLAC
+ .NUMKN
+ <SET NUMN <GEN .NUMNOD <DATUM FIX ANY-AC>>>>)>
+ <COND (<OR .RR <NOT .PAC>> <DELAY-KILL .NO-KILL .ONO>)>
+ <TOACV .STR>
+ <COND (<AND .PAC
+ <SET PAC <CHTYPE <DATVAL .STR> AC>>
+ <PUT .PAC ,ACPROT T>
+ <NOT <==? .WHERE FLUSHED>>
+ <OR <G? .NTHCASE 13> .REDEF>>
+ <PUT <SET SAC <GETREG <SET PSTR <DATUM .TYP1 LIST>>>>
+ ,ACPROT
+ T>
+ <PUT .PSTR ,DATVAL .SAC>
+ <OR .ONE-OR-TWO-HRRZS
+ <EMIT <INSTRUCTION `MOVEI <ACSYM .SAC> (<ADDRSYM .PAC>)>>>)
+ (ELSE <SET SAC <DATVAL .STR>>)>
+ <PUT .SAC ,ACPROT T>
+ <COND (<AND .NUMKN <NOT .FLAC>>
+ <SET NAC
+ <DATVAL <SET NUMN
+ <MOVE:ARG <REFERENCE .NUM> <DATUM FIX ANY-AC>>>>>)
+ (<NOT .FLAC> <TOACV .NUMN> <SET NAC <DATVAL .NUMN>>)>
+ <COND (<AND <NOT .PSTR>
+ <ISTYPE? .TYP>
+ <ACRESIDUE .SAC>
+ .ONE-OR-TWO-HRRZS
+ <NOT <AND <TYPE? .WHERE DATUM> <==? <DATVAL .WHERE> .SAC>>>
+ <G? <CHTYPE <FREE-ACS T> FIX> 0>>
+ <SET SAC1 <GETREG <>>>
+ <AND .PAC <SET PAC .SAC1>>)
+ (<AND .PSTR .ONE-OR-TWO-HRRZS>
+ <SET SAC1 .SAC>
+ <SET SAC .PAC>)
+ (ELSE <SET SAC1 .SAC>)>
+ <PUT .SAC ,ACPROT <>>
+ <AND .PAC <PUT <CHTYPE .PAC AC> ,ACPROT <>>>
+ <AND <==? .SAC .SAC1>
+ <NOT <L=? .NTHCASE 1>>
+ <N==? .NTHCASE 12>
+ <N==? .NTHCASE 13>
+ <MUNG-AC .SAC <COND (.PSTR .PSTR) (ELSE .STR)>>>
+ <AND <ASSIGNED? NAC> <MUNG-AC .NAC .NUMN>>
+ <MAPF <>
+ <FUNCTION (APAT)
+ #DECL ((APAT) <OR ATOM LIST>)
+ <COND (<TYPE? .APAT ATOM>
+ <LABEL:TAG <COND (<==? .APAT T1> .T1) (ELSE .T2)>>)
+ (<EMPTY? .APAT> T)
+ (ELSE
+ <EMIT <MAPF ,INSTRUCTION
+ <FUNCTION (ITM)
+ <COND (<==? .ITM A11> <ACSYM .SAC>)
+ (<==? .ITM IA11> (<ADDRSYM .SAC>))
+ (<==? .ITM A1> <ACSYM .SAC1>)
+ (<==? .ITM A2> <ACSYM .NAC>)
+ (<==? .ITM IA1> (<ADDRSYM .SAC1>))
+ (<==? .ITM IA2> (<ADDRSYM .NAC>))
+ (<==? .ITM T1> .T1)
+ (<==? .ITM T2> .T2)
+ (ELSE .ITM)>>
+ .APAT>>)>>
+ <NTH ,PATTRNS <+ .NTHCASE 1>>>
+ <OR .FLAC <RET-TMP-AC .NUMN>>
+ <COND (<AND <NOT .PSTR> <N==? .SAC .SAC1>>
+ <RET-TMP-AC .STR>
+ <SET STR <DATUM .TYP1 .SAC1>>
+ <PUT .SAC1 ,ACLINK (.STR)>)>
+ <COND
+ (<AND .SAME? .PAC> <SPEC-GEN .PN <OR .PSTR .STR> LIST 0>)
+ (.PAC
+ <COND
+ (<NOT .RR>
+ <SET VN
+ <GEN
+ .PN
+ <COND
+ (<SET TEM
+ <AND
+ <NOT .REDEF>
+ <OR
+ <ISTYPE? <RESULT-TYPE .PN>>
+ <ISTYPE?
+ <TYPE-MERGE <GET-ELE-TYPE <RESULT-TYPE .STRNOD>
+ <COND (.NUMKN <+ .NUM 1>) (ELSE ALL)>>
+ <GET-ELE-TYPE <RESULT-TYPE .NOD>
+ <COND (.NUMKN <+ .NUM 1>)
+ (ELSE ALL)>>>>>>>
+ <DATUM .TEM ANY-AC>)
+ (ELSE <DATUM ANY-AC ANY-AC>)>>>
+ <SET PUT-COMMON-DAT .VN>)>
+ <DELAY-KILL .NO-KILL .ONO>
+ <COND (.PSTR <TOACV .PSTR> <SET SAC <DATVAL .PSTR>>)
+ (ELSE <TOACV .STR> <SET SAC <DATVAL .STR>>)>
+ <COND (.REDEF
+ <MUNG-AC .SAC>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .SAC> 1 (<ADDRSYM .SAC>)>>
+ <TOACT .VN>
+ <SET PUT-COMMON-DAT .VN>
+ <EMIT <INSTRUCTION `MOVEM <ACSYM <CHTYPE <DATTYP .VN> AC>>
+ (<ADDRSYM .SAC>)>>)
+ (<OR <NOT .TEM>
+ <NOT <==? .TEM
+ <ISTYPE?
+ <GET-ELE-TYPE <RESULT-TYPE .STRNOD>
+ <COND (.NUMKN <+ .NUM 1>)
+ (ELSE ALL)>>>>>>
+ <TOACT .VN>
+ <SET PUT-COMMON-DAT .VN>
+ <EMIT <INSTRUCTION `HLLM <ACSYM <CHTYPE <DATTYP .VN> AC>>
+ (<ADDRSYM .SAC>)>>)>
+ <TOACV .VN>
+ <SET PUT-COMMON-DAT .VN>
+ <EMIT <INSTRUCTION `MOVEM
+ <ACSYM <CHTYPE <DATVAL .VN> AC>>
+ 1
+ (<ADDRSYM .SAC>)>>
+ <RET-TMP-AC .VN>
+ <RET-TMP-AC .PSTR>
+ <PUT <CHTYPE .PAC AC> ,ACPROT <>>)
+ (<AND .R? <N==? <ISTYPE? .TYP> LIST>>
+ <DATTYP-FLUSH .STR>
+ <PUT .STR ,DATTYP LIST>)>
+ <MOVE:ARG .STR .WHERE>>
+
+<SETG PATTRNS
+ '![()
+ ()
+ ((`JUMPE A11 |CERR2 ) (`HRRZ A1 IA11))
+ ((`HRRZ A1 IA11))
+ ((`JUMPE A11 |CERR2 )
+ (`HRRZ A1 IA11)
+ (`JUMPE A1 |CERR2 )
+ (`HRRZ A1 IA1))
+ ((`HRRZ A1 IA11) (`HRRZ A1 IA1))
+ (T1
+ (`JUMPE A1 |CERR2 )
+ (`HRRZ A1 IA1)
+ (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1))
+ (T1 (`HRRZ A1 IA1) (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1))
+ ((`JUMPL A2 |CERR1 )
+ (`JUMPE A2 T2)
+ T1
+ (`JUMPE A1 |CERR2 )
+ (`HRRZ A1 IA1)
+ (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
+ T2)
+ ((`JUMPE A2 T2)
+ T1
+ (`HRRZ A1 IA1)
+ (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
+ T2)
+ ((`JUMPE A2 T2)
+ T1
+ (`JUMPE A1 |CERR2 )
+ (`HRRZ A1 IA1)
+ (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
+ T2)
+ (T1
+ (`JUMPE A1 |CERR2 )
+ (`HRRZ A1 IA1)
+ (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1))
+ ((`JUMPE A1 |CERR2 ))
+ ()
+ ((`JUMPE A11 |CERR2 ) (`HRRZ A1 IA11) (`JUMPE A1 |CERR2 ))
+ ((`HRRZ A1 IA11))
+ ((`JUMPE A11 |CERR2 )
+ (`HRRZ A1 IA11)
+ (`JUMPE A1 |CERR2 )
+ (`HRRZ A1 IA1)
+ (`JUMPE A1 |CERR2 ))
+ ((`HRRZ A1 IA11) (`HRRZ A1 IA1))
+ (T1
+ (`JUMPE A1 |CERR2 )
+ (`HRRZ A1 IA1)
+ (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
+ (`JUMPE A1 |CERR2 ))
+ (T1 (`HRRZ A1 IA1) (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1))
+ ((`JUMPLE A2 |CERR2 )
+ (`SOJE A2 T2)
+ T1
+ (`JUMPE A1 |CERR2 )
+ (`HRRZ A1 IA1)
+ (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
+ T2
+ (`JUMPE A1 |CERR2 ))
+ ((`SOJE A2 T2)
+ T1
+ (`HRRZ A1 IA1)
+ (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
+ T2)
+ ((`JUMPLE A2 |CERR1 )
+ (`SOJE A2 T2)
+ T1
+ (`HRRZ A1 IA1)
+ (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
+ T2)
+ ((`SOJE A2 T2)
+ T1
+ (`JUMPE A1 |CERR2 )
+ (`HRRZ A1 IA1)
+ (#OPCODE!-OP!-PACKAGE 33151778816 A2 T1)
+ T2
+ (`JUMPE A1 |CERR2 ))!]>
+
+<DEFINE RCHK (AC RORN)
+ #DECL ((AC) AC (RORN) <OR FALSE ATOM>)
+ <COND (.RORN
+ <EMIT <INSTRUCTION `CAILE <ACSYM .AC> -1>>
+ <BRANCH:TAG |CERR2 >)
+ (ELSE <EMIT <INSTRUCTION `JUMPGE <ACSYM .AC> |CERR2 >>)>>
+
+<DEFINE NTH-GEN (NOD WHERE
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
+ "AUX" (K <KIDS .NOD>) W2 B2 (SDIR .DIR)
+ (TYP <RESULT-TYPE <1 .K>>) (TPS <STRUCTYP .TYP>) W
+ (2ARG <2 .K>) (NUMKN <==? <NODE-TYPE .2ARG> ,QUOTE-CODE>)
+ (NUM <COND (.NUMKN <COND (<TYPE? <NODE-NAME .2ARG>
+ OFFSET>
+ <INDEX <NODE-NAME .2ARG>>)
+ (ELSE <NODE-NAME .2ARG>)>) (ELSE 1)>)
+ (COD <LENGTH <CHTYPE <MEMQ .TPS ,STYPES> UVECTOR>>) FLS
+ (NR <GET-RANGE <RESULT-TYPE .2ARG>>) (TEM <>)
+ (1ARG <1 .K>) (NRP <NTH-REST-PUT? .1ARG>) NDAT
+ (DONE <>))
+ #DECL ((NOD) NODE (K) <LIST NODE NODE> (TPS) ATOM (NUM COD) FIX
+ (NDAT) DATUM)
+ <COND (.NUMKN <PUT .2ARG ,NODE-NAME .NUM>)>
+ <COND (<AND .BRANCH <NOT <NTH-PRED .COD>>>
+ <SET W <UPDATE-WHERE .NOD .WHERE>>)
+ (ELSE <SET W .WHERE>)>
+ <COND (<SET TEM <FIND-COMMON .NOD>>
+ <SET W <MOVE:ARG <GET-COMMON-DATUM .TEM> .W>>
+ <SET DONE T>)
+ (<AND <SET TEM <FIND-COMMON-REST-NODE .NOD>>
+ <SET W <LOC-COMMON .TEM .NOD .TPS .1ARG .2ARG .W>>>
+ <SET DONE T>)>
+ <PROG ((COMMON-SUB <>))
+ #DECL ((COMMON-SUB)
+ <SPECIAL <OR FALSE COMMON <LIST [REST COMMON]>>>)
+ <SET W
+ <COND (<AND <NOT .DONE> <NTH-PRED .COD>>
+ <APPLY <NTH ,NTHERS .COD>
+ .NOD
+ .WHERE
+ .TYP
+ .TPS
+ .NUMKN
+ .NUM
+ <1 .K>
+ .2ARG
+ .NOTF
+ .BRANCH
+ .DIR
+ .NR>)
+ (.BRANCH
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <COND (<NOT .DONE>
+ <SET W
+ <APPLY <NTH ,NTHERS .COD>
+ .NOD
+ .W
+ .TYP
+ .TPS
+ .NUMKN
+ .NUM
+ <1 .K>
+ .2ARG
+ .NR>>)>
+ <VAR-STORE <>>
+ <OR <SET FLS
+ <OR <==? .WHERE FLUSHED>
+ <AND <NOT .NOTF>
+ <OR <==? .WHERE DONT-CARE>
+ <=? .W .WHERE>>>>>
+ <SET DIR <NOT .DIR>>>
+ <D:B:TAG <COND (.FLS .BRANCH)
+ (ELSE <SET B2 <MAKE:TAG>>)>
+ .W
+ .DIR
+ <RESULT-TYPE .NOD>>
+ <SET W2
+ <MOVE:ARG <COND (.NOTF
+ <RET-TMP-AC .W>
+ <REFERENCE .SDIR>)
+ (ELSE .W)>
+ .WHERE>>
+ <COND (<NOT .FLS>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B2>)>
+ .W2)
+ (<NOT .DONE>
+ <APPLY <NTH ,NTHERS .COD>
+ .NOD
+ .WHERE
+ .TYP
+ .TPS
+ .NUMKN
+ .NUM
+ <1 .K>
+ .2ARG
+ .NR>)
+ (ELSE .W)>>
+ <SET TEM .COMMON-SUB>>
+ <COND (<NOT .DONE>
+ <HACK-COMMON NTH .1ARG .TEM .WHERE .W .NUMKN .NUM .TPS .NRP>)>
+ .W>
+
+<DEFINE VEC-NTH (NOD WHERE TYP TPS NUMKN NUM STRNOD NUMNOD NR
+ "AUX" STRN (MP <MPCNT .TPS>) (RV <==? <NODE-NAME .NOD> INTH>)
+ STR (TYPR <ISTYPE-GOOD? <RESULT-TYPE .NOD>>))
+ #DECL ((NOD STRNOD NUMNOD) NODE (NUM MP) FIX (STR) DATUM
+ (WHERE) <OR ATOM DATUM> (TYPR RV NUMKN) <OR FALSE ATOM>)
+ <COND (<NOT <G? .NUM 0>> <MESSAGE ERROR "ARG OUT OF RANGE " NTH>)
+ (<AND .NUMKN
+ <OR <NOT .CAREFUL> <NOT <G? .NUM <MINL .TYP>>>>>
+ <SET STR
+ <VEC-REST .NOD
+ DONT-CARE
+ .TYP
+ .TPS
+ T
+ 0
+ .STRNOD
+ .NUMNOD
+ <>
+ .RV
+ .NR>>
+ <SET STRN <OFFPTR <+ <* <- .NUM 1> .MP> -2 .MP> .STR .TPS>>)
+ (ELSE
+ <SET STR
+ <VEC-REST .NOD
+ DONT-CARE
+ .TYP
+ .TPS
+ .NUMKN
+ <- .NUM 1>
+ .STRNOD
+ .NUMNOD
+ <>
+ .RV
+ .NR>>
+ <SET STRN
+ <OFFPTR <- <COND (.NUMKN .MP) (ELSE 0)> 2> .STR .TPS>>)>
+ <MOVE:ARG <DATUM <COND (.TYPR .TYPR) (ELSE .STRN)> .STRN>
+ .WHERE>>
+
+<DEFINE LIST-NTH (NOD WHERE TYP TPS NUMKN NUM STRNOD NUMNOD NR
+ "AUX" STRN STR (ITYP <ISTYPE-GOOD? <RESULT-TYPE .NOD>>))
+ #DECL ((NOD STRNOD NUMNOD) NODE (NUM COD) FIX (STR) DATUM (SAC) AC
+ (WHERE) <OR DATUM ATOM> (ITYP) <OR ATOM FALSE>)
+ <SET STR
+ <LIST-REST .NOD
+ DONT-CARE
+ .TYP
+ .TPS
+ .NUMKN
+ <- .NUM 1>
+ .STRNOD
+ .NUMNOD
+ <>
+ <==? <NODE-NAME .NOD> INTH>
+ .NR>>
+ <SET STR <DEFER-IT .NOD .STR>>
+ <SET STRN <OFFPTR 0 .STR LIST>>
+ <MOVE:ARG <DATUM <COND (.ITYP .ITYP) (ELSE .STRN)> .STRN>
+ .WHERE>>
+
+<DEFINE STRING-REST (N W TYP TPS NK NUM STRN NUMN R? RV NR
+ "OPTIONAL" (VN <>)
+ "AUX" STRD VD ND SACT SSAC SAC (ML <MINL .TYP>)
+ (BSYZ <GETBSYZ .TYP>) NWDS NCHRS (ONO .NO-KILL)
+ (NO-KILL .ONO) TEM (LCAREFUL .CAREFUL)
+ (OT <COND (<==? .TPS STRING> CHARACTER) (ELSE FIX)>)
+ (RR
+ <AND .VN
+ <COMMUTE-STRUC <> .VN .NUMN>
+ <COMMUTE-STRUC <> .VN .STRN>>)
+ (STAY-MEM
+ <AND .R?
+ <==? <NODE-TYPE .STRN> ,LVAL-CODE>
+ <NOT <EMPTY? <SET TEM <PARENT .N>>>>
+ <==? <NODE-TYPE <CHTYPE .TEM NODE>> ,SET-CODE>
+ <==? <NODE-NAME .STRN> <NODE-NAME <CHTYPE .TEM NODE>>>>)
+ (W2
+ <COND (<AND .R? <NOT .STAY-MEM>> <REG? .TPS .W>)
+ (<AND .VN <NOT .RR>> <DATUM ANY-AC ANY-AC>)
+ (ELSE DONT-CARE)>) (FLS <==? .W FLUSHED>)
+ SSTRD)
+ #DECL ((N NUMN STRN) NODE (STRD SSTRD ND VD) DATUM (NUM ML NWDS NCHRS) FIX
+ (SACT SSAC SAC) AC (NO-KILL) <SPECIAL LIST>
+ (NR) <OR FALSE <LIST FIX FIX>> (VN) <OR NODE FALSE>
+ (BSYZ) <OR FIX FALSE>)
+ <COND (.RR <SET VD <GEN .VN <DATUM .OT ANY-AC>>> <SET PUT-COMMON-DAT .VD>)>
+ <COND
+ (.NK
+ <COND
+ (<L? .NUM 0> <MESSAGE ERROR " ARG OUT OF RANGE " <NODE-NAME .N> .N>)
+ (<0? .NUM>
+ <SET STRD <GEN .STRN .W2>>
+ <COND (<AND .LCAREFUL <NOT .R?> <0? .ML>>
+ <EMIT <INSTRUCTION `HRRZ !<ADDR:TYPE .STRD>>>
+ <EMIT <INSTRUCTION `JUMPE |CERR2 >>)>
+ <COND (<NOT <AND .TYP <NOT .R?>>>
+ <TOACV .STRD>
+ <MUNG-AC <DATVAL .STRD> .STRD>)>
+ <COND (.VN
+ <COND (<NOT .RR>
+ <SET PUT-COMMON-DAT
+ <SET VD <GEN .VN <DATUM .OT ANY-AC>>>>)>
+ <COND (<AND .FLS <TYPE? <DATVAL .STRD> AC>>
+ <TOACV .STRD>
+ <MUNG-AC <SET SAC <DATVAL .STRD>> .STRD>
+ <TOACV .VD>
+ <EMIT <INSTRUCTION `IDPB
+ <ACSYM <CHTYPE <DATVAL .VD> AC>>
+ !<ADDR:VALUE .STRD>>>)
+ (ELSE
+ <EMIT <INSTRUCTION `MOVE `O !<ADDR:VALUE .STRD>>>
+ <EMIT <INSTRUCTION `IDPB <ACSYM <CHTYPE <DATVAL .VD> AC>> `O>>)>)>)
+ (ELSE
+ <SET STRD <GEN .STRN .W2>>
+ <COND (<OR <TYPE? <DATTYP .STRD> AC> <TYPE? <DATVAL .STRD> AC>>
+ <SET STAY-MEM <>>)>
+ <COND (<AND .VN <NOT .RR>>
+ <SET VD <GEN .VN <DATUM .OT ANY-AC>>>
+ <SET PUT-COMMON-DAT .VD>)>
+ <DELAY-KILL .NO-KILL .ONO>
+ <COND
+ (<AND .LCAREFUL <COND (.R? <G? .NUM .ML>) (ELSE <G=? .NUM .ML>)>>
+ <COND (<AND .R? <NOT .STAY-MEM>>
+ <TOACT .STRD>
+ <MUNG-AC <SET SACT <DATTYP .STRD>>>)>
+ <COND (<TYPE? <DATTYP .STRD> AC>
+ <EMIT <INSTRUCTION `MOVEI `O (<ADDRSYM <DATTYP .STRD>>)>>)
+ (ELSE <EMIT <INSTRUCTION `HRRZ `O !<ADDR:TYPE .STRD>>>)>
+ <COND (<1? .NUM>
+ <EMIT <INSTRUCTION <COND (.R? `SOJL ) (ELSE `SOJLE )> |CERR2 >>)
+ (ELSE
+ <EMIT <INSTRUCTION `SUBI `O .NUM>>
+ <EMIT <INSTRUCTION <COND (.R? `JUMPL ) (ELSE `JUMPLE )>
+ `O
+ |CERR2 >>)>
+ <COND (.R?
+ <COND (<TYPE? <DATTYP .STRD> AC>
+ <EMIT <INSTRUCTION `HRR <ACSYM <DATTYP .STRD>> `O >>)
+ (ELSE
+ <EMIT <INSTRUCTION `HRRM `O !<ADDR:TYPE .STRD>>>)>)>)
+ (<AND <1? .NUM> .R?>
+ <COND (<NOT .STAY-MEM>
+ <TOACT .STRD>
+ <MUNG-AC <SET SACT <DATTYP .STRD>> .STRD>)>
+ <EMIT <INSTRUCTION #OPCODE!-OP!-PACKAGE 33285996544
+ !<ADDR:TYPE .STRD>>>)
+ (<AND .R? <NOT .STAY-MEM>>
+ <TOACT .STRD>
+ <MUNG-AC <SET SACT <DATTYP .STRD>> .STRD>
+ <EMIT <INSTRUCTION `SUBI <ACSYM .SACT> .NUM>>)
+ (.R?
+ <EMIT <INSTRUCTION `MOVNI `O .NUM>>
+ <EMIT <INSTRUCTION `ADDM `O !<ADDR:TYPE .STRD>>>)>
+ <COND (<OR <NOT .R?> <NOT .STAY-MEM>>
+ <TOACV .STRD>
+ <SET SAC <DATVAL .STRD>>)
+ (<TYPE? <DATVAL .STRD> AC> <SET SAC <DATVAL .STRD>>)>
+ <COND (<AND <NOT .FLS> .VN>
+ <SET SSAC <PUT .SAC ,ACPROT T>>
+ <SET SAC <GETREG <>>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .SAC> <ADDRSYM .SSAC>>>
+ <SET SSTRD <DATUM <DATTYP .STRD> .SAC>>
+ <PUT .SSAC ,ACPROT <>>)
+ (ELSE <SET SSTRD .STRD>)>
+ <COND
+ (.BSYZ
+ <SET NWDS </ 36 .BSYZ>>
+ <SET NCHRS <MOD .NUM .NWDS>>
+ <SET NWDS </ .NUM .NWDS>>
+ <COND (<AND <ASSIGNED? SAC> <NOT .FLS>> <MUNG-AC .SAC .SSTRD>)>
+ <COND (<NOT <0? .NWDS>>
+ <COND (<ASSIGNED? SAC>
+ <EMIT <INSTRUCTION `ADDI <ACSYM .SAC> .NWDS>>)
+ (ELSE
+ <EMIT <INSTRUCTION `MOVEI `O .NWDS>>
+ <EMIT <INSTRUCTION `ADDM `O !<ADDR:VALUE
+ .SSTRD>>>)>)>
+ <REPEAT ()
+ <COND (<L? <SET NCHRS <- .NCHRS 1>> 0> <RETURN>)>
+ <EMIT <INSTRUCTION `IBP `O !<ADDR:VALUE .SSTRD>>>>)
+ (ELSE
+ <SET TEM <STRINGER .NUM .STRD .SSTRD>>
+ <COND (.TEM <SET SSTRD <RSTRING .SSTRD .TEM .STAY-MEM>>)
+ (<1? .NUM>
+ <COND (<TYPE? <DATVAL .SSTRD> AC>
+ <MUNG-AC <DATVAL .SSTRD> .SSTRD>)>
+ <EMIT <INSTRUCTION `IBP !<ADDR:VALUE .SSTRD>>>)
+ (ELSE
+ <COND (<TYPE? <DATVAL .SSTRD> AC>
+ <MUNG-AC <DATVAL .SSTRD> .SSTRD>)>
+ <REPEAT ()
+ <COND (<L? <SET NUM <- .NUM 1>> 0> <RETURN>)>
+ <EMIT <INSTRUCTION `IBP !<ADDR:VALUE .SSTRD>>>>)>)>
+ <COND (.VN
+ <PUT .SAC ,ACPROT T>
+ <TOACV .VD>
+ <PUT .SAC ,ACPROT <>>
+ <EMIT <INSTRUCTION `IDPB <ACSYM <CHTYPE <DATVAL .VD> AC>>
+ <ADDRSYM .SAC>>>)
+ (ELSE <SET STRD .SSTRD>)>)>)
+ (ELSE
+ <SET RV <COMMUTE-STRUC .RV .NUMN .STRN>>
+ <COND (.RV
+ <SET ND <GEN .NUMN <REG? FIX .W>>>
+ <SET STRD <GEN .STRN DONT-CARE>>)
+ (<NOT <SIDE-EFFECTS .N>>
+ <SET STRD <GEN .STRN DONT-CARE>>
+ <SET ND <GEN .NUMN <REG? FIX .W>>>)
+ (ELSE
+ <SET STRD <GEN .STRN <DATUM ANY-AC ANY-AC>>>
+ <SET ND <GEN .NUMN <DATUM FIX ANY-AC>>>)>
+ <COND (<OR <TYPE? <DATVAL .STRD> AC> <TYPE? <DATTYP .STRD> AC>>
+ <SET STAY-MEM <>>)>
+ <COND (<AND .VN <NOT .RR>>
+ <SET VD <GEN .VN <DATUM .OT ANY-AC>>>
+ <SET PUT-COMMON-DAT .VD>)>
+ <DELAY-KILL .NO-KILL .ONO>
+ <TOACV .ND>
+ <COND (<AND .LCAREFUL
+ <OR <NOT .NR>
+ <COND (.R? <L? <1 .NR> 0>) (ELSE <L=? <1 .NR> 0>)>>>
+ <EMIT <INSTRUCTION <COND (.R? `JUMPL ) (ELSE `JUMPLE )>
+ <ACSYM <CHTYPE <DATVAL .ND> AC>>
+ |CERR1 >>)>
+ <COND (<OR .R? <AND .LCAREFUL <OR <NOT .NR> <G? <2 .NR> .ML>>>>
+ <EMIT <INSTRUCTION `HRRZ `O !<ADDR:TYPE .STRD>>>
+ <COND (<TYPE? <DATVAL .ND> AC>
+ <EMIT <INSTRUCTION `SUBI `O (<ADDRSYM <DATVAL .ND>>)>>)
+ (ELSE <EMIT <INSTRUCTION `SUB `O !<ADDR:VALUE .ND>>>)>
+ <COND (<AND .LCAREFUL <OR <NOT .NR> <G? <2 .NR> .ML>>>
+ <EMIT <INSTRUCTION `JUMPL `O |CERR2 >>)>
+ <COND (<AND .STAY-MEM <NOT <TYPE? <DATTYP .STRD> AC>>>
+ <EMIT <INSTRUCTION `HRRM `O !<ADDR:TYPE .STRD>>>)
+ (.R?
+ <TOACT .STRD>
+ <MUNG-AC <DATTYP .STRD> .STRD>
+ <EMIT <INSTRUCTION `HRR <ACSYM <CHTYPE <DATTYP .STRD> AC>> `O >>)>)>
+ <COND (.BSYZ
+ <SET BSYZ </ 36 .BSYZ>>
+ <TOACV .ND>
+ <PUT <SET SAC <DATVAL .ND>> ,ACPROT T>
+ <MUNG-AC .SAC .ND>
+ <COND (<==? .SAC ,LAST-AC>
+ <SGETREG <SET SAC ,LAST-AC-1> <>>
+ <PUT <SET SACT ,LAST-AC> ,ACPROT <>>
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM ,LAST-AC-1>
+ <ADDRSYM ,LAST-AC>>>)
+ (ELSE
+ <SGETREG <SET SACT <NTH ,ALLACS <+ <ACNUM .SAC> 1>>> <>>
+ <PUT .SAC ,ACPROT <>>)>
+ <EMIT <INSTRUCTION `IDIVI <ACSYM .SAC> .BSYZ>>)
+ (ELSE <SET SAC <STRINGER <> .ND .STRD>>)>
+ <RET-TMP-AC .ND>
+ <COND (<AND .VN <NOT .FLS>>
+ <PUT <SET SACT <NTH ,ALLACS <+ <ACNUM <PUT .SAC ,ACPROT T>> 1>>>
+ ,ACPROT
+ T>
+ <SET SSAC <GETREG <>>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .SSAC> !<ADDR:VALUE .STRD>>>
+ <PUT .SAC ,ACPROT <>>
+ <PUT .SACT ,ACPROT <>>
+ <RSTRING <DATUM <DATTYP .STRD> .SSAC> .SAC .STAY-MEM>)
+ (ELSE <SET STRD <RSTRING .STRD .SAC .STAY-MEM>>)>
+ <COND (.VN
+ <COND (.FLS
+ <TOACV .VD>
+ <EMIT <INSTRUCTION `DPB
+ <ACSYM <CHTYPE <DATVAL .VD> AC>>
+ !<ADDR:VALUE .STRD>>>)
+ (ELSE
+ <PUT .SSAC ,ACPROT T>
+ <TOACV .VD>
+ <PUT .SSAC ,ACPROT <>>
+ <EMIT <INSTRUCTION `DPB
+ <ACSYM <CHTYPE <DATVAL .VD> AC>>
+ <ADDRSYM .SSAC>>>)>)>)>
+ <COND (.VN <RET-TMP-AC .VD>)>
+ <COND (.STAY-MEM <SET STORE-SET T> .STRD) (ELSE <MOVE:ARG .STRD .W>)>>
+
+<DEFINE STRING-NTH (N W TYP TPS NK NUM STRN NUMN NR "AUX" STRD RES)
+ #DECL ((N STRN) NODE (STRD) DATUM (RES) <DATUM ATOM AC>)
+ <PREFER-DATUM .W>
+ <SET STRD
+ <STRING-REST .N
+ DONT-CARE
+ .TYP
+ .TPS
+ .NK
+ <- .NUM 1>
+ .STRN
+ .NUMN
+ <>
+ <==? <NODE-NAME .N> INTH>
+ .NR>>
+ <SET RES
+ <DATUM <COND (<==? .TPS STRING> CHARACTER)
+ (ELSE FIX)>
+ <COND (<AND <TYPE? .W DATUM> <TYPE? <DATVAL .W> AC>>
+ <SGETREG <DATVAL .W> <>>)
+ (ELSE <GETREG <>>)>>>
+ <PUT <DATVAL .RES> ,ACLINK (.RES !<ACLINK <DATVAL .RES>>)>
+ <COND (.NK <TOACV .STRD> <MUNG-AC <DATVAL .STRD> .STRD>)>
+ <RET-TMP-AC .STRD>
+ <EMIT <INSTRUCTION <COND (.NK `ILDB ) (ELSE `LDB )>
+ <ACSYM <DATVAL .RES>>
+ !<ADDR:VALUE .STRD>>>
+ <MOVE:ARG .RES .W>>
+
+<DEFINE STRING-PUT (N W TYP TPS NK NUM STRN NUMN VN NR SAME?
+ "AUX" STRD RES (ONO .NO-KILL) (NO-KILL .ONO))
+ #DECL ((NO-KILL) <SPECIAL LIST> (NR) <OR FALSE <LIST FIX FIX>>)
+ <STRING-REST .N
+ .W
+ .TYP
+ .TPS
+ .NK
+ <- .NUM 1>
+ .STRN
+ .NUMN
+ <>
+ <>
+ .NR
+ .VN>>
+
+<DEFINE STRINGER (NUM ND STRD "AUX" SAC SACT)
+ #DECL ((STRD ND) DATUM (NUM) <OR FALSE FIX> (SAC SACT) AC)
+ <COND (<AND .NUM <L? .NUM 5>> <>)
+ (ELSE
+ <PUT <SET SAC
+ <COND (<AND <NOT .NUM> <TYPE? <DATVAL .ND> AC>>
+ <MUNG-AC <DATVAL .ND> .ND>
+ <DATVAL .ND>)
+ (ELSE <GETREG <>>)>>
+ ,ACPROT
+ T>
+ <COND (<==? .SAC ,LAST-AC>
+ <SET SAC <SGETREG ,LAST-AC-1 <>>>
+ <PUT <SET SACT ,LAST-AC> ,ACPROT <>>
+ <SGETREG ,LAST-AC <>>)
+ (ELSE
+ <SET SACT <SGETREG <NTH ,ALLACS <+ <ACNUM .SAC> 1>> <>>>)>
+ <PUT .SAC ,ACPROT <>>
+ <EMIT <INSTRUCTION `LDB
+ <ACSYM .SACT>
+ [<FORM (98688) !<ADDR:VALUE .STRD>>]>>
+ <EMIT '<`MOVEI `O 36>>
+ <EMIT <INSTRUCTION `IDIVM `O <ADDRSYM .SACT>>>
+ <COND (.NUM <EMIT <INSTRUCTION `MOVEI <ACSYM .SAC> .NUM>>)
+ (<==? .SAC <DATVAL .ND>>)
+ (ELSE
+ <PUT .SAC ,ACPROT T>
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM .SAC>
+ !<ADDR:VALUE .ND>>>
+ <PUT .SAC ,ACPROT <>>)>
+ <EMIT <INSTRUCTION `IDIV <ACSYM .SAC> <ADDRSYM .SACT>>>
+ .SAC)>>
+
+<DEFINE RSTRING (ST SAC STAY-MEM "AUX" (SAC1 <NTH ,ALLACS <+ <ACNUM .SAC> 1>>))
+ #DECL ((SAC SAC1) AC (ST) DATUM)
+ <COND (<AND <TYPE? <DATVAL .ST> AC> <NOT <ACRESIDUE <DATVAL .ST>>>>
+ <MUNG-AC <DATVAL .ST> .ST>
+ <EMIT <INSTRUCTION `ADD <ACSYM <CHTYPE <DATVAL .ST> AC>> <ADDRSYM .SAC>>>
+ <SET SAC <DATVAL .ST>>)
+ (.STAY-MEM
+ <EMIT <INSTRUCTION `ADDM <ACSYM .SAC> !<ADDR:VALUE .ST>>>)
+ (ELSE
+ <EMIT <INSTRUCTION `ADD <ACSYM .SAC> !<ADDR:VALUE .ST>>>
+ <RET-TMP-AC <DATVAL .ST> .ST>
+ <PUT .ST ,DATVAL .SAC>
+ <PUT .SAC ,ACLINK (.ST !<ACLINK .SAC>)>)>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM .SAC1> '.HERE!-OP!-PACKAGE 3>>
+ <EMIT <INSTRUCTION `IBP !<ADDR:VALUE .ST>>>
+ <EMIT <INSTRUCTION `SOJG <ACSYM .SAC1> '.HERE!-OP!-PACKAGE -1>>
+ .ST>
+
+<SETG RESTERS
+ [,STRING-REST
+ ,STRING-REST
+ ,STRING-REST
+ ,VEC-REST
+ ,VEC-REST
+ ,VEC-REST
+ ,VEC-REST
+ ,LIST-REST]>
+
+<SETG STYPES ![LIST TUPLE VECTOR UVECTOR STORAGE STRING BYTES TEMPLATE!]>
+
+<DEFINE NTH-PRED (C) #DECL ((C) FIX) <==? .C 1>>
+
+<SETG NTHERS
+ [<AND <GASSIGNED? TEMPLATE-NTH> ,TEMPLATE-NTH>
+ ,STRING-NTH
+ ,STRING-NTH
+ ,VEC-NTH
+ ,VEC-NTH
+ ,VEC-NTH
+ ,VEC-NTH
+ ,LIST-NTH]>
+
+<DEFINE PUT-GEN (NOD WHERE "OPTIONAL" (SAME? <>)
+ "AUX" (K <KIDS .NOD>) (TYP <RESULT-TYPE <1 .K>>)
+ (TPS <STRUCTYP .TYP>) (2ARG <2 .K>)
+ (NUMKN <==? <NODE-TYPE .2ARG> ,QUOTE-CODE>)
+ (NUM <COND (.NUMKN <COND (<TYPE? <NODE-NAME .2ARG>
+ OFFSET>
+ <INDEX <NODE-NAME .2ARG>>)
+ (ELSE <NODE-NAME .2ARG>)>) (ELSE 1)>)
+ (NR <GET-RANGE <RESULT-TYPE .2ARG>>) TEM W (1ARG <1 .K>)
+ (NRP <NTH-REST-PUT? <1 .K>>) PUT-COMMON-DAT)
+ #DECL ((NOD) NODE (K) <LIST NODE NODE NODE> (NUM) FIX
+ (PUT-COMMON-DAT) <SPECIAL DATUM> (W) DATUM)
+ <COND (.NUMKN <PUT .2ARG ,NODE-NAME .NUM>)>
+ <COND (<AND <==? .WHERE FLUSHED>
+ <SET TEM <FIND-COMMON-REST-NODE .NOD>>
+ <OR <NOT .CAREFUL> <NOT <MEMQ .TPS '[UVECTOR STORAGE]>>>>
+ <SET W
+ <COMMON-CLOBBER .TEM
+ .NOD
+ <3 .K>
+ <NODE-NAME .2ARG>
+ .1ARG
+ .TPS
+ .SAME?>>
+ <SET TEM <>>
+ <KILL-COMMON .TPS>)
+ (ELSE
+ <KILL-COMMON .TPS>
+ <PROG ((COMMON-SUB <>))
+ #DECL ((COMMON-SUB) <SPECIAL <OR FALSE COMMON>>)
+ <SET W
+ <APPLY <NTH ,PUTTERS <LENGTH <CHTYPE <MEMQ .TPS ,STYPES>
+ UVECTOR>>>
+ .NOD
+ .WHERE
+ .TYP
+ .TPS
+ .NUMKN
+ .NUM
+ <1 .K>
+ .2ARG
+ <3 .K>
+ .NR
+ .SAME?>>
+ <SET TEM .COMMON-SUB>>
+ <OR <==? <TYPEPRIM .TPS> TEMPLATE>
+ <AND <TYPE? <DATTYP .W> AC>
+ <MEMQ <DATTYP .W> .PUT-COMMON-DAT>>
+ <AND <TYPE? <DATVAL .W> AC>
+ <MEMQ <DATVAL .W> .PUT-COMMON-DAT>>
+ <HACK-COMMON NTH
+ .1ARG
+ .TEM
+ .PUT-COMMON-DAT
+ .PUT-COMMON-DAT
+ .NUMKN
+ .NUM
+ .TPS
+ .NRP>
+ <HACK-COMMON NTH
+ .1ARG
+ .TEM
+ .PUT-COMMON-DAT
+ .PUT-COMMON-DAT
+ .NUMKN
+ .NUM
+ .TPS
+ .NRP>>)>
+ <COND (.TEM
+ <OR <==? <TYPEPRIM .TPS> TEMPLATE>
+ <AND <TYPE? <DATTYP .W> AC>
+ <MEMQ <DATTYP .W> .PUT-COMMON-DAT>>
+ <AND <TYPE? <DATVAL .W> AC>
+ <MEMQ <DATVAL .W> .PUT-COMMON-DAT>>
+ <HACK-COMMON NTH
+ .1ARG
+ .TEM
+ .PUT-COMMON-DAT
+ .PUT-COMMON-DAT
+ .NUMKN
+ .NUM
+ .TPS
+ .NRP>
+ <HACK-COMMON NTH
+ .1ARG
+ .TEM
+ .PUT-COMMON-DAT
+ .PUT-COMMON-DAT
+ .NUMKN
+ .NUM
+ .TPS
+ .NRP>>)>
+ .W>
+
+<DEFINE VEC-PUT (N W TYP TPS NK NUM SNOD NNOD VNOD NR SAME?
+ "AUX" VN (ONO .NO-KILL) (NO-KILL .ONO)
+ (RV <AND <NOT .SAME?> <COMMUTE-STRUC <> .NNOD .SNOD>>)
+ (RR
+ <AND <NOT .SAME?>
+ <COMMUTE-STRUC <> .VNOD .SNOD>
+ <COMMUTE-STRUC <> .VNOD .NNOD>>) (MP <MPCNT .TPS>)
+ (NN 0) NAC SAC STR NUMN TEM (CFLG 0))
+ #DECL ((N SNOD NNOD VNOD) NODE (NUM NN MP CFLG) FIX (SAC NAC) AC
+ (NUMN STR VN) DATUM (NO-KILL) <SPECIAL LIST>
+ (NR) <OR FALSE <LIST FIX FIX>>)
+ <COND (.NK
+ <COND (<NOT <G? .NUM 0>> <MESSAGE ERROR "ARG OUT OF RANGE " PUT>)
+ (<OR <NOT .CAREFUL> <L=? .NUM <MINL .TYP>> <1? <SET CFLG .NUM>>>
+ <COND (.RR
+ <SET VN <GEN .VNOD DONT-CARE>>
+ <SET PUT-COMMON-DAT .VN>
+ <SET STR <GEN .SNOD <PREG? .TYP .W>>>
+ <AND <1? .CFLG> <RCHK <DATVAL .STR> <>>>)
+ (ELSE
+ <SET STR <GEN .SNOD <PREG? .TYP .W>>>
+ <AND <1? .CFLG> <RCHK <DATVAL .STR> <>>>
+ <OR .SAME?
+ <SET PUT-COMMON-DAT
+ <SET VN <GEN .VNOD DONT-CARE>>>>)>
+ <DELAY-KILL .NO-KILL .ONO>
+ <COND (.SAME? <SPEC-GEN .VNOD .STR .TPS .NUM>)
+ (ELSE <DATCLOB .VNOD .VN .NUM .MP .STR .TYP T>)>
+ <MOVE:ARG .STR .W>)
+ (ELSE
+ <COND (.RR
+ <SET VN <GEN .VNOD DONT-CARE>>
+ <SET PUT-COMMON-DAT .VN>
+ <SET SAC <DATVAL <SET STR <GEN .SNOD <PREG? .TYP .W>>>>>
+ <MUNG-AC .SAC .STR>)
+ (ELSE
+ <SET STR <GEN .SNOD <PREG? .TYP .W>>>
+ <OR .SAME?
+ <SET PUT-COMMON-DAT <SET VN <GEN .VNOD DONT-CARE>>>>
+ <SET SAC <DATVAL <SET STR <TOACV .STR>>>>
+ <MUNG-AC .SAC .STR>)>
+ <DELAY-KILL .NO-KILL .ONO>
+ <EMIT <INSTRUCTION `ADD
+ <ACSYM .SAC>
+ [<FORM <SET NN <* <- .NUM 1> .MP>> (.NN)>]>>
+ <RCHK .SAC <>>
+ <COND (.SAME? <SPEC-GEN .VNOD .STR .TPS 1>)
+ (ELSE <DATCLOB .VNOD .VN 1 .MP .STR .TYP T .NUM>)>
+ <SET SAC <DATVAL <TOACV .STR>>>
+ <OR <==? .W FLUSHED>
+ <EMIT <INSTRUCTION `SUB
+ <ACSYM .SAC>
+ [<FORM .NN (.NN)>]>>>
+ <MOVE:ARG .STR .W>)>)
+ (ELSE
+ <COND (.RR <SET VN <GEN .VNOD DONT-CARE>> <SET PUT-COMMON-DAT .VN>)>
+ <COND (.RV
+ <PREFER-DATUM <SET STR <PREG? .TYP .W>>>
+ <SET NUMN <GEN .NNOD <DATUM FIX ANY-AC>>>
+ <SET STR <GEN .SNOD .STR>>
+ <TOACV .NUMN>
+ <SET NAC <DATVAL .NUMN>>)
+ (ELSE
+ <SET STR <GEN .SNOD <PREG? .TYP .W>>>
+ <SET NAC <DATVAL <SET NUMN <GEN .NNOD <DATUM FIX ANY-AC>>>>>)>
+ <COND (.RR <DELAY-KILL .NO-KILL .ONO>)>
+ <TOACV .STR>
+ <SET SAC <DATVAL .STR>>
+ <MUNG-AC .NAC .NUMN>
+ <AND .CAREFUL
+ <NOT <AND .NR <G? <1 .NR> 0>>>
+ <EMIT <INSTRUCTION `JUMPLE <ACSYM .NAC> |CERR1 >>>
+ <OR <1? .MP> <EMIT <INSTRUCTION `ASH <ACSYM .NAC> 1>>>
+ <EMIT <INSTRUCTION `HRLI <ACSYM .NAC> (<ADDRSYM .NAC>)>>
+ <EMIT <INSTRUCTION `ADD <ACSYM .NAC> <ADDRSYM .SAC>>>
+ <AND .CAREFUL <NOT <AND .NR <L=? <2 .NR> <MINL .TYP>>>> <RCHK .NAC T>>
+ <RET-TMP-AC <DATTYP .NUMN> .NUMN>
+ <COND (<==? .TPS TUPLE>
+ <PUT .NUMN ,DATTYP <DATTYP .STR>>
+ <COND (<TYPE? <DATTYP .STR> AC>
+ <PUT <SET SAC <DATTYP .STR>>
+ ,ACLINK
+ (.NUMN !<ACLINK .SAC>)>)>)
+ (ELSE <PUT .NUMN ,DATTYP .TPS>)>
+ <COND (<NOT .RR>
+ <DELAY-KILL .NO-KILL .ONO>
+ <OR .SAME?
+ <SET PUT-COMMON-DAT <SET VN <GEN .VNOD DONT-CARE>>>>)>
+ <COND (.SAME? <SPEC-GEN .VNOD .NUMN .TPS 0>)
+ (ELSE <DATCLOB .VNOD .VN 0 .MP .NUMN .TYP <>>)>
+ <RET-TMP-AC .NUMN>
+ <MOVE:ARG .STR .W>)>>
+
+<DEFINE LIST-PUT (N W TYP TPS NK NUM SNOD NNOD VNOD NR SAME?)
+ #DECL ((N SNOD NNOD NOD) NODE (NUM) FIX)
+ <LIST-REST .N
+ .W
+ .TYP
+ .TPS
+ .NK
+ <- .NUM 1>
+ .SNOD
+ .NNOD
+ <>
+ <>
+ .NR
+ T
+ .VNOD .SAME?>>
+
+<SETG PUTTERS
+ [<AND <GASSIGNED? TEMPLATE-PUT> ,TEMPLATE-PUT>
+ ,STRING-PUT
+ ,STRING-PUT
+ ,VEC-PUT
+ ,VEC-PUT
+ ,VEC-PUT
+ ,VEC-PUT
+ ,LIST-PUT]>
+
+<DEFINE DATCLOB (VNOD N O TY N2 TP NK
+ "OPTIONAL" (RN .O)
+ "AUX" (ETYP <GET-ELE-TYPE .TP <COND (.NK .RN) (ELSE ALL)>>)
+ (VTYP <RESULT-TYPE .VNOD>) TT TEM)
+ #DECL ((N) DATUM (O RN TY) FIX (N2) DATUM (VNOD) NODE)
+ <SET O <+ <* <- .O 1> .TY> -2 .TY>>
+ <COND
+ (<1? .TY>
+ <COND
+ (<AND .CAREFUL <NOT <TYPESAME .ETYP .VTYP>>>
+ <COND (<SET TT <ISTYPE? .ETYP>>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O !<ADDR:TYPE .N>>>
+ <EMIT <INSTRUCTION `CAIE `O <FORM TYPE-CODE!-OP!-PACKAGE .TT>>>
+ <BRANCH:TAG |CERR3 >)
+ (<SET TT <ISTYPE? .VTYP>>
+ <TOACV .N2>
+ <GETUVT <DATVAL .N2> ,ACO T>
+ <EMIT <INSTRUCTION `CAIE `O <FORM TYPE-CODE!-OP!-PACKAGE .TT>>>
+ <BRANCH:TAG |CERR3 >)
+ (ELSE
+ <PUT <SET TT <GETREG <>>> ,ACPROT T>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE
+ <ACSYM .TT>
+ !<ADDR:TYPE .N>>>
+ <TOACV .N2>
+ <GETUVT <DATVAL .N2> ,ACO T>
+ <EMIT <INSTRUCTION `CAIE `O (<ADDRSYM .TT>)>>
+ <BRANCH:TAG |CERR3 >
+ <PUT .TT ,ACPROT <>>)>
+ <MOVE:ARG .N <DATUM DONT-CARE <OFFPTR .O .N2 UVECTOR>>>)
+ (ELSE
+ <MOVE:ARG .N <DATUM DONT-CARE <OFFPTR .O .N2 UVECTOR>>>)>)
+ (ELSE
+ <MOVE:ARG .N
+ <COND (<AND <SET ETYP <ISTYPE-GOOD? .ETYP>>
+ <TYPESAME .ETYP .VTYP>>
+ <DATUM .ETYP <OFFPTR .O .N2 VECTOR>>)
+ (ELSE <DATUM <SET TEM <OFFPTR .O .N2 VECTOR>> .TEM>)>>)>>
+
+<DEFINE MPCNT (TY)
+ #DECL ((TY) ATOM)
+ <COND (<OR <==? .TY UVECTOR> <==? .TY STORAGE>> 1)
+ (ELSE 2)>>
+
+<DEFINE IPUT-GEN (NOD WHERE
+ "AUX" (OS .STK) (STK (0 !.STK)) PINDIC (K <KIDS .NOD>) PITEM)
+ #DECL ((NOD) NODE (K) <LIST NODE NODE NODE> (PITEM PINDIC) DATUM
+ (STK) <SPECIAL LIST>)
+ <SET PITEM <GEN <1 .K> <DATUM ,AC-A ,AC-B>>>
+ <SET PINDIC <GEN <2 .K> <DATUM ,AC-C ,AC-D>>>
+ <RET-TMP-AC <STACK:ARGUMENT <GEN <3 .K> DONT-CARE>>>
+ <ADD:STACK 2>
+ <SET PITEM <MOVE:ARG .PITEM <DATUM ,AC-A ,AC-B>>>
+ <RET-TMP-AC <MOVE:ARG .PINDIC <DATUM ,AC-C ,AC-D>>>
+ <RET-TMP-AC .PITEM>
+ <REGSTO T>
+ <EMIT <INSTRUCTION `PUSHJ `P* <COND (<==? <NODE-SUBR .NOD> ,PUT> |CIPUT)
+ (ELSE |CIPUTP)>>>
+ <SET STK .OS>
+ <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>
+
+<DEFINE IREMAS-GEN (NOD WHERE "AUX" (K <KIDS .NOD>) PINDIC PITEM)
+ #DECL ((NOD) NODE (K) <LIST NODE NODE> (PINDIC PITEM) DATUM)
+ <SET PITEM <GEN <1 .K> <DATUM ,AC-A ,AC-B>>>
+ <SET PINDIC <GEN <2 .K> <DATUM ,AC-C ,AC-D>>>
+ <SET PITEM <MOVE:ARG .PITEM <DATUM ,AC-A ,AC-B>>>
+ <RET-TMP-AC <MOVE:ARG .PINDIC <DATUM ,AC-C ,AC-D>>>
+ <RET-TMP-AC .PITEM>
+ <REGSTO T>
+ <EMIT <INSTRUCTION `PUSHJ `P* |CIREMA >>
+ <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>
+
+<DEFINE PUTREST-GEN (NOD WHERE
+ "AUX" ST1 ST2 (K <KIDS .NOD>) (FLG T) N CD (ONO .NO-KILL)
+ (NO-KILL .ONO) (2RET <>))
+ #DECL ((NOD N) NODE (K) <LIST NODE NODE> (ST1 ST2) DATUM
+ (NO-KILL) <SPECIAL LIST> (ONO) LIST)
+ <COND (<==? <NODE-SUBR .NOD> ,REST>
+ <SET NOD <1 .K>>
+ <SET K <KIDS .NOD>>
+ <SET 2RET T>)> ;"Really <REST <PUTREST ...."
+ <COND (<AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <==? <NODE-NAME <2 .K>> ()>>
+ <SET ST1 <GEN <1 .K> <UPDATE-WHERE .NOD .WHERE>>>)
+ (<AND <NOT <SIDE-EFFECTS? <1 .K>>>
+ <NOT <SIDE-EFFECTS? <2 .K>>>
+ <MEMQ <NODE-TYPE <1 .K>> ,SNODES>>
+ <AND <==? <NODE-TYPE <SET N <1 .K>>> ,LVAL-CODE>
+ <COND (<==? <LENGTH <SET CD <TYPE-INFO .N>>> 2> <2 .CD>)
+ (ELSE T)>
+ <SET CD <NODE-NAME .N>>
+ <NOT <MAPF <>
+ <FUNCTION (LL)
+ #DECL ((LL) <LIST SYMTAB ANY>)
+ <AND <==? .CD <1 .LL>> <MAPLEAVE>>>
+ .NO-KILL>>
+ <SET NO-KILL ((.CD <>) !.NO-KILL)>>
+ <SET ST2
+ <GEN <2 .K>
+ <COND (.2RET <GOODACS <2 .K> .WHERE>)
+ (ELSE <DATUM LIST ANY-AC>)>>>
+ <SET ST1
+ <GEN <1 .K>
+ <COND (.2RET DONT-CARE)
+ (ELSE <UPDATE-WHERE .NOD .WHERE>)>>>
+ <DELAY-KILL .NO-KILL .ONO>)
+ (ELSE
+ <SET ST1
+ <GEN <1 .K>
+ <GOODACS .NOD
+ <COND (<OR <==? .WHERE FLUSHED> .2RET>
+ DONT-CARE)
+ (ELSE .WHERE)>>>>
+ <SET ST2 <GEN <2 .K> <DATUM LIST ANY-AC>>>)>
+ <KILL-COMMON LIST>
+ <AND .CAREFUL
+ <G? 1 <MINL <RESULT-TYPE <1 .K>>>>
+ <COND (<TYPE? <DATVAL .ST1> AC>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM <DATVAL .ST1>> |CERR2 >>)
+ (ELSE
+ <EMIT <INSTRUCTION `SKIPN !<ADDR:VALUE .ST1>>>
+ <BRANCH:TAG |CERR2 >)>>
+ <AND <ASSIGNED? ST2> <TOACV .ST2>>
+ <OR <TYPE? <DATVAL .ST1> AC> <SET FLG <>>>
+ <COND (<ASSIGNED? ST2>
+ <COND (.FLG
+ <EMIT <INSTRUCTION `HRRM
+ <ACSYM <CHTYPE <DATVAL .ST2> AC>>
+ (<ADDRSYM <CHTYPE <DATVAL .ST1> AC>>)>>)
+ (ELSE
+ <EMIT <INSTRUCTION `HRRM
+ <ACSYM <CHTYPE <DATVAL .ST2> AC>>
+ `@
+ !<ADDR:VALUE .ST1>>>)>
+ <RET-TMP-AC <COND (.2RET .ST1) (ELSE .ST2)>>)
+ (ELSE
+ <COND (.FLG
+ <EMIT <INSTRUCTION `HLLZS (<ADDRSYM <CHTYPE <DATVAL .ST1> AC>>)>>)
+ (ELSE
+ <EMIT <INSTRUCTION `HLLZS `@ !<ADDR:VALUE .ST1>>>)>)>
+ <MOVE:ARG <COND (.2RET .ST2) (ELSE .ST1)> .WHERE>>
+
+<DEFINE SIDE-EFFECTS? (N)
+ #DECL ((N) NODE)
+ <AND <N==? <NODE-TYPE .N> ,QUOTE-CODE> <SIDE-EFFECTS .N>>>
+
+<DEFINE COMMUTE-STRUC (RV NUMNOD STRNOD "AUX" N (L .NO-KILL) CD (FLG T))
+ #DECL ((NO-KILL) LIST (NUMNOD STRNOD) NODE (L) LIST)
+ <COND
+ (<OR <AND <NOT .RV>
+ <OR <AND <==? <NODE-TYPE .NUMNOD> ,QUOTE-CODE>
+ <NOT <SET FLG <>>>>
+ <NOT <SIDE-EFFECTS .NUMNOD>>>
+ <MEMQ <SET CD <NODE-TYPE <SET N .STRNOD>>> ,SNODES>>
+ <AND .RV
+ <OR <AND <==? <NODE-TYPE .STRNOD> ,QUOTE-CODE>
+ <NOT <SET FLG <>>>>
+ <NOT <SIDE-EFFECTS .STRNOD>>>
+ <NOT <MEMQ <SET CD <NODE-TYPE <SET N .NUMNOD>>> ,SNODES>>>>
+ <COND (<AND .FLG
+ <==? .CD ,LVAL-CODE>
+ <COND (<==? <LENGTH <SET CD <TYPE-INFO .N>>> 2> <2 .CD>)
+ (ELSE T)>
+ <SET CD <NODE-NAME .N>>
+ <NOT <MAPF <>
+ <FUNCTION (LL)
+ #DECL ((LL) <LIST SYMTAB ANY>)
+ <AND <==? .CD <1 .LL>> <MAPLEAVE>>>
+ .L>>>
+ <SET NO-KILL ((.CD <>) !.L)>)>
+ <NOT .RV>)
+ (ELSE .RV)>>
+
+
+<DEFINE DEFER-IT (NOD STR "AUX" SAC SAC1 STR1 COD)
+ #DECL ((STR STR1) DATUM (NOD) NODE (SAC SAC1) AC (COD) FIX)
+ <COND
+ (<1? <SET COD <DEFERN <RESULT-TYPE .NOD>>>>
+ <COND (<AND <ACRESIDUE
+ <SET SAC
+ <DATVAL <SET STR <MOVE:ARG .STR <REG? LIST .STR>>>>>>
+ <NOT <0? <CHTYPE <FREE-ACS T> FIX>>>>
+ <SET SAC1 <GETREG <SET STR1 <DATUM LIST ANY-AC>>>>
+ <PUT .STR1 ,DATVAL .SAC1>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .SAC1> 1 (<ADDRSYM .SAC>)>>
+ <RET-TMP-AC .STR>
+ <SET STR .STR1>)
+ (ELSE
+ <MUNG-AC .SAC .STR>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .SAC> 1 (<ADDRSYM .SAC>)>>)>)
+ (<AND <NOT <0? .COD>>
+ <G? <CHTYPE <FREE-ACS T> FIX> 0>
+ <ACRESIDUE <SET SAC <DATVAL .STR>>>
+ <MAPF <>
+ <FUNCTION (ITEM)
+ #DECL ((ITEM) SYMBOL)
+ <COND (<AND <TYPE? .ITEM SYMTAB> <NOT <STORED .ITEM>>>
+ <MAPLEAVE T>)>>
+ <ACRESIDUE .SAC>>>
+ <SET SAC
+ <DATVAL <SET STR <MOVE:ARG .STR <REG? LIST .STR>>>>>
+ <SET SAC1 <GETREG <SET STR1 <DATUM LIST ANY-AC>>>>
+ <PUT .STR1 ,DATVAL .SAC1>
+ <EMIT <INSTRUCTION `MOVEI <ACSYM .SAC1> (<ADDRSYM .SAC>)>>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O (<ADDRSYM .SAC>)>>
+ <EMIT <INSTRUCTION `CAIN `O TDEFER!-OP!-PACKAGE>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .SAC1> 1 (<ADDRSYM .SAC1>)>>
+ <RET-TMP-AC .STR>
+ <SET STR .STR1>)
+ (<NOT <0? .COD>>
+ <SET SAC
+ <DATVAL <SET STR <MOVE:ARG .STR <REG? LIST .STR>>>>>
+ <MUNG-AC .SAC .STR>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O (<ADDRSYM .SAC>)>>
+ <EMIT <INSTRUCTION `CAIN `O TDEFER!-OP!-PACKAGE>>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .SAC> 1 (<ADDRSYM .SAC>)>>)>
+ .STR>
+
+\\f
+
+"ROUTINES TO DO COMMON SUBEXPRESSION HACKING IN SIMPLE CASES
+ (CURRENTLY NTH REST)."
+
+"ROUTINE TO CREATE A COMMON"
+
+<DEFINE COMMON (CODE SYMT OBJ PTYP DAT)
+ #DECL ((CODE) ATOM (SYMT) <OR SYMTAB COMMON> (OBJ) FIX)
+ <CHTYPE [.CODE .SYMT .OBJ .PTYP .DAT] COMMON>>
+
+"THIS ROUTINE BUILDS A CANONACAILZED COMMON. THIS ROUTINE CAN RETURN
+ EITHER A COMMON OR A LIST OF COMMONS."
+
+<DEFINE BUILD-COMMON (CODE COMSYMT ITEM PTYP DAT "AUX" INAC COMM COMT CUR-COM)
+ #DECL ((CODE) ATOM (COMSYMT) <OR SYMTAB COMMON LIST> (ITEM) FIX
+ (CUR-COM) <OR COMMON <LIST [REST COMMON]>>)
+ <COND (<TYPE? .COMSYMT LIST>
+ <REPEAT ((PTR .COMSYMT) (CLIST ()))
+ <COND (<EMPTY? .PTR>
+ <RETURN <COND (<1? <LENGTH .CLIST>> <1 .CLIST>)
+ (.CLIST)>>)>
+ <SET CUR-COM <BUILD-COMMON .CODE <1 .PTR> .ITEM .PTYP .DAT>>
+ <COND (<TYPE? .CUR-COM COMMON>
+ <SET CLIST (.CUR-COM !.CLIST)>)
+ (<PUTREST <REST .CUR-COM <- <LENGTH .CUR-COM> 1>>
+ .CLIST>)>
+ <SET PTR <REST .PTR>>>)
+ (<TYPE? .COMSYMT SYMTAB>
+ <COND (<AND <SET INAC <INACS .COMSYMT>>
+ <SET COMM <FIND-COMMON-AC <DATVAL .INAC>>>>
+ <SET COMT <BUILD-COMMON .CODE .COMM .ITEM .PTYP .DAT>>
+ <COND (<TYPE? .COMT LIST>
+ (<COMMON .CODE .COMSYMT .ITEM .PTYP .DAT> !.COMT))
+ (ELSE
+ (<COMMON .CODE .COMSYMT .ITEM .PTYP .DAT> .COMT))>)
+ (<COMMON .CODE .COMSYMT .ITEM .PTYP .DAT>)>)
+ (ELSE
+ <COND (<==? <COMMON-TYPE .COMSYMT> REST>
+ (<COMMON .CODE .COMSYMT .ITEM .PTYP .DAT>
+ <COMMON .CODE
+ <COMMON-SYMT .COMSYMT>
+ <+ .ITEM <COMMON-ITEM .COMSYMT>>
+ .PTYP
+ .DAT>))
+ (<COMMON .CODE .COMSYMT .ITEM .PTYP .DAT>)>)>>
+
+"ROUTINE TO FIND A COMMON GIVEN A NODE"
+
+<DEFINE FIND-COMMON (NOD "OPTIONAL" (NAME <>) (NUM <>))
+ #DECL ((NOD) NODE)
+ <PROG RTPNT ()
+ <MAPF <>
+ <FUNCTION (AC "AUX" ACR)
+ #DECL ((AC) AC)
+ <COND
+ (<SET ACR <ACRESIDUE .AC>>
+ <MAPF <>
+ <FUNCTION (ITEM)
+ <COND (<AND <TYPE? .ITEM COMMON>
+ <COND (.NAME
+ <SPEC-COMMON-EQUAL
+ .NAME .NOD .NUM .ITEM>)
+ (<COMMON-EQUAL .NOD .ITEM>)>>
+ <RETURN .ITEM .RTPNT>)>>
+ .ACR>)>>
+ ,ALLACS>>>
+
+"ROUTINE TO SEE IF A COMMON AND A NODE ARE EQUAL"
+
+<DEFINE COMMON-EQUAL (NODE COM)
+ #DECL ((NODE) <OR NODE SYMTAB> (COM) <OR SYMTAB COMMON>)
+ <COND (<==? .NODE .COM>)
+ (<NOT <OR <TYPE? .NODE SYMTAB> <TYPE? .COM SYMTAB>>>
+ <AND <EQCODE .NODE .COM>
+ <EQNUM .NODE .COM>
+ <EQKIDS .NODE .COM>>)>>
+
+"ROUTINE TO SEE IF THE CODES OF THE COMMONS ARE EQUAL"
+
+<DEFINE EQCODE (NODE COM "OPTIONAL" (NT <NODE-TYPE .NODE>))
+ #DECL ((NODE) NODE (COM) COMMON)
+ <OR <AND <==? .NT ,NTH-CODE> <==? <COMMON-TYPE .COM> NTH>>
+ <AND <==? .NT ,REST-CODE> <==? <COMMON-TYPE .COM> REST>>>>
+
+"ROUTINE TO SEE IF THE NUMBERS OF A COMMON AND A NODE ARE EQUAL"
+
+<DEFINE EQNUM (NODE COM "OPTIONAL" (NUM <NODE-NAME <2 <KIDS .NODE>>>))
+ #DECL ((NODE) NODE (COM) COMMON)
+ <==? <COMMON-ITEM .COM> .NUM>>
+
+"ROUTINE TO SEE IF THE KIDS OF A COMMON AND A NODE ARE EQUAL"
+
+<DEFINE EQKIDS (NODE COM "OPTIONAL" (KID <1 <KIDS .NODE>>))
+ #DECL ((NODE) NODE (COM) COMMON)
+ <COMMON-EQUAL <COND (<SYMTAB? .KID T>) (.KID)>
+ <COMMON-SYMT .COM>>>
+
+"ROUTINE TO FLUSH COMMONS IF PUTS OR PUTRESTS COME ALONG
+ IF TYP IS FALSE THEN KILL ALL COMMONS.
+ OTHERWISE KILL THOSE COMMONS WHICH ARE TYE SAME TYPE AS TYP OR UNKNOWN."
+
+<DEFINE KILL-COMMON (PTYP)
+ #DECL ((TYP) <OR FALSE ATOM>)
+ <MAPF <>
+ <FUNCTION (AC "AUX" ACR)
+ #DECL ((AC) AC)
+ <COND (<SET ACR <ACRESIDUE .AC>>
+ <PUT .AC ,ACRESIDUE <FLUSH-COMMONS .ACR .PTYP>>)>>
+ ,ALLACS>>
+
+"FLUSH-COMMONS IS USED TO FLUSH ALL THE COMMONS FROM AN AC"
+
+<DEFINE FLUSH-COMMONS FC (ACR PTYP)
+ #DECL ((TYP) <OR ATOM FALSE> (ACR) LIST)
+ <REPEAT ()
+ <COND (<FLUSH? <1 .ACR> .PTYP>
+ <COND (<EMPTY? <SET ACR <REST .ACR>>> <RETURN <> .FC>)>)
+ (<RETURN .ACR>)>>
+ <REPEAT ((PTR <REST .ACR>) (TOPACR .ACR))
+ <COND (<EMPTY? .PTR> <RETURN .TOPACR>)>
+ <COND (<FLUSH? <1 .PTR> .PTYP> <PUTREST .ACR <REST .PTR>>)>
+ <SET ACR <REST .ACR>>
+ <SET PTR <REST .PTR>>>>
+
+"FLUSH? SEES IF A COMMON SHOULD BE FLUSHED"
+
+<DEFINE FLUSH? (COM PTYP)
+ <OR <NOT .PTYP>
+ <AND <TYPE? .COM COMMON>
+ <==? <COMMON-PRIMTYPE .COM> .PTYP>>>>
+
+"FLUSH-COMMON-SYMT IS USED TO FLUSH THE COMMONS ASSOCATED WITH A GIVEN SYMTAB"
+
+<DEFINE FLUSH-COMMON-SYMT (SYMT)
+ #DECL ((SYMT) SYMTAB)
+ <MAPF <>
+ <FUNCTION (AC "AUX" ACR)
+ #DECL ((AC) AC)
+ <SET ACR
+ <COND (<SET ACR <ACRESIDUE .AC>>
+ <COND (<EQSYMT <1 .ACR> .SYMT> <REST .ACR>)
+ (<REPEAT ((PTR <REST .ACR>) (SACR .ACR))
+ <COND (<EMPTY? .PTR> <RETURN .SACR>)>
+ <COND (<EQSYMT <1 .PTR> .SYMT>
+ <PUTREST .ACR <REST .PTR>>
+ <RETURN .SACR>)>
+ <SET PTR <REST .PTR>>
+ <SET ACR <REST .ACR>>>)>)>>
+ <PUT .AC ,ACRESIDUE <COND (<EMPTY? .ACR> <>) (ELSE .ACR)>>>
+ ,ALLACS>>
+
+<DEFINE EQSYMT (ITEM SYMT "AUX" COM)
+ <COND (<TYPE? .ITEM COMMON>
+ <OR <==? <SET COM <COMMON-SYMT .ITEM>> .SYMT>
+ <EQSYMT .COM .SYMT>>)>>
+
+"SEE IF NODE CONTAINS SYMTABS"
+
+<DEFINE SYMTAB? (NOD "OPTIONAL" (SRCHCOM <>))
+ #DECL ((NOD) NODE)
+ <COND (<OR <==? <NODE-TYPE .NOD> ,LVAL-CODE>
+ <AND <NOT .SRCHCOM> <==? <NODE-TYPE .NOD> ,SET-CODE>>>
+ <NODE-NAME .NOD>)>>
+
+"SEE IF THIS IS A NTH OR REST OR PUT CODE"
+
+<DEFINE NTH-REST-PUT? (NOD "AUX" (COD <NODE-TYPE .NOD>))
+ #DECL ((NOD) NODE)
+ <OR <==? .COD ,PUT-CODE>
+ <==? .COD ,REST-CODE>
+ <==? .COD ,NTH-CODE>>>
+
+"SMASH A COMMON INTO AN DATUM"
+
+<DEFINE SMASH-COMMON (COM DAT "AUX" AC)
+ #DECL ((DAT) DATUM (COM) COMMON)
+ <COND (<TYPE? <SET AC <DATTYP .DAT>> AC>
+ <OR <MEMQ .COM <ACRESIDUE .AC>>
+ <PUT .AC ,ACRESIDUE (.COM !<ACRESIDUE .AC>)>>)>
+ <COND (<TYPE? <SET AC <DATVAL .DAT>> AC>
+ <OR <MEMQ .COM <ACRESIDUE .AC>>
+ <PUT .AC ,ACRESIDUE (.COM !<ACRESIDUE .AC>)>>)>
+ <PUT .COM ,COMMON-DATUM <DATUM !.DAT>>>
+
+<DEFINE HACK-COMMON (COD 2NARGNOD TEM WHERE W NUMKN NUM PTYP NRP
+ "AUX" (COM-ITEM <>) COM)
+ #DECL ((W) DATUM)
+ <COND (<AND <N==? .WHERE FLUSHED> <TYPE? <DATVAL .W> AC> .NUMKN>
+ <COND (<SET COM-ITEM <SYMTAB? .2NARGNOD>>)
+ (.NRP <SET COM-ITEM .TEM>)>
+ <COND (.COM-ITEM
+ <SET COM <BUILD-COMMON .COD .COM-ITEM .NUM .PTYP .W>>
+ <COND (<TYPE? .COM LIST>
+ <MAPF <> <FUNCTION (X) <SMASH-COMMON .X .W>> .COM>)
+ (<SMASH-COMMON .COM .W>)>
+ <SET COMMON-SUB .COM>)>)>>
+
+<DEFINE FIND-COMMON-AC (AC)
+ <COND (<TYPE? .AC AC>
+ <MAPF <>
+ <FUNCTION (ITEM)
+ <COND (<TYPE? .ITEM COMMON> <MAPLEAVE .ITEM>)>>
+ <ACRESIDUE .AC>>)>>
+
+<DEFINE FIND-COMMON-REST-NODE (NOD "AUX" (K <KIDS .NOD>))
+ #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
+ <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <FIND-COMMON <1 .K>
+ REST
+ <- <CHTYPE <NODE-NAME <2 .K>> FIX> 1>>>>
+
+<DEFINE SPEC-COMMON-EQUAL (NAME KID NUM COM)
+ #DECL ((NAME) ATOM (NUM) FIX (KID) NODE (COM) COMMON)
+ <AND <==? <COMMON-TYPE .COM> .NAME>
+ <EQNUM .KID .COM .NUM>
+ <EQKIDS .KID .COM .KID>>>
+
+<DEFINE COMMON-CLOBBER (TEM NOD VAL NUM OBJ TPS SAME?
+ "AUX" TSM (NDAT <COMMON-DATUM .TEM>)
+ (ETYP <GET-ELE-TYPE .OBJ .NUM>)
+ (VTYP <RESULT-TYPE .VAL>) ODAT VDAT AC)
+ #DECL ((VDAT ODAT NDAT) DATUM (TEM) COMMON (NOD) NODE (NUM) FIX
+ (VAL OBJ) NODE)
+ <SET TSM
+ <OR <TYPESAME .ETYP .VTYP>
+ <MEMQ .TPS '![STORAGE UVECTOR STRING!]>>>
+ <SET ODAT <DATUM .TPS <DATVAL .NDAT>>>
+ <COND (<AND <NOT .TSM> <TYPE? <SET AC <DATTYP .NDAT>> AC>> <SGETREG .AC .ODAT>)>
+ <COND (<TYPE? <SET AC <DATVAL .NDAT>> AC> <SGETREG .AC .ODAT>)>
+ <OR .SAME?
+ <SET VDAT
+ <GEN .VAL
+ <DATUM <COND (<NOT .TSM> ANY-AC) (FLUSHED)> ANY-AC>>>>
+ <COND (.SAME? <SPEC-GEN .VAL .ODAT .TPS 0>)
+ (ELSE
+ <PUT <CHTYPE <DATVAL .VDAT> AC> ,ACPROT T>
+ <COND (<NOT .TSM> <PUT <CHTYPE <DATTYP .VDAT> AC> ,ACPROT T>)>
+ <COND (<NOT <TYPE? <DATVAL .ODAT> AC>> <TOACV .ODAT>)>
+ <PUT <CHTYPE <DATVAL .VDAT> AC> ,ACPROT <>>
+ <COND (<NOT .TSM> <PUT <CHTYPE <DATTYP .VDAT> AC> ,ACPROT <>>)>
+ <COND (<NOT .TSM>
+ <EMIT <INSTRUCTION <COND (<=? .TPS LIST> `HLLM ) (ELSE `MOVEM )>
+ <ACSYM <CHTYPE <DATTYP .VDAT> AC>>
+ (<ADDRSYM <CHTYPE <DATVAL .ODAT> AC>>)>>)>
+ <COND (<==? .TPS STRING>
+ <EMIT <INSTRUCTION `IDPB
+ <ACSYM <CHTYPE <DATVAL .VDAT> AC>>
+ <ADDRSYM <CHTYPE <DATVAL .ODAT> AC>>>>)
+ (<EMIT <INSTRUCTION `MOVEM
+ <ACSYM <CHTYPE <DATVAL .VDAT> AC>>
+ 1
+ (<ADDRSYM <CHTYPE <DATVAL .ODAT> AC>>)>>)>)>
+ <RET-TMP-AC .VDAT>
+ <RET-TMP-AC .ODAT>
+ ,NO-DATUM>
+
+<DEFINE LOC-COMMON (TEM NOD TPS 1ARG 2ARG WHERE "AUX" W NDAT)
+ #DECL ((TEM) COMMON (NOD 1ARG 2ARG) NODE (WHERE W) <OR ATOM DATUM>
+ (NDAT) DATUM)
+ <COND (<AND <N==? .WHERE FLUSHED> <N==? .TPS STRING>>
+ <MOVE:ARG
+ <DATUM <OFFPTR 0 <SET NDAT <GET-COMMON-DATUM .TEM>> .TPS>
+ <OFFPTR 0 .NDAT .TPS>>
+ .WHERE>)>>
+
+
+<DEFINE GET-COMMON-DATUM (COM "AUX" TEM DAT)
+ #DECL ((COM) COMMON (DAT) DATUM)
+ <SET DAT <DATUM !<COMMON-DATUM .COM>>>
+ <COND (<TYPE? <SET TEM <DATTYP .DAT>> AC>
+ <PUT .TEM ,ACLINK (.DAT !<ACLINK .TEM>)>)>
+ <PUT <SET TEM <CHTYPE <DATVAL .DAT> AC>> ,ACLINK (.DAT !<ACLINK .TEM>)>
+ .DAT>
+\f
+<ENDPACKAGE>
--- /dev/null
+<PACKAGE "SUBRTY">
+
+<ENTRY SUBRS TEMPLATES>
+
+<USE "COMPDEC" "CHKDCL">
+
+
+; "Functions to decide arg dependent types."
+
+<DEFINE FIRST-ARG ("TUPLE" T) <1 .T>>
+
+<DEFINE SECOND-ARG ("TUPLE" T) <2 .T>>
+
+<DEFINE LOC-FCN (STR "OPTIONAL" N
+ "AUX" (TEM <MEMQ <ISTYPE? .STR>
+ ![UVECTOR VECTOR ASOC TUPLE STRING LIST!]>))
+ <COND (.TEM <NTH '![LOCL LOCS LOCA LOCAS LOCV LOCU!] <LENGTH .TEM>>)
+ (ELSE ANY)>>
+
+<DEFINE MAPF-VALUE ("TUPLE" T) ANY>
+
+<DEFINE MEM-VALUE (ITEM STR "AUX" TEM)
+ <COND (<SET TEM <ISTYPE? .STR>> <FORM OR FALSE <TYPEPRIM .TEM>>)
+ (ELSE STRUCTURED)>>
+
+<DEFINE SPFIRST-ARG ("TUPLE" T "AUX" TEM)
+ <COND (<SET TEM <STRUCTYP <1 .T>>>
+ <COND (<==? .TEM TUPLE> VECTOR)(ELSE .TEM)>)>>
+
+
+<DEFINE PFIRST-ARG ("TUPLE" T "AUX" TEM)
+ <COND (<SET TEM <STRUCTYP <1 .T>>>)
+ (ELSE ANY)>>
+
+; "Data structure specifying return types and # of args to common subrs."
+
+<SETG SUBR-DATA
+ ![(,*!- ANY '<OR FIX FLOAT> () STACK <> |CTIMES)
+ (,+!- ANY '<OR FIX FLOAT> () STACK <> |CPLUS)
+ (,/!- ANY '<OR FIX FLOAT> () STACK <> |CDIVID)
+ (,-!- ANY '<OR FIX FLOAT> () STACK <> |CMINUS)
+ (,0?!- 1 '<OR ATOM FALSE>)
+ (,1?!- 1 '<OR ATOM FALSE>)
+ (,1STEP!- 1 PROCESS)
+ (,==?!- 2 '<OR ATOM FALSE>)
+ (,=?!- 2 '<OR ATOM FALSE> () ((,AC-A ,AC-B) (,AC-C ,AC-D)) T |CIEQUA)
+ (,ABS!- 1 '<OR FIX FLOAT>)
+ (,ACCESS!- 2 CHANNEL)
+ (,ALLTYPES!- 0 '<VECTOR [REST ATOM]>)
+ (,ANDB!- ANY WORD)
+ (,APPLY!- ANY ANY)
+ (,APPLYTYPE!- '(1 2) '<OR FALSE ATOM APPLICABLE>)
+ (,ARGS!- 1 TUPLE () ((,AC-A ,AC-B)) <> |CARGS)
+ (,ASCII!- 1 '<OR CHARACTER FIX>)
+ (,ASSIGNED?!- '(1 2) '<OR ATOM FALSE> () ((ATOM ,AC-B)) T |CASSQ)
+ (,ASSOCIATIONS!- 0 ASOC)
+ (,AT!- '(1 2) ,LOC-FCN (1) ((,AC-A ,AC-B) (FIX ,AC-C)) <> |CIAT)
+ (,ATAN!- 1 FLOAT () ((,AC-A ,AC-B)) <> |CATAN)
+ (,ATOM!- 1 ATOM () ((,AC-A ,AC-B)) <> |CATOM)
+ (,AVALUE!- 1 ANY)
+ (,BACK!- '(1 2) ,PFIRST-ARG (1) ((,AC-A ,AC-B) (FIX ,AC-C)) <> |CIBACK)
+ (,BITS!- '(1 2) BITS)
+ (,BLOAT!- '(0 15) FIX)
+ (,BLOCK!- 1 '<LIST [REST OBLIST]>)
+ (,BOUND?!- '(1 2) '<OR ATOM FALSE>)
+ (,BREAK-SEQ!- 2 PROCESS)
+ (,CHANLIST!- 0 '<LIST [REST CHANNEL]>)
+ (,CHANNEL!- '(0 6) CHANNEL)
+ (,CHTYPE!- 2 ANY)
+ (,CHUTYPE!- 2 UVECTOR () ((UVECTOR ,AC-A) (ATOM ,AC-B)) <> |CCHUTY)
+ (,CLOSE!- 1 CHANNEL)
+ (,CONS!- 2 LIST () ((,AC-C ,AC-D) (LIST ,AC-E)) <> |CICONS)
+ (,COS!- 1 FLOAT () ((,AC-A ,AC-B)) <> |CCOS)
+ (,CRLF 1 ATOM () ((,AC-A ,AC-B)) <> |CICRLF)
+ (,DISABLE!- 1 IHEADER)
+ ;(,DISPLAY!- 2 ANY)
+ (,ECHOPAIR!- 2 CHANNEL)
+ (,EMPTY?!- 1 '<OR FALSE ATOM> () ((,AC-A ,AC-B)) T |CEMPTY)
+ (,ENABLE!- 1 IHEADER)
+ (,ENDBLOCK!- 0 '<LIST [REST OBLIST]>)
+ (,EQVB!- ANY WORD)
+ ;(,ERASE!- '(1 2) ANY)
+ (,ERRET!- '(0 2) ANY)
+ (,ERRORS!- 0 OBLIST)
+ (,EVAL!- '(1 2) ANY)
+ (,EVALTYPE!- '(1 2) '<OR FALSE ATOM APPLICABLE>)
+ (,EVENT!- '(1 3) IHEADER)
+ (,EXP!- 1 FLOAT () ((,AC-A ,AC-B)) <> |CEXP)
+ (,FIX!- 1 FIX () ((,AC-A ,AC-B)) <> |CFIX)
+ (,FLATSIZE!- 3 '<OR FALSE FIX> () ((,AC-A ,AC-B) (FIX ,AC-D) (FIX ,AC-C))
+ T |CIFLTZ)
+ (,FLOAD!- '(0 5) STRING) ;"\"DONE\""
+ (,FLOAT!- 1 FLOAT () ((,AC-A ,AC-B)) <> |CFLOAT)
+ (,FORM!- ANY FORM () STACK <> |IIFORM)
+ (,FRAME!- '(0 1) FRAME (#LOSE 0) ((,AC-A ,AC-B)) <> |CFRAME)
+ ;(,FREE!- 1 STORAGE)
+ (,FREE-RUN!- 1 <OR FALSE PROCESS>)
+ (,FUNCT!- 1 ATOM () ((,AC-A ,AC-B)) <> |CFUNCT)
+ (,G=?!- 2 '<OR ATOM FALSE> () ((,AC-A ,AC-B)(,AC-C ,AC-D)) T |CGEQ)
+ (,G?!- 2 '<OR ATOM FALSE> () ((,AC-A ,AC-B)(,AC-C ,AC-D)) T |CGQ)
+ (,GASSIGNED?!- 1 '<OR FALSE ATOM> () ((ATOM ,AC-B)) T |CGASSQ)
+ (,GC!- '(0 3) FIX)
+ (,GET!- '(2 3) ANY () ((,AC-A ,AC-B) (,AC-C ,AC-D)) T |CIGET)
+ (,GETBITS!- 2 WORD)
+ (,GETL!- '(2 3) LOCAS () ((,AC-A ,AC-B)(,AC-C ,AC-D)) T |CIGETL)
+ (,GETPROP!- '(2 3) ANY)
+ (,GLOC!- '(1 2) LOCD () ((ATOM ,AC-B)) <> |CGLOC)
+ (,GO!- 1 ANY)
+ (,MULTI-SECTION!- '(0 1) ANY)
+ (,GUNASSIGN!- 1 ATOM)
+ (,GVAL!- 1 ANY)
+ (,HANDLER!- '(2 3) HANDLER)
+ (,IFORM!- '(1 2) FORM)
+ (,ILIST!- '(1 2) LIST)
+ (,IMAGE!- '(1 2) FIX)
+ (,IN!- 1 ANY () ((,AC-A ,AC-B)) <> |CIN)
+ (,INDICATOR!- 1 ANY)
+ (,INSERT!- 2 ATOM () ((,AC-A ,AC-B) (OBLIST ,AC-C)) <> |CINSER)
+ (,INT-LEVEL!- '(0 1) FIX)
+ (,INTERRUPT!- ANY '<OR FALSE ATOM>)
+ (,INTERRUPTS!- 0 OBLIST)
+ (,ISTRING!- '(1 2) STRING)
+ (,ITEM!- 1 ANY)
+ (,ITUPLE!- '(1 2) TUPLE)
+ (,IUVECTOR!- '(1 2) UVECTOR)
+ (,IVECTOR!- '(1 2) VECTOR)
+ (,L=?!- 2 '<OR FALSE ATOM> () ((,AC-A ,AC-B)(,AC-C ,AC-D)) T |CLEQ)
+ (,L?!- 2 '<OR FALSE ATOM> () ((,AC-A ,AC-B)(,AC-C ,AC-D)) T |CLQ)
+ (,LEGAL?!- 1 '<OR FALSE ATOM> () ((,AC-A ,AC-B)) T |CILEGQ)
+ (,LENGTH!- 1 FIX () ((,AC-A ,AC-B)) <> |CILNT)
+ (,LENGTH? 2 '<OR FALSE FIX> () ((,AC-A ,AC-B) (FIX ,AC-C)) T |CILNQ)
+ (,LINK!- '(2 3) ,FIRST-ARG)
+ (,LIST!- ANY LIST () STACK <> |IILIST)
+ (,LISTEN!- ANY ANY)
+ (,LLOC!- '(1 2) LOCD () ((ATOM ,AC-B)) <> |CLLOC)
+ (,LOAD!- '(1 2) STRING)
+ (,LOG!- 1 FLOAT () ((,AC-A ,AC-B)) <> |CLOG)
+ (,LOGOUT!- 0 FALSE)
+ (,LOOKUP!- 2 '<OR ATOM FALSE> () ((,AC-A ,AC-B) (OBLIST ,AC-C))
+ T |CLOOKU)
+ (,LVAL!- '(1 2) ANY)
+ (,MAIN!- 0 PROCESS)
+ (,MAPF!- ANY ,MAPF-VALUE)
+ (,MAPR!- ANY ,MAPF-VALUE)
+ (,MAX!- ANY '<OR FIX FLOAT> () STACK <> |CMAX)
+ (,ME!- 0 PROCESS)
+ (,MEMBER!- 2 ,MEM-VALUE () ((,AC-A ,AC-B)(,AC-C ,AC-D)) T |CIMEMB)
+ (,MEMQ!- 2 ,MEM-VALUE () ((,AC-A ,AC-B)(,AC-C ,AC-D)) T |CIMEMQ)
+ (,MIN!- ANY '<OR FIX FLOAT> () STACK <> |CMIN)
+ (,MOBLIST!- '(0 2) OBLIST)
+ (,MOD!- 2 '<OR FIX FLOAT>)
+ (,MONAD?!- 1 '<OR ATOM FALSE> () ((,AC-A ,AC-B)) T |CIMON)
+ (,N==?!- 2 '<OR FALSE ATOM>)
+ (,N=?!- 2 '<OR FALSE ATOM> () ((,AC-A ,AC-B)(,AC-C ,AC-D)) T |CINEQU)
+ (,NETACC!- 1 CHANNEL)
+ (,NETS!- 1 CHANNEL)
+ (,NETSTATE!- 1 '<UVECTOR [3 FIX]>)
+ (,NEWTYPE!- '(2 3) ATOM)
+ (,NEXT!- 1 '<OR ASOC FALSE>)
+ (,NEXTCHR!- 1 ANY () ((,AC-A ,AC-B)) <> |CNXTC1)
+ (,NOT!- 1 '<OR ATOM FALSE>)
+ (,NTH!- '(1 2) ANY (1) ((,AC-A ,AC-B) (FIX ,AC-C)) <> |CINTH)
+ (,OBLIST?!- 1 '<OR FALSE OBLIST>)
+ (,OFF!- '(1 2) '<OR HANDLER IHEADER FALSE>)
+ (,ON!- '(3 5) HANDLER)
+ (,OPEN!- '(0 6) '<OR CHANNEL FALSE>)
+ (,ORB!- ANY WORD)
+ (,PARSE!- '(0 5) ANY)
+ (,PNAME!- 1 STRING () ((ATOM ,AC-A)) <> |CIPNAM)
+ (,PRIMTYPE!- 1 ATOM () ((,AC-A DONT-CARE)) <> |CPTYPE)
+ (,PRINC!- '(1 2) ,FIRST-ARG)
+ (,PRIN1!- '(1 2) ,FIRST-ARG)
+ (,PRINT!- '(1 2) ,FIRST-ARG)
+ (,PRINTB!- 2 UVECTOR)
+ (,PRINTTYPE!- '(1 2) '<OR FALSE ATOM APPLICABLE>)
+ (,PROCESS!- 1 PROCESS)
+ (,PUT!- '(2 3) ANY)
+ (,PUTBITS!- '(2 3) ,FIRST-ARG)
+ (,PUTPROP!- '(2 3) ANY)
+ (,PUTREST!- 2 ,FIRST-ARG)
+ (,QUIT!- 0 FALSE)
+ (,QUITTER!- 2 ANY)
+ (,RANDOM!- '(0 2) FIX () () <> |CRAND)
+ (,READ!- '(0 4) ANY)
+ (,READB!- '(2 3) FIX)
+ (,READCHR!- 1 ANY () ((,AC-A ,AC-B)) <> |CREDC1)
+ (,REMOVE!- '(1 2) '<OR ATOM FALSE> (0) ((,AC-A ,AC-B)(OBLIST ,AC-C))
+ <> |CIRMV)
+ (,RENAME!- '(1 9) '<OR ATOM FALSE CHANNEL>)
+ (,RESET!- 1 '<OR FALSE CHANNEL>)
+ (,REST!- '(1 2) ,PFIRST-ARG (1) ((,AC-A ,AC-B) (FIX ,AC-C)) <> |CIREST)
+ (,RESTORE!- '(1 4) ANY)
+ (,RESUME!- '(1 2) ANY)
+ (,RESUMER!- '(0 1) '<OR FALSE PROCESS>)
+ (,RETRY!- '(0 1) ANY)
+ (,RETURN!- '(1 2) ANY)
+ (,ROOT!- 0 OBLIST)
+ (,RSUBR!- 1 RSUBR)
+ (,SAVE!- '(0 4) STRING)
+ (,SET!- '(2 3) ,SECOND-ARG)
+ (,SETG!- 2 ,SECOND-ARG)
+ (,SETLOC!- 2 ,SECOND-ARG)
+ (,SIN!- 1 FLOAT () ((,AC-A ,AC-B)) <> |CSIN)
+ (,SNAME!- '(0 1) STRING)
+ (,SORT!- ANY ,SECOND-ARG)
+ (,SPNAME 1 STRING () ((ATOM ,AC-B)) <> |CSPNAM)
+ (,SQRT!- 1 FLOAT () ((,AC-A ,AC-B)) <> |CSQRT)
+ (,STATE!- 1 ATOM)
+ ;(,STORE!- 1 STORAGE)
+ (,STRCOMP!- 2 FIX () ((,AC-A ,AC-B)(,AC-C ,AC-D)) <> |ISTRCM)
+ (,STRING!- ANY STRING () STACK <> |CISTNG)
+ (,STRUCTURED?!- 1 '<OR FALSE ATOM> () ((,AC-A DONT-CARE)) T |CISTRU)
+ (,SUBSTRUC!- ANY ,SPFIRST-ARG () STACK <> |CSBSTR)
+ (,SUICIDE!- '(1 2) ANY)
+ (,TAG!- 1 TAG)
+ (,TERPRI!- 1 FALSE () ((,AC-A ,AC-B)) <> |CITERP)
+ (,TIME!- ANY FLOAT)
+ (,TOP!- 1 ,PFIRST-ARG () ((,AC-A ,AC-B)) <> |CITOP)
+ (,TTYECHO!- 2 CHANNEL)
+ (,TUPLE!- ANY TUPLE)
+ (,TYI!- '(0 1) CHARACTER)
+ (,TYPE!- 1 ATOM () ((,AC-A DONT-CARE)) <> |CITYPE)
+ (,TYPE-C '(1 2) TYPE-C (ANY) ((ATOM ,AC-B)(ATOM ,AC-C)) <> |CTYPEC)
+ (,TYPE-W '(1 3) TYPE-W (ANY 0) ((ATOM ,AC-B)(ATOM ,AC-C)(FIX ,AC-D)) <>
+ |CTYPEW)
+ (,TYPE?!- ANY '<OR ATOM FALSE> () STACK T |CTYPEQ)
+ (,TYPEPRIM!- 1 ATOM () ((ATOM ,AC-B)) <> |CTYPEP)
+ (,UNASSIGN!- '(1 2) ATOM)
+ (,UNPARSE!- 2 STRING () ((,AC-A ,AC-B) (FIX ,AC-C)) <> |CIUPRS)
+ (,UTYPE!- 1 ATOM () ((UVECTOR ,AC-B)) <> |CUTYPE)
+ (,UVECTOR!- ANY UVECTOR () STACK <> |CIUVEC)
+ (,VALID-TYPE? 1 '<OR FALSE TYPE-C> () ((ATOM ,AC-B)) T |CVTYPE)
+ (,VALRET!- 1 FALSE)
+ (,VALUE!- 1 ANY)
+ (,VECTOR!- ANY VECTOR () STACK <> |CIVEC)
+ (,XORB!- ANY WORD)!]>
+
+<SETG SUBRS <MAPF ,UVECTOR 1 ,SUBR-DATA>>
+
+<SETG TEMPLATES <MAPF ,UVECTOR ,REST ,SUBR-DATA>>
+
+<PROG (I)
+ <SETG TEMPLATES
+ <IUVECTOR <SET I <LENGTH ,TEMPLATES>>
+ '<PROG ((T <NTH ,TEMPLATES .I>))
+ <SET I <- .I 1>> .T>>>>
+
+<SETG SUBR-DATA ()>
+
+<REMOVE SUBR-DATA>
+\f
+<ENDPACKAGE>
--- /dev/null
+<PACKAGE "SYMANA">
+
+
+<ENTRY ANA EANA SET-CURRENT-TYPE TYPE-NTH-REST WHO TMPS GET-TMP TRUTH UNTRUTH SEGFLUSH
+ KILL-REM BUILD-TYPE-LIST ANALYSIS GET-CURRENT-TYPE ADD-TYPE-LIST PUT-FLUSH WHON
+ SAVE-SURVIVORS SEQ-AN ARGCHK ASSUM-OK? FREST-L-D-STATE HTMPS ORUPC APPLTYP
+ MSAVE-L-D-STATE SHTMPS RESET-VARS STMPS ASSERT-TYPES SAVE-L-D-STATE
+ MUNG-L-D-STATE NORM-BAN SUBR-C-AN ENTROPY NAUX-BAN TUP-BAN ARGS-BAN
+ SPEC-FLUSH LIFE MANIFESTQ>
+
+<USE "CHKDCL" "SUBRTY" "COMPDEC" "STRANA" "CARANA" "BITANA" "NOTANA" "ADVMESS" "MAPANA">
+
+" This is the main file associated with the type analysis phase of
+the compilation. It is called by calling FUNC-ANA with the main data structure
+pointer. ANA is the FUNCTION that dispatches to the various special handlers
+and the SUBR call analyzer further dispatches for specific functions."
+
+" Many analyzers for specific SUBRs appear in their own files
+(CARITH, STRUCT etc.). Currently no special hacks are done for TYPE?, EMPTY? etc.
+in COND, ANDS and ORS."
+
+" All analysis functions are called with 2 args, a NODE and a desired
+type specification. These args are usually called NOD and RTYP or
+N and R."
+
+" ANA is the main analysis dispatcher (see ANALYZERS at the end of
+ this file for its dispatch table."
+
+<GDECL (TEMPLATES SUBRS) UVECTOR>
+
+<DEFINE ANA (NOD RTYP "AUX" (P <PARENT .NOD>) TT TEM)
+ #DECL ((NOD) NODE (P) ANY (TEM TT) <OR FALSE LIST>)
+ <COND (<G=? <LENGTH .NOD> <INDEX ,SIDE-EFFECTS>>
+ <PUT .NOD ,SIDE-EFFECTS <>>)>
+ <PUT .NOD
+ ,RESULT-TYPE
+ <APPLY <NTH ,ANALYZERS <NODE-TYPE .NOD>> .NOD .RTYP>>
+ <AND <N==? <NODE-TYPE .NOD> ,QUOTE-CODE>
+ <SET TEM <SIDE-EFFECTS .NOD>>
+ <TYPE? .P NODE>
+ <PUT .P
+ ,SIDE-EFFECTS
+ <COND (<EMPTY? .TEM> <SIDE-EFFECTS .P>)
+ (<EMPTY? <SET TT <SIDE-EFFECTS .P>>> .TEM)
+ (<OR <AND <TYPE? .TEM LIST>
+ <NOT <EMPTY? .TEM>>
+ <==? <1 .TEM> ALL>>
+ <AND <TYPE? .TT LIST>
+ <NOT <EMPTY? .TT>>
+ <==? <1 .TT> ALL>>>
+ (ALL))
+ (ELSE
+ <PUTREST <REST .TEM <- <LENGTH .TEM> 1>> .TT>
+ .TEM)>>>
+ <RESULT-TYPE .NOD>>
+
+<DEFINE ARGCHK (GIV REQ NAME "AUX" (HI .REQ) (LO .REQ))
+ #DECL ((GIV) FIX (REQ HI LO) <OR <LIST FIX FIX> FIX>)
+ <COND (<TYPE? .REQ LIST>
+ <SET HI <2 .REQ>>
+ <SET LO <1 .REQ>>)>
+ <COND (<L? .GIV .LO>
+ <MESSAGE ERROR "TOO FEW ARGS TO " .NAME>)
+ (<G? .GIV .HI>
+ <MESSAGE ERROR "TOO MANY ARGS TO " .NAME>)> T>
+
+<DEFINE EANA (NOD RTYP NAME)
+ #DECL ((NOD) NODE)
+ <OR <ANA .NOD .RTYP>
+ <MESSAGE ERROR "BAD ARGUMENT TO " .NAME .NOD>>>
+
+" FUNC-ANA main entry to analysis phase. Analyzes bindings then body."
+
+<DEFINE FUNC-ANA ANA-ACT (N R
+ "AUX" (ANALY-OK
+ <COND (<ASSIGNED? ANALY-OK> .ANALY-OK)
+ (ELSE T)>) (OV .VERBOSE))
+ #DECL ((ANA-ACT) <SPECIAL ACTIVATION> (ANALY-OK) <SPECIAL ANY>)
+ <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
+ <FUNC-AN1 .N .R>>
+
+<DEFINE FUNC-AN1 (FCN RTYP
+ "AUX" (VARTBL <SYMTAB .FCN>) (TMPS 0) (HTMPS 0) (TRUTH ())
+ (UNTRUTH ()) (WHO ()) (WHON <>) (PRED <>) TEM (LIFE ())
+ (USE-COUNT 0) (BACKTRACK 0))
+ #DECL ((FCN) <SPECIAL NODE> (VARTBL) <SPECIAL SYMTAB>
+ (TMPS BACKTRACK USE-COUNT HTMPS) <SPECIAL FIX>
+ (LIFE TRUTH UNTRUTH) <SPECIAL LIST>
+ (WHO PRED WHON) <SPECIAL ANY>)
+ <RESET-VARS .VARTBL>
+ <BIND-AN <BINDING-STRUCTURE .FCN>>
+ <OR <SET RTYP <TYPE-OK? .RTYP <INIT-DECL-TYPE .FCN>>>
+ <MESSAGE ERROR "FUNCTION RETURNS WRONG TYPE " <NODE-NAME .FCN>>>
+ <PROG ((ACT? <ACTIV? <BINDING-STRUCTURE .FCN> T>) (OV .VERBOSE))
+ <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
+ <PUT .FCN ,AGND <>>
+ <PUT .FCN ,LIVE-VARS ()>
+ <SET LIFE ()>
+ <PUT .FCN ,ASSUM <BUILD-TYPE-LIST .VARTBL>>
+ <PUT .FCN ,ACCUM-TYPE <COND (.ACT? .RTYP) (ELSE NO-RETURN)>>
+ <SET TEM <SEQ-AN <KIDS .FCN> <INIT-DECL-TYPE .FCN>>>
+ <COND (.ACT? <SPEC-FLUSH> <PUT-FLUSH ALL>)>
+ <OR <NOT <AGND .FCN>>
+ <ASSUM-OK? <ASSUM .FCN> <AGND .FCN>>
+ <AGAIN>>>
+ <PUT .FCN ,ASSUM ()>
+ <PUT .FCN ,DEAD-VARS ()>
+ <OR .TEM
+ <MESSAGE ERROR " RETURNED VALUE VIOLATES VALUE DECL OF " .RTYP>>
+ <PUT .FCN ,RESULT-TYPE <TYPE-MERGE <ACCUM-TYPE .FCN> .TEM>>
+ <PUT <RSUBR-DECLS .FCN> 2 <TASTEFUL-DECL <RESULT-TYPE .FCN>>>
+ <RESULT-TYPE .FCN>>
+
+" BIND-AN analyze binding structure for PROGs, FUNCTIONs etc."
+
+<DEFINE BIND-AN (BNDS "AUX" COD)
+ #DECL ((BNDS) <LIST [REST SYMTAB]> (COD) FIX)
+ <REPEAT (SYM)
+ #DECL ((SYM) SYMTAB)
+ <AND <EMPTY? .BNDS> <RETURN>>
+ <PUT <SET SYM <1 .BNDS>> ,COMPOSIT-TYPE ANY>
+ <PUT .SYM ,CURRENT-TYPE <>>
+ <APPLY <NTH ,BANALS <SET COD <CODE-SYM .SYM>>> .SYM>
+ <SET BNDS <REST .BNDS>>>>
+
+" ENTROPY ignore call and return."
+
+<DEFINE ENTROPY (SYM) T>
+
+<DEFINE TUP-BAN (SYM) #DECL ((SYM) SYMTAB)
+ <COND (<NOT .ANALY-OK>
+ <PUT .SYM ,COMPOSIT-TYPE <1 <DECL-SYM .SYM>>>
+ <PUT .SYM ,CURRENT-TYPE ANY>)
+ (<N==? <ISTYPE? <1 <DECL-SYM .SYM>>> TUPLE>
+ <PUT .SYM ,COMPOSIT-TYPE TUPLE>
+ <PUT .SYM ,CURRENT-TYPE TUPLE>)
+ (ELSE
+ <PUT .SYM ,CURRENT-TYPE <1 <DECL-SYM .SYM>>>
+ <PUT .SYM ,COMPOSIT-TYPE <1 <DECL-SYM .SYM>>>)>>
+
+" Analyze AUX and OPTIONAL intializations."
+
+<DEFINE NORM-BAN (SYM "AUX" (VARTBL <NEXT-SYM .SYM>) TEM COD)
+ #DECL ((VARTBL) <SPECIAL SYMTAB> (SYM) SYMTAB (COD) FIX)
+ <OR <SET TEM <ANA <INIT-SYM .SYM> <1 <DECL-SYM .SYM>>>>
+ <MESSAGE ERROR "BAD AUX/OPT INIT " <NAME-SYM .SYM>
+ <INIT-SYM .SYM>
+ "DECL MISMATCH"
+ <RESULT-TYPE <INIT-SYM .SYM>>
+ <1 <DECL-SYM .SYM>>>>
+ <COND (<AND .ANALY-OK
+ <OR <G? <SET COD <CODE-SYM .SYM>> 9>
+ <L? .COD 6>>>
+ <COND (<NOT <SAME-DECL? .TEM <1 <DECL-SYM .SYM>>>>
+ <PUT .SYM ,CURRENT-TYPE .TEM>)>
+ <PUT .SYM ,COMPOSIT-TYPE .TEM>)
+ (ELSE
+ <PUT .SYM ,COMPOSIT-TYPE <1 <DECL-SYM .SYM>>>
+ <PUT .SYM ,CURRENT-TYPE <1 <DECL-SYM .SYM>>>)>>
+
+" ARGS-BAN analyze ARGS decl (change to OPTIONAL in some cases)."
+
+<DEFINE ARGS-BAN (SYM)
+ #DECL ((SYM) SYMTAB)
+ <PUT .SYM ,INIT-SYM <NODE1 ,QUOTE-CODE () LIST () ()>>
+ <PUT .SYM ,CODE-SYM 7>
+ <COND (.ANALY-OK <PUT .SYM ,COMPOSIT-TYPE LIST>)
+ (ELSE <PUT .SYM ,COMPOSIT-TYPE <1 <DECL-SYM .SYM>>>)>
+ <COND (<AND .ANALY-OK <NOT <SAME-DECL? LIST <1 <DECL-SYM .SYM>>>>>
+ <PUT .SYM ,CURRENT-TYPE LIST>)
+ (<NOT .ANALY-OK> <PUT .SYM ,CURRENT-TYPE ANY>)>>
+
+<DEFINE NAUX-BAN (SYM)
+ #DECL ((SYM) SYMTAB)
+ <PUT .SYM ,COMPOSIT-TYPE
+ <COND (.ANALY-OK NO-RETURN) (ELSE <1 <DECL-SYM .SYM>>)>>
+ <PUT .SYM ,CURRENT-TYPE <COND (.ANALY-OK NO-RETURN)(ELSE ANY)>>>
+
+" VECTOR of binding analyzers."
+
+<SETG BANALS
+ ![,ENTROPY
+ ,NORM-BAN
+ ,NAUX-BAN
+ ,TUP-BAN
+ ,ARGS-BAN
+ ,NORM-BAN
+ ,NORM-BAN
+ ,ENTROPY
+ ,ENTROPY
+ ,ENTROPY
+ ,ENTROPY
+ ,ENTROPY
+ ,ENTROPY!]>
+
+" SEQ-AN analyze a sequence of NODES discarding values until the last."
+
+<DEFINE SEQ-AN (L FTYP "OPTIONAL" (INP <>))
+ #DECL ((L) <LIST [REST NODE]> (FTYP) ANY)
+ <COND (<EMPTY? .L> <MESSAGE INCONSISTENCY "EMPTY KIDS LIST ">)
+ (ELSE
+ <REPEAT (TT N)
+ <AND .INP
+ <==? <NODE-TYPE <1 .L>> ,QUOTE-CODE>
+ <==? <RESULT-TYPE <1 .L>> ATOM>
+ <RESET-VARS .VARTBL>>
+ <OR <SET TT
+ <ANA <SET N <1 .L>>
+ <COND (<EMPTY? <SET L <REST .L>>> .FTYP)
+ (ELSE ANY)>>>
+ <RETURN <>>>
+ <COND (<==? .TT NO-RETURN>
+ <COND (<AND .VERBOSE <NOT <EMPTY? .L>>>
+ <ADDVMESS <PARENT .N>
+ ("This object ends a sequence of forms"
+ .N " because it never returns")>)>
+ <RETURN NO-RETURN>)>
+ <AND <EMPTY? .L> <RETURN .TT>>>)>>
+
+" ANALYZE ASSIGNED? usage."
+
+<DEFINE ASSIGNED?-ANA (NOD RTYP "AUX" (TEM <KIDS .NOD>) TT T1 T2)
+ #DECL ((TT NOD) NODE (T1) SYMTAB (TEM) <LIST [REST NODE]>)
+ <COND (<EMPTY? .TEM> <MESSAGE ERROR "NO ARGS ASSIGNED? " .NOD>)
+ (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <EANA <SET TT <1 .TEM>> ATOM ASSIGNED?>
+ <COND (<AND <EMPTY? <REST .TEM>>
+ <==? <NODE-TYPE .TT> ,QUOTE-CODE>
+ <SET T2 <SRCH-SYM <NODE-NAME .TT>>>
+ <NOT <==? <CODE-SYM <SET T1 .T2>> -1>>>
+ <PUT .NOD ,NODE-TYPE ,ASSIGNED?-CODE>
+ <PUT .NOD ,NODE-NAME .T1>
+ <PUT .T1 ,ASS? T>
+ <PUT .T1 ,USED-AT-ALL T>
+ <REVIVE .NOD .T1>)
+ (<==? <LENGTH .TEM> 2>
+ <EANA <2 .TEM> '<OR <PRIMTYPE FRAME> PROCESS> ASSIGNED?>)
+ (<EMPTY? <REST .TEM>>
+ <COND (<AND .VERBOSE <==? <NODE-TYPE .TT> ,QUOTE-CODE>>
+ <ADDVMESS .NOD
+ ("External reference to LVAL: "
+ <NODE-NAME .TT>)>)>
+ <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)
+ (ELSE <MESSAGE ERROR "TOO MANY ARGS TO ASSIGNED?" .NOD>)>)>
+ <TYPE-OK? '<OR ATOM FALSE> .RTYP>>
+
+<PUT ,ASSIGNED? ANALYSIS ,ASSIGNED?-ANA>
+
+" ANALYZE LVAL usage. Become either direct reference or PUSHJ"
+
+<DEFINE LVAL-ANA (NOD RTYP "AUX" TEM ITYP (TT <>) T1 T2 T3)
+ #DECL ((NOD) NODE (TEM) <LIST [REST NODE]> (T1) SYMTAB (WHO) LIST
+ (USE-COUNT) FIX)
+ <COND
+ (<EMPTY? <SET TEM <KIDS .NOD>>> <MESSAGE ERROR "NO ARGS TO LVAL " .NOD>)
+ (<SEGFLUSH .NOD .RTYP>)
+ (<AND <OR <AND <TYPE? <NODE-NAME .NOD> SYMTAB> <SET TT <NODE-NAME .NOD>>>
+ <AND <EANA <1 .TEM> ATOM LVAL>
+ <EMPTY? <REST .TEM>>
+ <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>
+ <==? <RESULT-TYPE <1 .TEM>> ATOM>
+ <SET TT <SRCH-SYM <NODE-NAME <1 .TEM>>>>>>
+ <COND (<==? .WHON <PARENT .NOD>> <SET WHO ((<> .TT) !.WHO)>) (ELSE T)>
+ <PROG ()
+ <SET ITYP <GET-CURRENT-TYPE .TT>>
+ T>
+ <COND (<AND <==? .PRED <PARENT .NOD>>
+ <SET T2 <TYPE-OK? .ITYP FALSE>>
+ <SET T3 <TYPE-OK? .ITYP '<NOT FALSE>>>>
+ <SET TRUTH <ADD-TYPE-LIST .TT .T3 .TRUTH <>>>
+ <SET UNTRUTH <ADD-TYPE-LIST .TT .T2 .UNTRUTH <>>>)
+ (ELSE T)>
+ <NOT <==? <CODE-SYM <SET T1 .TT>> -1>>>
+ <PUT .NOD ,NODE-TYPE ,LVAL-CODE>
+ <COND (<==? <USAGE-SYM .T1> 0>
+ <PUT .T1 ,USAGE-SYM <SET USE-COUNT <+ .USE-COUNT 1>>>)>
+ <REVIVE .NOD .T1>
+ <PUT .T1 ,RET-AGAIN-ONLY <>>
+ <PUT .T1 ,USED-AT-ALL T>
+ <PUT .NOD ,NODE-NAME .T1>
+ <SET ITYP <TYPE-OK? .ITYP .RTYP>>
+ <AND .ITYP <SET-CURRENT-TYPE .T1 .ITYP>>
+ .ITYP)
+ (<EMPTY? <REST .TEM>>
+ <COND
+ (<AND .VERBOSE <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>>
+ <ADDVMESS .NOD
+ ("External variable being referenced: " <NODE-NAME <1 .TEM>>)>)>
+ <PUT .NOD ,NODE-TYPE ,FLVAL-CODE>
+ <AND .TT <PUT .NOD ,NODE-NAME <SET T1 .TT>>>
+ <COND (.TT <TYPE-OK? <1 <DECL-SYM .T1>> .RTYP>)
+ (.CAREFUL ANY)
+ (ELSE .RTYP)>)
+ (<AND <==? <LENGTH .TEM> 2>
+ <EANA <2 .TEM> '<OR <PRIMTYPE FRAME> PROCESS> LVAL>>
+ ANY)
+ (ELSE <MESSAGE ERROR "BAD CALL TO LVAL " .NOD>)>>
+
+<PUT ,LVAL ANALYSIS ,LVAL-ANA>
+
+" SET-ANA analyze uses of SET."
+
+<DEFINE SET-ANA (NOD RTYP
+ "AUX" (TEM <KIDS .NOD>) (LN <LENGTH .TEM>) T1 T2 T11
+ (WHON .WHON) (PRED .PRED) OTYP T3 XX)
+ #DECL ((NOD) NODE (TEM) <LIST [REST NODE]> (LN) FIX (T1) SYMTAB
+ (WHON PRED) <SPECIAL ANY> (WHO) LIST)
+ <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
+ <COND
+ (<SEGFLUSH .NOD .RTYP>)
+ (<L? .LN 2> <MESSAGE ERROR "TOO FEW ARGS TO SET " .NOD>)
+ (<AND <OR <AND <TYPE? <NODE-NAME .NOD> SYMTAB> <SET T11 <NODE-NAME .NOD>>>
+ <AND <EANA <1 .TEM> ATOM SET>
+ <==? .LN 2>
+ <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>
+ <==? <RESULT-TYPE <1 .TEM>> ATOM>
+ <SET T11 <SRCH-SYM <NODE-NAME <1 .TEM>>>>>>
+ <COND (<==? .WHON <PARENT .NOD>>
+ <SET WHON .NOD>
+ <SET WHO ((T .T11) !.WHO)>)
+ (ELSE T)>
+ <COND (<==? .PRED <PARENT .NOD>> <SET PRED .NOD>) (ELSE T)>
+ <OR <SET T2 <ANA <2 .TEM> <1 <DECL-SYM <SET T1 .T11>>>>>
+ <MESSAGE ERROR "DECL VIOLATION " <NAME-SYM .T1> .NOD>>>
+ <PUT .T1 ,PURE-SYM <>>
+ <SET XX <1 <DECL-SYM .T1>>>
+ <SET OTYP <OR <CURRENT-TYPE .T1> ANY>>
+ <COND (<AND <==? <CODE-SYM .T1> -1> .VERBOSE>
+ <ADDVMESS .NOD ("External variable being SET: " <NAME-SYM .T1>)>)>
+ <COND (<SET OTYP <TYPESAME .OTYP .T2>> <PUT .NOD ,TYPE-INFO (.OTYP <>)>)
+ (ELSE <PUT .NOD ,TYPE-INFO (<> <>)>)>
+ <PUT .NOD
+ ,NODE-TYPE
+ <COND (<==? <CODE-SYM .T1> -1> ,FSET-CODE) (ELSE ,SET-CODE)>>
+ <PUT .NOD ,NODE-NAME .T1>
+ <MAKE-DEAD .NOD .T1>
+ <SET-CURRENT-TYPE .T1 .T2>
+ <PUT .T1 ,USED-AT-ALL T>
+ <COND (<AND <==? .PRED .NOD>
+ <SET OTYP <TYPE-OK? .T2 '<NOT FALSE>>>
+ <SET T3 <TYPE-OK? .T2 FALSE>>>
+ <SET TRUTH <ADD-TYPE-LIST .T1 .OTYP .TRUTH T>>
+ <SET UNTRUTH <ADD-TYPE-LIST .T1 .T3 .UNTRUTH T>>)>
+ <TYPE-OK? .T2 .RTYP>)
+ (<L? .LN 4>
+ <SET T11 <ANA <2 .TEM> ANY>>
+ <COND (<==? .LN 2>
+ <COND (<AND .VERBOSE <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>>
+ <ADDVMESS .NOD
+ ("External variable being SET: "
+ <NODE-NAME <1 .TEM>>)>)>
+ <PUT .NOD ,NODE-TYPE ,FSET-CODE>)
+ (ELSE <EANA <3 .TEM> '<OR <PRIMTYPE FRAME> PROCESS> SET>)>
+ <TYPE-OK? .T11 .RTYP>)
+ (ELSE <MESSAGE ERROR "BAD CALL TO SET " <NODE-NAME <1 .TEM>> .NOD>)>>
+
+<PUT ,SET ANALYSIS ,SET-ANA>
+
+<DEFINE MUNG-L-D-STATE (V) #DECL ((V) <OR VECTOR SYMTAB>)
+ <REPEAT () <COND (<TYPE? .V VECTOR> <RETURN>)>
+ <PUT .V ,DEATH-LIST ()>
+ <SET V <NEXT-SYM .V>>>>
+
+<DEFINE MRESTORE-L-D-STATE (L1 L2 V)
+ <RESTORE-L-D-STATE .L1 .V>
+ <RESTORE-L-D-STATE .L2 .V T>>
+
+<DEFINE FREST-L-D-STATE (L)
+ #DECL ((L) LIST)
+ <MAPF <>
+ <FUNCTION (LL)
+ #DECL ((LL) <LIST SYMTAB <LIST [REST NODE]>>)
+ <COND (<NOT <2 <TYPE-INFO <1 <2 .LL>>>>>
+ <PUT <1 .LL> ,DEATH-LIST <2 .LL>>)>>
+ .L>>
+
+<DEFINE RESTORE-L-D-STATE (L V "OPTIONAL" (FLG <>))
+ #DECL ((L) <LIST [REST <LIST SYMTAB LIST>]> (V) <OR SYMTAB VECTOR>)
+ <OR .FLG
+ <REPEAT (DL)
+ #DECL ((DL) <LIST [REST NODE]>)
+ <COND (<TYPE? .V VECTOR> <RETURN>)>
+ <COND (<AND <NOT <EMPTY? <SET DL <DEATH-LIST .V>>>>
+ <NOT <2 <TYPE-INFO <1 .DL>>>>>
+ <PUT .V ,DEATH-LIST ()>)>
+ <SET V <NEXT-SYM .V>>>>
+ <REPEAT (S DL)
+ #DECL ((DL) <LIST NODE> (S) SYMTAB)
+ <COND (<EMPTY? .L> <RETURN>)>
+ <SET S <1 <1 .L>>>
+ <AND .FLG
+ <REPEAT ()
+ <COND (<==? .S .V> <RETURN>) (<TYPE? .V VECTOR> <RETURN>)>
+ <PUT .V
+ ,DEATH-LIST
+ <MAPF ,LIST
+ <FUNCTION (N)
+ #DECL ((N) NODE)
+ <COND (<==? <NODE-TYPE .N> ,SET-CODE>
+ <MAPRET>)
+ (ELSE .N)>>
+ <DEATH-LIST .V>>>
+ <SET V <NEXT-SYM .V>>>>
+ <COND (<NOT <2 <TYPE-INFO <1 <SET DL <2 <1 .L>>>>>>>
+ <PUT .S
+ ,DEATH-LIST
+ <COND (.FLG <LMERGE <DEATH-LIST .S> .DL>) (ELSE .DL)>>)>
+ <SET L <REST .L>>>>
+
+<DEFINE SAVE-L-D-STATE (V)
+ #DECL ((V) <OR VECTOR SYMTAB>)
+ <REPEAT ((L (())) (LP .L) DL)
+ #DECL ((L LP) LIST (DL) <LIST [REST NODE]>)
+ <COND (<TYPE? .V VECTOR> <RETURN <REST .L>>)>
+ <COND (<AND <NOT <EMPTY? <SET DL <DEATH-LIST .V>>>>
+ <NOT <2 <CHTYPE <TYPE-INFO <1 .DL>> LIST>>>>
+ <SET LP <REST <PUTREST .LP ((.V .DL))>>>)>
+ <SET V <NEXT-SYM .V>>>>
+
+<DEFINE MSAVE-L-D-STATE (L V)
+ #DECL ((V) <OR VECTOR SYMTAB> (L) LIST)
+ <REPEAT ((L (() !.L)) (LR .L) (LP <REST .L>) DL S TEM)
+ #DECL ((L LP LR TEM) LIST (S) SYMTAB (DL) <LIST [REST NODE]>)
+ <COND (<EMPTY? .LP>
+ <PUTREST .L <SAVE-L-D-STATE .V>>
+ <RETURN <REST .LR>>)
+ (<TYPE? .V VECTOR> <RETURN <REST .LR>>)
+ (<AND <NOT <EMPTY? <SET DL <DEATH-LIST .V>>>>
+ <NOT <2 <TYPE-INFO <1 .DL>>>>>
+ <COND (<==? <SET S <1 <1 .LP>>> .V>
+ <SET TEM <LMERGE <2 <1 .LP>> .DL>>
+ <COND (<EMPTY? .TEM>
+ <PUTREST .L <SET LP <REST .LP>>>)
+ (ELSE
+ <PUT <1 .LP> 2 .TEM>
+ <SET LP <REST <SET L .LP>>>)>)
+ (ELSE
+ <PUTREST .L <SET L ((.V .DL))>>
+ <PUTREST .L .LP>)>)
+ (<==? .V <1 <1 .LP>>> <SET LP <REST <SET L .LP>>>)>
+ <SET V <NEXT-SYM .V>>>>
+
+<DEFINE LMERGE (L1 L2)
+ #DECL ((L1 L2) <LIST [REST NODE]>)
+ <SET L1
+ <MAPF ,LIST
+ <FUNCTION (N)
+ <COND (<OR <2 <TYPE-INFO .N>>
+ <AND <==? <NODE-TYPE .N> ,SET-CODE>
+ <NOT <MEMQ .N .L2>>>>
+ <MAPRET>)>
+ .N>
+ .L1>>
+ <SET L2
+ <MAPF ,LIST
+ <FUNCTION (N)
+ <COND (<OR <2 <TYPE-INFO .N>>
+ <==? <NODE-TYPE .N> ,SET-CODE>
+ <MEMQ .N .L1>>
+ <MAPRET>)>
+ .N>
+ .L2>>
+ <COND (<EMPTY? .L1> .L2)
+ (ELSE <PUTREST <REST .L1 <- <LENGTH .L1> 1>> .L2> .L1)>>
+
+<DEFINE MAKE-DEAD (N SYM) #DECL ((N) NODE (SYM) SYMTAB)
+ <PUT .SYM ,DEATH-LIST (.N)>>
+
+<DEFINE KILL-REM (L V)
+ #DECL ((L) <LIST [REST SYMTAB]> (V) <OR SYMTAB VECTOR>)
+ <REPEAT ((L1 ()))
+ #DECL ((L1) LIST)
+ <COND (<TYPE? .V VECTOR> <RETURN .L1>)>
+ <COND (<AND <NOT <SPEC-SYM .V>>
+ <N==? <CODE-SYM .V> -1>
+ <MEMQ .V .L>>
+ <SET L1 (.V !.L1)>)>
+ <SET V <NEXT-SYM .V>>>>
+
+<DEFINE SAVE-SURVIVORS (LS LI "OPTIONAL" (FLG <>))
+ #DECL ((LS) <LIST [REST <LIST SYMTAB LIST>]> (LI) <LIST [REST SYMTAB]>)
+ <MAPF <>
+ <FUNCTION (LL)
+ <COND (<MEMQ <1 .LL> .LI>
+ <MAPF <>
+ <FUNCTION (N)
+ #DECL ((N) NODE)
+ <PUT <TYPE-INFO .N> 2 T>>
+ <2 .LL>>)
+ (.FLG <PUT <1 .LL> ,DEATH-LIST <2 .LL>>)>>
+ .LS>>
+
+<DEFINE REVIVE (NOD SYM "AUX" (L <DEATH-LIST .SYM>))
+ #DECL ((L) <LIST [REST NODE]> (SYM) SYMTAB (NOD) NODE)
+ <COND (<AND <NOT <SPEC-SYM .SYM>> <N==? <CODE-SYM .SYM> -1>>
+ <COND (<EMPTY? .L> <SET LIFE (.SYM !.LIFE)>)
+ (ELSE
+ <MAPF <> <FUNCTION (N) #DECL ((N) NODE) <PUT <TYPE-INFO .N> 2 T>>
+ ;"Temporary kludge."
+ .L>)>
+ <PUT .SYM ,DEATH-LIST (.NOD)>
+ <PUT .NOD ,TYPE-INFO (<> <>)>)>>
+
+" Ananlyze a FORM that could really be an NTH."
+
+<DEFINE FORM-F-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (OBJ <NODE-NAME .NOD>) TYP)
+ #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
+ <COND (<==? <ISTYPE? <SET TYP <ANA <1 .K> APPLICABLE>>> FIX>
+ <PUT .NOD ,KIDS (<2 .K> <1 .K> !<REST .K 2>)>
+ <COND (<==? <LENGTH .K> 2>
+ <SET RTYP <NTH-REST-ANA .NOD .RTYP ,NTH-CODE .TYP>>)
+ (ELSE
+ <SET RTYP <PUT-ANA .NOD .RTYP ,PUT-CODE .TYP>>)>
+ <PUT .NOD ,NODE-SUBR <NODE-TYPE .NOD>>
+ <PUT .NOD ,KIDS .K>
+ <PUT .NOD ,NODE-NAME .OBJ>
+ <PUT .NOD ,NODE-TYPE ,FORM-F-CODE>
+ .RTYP)
+ (ELSE
+ <SPECIALIZE <NODE-NAME .NOD>>
+ <SPEC-FLUSH>
+ <PUT-FLUSH ALL>
+ <PUT .NOD ,SIDE-EFFECTS (ALL)>
+ <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>)>>
+
+" Further analyze a FORM."
+
+<DEFINE FORM-AN (NOD RTYP)
+ #DECL ((NOD) NODE)
+ <APPLY <OR <GET <NODE-SUBR .NOD> ANALYSIS>
+ <GET <TYPE <NODE-SUBR .NOD>> TANALYSIS>
+ <FUNCTION (N R)
+ #DECL ((N) NODE)
+ <SPEC-FLUSH>
+ <PUT-FLUSH ALL>
+ <PUT .N ,SIDE-EFFECTS (ALL)>
+ <TYPE-OK? <RESULT-TYPE .N> .R>>>
+ .NOD
+ .RTYP>>
+
+"Determine if an ATOM is mainfest."
+
+<DEFINE MANIFESTQ (ATM)
+ #DECL ((ATM) ATOM)
+ <AND <MANIFEST? .ATM>
+ <GASSIGNED? .ATM>
+ <NOT <TYPE? ,.ATM SUBR>>
+ <NOT <TYPE? ,.ATM RSUBR>>>>
+
+" Search for a decl associated with a local value."
+
+<DEFINE SRCH-SYM (ATM "AUX" (TB .VARTBL))
+ #DECL ((ATM) ATOM (TB) <PRIMTYPE VECTOR>)
+ <REPEAT ()
+ <AND <EMPTY? .TB> <RETURN <>>>
+ <AND <==? .ATM <NAME-SYM .TB>> <RETURN .TB>>
+ <SET TB <NEXT-SYM .TB>>>>
+
+" Here to flush decls of specials for an external function call."
+
+<DEFINE SPEC-FLUSH () <FLUSHER <>>>
+
+" Here to flush decls when a PUT, PUTREST or external call happens."
+
+<DEFINE PUT-FLUSH (TYP) <FLUSHER .TYP>>
+
+<DEFINE FLUSHER (FLSFLG "AUX" (V .VARTBL))
+ #DECL ((SYM) SYMTAB (V) <OR SYMTAB VECTOR>)
+ <COND
+ (.ANALY-OK
+ <REPEAT (SYM TEM)
+ #DECL ((SYM) SYMTAB)
+ <COND
+ (<AND <CURRENT-TYPE <SET SYM .V>>
+ <OR <AND <SPEC-SYM .SYM> <NOT .FLSFLG>>
+ <AND .FLSFLG
+ <N==? <CURRENT-TYPE .V> NO-RETURN>
+ <TYPE-OK? <CURRENT-TYPE .V> STRUCTURED>
+ <OR <==? .FLSFLG ALL>
+ <NOT <SET TEM <STRUCTYP <CURRENT-TYPE .V>>>>
+ <==? .TEM .FLSFLG>>>>>
+ <SET-CURRENT-TYPE
+ .SYM <FLUSH-FIX-TYPE .SYM <CURRENT-TYPE .SYM> .FLSFLG>>)>
+ <COND (<==? <USAGE-SYM .SYM> 0> <PUT .SYM ,USAGE-SYM <>>)>
+ <COND (<EMPTY? <SET V <NEXT-SYM .V>>> <RETURN>)>>)
+ (ELSE
+ <REPEAT (SYM)
+ #DECL ((SYM) SYMTAB)
+ <COND (<==? <USAGE-SYM <SET SYM .V>> 0> <PUT .SYM ,USAGE-SYM <>>)>
+ <COND (<EMPTY? <SET V <NEXT-SYM .V>>> <RETURN>)>>)>>
+
+<DEFINE FLUSH-FIX-TYPE (SYM TY FLG "AUX" TEM)
+ #DECL ((SYM) SYMTAB)
+ <OR <AND .FLG
+ <SET TEM <TOP-TYPE <TYPE-OK? .TY STRUCTURED>>>
+ <TYPE-OK? <COND (<SET TY <TYPE-OK? .TY '<NOT STRUCTURED>>>
+ <TYPE-MERGE .TEM .TY>)
+ (ELSE .TEM)>
+ <1 <DECL-SYM .SYM>>>>
+ <1 <DECL-SYM .SYM>>>>
+
+
+" Punt forms with segments in them."
+
+<DEFINE SEGFLUSH (NOD RTYP)
+ #DECL ((NOD) NODE (L) <LIST [REST NODE]>)
+ <COND (<REPEAT ((L <KIDS .NOD>))
+ <AND <EMPTY? .L> <RETURN <>>>
+ <AND <==? <NODE-TYPE <1 .L>> ,SEGMENT-CODE> <RETURN T>>
+ <SET L <REST .L>>>
+ <COND (.VERBOSE
+ <ADDVMESS .NOD
+ ("Not open compiled due to SEGMENT.")>)>
+ <SUBR-C-AN .NOD .RTYP>)>>
+
+" STACKFORM analyzer."
+
+<DEFINE STACKFORM-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) TEM STFTYP TT)
+ #DECL ((NOD TT) NODE (K) <LIST [REST NODE]>)
+ <MESSAGE WARNING "STACKFORM IS HAZARDOUS TO YOUR CODE!">
+ <PUT .NOD ,NODE-TYPE ,STACKFORM-CODE>
+ <ARGCHK <LENGTH .K> 3 STACKFORM>
+ <ANA <SET TT <1 .K>> ANY>
+ <SET STFTYP <APPLTYP .TT>>
+ <ANA <2 .K> ANY>
+ <SET TEM <ANA <3 .K> ANY>>
+ <OR <TYPE-OK? .TEM FALSE>
+ <MESSAGE WARNING " STACKFORM CAN'T STOP " .NOD>>
+ <PUT .NOD ,SIDE-EFFECTS (ALL)>
+ <PUT-FLUSH ALL>
+ <SPEC-FLUSH>
+ <TYPE-OK? .STFTYP .RTYP>>
+
+<PUT ,STACKFORM ANALYSIS ,STACKFORM-ANA>
+
+" Determine if the arg to STACKFORM is a SUBR."
+
+<DEFINE APPLTYP (NOD "AUX" (NT <NODE-TYPE .NOD>) ATM TT)
+ #DECL ((ATM) ATOM (NOD TT) NODE (NT) FIX)
+ <COND (<==? .NT ,GVAL-CODE> ;"<STACKFORM ,FOO ..."
+ <COND (<AND <==? <NODE-TYPE <SET TT <1 <KIDS .NOD>>>>
+ ,QUOTE-CODE>
+ <GASSIGNED? <SET ATM <NODE-NAME .TT>>>
+ <TYPE? ,.ATM SUBR>>
+ <SUBR-TYPE ,.ATM>)
+ (ELSE ANY)>)
+ (ELSE ANY) ;"MAY TRY OTHERS LATER ">>
+
+" Return type returned by a SUBR."
+
+<DEFINE SUBR-TYPE (SUB "AUX" TMP)
+ #DECL ((SUB) SUBR)
+ <SET TMP <2 <GET-TMP .SUB>>>
+ <COND (<TYPE? .TMP ATOM FORM> .TMP) (ELSE ANY)>>
+
+" Access the SUBR data base for return type."
+
+<DEFINE GET-TMP (SUB "AUX" (LS <MEMQ .SUB ,SUBRS>))
+ #DECL ((VALUE) <LIST ANY ANY>)
+ <COND (.LS <NTH ,TEMPLATES <LENGTH .LS>>)
+ (ELSE '(ANY ANY))>>
+
+" GVAL analyzer."
+
+<DEFINE GVAL-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM TT TEM1)
+ #DECL ((NOD TEM) NODE (TT) <VECTOR VECTOR ATOM ANY> (LN) FIX)
+ <COND (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <ARGCHK .LN 1 GVAL>
+ <PUT .NOD ,NODE-TYPE ,FGVAL-CODE>
+ <EANA <1 .K> ATOM GVAL>
+ <COND (<AND <==? <NODE-TYPE <SET TEM <1 .K>>> ,QUOTE-CODE>
+ <==? <RESULT-TYPE .TEM> ATOM>>
+ <PUT .NOD ,NODE-TYPE ,GVAL-CODE>
+ <COND (<MANIFEST? <SET TEM1 <NODE-NAME .TEM>>>
+ <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
+ <PUT .NOD ,NODE-NAME ,.TEM1>
+ <PUT .NOD ,KIDS ()>
+ <TYPE-OK? <GEN-DECL ,.TEM1> .RTYP>)
+ (<AND <GBOUND? .TEM1> <SET TEM1 <GET-DECL <GLOC .TEM1>>>>
+ <TYPE-OK? .TEM .RTYP>)
+ (ELSE <TYPE-OK? ANY .RTYP>)>)
+ (ELSE <TYPE-OK? ANY .RTYP>)>)>>
+
+<PUT ,GVAL ANALYSIS ,GVAL-ANA>
+
+" Analyze SETG usage."
+
+<DEFINE SETG-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM TT T1 TTT)
+ #DECL ((NOD TEM) NODE (K) <LIST [REST NODE]> (LN) FIX (TT) VECTOR)
+ <COND (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <ARGCHK .LN 2 SETG>
+ <PUT .NOD ,NODE-TYPE ,FSETG-CODE>
+ <EANA <SET TEM <1 .K>> ATOM SETG>
+ <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
+ <COND (<==? <NODE-TYPE .TEM> ,QUOTE-CODE>
+ <AND <MANIFEST? <SET TTT <NODE-NAME .TEM>>>
+ <MESSAGE WARNING
+ "ATTEMPT TO SETG MANIFEST VARIABLE "
+ .TTT .NOD>>
+ <PUT .NOD ,NODE-TYPE ,SETG-CODE>
+ <COND (<AND <GBOUND? .TTT>
+ <SET T1 <GET-DECL <GLOC .TTT>>>>
+ <OR <ANA <2 .K> .T1>
+ <MESSAGE ERROR
+ " GLOBAL DECL VIOLATION "
+ .TTT .NOD>>
+ <TYPE-OK? .T1 .RTYP>)
+ (ELSE
+ <SET TTT <ANA <2 .K> ANY>>
+ <TYPE-OK? .TTT .RTYP>)>)
+ (ELSE
+ <SET TTT <ANA <2 .K> ANY>>
+ <TYPE-OK? .TTT .RTYP>)>)>>>
+
+<PUT ,SETG ANALYSIS ,SETG-ANA>
+
+<DEFINE BUILD-TYPE-LIST (V)
+ #DECL ((V) <OR VECTOR SYMTAB> (VALUE) LIST)
+ <COND (.ANALY-OK
+ <REPEAT ((L (())) (LP .L) TEM)
+ #DECL ((L LP) LIST)
+ <COND (<EMPTY? .V> <RETURN <REST .L>>)
+ (<N==? <CODE-SYM .V> -1>
+ <SET TEM <GET-CURRENT-TYPE .V>>
+ <SET LP <REST <PUTREST .LP ((.V .TEM T))>>>)>
+ <SET V <NEXT-SYM .V>>>) (ELSE ())>>
+
+<DEFINE RESET-VARS (V "OPTIONAL" (VL '[]) (FLG <>))
+ #DECL ((V VL) <OR SYMTAB VECTOR>)
+ <REPEAT ()
+ <COND (<==? .V .VL> <SET FLG T>)>
+ <COND (<EMPTY? .V> <RETURN>)
+ (<NOT .FLG>
+ <PUT .V ,CURRENT-TYPE <>>
+ <PUT .V ,COMPOSIT-TYPE ANY>)>
+ <PUT .V ,USAGE-SYM 0>
+ <PUT .V ,DEATH-LIST ()>
+ <SET V <NEXT-SYM .V>>>>
+
+<DEFINE GET-CURRENT-TYPE (SYM)
+ #DECL ((SYM) SYMTAB)
+ <OR <AND .ANALY-OK <CURRENT-TYPE .SYM>> <1 <DECL-SYM .SYM>>>>
+
+<DEFINE SET-CURRENT-TYPE (SYM ITYP "AUX" (OTYP <1 <DECL-SYM .SYM>>))
+ #DECL ((SYM) SYMTAB)
+ <COND (<AND .ANALY-OK
+ <N==? <CODE-SYM .SYM> -1>
+ <NOT <SAME-DECL? <TYPE-AND .ITYP .OTYP> .OTYP>>>
+ <PUT .SYM ,CURRENT-TYPE .ITYP>
+ <PUT .SYM
+ ,COMPOSIT-TYPE
+ <TYPE-MERGE .ITYP <COMPOSIT-TYPE .SYM>>>)
+ (ELSE
+ <PUT .SYM ,CURRENT-TYPE <>>
+ <PUT .SYM ,COMPOSIT-TYPE .OTYP>)>>
+
+<DEFINE ANDUPC (V L)
+ #DECL ((V) <OR VECTOR SYMTAB> (L) <LIST [REST <LIST SYMTAB ANY ANY>]>)
+ <REPEAT ()
+ <COND (<EMPTY? .V> <RETURN>)>
+ <COND (<CURRENT-TYPE .V>
+ <SET L <ADD-TYPE-LIST .V <CURRENT-TYPE .V> .L T>>)>
+ <SET V <NEXT-SYM .V>>>
+ .L>
+
+<DEFINE ANDUP (FROM TO)
+ #DECL ((TO FROM) <LIST [REST <LIST SYMTAB ANY ANY>]>)
+ <MAPF <>
+ <FUNCTION (L) <SET TO <ADD-TYPE-LIST <1 .L> <2 .L> .TO T>>>
+ .FROM>
+ .TO>
+
+<DEFINE ORUPC (V L "AUX" WIN)
+ #DECL ((V) <OR VECTOR SYMTAB> (L) <LIST [REST <LIST SYMTAB ANY ANY>]>)
+ <COND
+ (.ANALY-OK
+ <REPEAT ()
+ <COND (<TYPE? .V VECTOR> <RETURN>)>
+ <SET WIN <>>
+ <MAPF <>
+ <FUNCTION (LL) #DECL ((LL) <LIST SYMTAB <OR ATOM FORM SEGMENT> ANY>)
+ <COND (<==? <1 .LL> .V>
+ <PUT .LL 2 <TYPE-MERGE <2 .LL> <GET-CURRENT-TYPE .V>>>
+ <PUT .LL 3 T>
+ <MAPLEAVE <SET WIN T>>)>>
+ .L>
+ <COND (<AND <NOT .WIN>
+ <CURRENT-TYPE .V>>
+ <SET L ((.V <1 <DECL-SYM .V>> T) !.L)>)>
+ <SET V <NEXT-SYM .V>>>)>
+ .L>
+
+<DEFINE ORUP (FROM TO "AUX" NDECL)
+ #DECL ((TO FROM) <LIST [REST <LIST SYMTAB <OR ATOM FORM SEGMENT> <OR ATOM FALSE>>]>
+ (NDECL) <OR ATOM FORM SEGMENT>)
+ <MAPF <>
+ <FUNCTION (L "AUX" (SYM <1 .L>) (WIN <>))
+ <MAPF <>
+ <FUNCTION (LL)
+ <COND (<==? <1 .LL> .SYM>
+ <SET NDECL <TYPE-MERGE <2 .LL> <2 .L>>>
+ <PUT .LL 2 .NDECL>
+ <PUT .LL 3 <3 .LL>>
+ <MAPLEAVE <SET WIN T>>)>>
+ .TO>
+ <COND (<NOT .WIN>
+ <SET TO
+ ((.SYM
+ <TYPE-MERGE <GET-CURRENT-TYPE .SYM> <2 .L>>
+ <3 .L>)
+ !.TO)>)>>
+ .FROM>
+ .TO>
+
+<DEFINE ASSERT-TYPES (L)
+ #DECL ((L) <LIST [REST <LIST SYMTAB ANY ANY>]>)
+ <MAPF <>
+ <FUNCTION (LL) <SET-CURRENT-TYPE <1 .LL> <2 .LL>>>
+ .L>>
+
+<DEFINE ADD-TYPE-LIST (SYM NDECL INF MUNG
+ "OPTIONAL" (NTH-REST ())
+ "AUX" (WIN <>) (OD <GET-CURRENT-TYPE .SYM>))
+ #DECL ((SYM) SYMTAB (INF) LIST (NTH-REST) <LIST [REST ATOM FIX]>
+ (NDECL) <OR ATOM FALSE FORM SEGMENT> (MUNG) <OR ATOM FALSE>)
+ <COND (.ANALY-OK
+ <SET NDECL <TYPE-NTH-REST .NDECL .NTH-REST>>
+ <MAPF <>
+ <FUNCTION (L)
+ #DECL ((L) <LIST SYMTAB ANY>)
+ <COND (<==? <1 .L> .SYM>
+ <SET NDECL
+ <COND (.MUNG <TYPE-AND .NDECL .OD>)
+ (ELSE <TYPE-AND .NDECL <2 .L>>)>>
+ <PUT .L 2 .NDECL>
+ <PUT .L 3 .MUNG>
+ <MAPLEAVE <SET WIN T>>)>>
+ .INF>
+ <COND (<NOT .WIN>
+ <SET NDECL <TYPE-AND .NDECL .OD>>
+ <SET INF ((.SYM .NDECL .MUNG) !.INF)>)>)>
+ .INF>
+
+<DEFINE TYPE-NTH-REST (NDECL NTH-REST) #DECL ((NTH-REST) <LIST [REST ATOM FIX]>)
+ <REPEAT ((FIRST T) (NUM 0))
+ #DECL ((NUM) FIX)
+ <COND (<EMPTY? .NTH-REST> <RETURN .NDECL>)>
+ <COND (<==? <1 .NTH-REST> NTH>
+ <SET NDECL
+ <FORM STRUCTURED
+ !<COND (<0? <SET NUM
+ <+ .NUM <2 .NTH-REST> -1>>>
+ ())
+ (<1? .NUM> (ANY))
+ (ELSE ([.NUM ANY]))>
+ .NDECL>>
+ <SET NUM 0>
+ <SET FIRST <>>)
+ (.FIRST <SET NDECL <REST-DECL .NDECL <2 .NTH-REST>>>)
+ (ELSE <SET NUM <+ .NUM <2 .NTH-REST>>>)>
+ <SET NTH-REST <REST .NTH-REST 2>>>>
+
+" AND/OR analyzer. Called from AND-ANA and OR-ANA."
+
+<DEFINE BOOL-AN (NOD RTYP ORER
+ "AUX" (L <KIDS .NOD>) FTYP FTY
+ (RTY
+ <COND (<TYPE-OK? .RTYP FALSE> .RTYP)
+ (ELSE <FORM OR .RTYP FALSE>)>)
+ (FLG <==? .PRED <PARENT .NOD>>) (SINF ()) STR SUNT
+ (FIRST T) FNOK NFNOK PASS)
+ #DECL ((NOD) NODE (L) <LIST [REST NODE]> (ORER RTYP) ANY (FTYP) FORM
+ (STR SINF SUNT) LIST)
+ <PROG ((TRUTH ()) (UNTRUTH ()) (PRED .NOD) L-D)
+ #DECL ((TRUTH UNTRUTH) <SPECIAL LIST> (PRED) <SPECIAL ANY> (L-D) LIST)
+ <COND
+ (<EMPTY? .L> <SET FTYP <TYPE-OK? FALSE .RTYP>>)
+ (ELSE
+ <SET FTY
+ <MAPR ,TYPE-MERGE
+ <FUNCTION (N
+ "AUX" (LAST <EMPTY? <REST .N>>) TY)
+ #DECL ((N) <LIST NODE>)
+ <COND (<AND .LAST <NOT .FLG>> <SET PRED <>>)>
+ <SET TY <ANA <1 .N> <COND (.LAST .RTYP) (.ORER .RTY) (ELSE ANY)>>>
+ <SET FNOK
+ <OR <==? .TY NO-RETURN> <NOT <TYPE-OK? .TY FALSE>>>>
+ <SET NFNOK <==? FALSE <ISTYPE? .TY>>>
+ <SET PASS <COND (.ORER .NFNOK) (ELSE .FNOK)>>
+ <COND (<NOT .TY>
+ <SET TY ANY>
+ <MESSAGE WARNING " OR/AND MAY RETURN WRONG TYPE " <1 .N>>)>
+ <COND (<COND (.ORER .FNOK) (ELSE .NFNOK)>
+ ;"This must end the AND/OR"
+ <COND (<AND .VERBOSE <NOT .LAST>>
+ <ADDVMESS .NOD
+ ("This object prematurely ends AND/OR: "
+ <1 .N> " its type is: " .TY)>)>
+ <SET LAST T>)>
+ <COND (<AND <N==? .TY NO-RETURN> <OR .LAST <NOT .PASS>>>
+ <COND (.FIRST
+ <SET L-D <SAVE-L-D-STATE .VARTBL>>
+ <SET SINF
+ <ANDUP <COND (.ORER .TRUTH) (ELSE .UNTRUTH)>
+ <BUILD-TYPE-LIST .VARTBL>>>)
+ (ELSE
+ <SET L-D <MSAVE-L-D-STATE .L-D .VARTBL>>
+ <SET SINF
+ <ORUP <COND (.ORER .TRUTH) (ELSE .UNTRUTH)>
+ <ORUPC .VARTBL .SINF>>>)>
+ <SET FIRST <>>)>
+ <ASSERT-TYPES <COND (.ORER .UNTRUTH) (ELSE .TRUTH)>>
+ <SET TRUTH <SET UNTRUTH ()>>
+ <OR .FIRST <RESTORE-L-D-STATE .L-D .VARTBL>>
+ <COND (<==? .TY NO-RETURN>
+ <OR .LAST
+ <MESSAGE WARNING
+ "UNREACHABLE AND/OR CLAUSE "
+ <1 .N>>>
+ <SET FLG <>>
+ <ASSERT-TYPES .SINF>
+ <MAPSTOP NO-RETURN>)
+ (.LAST
+ <COND (.FLG
+ <SET STR
+ <COND (.ORER .SINF)
+ (ELSE <BUILD-TYPE-LIST .VARTBL>)>>
+ <SET SUNT
+ <COND (.ORER <BUILD-TYPE-LIST .VARTBL>)
+ (ELSE .SINF)>>)>
+ <ASSERT-TYPES <ORUPC .VARTBL .SINF>>
+ <MAPSTOP .TY>)
+ (<AND .ORER .NFNOK> <MAPRET>)
+ (.ORER .TY)
+ (.FNOK <MAPRET>)
+ (ELSE FALSE)>>
+ .L>>
+ <COND (<AND .FNOK .ORER> <SET FTY <TYPE-OK? .FTY '<NOT FALSE>>>)>)>>
+ <COND (.FLG <SET TRUTH .STR> <SET UNTRUTH .SUNT>)>
+ .FTY>
+
+<DEFINE AND-ANA (NOD RTYP)
+ #DECL ((NOD) NODE)
+ <PUT .NOD ,NODE-TYPE ,AND-CODE>
+ <BOOL-AN .NOD .RTYP <>>>
+
+<PUT ,AND ANALYSIS ,AND-ANA>
+
+<DEFINE OR-ANA (NOD RTYP)
+ #DECL ((NOD) NODE)
+ <PUT .NOD ,NODE-TYPE ,OR-CODE>
+ <BOOL-AN .NOD .RTYP T>>
+
+<PUT ,OR ANALYSIS ,OR-ANA>
+
+" COND analyzer."
+
+<DEFINE CASE-ANA (N R) <COND-CASE .N .R T>>
+
+<DEFINE COND-ANA (N R) <COND-CASE .N .R <>>>
+
+<DEFINE COND-CASE (NOD RTYP CASE?
+ "AUX" (L <KIDS .NOD>) (FIRST T) (LAST <>) TT FNOK NFNOK STR
+ SUNT (FIRST1 T) PRAT (DFLG <>) TST-TYP SVWHO)
+ #DECL ((NOD) NODE (L) <LIST [REST NODE]> (RTYP) ANY)
+ <PROG ((TRUTH ()) (UNTRUTH ()) (TINF1 ()) (TINF ()) L-D L-D1)
+ #DECL ((TRUTH UNTRUTH) <SPECIAL LIST> (TINF1 TINF L-D L-D1) LIST)
+ <COND
+ (<EMPTY? .L> <TYPE-OK? FALSE .RTYP>)
+ (ELSE
+ <COND (.CASE?
+ <SET PRAT <NODE-NAME <1 <KIDS <1 .L>>>>>
+ <PROG ((WHON .NOD) (WHO ()))
+ #DECL ((WHO) <SPECIAL LIST> (WHON) <SPECIAL NODE>)
+ <SET TST-TYP <EANA <2 .L> ANY CASE>>
+ <SET SVWHO .WHO>>
+ <SET L <REST .L 2>>)>
+ <SET TT
+ <MAPR ,TYPE-MERGE
+ <FUNCTION (BRN "AUX" (BR <1 .BRN>) (PRED .BR) (EC T))
+ #DECL ((BRN) <LIST NODE> (BR) NODE (PRED) <SPECIAL
+ <OR NODE FALSE>>)
+ <COND (<AND .CASE? <==? <NODE-TYPE .BR> ,QUOTE-CODE> <SET DFLG T>>
+ <MAPRET>)>
+ <OR <PREDIC .BR> <MESSAGE ERROR "EMPTY COND CLAUSE " .BR>>
+ <SET UNTRUTH <SET TRUTH ()>>
+ <SET LAST <EMPTY? <REST .BRN>>>
+ <SET TT
+ <COND (<NOT <EMPTY? <CLAUSES .BR>>> <SET EC <>> ANY)
+ (.LAST .RTYP)
+ (ELSE <TYPE-MERGE .RTYP FALSE>)>>
+ <SET TT
+ <COND (.CASE?
+ <SPEC-ANA <NODE-NAME <CHTYPE <PREDIC .BR> NODE>>
+ .PRAT
+ .TST-TYP
+ .TT
+ .DFLG
+ .BR
+ .SVWHO>)
+ (ELSE <ANA <PREDIC .BR> .TT>)>>
+ <SET DFLG <SET PRED <>>>
+ <SET FNOK <OR <==? .TT NO-RETURN> <NOT <TYPE-OK? .TT FALSE>>>>
+ <SET NFNOK <==? <ISTYPE? .TT> FALSE>>
+ <COND
+ (.VERBOSE
+ <COND
+ (.NFNOK
+ <ADDVMESS
+ .NOD
+ ("Cond predicate always FALSE: "
+ <PREDIC .BR>
+ !<COND (<EMPTY? <CLAUSES .BR>> ())
+ (ELSE (" and non-reachable code in clause."))>)>)>
+ <COND
+ (<AND .FNOK <NOT .LAST>>
+ <ADDVMESS
+ .NOD
+ ("Cond ended prematurely because predicate always true: "
+ <PREDIC .BR>
+ " type of value: "
+ .TT)>)>)>
+ <COND (<NOT <OR .FNOK <AND <NOT .LAST> .NFNOK>>>
+ <SET L-D <SAVE-L-D-STATE .VARTBL>>
+ <COND (.FIRST
+ <SET TINF <ANDUP .UNTRUTH <BUILD-TYPE-LIST .VARTBL>>>)
+ (ELSE
+ <SET TINF <ANDUP .UNTRUTH <ORUPC .VARTBL .TINF>>>)>
+ <ASSERT-TYPES .TRUTH>
+ <SET FIRST <>>)>
+ <COND (<NOT .NFNOK>
+ <OR .EC <SET TT <SEQ-AN <CLAUSES .BR> .RTYP>>>
+ <COND (<N==? .TT NO-RETURN>
+ <COND (.FIRST1
+ <SET TINF1 <BUILD-TYPE-LIST .VARTBL>>
+ <SET L-D1 <SAVE-L-D-STATE .VARTBL>>)
+ (ELSE
+ <SET TINF1 <ORUPC .VARTBL .TINF1>>
+ <SET L-D1 <MSAVE-L-D-STATE .L-D1 .VARTBL>>)>
+ <SET FIRST1 <>>)>
+ <OR .FIRST <RESTORE-L-D-STATE .L-D .VARTBL>>
+ <COND (.LAST
+ <AND <NOT .FNOK> <SET TT <TYPE-MERGE .TT FALSE>>>)
+ (.EC <SET TT <TYPE-OK? .TT '<NOT FALSE>>>)>)
+ (.NFNOK <SET TT FALSE>)>
+ <COND (<OR .LAST .FNOK>
+ <COND (.FNOK
+ <ASSERT-TYPES .TINF1>
+ <OR .FIRST1 <RESTORE-L-D-STATE .L-D1 .VARTBL>>)
+ (ELSE
+ <COND (.FIRST1
+ <ASSERT-TYPES .TINF>
+ <OR .FIRST <RESTORE-L-D-STATE .L-D .VARTBL>>)
+ (ELSE
+ <ASSERT-TYPES <ORUP .TINF .TINF1>>
+ <MRESTORE-L-D-STATE .L-D1 .L-D .VARTBL>)>)>
+ <MAPSTOP .TT>)
+ (ELSE <ASSERT-TYPES .TINF> .TT)>>
+ .L>>)>>
+ .TT>
+
+
+<DEFINE SPEC-ANA (CONST PRED-NAME OTYPE RTYP DFLG NOD WHO "AUX" TEM PAT)
+ #DECL ((NOD) NODE)
+ <SET PAT
+ <COND (<TYPE? .CONST LIST>
+ <COND (<==? .PRED-NAME ==?> <GEN-DECL <1 .CONST>>)
+ (<==? .PRED-NAME TYPE?> <TYPE-MERGE !.CONST>)
+ (ELSE
+ <MAPF ,TYPE-MERGE
+ <FUNCTION (X) <FORM PRIMTYPE .X>>
+ .CONST>)>)
+ (ELSE
+ <COND (<==? .PRED-NAME ==?> <GEN-DECL .CONST>)
+ (<==? .PRED-NAME TYPE?> .CONST)
+ (ELSE <FORM PRIMTYPE .CONST>)>)>>
+ <COND (.DFLG
+ <PUT .NOD ,RESULT-TYPE <SET TEM <TYPE-OK? ATOM .RTYP>>>
+ .TEM)
+ (ELSE
+ <COND (<AND <N==? .PRED-NAME ==?>
+ <N==? .OTYPE ANY>
+ <NOT <TYPE-OK? <FORM NOT .PAT> .OTYPE>>>
+ <SET TEM ATOM>)
+ (<TYPE-OK? .OTYPE .PAT> <SET TEM '<OR FALSE ATOM>>)
+ (ELSE <SET TEM FALSE>)>
+ <MAPF <>
+ <FUNCTION (L "AUX" (FLG <1 .L>) (SYM <2 .L>))
+ #DECL ((L) <LIST <OR ATOM FALSE> SYMTAB>
+ (SYM) SYMTAB)
+ <SET TRUTH
+ <ADD-TYPE-LIST .SYM
+ .PAT
+ .TRUTH
+ .FLG
+ <REST .L 2>>>
+ <OR <==? .TEM ATOM>
+ <SET UNTRUTH
+ <ADD-TYPE-LIST
+ .SYM
+ <FORM NOT .PAT>
+ .UNTRUTH
+ .FLG
+ <REST .L 2>>>>>
+ .WHO>
+ <PUT .NOD ,RESULT-TYPE <SET TEM <TYPE-OK? .TEM .RTYP>>>
+ .TEM)>>
+
+" PROG/REPEAT analyzer. Hacks bindings and sets up info for GO/RETURN/AGAIN
+ analyzers."
+
+<DEFINE PRG-REP-ANA (PPNOD PRTYP
+ "AUX" (OV .VARTBL) (VARTBL <SYMTAB .PPNOD>) TT L-D
+ (OPN <AND <ASSIGNED? PNOD> .PNOD>) PNOD)
+ #DECL ((PNOD) <SPECIAL NODE> (VARTBL) <SPECIAL SYMTAB> (OV) SYMTAB (L-D) LIST
+ (PPNOD) NODE)
+ <COND (<N==? <NODE-SUBR .PPNOD> ,BIND> <SET PNOD .PPNOD>)
+ (.OPN <SET PNOD .OPN>)>
+ <PROG ((TMPS 0) (HTMPS 0) (ACT? <ACTIV? <BINDING-STRUCTURE .PPNOD> T>))
+ #DECL ((TMPS HTMPS) <SPECIAL FIX>)
+ <BIND-AN <BINDING-STRUCTURE .PPNOD>>
+ <SET L-D <SAVE-L-D-STATE .VARTBL>>
+ <RESET-VARS .VARTBL .OV T>
+ <OR <SET PRTYP <TYPE-OK? .PRTYP <INIT-DECL-TYPE .PPNOD>>>
+ <MESSAGE ERROR "PROG RETURNS WRONG TYPE ">>
+ <PUT .PPNOD ,RESULT-TYPE .PRTYP>
+ <PROG ((STMPS .TMPS) (SHTMPS .HTMPS) (LL .LIFE) (OV .VERBOSE))
+ #DECL ((STMPS SHTMPS) FIX (LL LIFE) LIST)
+ <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
+ <MUNG-L-D-STATE .VARTBL>
+ <SET LIFE .LL>
+ <PUT .PPNOD ,AGND <>>
+ <PUT .PPNOD ,DEAD-VARS ()>
+ <PUT .PPNOD ,VSPCD ()>
+ <PUT .PPNOD ,LIVE-VARS ()>
+ <SET TMPS .STMPS>
+ <SET HTMPS .SHTMPS>
+ <PUT .PPNOD ,ASSUM <BUILD-TYPE-LIST .VARTBL>>
+ <PUT .PPNOD ,ACCUM-TYPE NO-RETURN>
+ <SET TT
+ <SEQ-AN <KIDS .PPNOD>
+ <COND (<N==? <NODE-SUBR .PPNOD> ,REPEAT> .PRTYP)
+ (ELSE ANY)>>>
+ <AND .ACT? <PROG ()
+ <SPEC-FLUSH>
+ <PUT-FLUSH ALL>>>
+ <OR <AND <N==? <NODE-SUBR .PPNOD> ,REPEAT> <NOT <AGND .PPNOD>>>
+ <ASSUM-OK?
+ <ASSUM .PPNOD>
+ <COND (<N==? <NODE-SUBR .PPNOD> ,REPEAT> <AGND .PPNOD>)
+ (<AGND .PPNOD>
+ <ORUPC .VARTBL <CHTYPE <AGND .PPNOD> LIST>>)
+ (ELSE <BUILD-TYPE-LIST .VARTBL>)>>
+ <AGAIN>>>
+ <COND (<==? <NODE-SUBR .PPNOD> ,REPEAT>
+ <COND (<AGND .PPNOD>
+ <PUT .PPNOD
+ ,LIVE-VARS
+ <MSAVE-L-D-STATE <LIVE-VARS .PPNOD> .VARTBL>>)
+ (ELSE <PUT .PPNOD ,LIVE-VARS <SAVE-L-D-STATE .VARTBL>>)>)>
+ <SAVE-SURVIVORS .L-D .LIFE T>
+ <SAVE-SURVIVORS <LIVE-VARS .PPNOD> .LIFE>
+ <OR .TT
+ <MESSAGE " ERROR PROG VALUE VIOLATES VALUE DECL OF "
+ .PRTYP
+ .PPNOD>>
+ <COND (<NOT <OR <==? .TT NO-RETURN> <==? <NODE-SUBR .PPNOD> ,REPEAT>>>
+ <PUT .PPNOD
+ ,DEAD-VARS
+ <MSAVE-L-D-STATE <DEAD-VARS .PPNOD> .VARTBL>>
+ <COND (<N==? <ACCUM-TYPE .PPNOD> NO-RETURN>
+ <ASSERT-TYPES <ORUPC .VARTBL <VSPCD .PPNOD>>>)>)
+ (<N==? <ACCUM-TYPE .PPNOD> NO-RETURN>
+ <ASSERT-TYPES <VSPCD .PPNOD>>)>
+ <FREST-L-D-STATE <DEAD-VARS .PPNOD>>
+ <SET LIFE <KILL-REM .LIFE .OV>>
+ <PUT .PPNOD
+ ,ACCUM-TYPE
+ <COND (.ACT? <PUT .PPNOD ,SIDE-EFFECTS (ALL)> .PRTYP)
+ (<==? <NODE-SUBR .PPNOD> ,REPEAT> <ACCUM-TYPE .PPNOD>)
+ (ELSE <TYPE-MERGE .TT <ACCUM-TYPE .PPNOD>>)>>>
+ <ACCUM-TYPE .PPNOD>>
+
+" Determine if assumptions made for this loop are still valid."
+
+<DEFINE ASSUM-OK? (AS TY "AUX" (OK? T))
+ #DECL ((TY AS) <LIST [REST <LIST SYMTAB ANY ANY>]>)
+ <COND
+ (.ANALY-OK
+ <MAPF <>
+ <FUNCTION (L "AUX" (SYM <1 .L>) (TT <>))
+ #DECL ((L) <LIST SYMTAB <OR ATOM FORM SEGMENT>>)
+ <COND
+ (<N==? <2 .L> ANY>
+ <MAPF <>
+ <FUNCTION (LL)
+ <COND (<AND <SET TT <==? <1 .LL> .SYM>>
+ <N=? <2 .L> <2 .LL>>
+ <OR <==? <2 .L> NO-RETURN>
+ <TYPE-OK? <2 .LL> <NOTIFY <2 .L>>>>>
+ <COND (.OK? <SET BACKTRACK <+ .BACKTRACK 1>>)>
+ <SET OK? <>>
+ <AND <GASSIGNED? DEBUGSW>
+ ,DEBUGSW
+ <PRIN1 <NAME-SYM .SYM>>
+ <PRINC " NOT OK current type: ">
+ <PRIN1 <2 .LL>>
+ <PRINC " assumed type: ">
+ <PRIN1 <2 .L>>
+ <TERPRI>>)>
+ <AND .TT
+ <PUT .L 2 <TYPE-MERGE <2 .LL> <2 .L>>>
+ <MAPLEAVE>>>
+ .TY>)>>
+ .AS>
+ <COND (<NOT .OK?> <ASSERT-TYPES .AS>)>)>
+ .OK?>
+
+<DEFINE NOTIFY (D)
+ <COND (<AND <TYPE? .D FORM> <==? <LENGTH .D> 2> <==? <1 .D> NOT>>
+ <2 .D>)
+ (ELSE <FORM NOT .D>)>>
+
+" Analyze RETURN from a PROG/REPEAT. Check with PROGs final type."
+
+<DEFINE RETURN-ANA (NOD RTYP "AUX" (TT <KIDS .NOD>) N (LN <LENGTH .TT>) TEM)
+ #DECL ((NOD) NODE (TT) <LIST [REST NODE]> (LN) FIX (N) <OR NODE FALSE>)
+ <COND (<G? .LN 2>
+ <MESSAGE ERROR "TOO MANY ARGS TO RETURN " .NOD>)
+ (<OR <AND <==? .LN 2> <SET N <ACT-CHECK <2 .TT>>>>
+ <AND <L=? .LN 1> <SET N <PROGCHK RETURN>>>>
+ <SET N <CHTYPE .N NODE>>
+ <AND <0? .LN>
+ <PUT .NOD
+ ,KIDS
+ <SET TT (<NODE1 ,QUOTE-CODE .NOD ATOM T ()>)>>>
+ <SET TEM <EANA <1 .TT> <INIT-DECL-TYPE .N> RETURN>>
+ <COND (<==? <ACCUM-TYPE .N> NO-RETURN>
+ <PUT .N ,VSPCD <BUILD-TYPE-LIST <SYMTAB .N>>>
+ <PUT .N ,DEAD-VARS <SAVE-L-D-STATE .VARTBL>>)
+ (ELSE
+ <PUT .N ,VSPCD <ORUPC <SYMTAB .N> <VSPCD .N>>>
+ <PUT .N
+ ,DEAD-VARS
+ <MSAVE-L-D-STATE <DEAD-VARS .N> .VARTBL>>)>
+ <PUT .N ,ACCUM-TYPE <TYPE-MERGE .TEM <ACCUM-TYPE .N>>>
+ <PUT .NOD ,NODE-TYPE ,RETURN-CODE>
+ NO-RETURN)
+ (ELSE <SUBR-C-AN .NOD ANY>)>>
+
+<PUT ,RETURN ANALYSIS ,RETURN-ANA>
+
+<DEFINE ACT-CHECK (N "AUX" SYM RAO N1)
+ #DECL ((N N1) NODE (SYM) <OR SYMTAB FALSE> (RAO VALUE) <OR FALSE NODE>)
+ <COND (<OR <AND <==? <NODE-TYPE .N> ,LVAL-CODE>
+ <TYPE? <NODE-NAME .N> SYMTAB>
+ <PURE-SYM <SET SYM <NODE-NAME .N>>>
+ <==? <CODE-SYM .SYM> 1>>
+ <AND <==? <NODE-TYPE .N> ,SUBR-CODE>
+ <==? <NODE-SUBR .N> ,LVAL>
+ <==? <LENGTH <KIDS .N>> 1>
+ <==? <NODE-TYPE <SET N1 <1 <KIDS .N>>>> ,QUOTE-CODE>
+ <TYPE? <NODE-NAME .N1> ATOM>
+ <SET SYM <SRCH-SYM <NODE-NAME .N1>>>
+ <PURE-SYM .SYM>
+ <==? <CODE-SYM .SYM> 1>>>
+ <SET RAO <RET-AGAIN-ONLY <CHTYPE .SYM SYMTAB>>>
+ <EANA .N ACTIVATION AGAIN-RETURN>
+ <PUT <CHTYPE .SYM SYMTAB> ,RET-AGAIN-ONLY .RAO>
+ .RAO)>>
+
+" AGAIN analyzer."
+
+<DEFINE AGAIN-ANA (NOD RTYP "AUX" (TEM <KIDS .NOD>) N)
+ #DECL ((NOD) NODE (TEM) <LIST [REST NODE]> (N) <OR FALSE NODE>)
+ <COND (<OR <AND <EMPTY? .TEM> <SET N <PROGCHK AGAIN>>>
+ <AND <EMPTY? <REST .TEM>> <SET N <ACT-CHECK <1 .TEM>>>>>
+ <PUT .NOD ,NODE-TYPE ,AGAIN-CODE>
+ <SET N <CHTYPE .N NODE>>
+ <COND (<AGND .N>
+ <PUT .N ,LIVE-VARS
+ <MSAVE-L-D-STATE <LIVE-VARS .N> .VARTBL>>)
+ (ELSE <PUT .N ,LIVE-VARS <SAVE-L-D-STATE .VARTBL>>)>
+ <PUT .N
+ ,AGND
+ <COND (<NOT <AGND .N>> <BUILD-TYPE-LIST <SYMTAB .N>>)
+ (ELSE <ORUPC <SYMTAB .N> <AGND .N>>)>>
+ NO-RETURN)
+ (<EMPTY? <REST .TEM>>
+ <OR <ANA <1 .TEM> ACTIVATION>
+ <MESSAGE ERROR "WRONG TYPE FOR AGAIN " .NOD>>
+ ANY)
+ (ELSE <MESSAGE ERROR "TOO MANY ARGS TO AGAIN " .NOD>)>>
+
+<PUT ,AGAIN ANALYSIS ,AGAIN-ANA>
+
+" Analyze losing GOs."
+
+<DEFINE GO-ANA (NOD RTYP "AUX" (TEM <KIDS .NOD>) N RT)
+ #DECL ((NOD N) NODE (TEM) <LIST [REST NODE]>)
+ <MESSAGE WARGINING "GO/TAG NOT REALLY SUPPORTED.">
+ <COND (<1? <LENGTH .TEM>>
+ <SET RT <EANA <SET N <1 .TEM>> '<OR TAG ATOM> GO>>
+ <COND (<OR <AND <==? <NODE-TYPE .N> ,QUOTE-CODE>
+ <==? .RT ATOM>
+ <PROGCHK GO>>
+ <==? .RT TAG>>
+ <AND <==? .RT ATOM> .ANALY-OK
+ <PROG () <SET ANALY-OK <>> <AGAIN .ANA-ACT>>>
+ <PUT .NOD ,NODE-TYPE ,GO-CODE> NO-RETURN)
+ (ELSE <MESSAGE ERROR "BAD ARG TO GO " .NOD>)>)
+ (ELSE <MESSAGE ERROR "WRONG NO. OF ARGS TO GO " .NOD>)>>
+
+<PUT ,GO ANALYSIS ,GO-ANA>
+
+<DEFINE TAG-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) N)
+ #DECL ((PNOD N NOD) NODE (K) <LIST [REST NODE]>)
+ <MESSAGE WARGINING "GO/TAG NOT REALLY SUPPORTED.">
+ <COND (<1? <LENGTH .K>>
+ <PROGCHK TAG>
+ <AND .ANALY-OK <PROG () <SET ANALY-OK <>> <AGAIN .ANA-ACT>>>
+ <PUT .PNOD ,ACTIVATED T>
+ <EANA <SET N <1 .K>> ATOM TAG>
+ <COND (<AND <==? <NODE-TYPE .N> ,QUOTE-CODE>
+ <==? <RESULT-TYPE .N> ATOM>>
+ <PUT .NOD ,NODE-TYPE ,TAG-CODE> TAG)
+ (ELSE <MESSAGE ERROR "BAD ARG TO TAG " .NOD>)>)>>
+
+<PUT ,TAG ANALYSIS ,TAG-ANA>
+
+" If not in PROG/REPEAT complain about NAME."
+
+<DEFINE PROGCHK (NAME)
+ <OR <ASSIGNED? PNOD>
+ <MESSAGE ERROR "NOT IN PROG/REPEAT " .NAME>>
+ .PNOD>
+
+" Dispatch to special handlers for SUBRs. Or use standard."
+
+<DEFINE SUBR-ANA (NOD RTYP)
+ #DECL ((NOD) NODE)
+ <APPLY <GET <NODE-SUBR .NOD> ANALYSIS ',SUBR-C-AN>
+ .NOD
+ .RTYP>>
+
+" Hairy SUBR call analyzer. Also looks for internal calls."
+
+<DEFINE SUBR-C-AN (NOD RTYP
+ "AUX" (ARGS 0) (TYP ANY)
+ (TMPL <GET-TMP <NODE-SUBR .NOD>>) (NRGS1 <1 .TMPL>)
+ (ARGACS
+ <COND (<AND <G? <LENGTH .TMPL> 4>
+ <NOT <==? <4 .TMPL> STACK>>>
+ <4 .TMPL>)>))
+ #DECL ((NOD) <SPECIAL NODE> (ARGS) <SPECIAL FIX>
+ (TYP NRGS1 ARGACS) <SPECIAL ANY> (TMPL) <SPECIAL LIST>)
+ <MAPF
+ <FUNCTION ("TUPLE" T "AUX" NARGS (TL <LENGTH .TMPL>) TEM (NARGS1 .NRGS1) (N .NOD)
+ (TPL .TMPL) (RGS .ARGS))
+ #DECL ((T) TUPLE (ARGS RGS TL) FIX
+ (TMPL TPL) <LIST ANY ANY [REST LIST ANY ANY ANY]> (N NOD) NODE
+ (NARGS) <LIST FIX FIX>)
+ <SET TYP <2 .TPL>>
+ <SPEC-FLUSH>
+ <PUT-FLUSH ALL>
+ <COND
+ (<SEGS .N>
+ <COND (<TYPE? .TYP ATOM FORM>) (ELSE <SET TYP ANY>)>
+ <COND (<AND <G? .TL 2> <NOT .ARGACS>>
+ <PUT .N ,NODE-TYPE ,ISUBR-CODE>)>)
+ (ELSE
+ <COND
+ (<TYPE? .NARGS1 FIX>
+ <ARGCHK .RGS .NARGS1 <NODE-NAME .N>>)
+ (<TYPE? .NARGS1 LIST>
+ <AND <G? .RGS <2 <SET NARGS .NARGS1>>>
+ <MESSAGE ERROR " TOO MANY ARGS TO " <NODE-NAME .N> .N>>
+ <AND <L? .RGS <1 .NARGS>>
+ <MESSAGE ERROR " TOO FEW ARGS TO " <NODE-NAME .N> .N>>
+ <AND <G? .TL 2>
+ <G? .RGS <+ <1 .NARGS> <LENGTH <3 .TPL>>>>
+ <SET TL 0>> ;"Dont handle funny calls to things like LLOC."
+ <COND (<AND <L? .RGS <2 .NARGS>> <G? .TL 2>>
+ ;"For funny cases like LLOC."
+ <SET TEM
+ <MAPF ,LIST
+ <FUNCTION (DEF)
+ <NODE1 ,QUOTE-CODE
+ .NOD
+ <TYPE .DEF>
+ .DEF
+ ()>>
+ <REST <3 .TPL> <- .RGS <1 .NARGS>>>>>
+ <SET RGS <2 .NARGS>>
+ <COND (<EMPTY? <KIDS .N>> <PUT .N ,KIDS .TEM>)
+ (ELSE
+ <PUTREST <REST <KIDS .N> <- <LENGTH <KIDS .N>> 1>>
+ .TEM>)>)>)>
+ <COND (<TYPE? .TYP ATOM FORM>)
+ (ELSE <SET TYP <APPLY .TYP !.T>>)>
+ <COND (<G? .TL 2> ;"Short call exists?."
+ <OR <==? <4 .TPL> STACK> <SET RGS 0>>
+ <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
+ <SET ARGS .RGS>)>>
+ <FUNCTION (N "AUX" TYP)
+ #DECL ((N NOD) NODE (ARGS) FIX (ARGACS) <PRIMTYPE LIST>)
+ <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE>
+ <EANA <1 <KIDS .N>> STRUCTURED SEGMENT>
+ <PUT .NOD ,SEGS T>
+ ANY)
+ (ELSE
+ <SET ARGS <+ .ARGS 1>>
+ <SET TYP <ANA .N ANY>>
+ <COND (<AND <NOT <SEGS .NOD>> .ARGACS <NOT <EMPTY? .ARGACS>>>
+ <SET ARGACS <REST .ARGACS>>)>
+ .TYP)>>
+ <KIDS .NOD>>
+ <PUT .NOD ,SIDE-EFFECTS (ALL)>
+ <PUT .NOD ,STACKS <* .ARGS 2>>
+ <TYPE-OK? .TYP .RTYP>>
+
+<DEFINE SEGMENT-ANA (NOD RTYP) <MESSAGE ERROR "ILLEGAL SEGMENT " .NOD>>
+
+" Analyze VECTOR, UVECTOR and LIST builders."
+
+<DEFINE COPY-AN (NOD RTYP
+ "AUX" (ARGS 0) (RT <ISTYPE? <RESULT-TYPE .NOD>>) (K <KIDS .NOD>) N
+ (LWIN <==? .RT LIST>) NN COD)
+ #DECL ((NOD N) NODE (ARGS) FIX (K) <LIST [REST NODE]>)
+ <COND
+ (<NOT <EMPTY? .K>>
+ <REPEAT (DC STY PTY TEM TT (SG <>) (FRM <FORM .RT>)
+ (FRME <CHTYPE .FRM LIST>) (GOTDC <>))
+ #DECL ((FRM) FORM (FRME) <LIST ANY>)
+ <COND (<EMPTY? .K>
+ <COND (<==? .RT LIST>
+ <RETURN <SET RT
+ <COND (<EMPTY? <REST .FRM>> <1 .FRM>)
+ (ELSE .FRM)>>>)>
+ <COND (.DC <PUTREST .FRME ([REST .DC])>)
+ (.STY <PUTREST .FRME ([REST .STY])>)
+ (.PTY <PUTREST .FRME ([REST <FORM PRIMTYPE .PTY>])>)>
+ <RETURN <SET RT .FRM>>)
+ (<OR <==? <SET COD <NODE-TYPE <SET N <1 .K>>>> ,SEGMENT-CODE>
+ <==? .COD ,SEG-CODE>>
+ <SET TEM
+ <GET-ELE-TYPE <EANA <1 <KIDS .N>> STRUCTURED SEGMENT>
+ ALL>>
+ <PUT .NOD ,SEGS T>
+ <COND (<NOT .SG> <SET GOTDC <>>)>
+ <SET SG T>
+ <COND (<AND .LWIN
+ <MEMQ <STRUCTYP <RESULT-TYPE <1 <KIDS .N>>>>
+ '![LIST VECTOR UVECTOR TUPLE!]>>)
+ (ELSE <SET LWIN <>>)>)
+ (ELSE <SET ARGS <+ .ARGS 2>> <SET TEM <ANA .N ANY>>)>
+ <COND (<NOT .GOTDC>
+ <SET GOTDC T>
+ <SET PTY
+ <COND (<SET STY <ISTYPE? <SET DC .TEM>>>
+ <TYPEPRIM .STY>)>>)
+ (<OR <NOT .DC> <N==? .DC .TEM>>
+ <SET DC <>>
+ <COND (<OR <N==? <SET TT <ISTYPE? .TEM>> .STY> <NOT .STY>>
+ <SET STY <>>
+ <COND (<AND .PTY
+ <==? .PTY <AND .TT <TYPEPRIM .TT>>>>)
+ (ELSE <SET PTY <>>)>)>)>
+ <COND (<NOT .SG> <SET FRME <REST <PUTREST .FRME (.TEM)>>>)>
+ <SET K <REST .K>>>)>
+ <PUT .NOD ,RESULT-TYPE .RT>
+ <PUT .NOD ,STACKS .ARGS>
+ <COND
+ (<AND <GASSIGNED? COPY-LIST-CODE> .LWIN>
+ <MAPF <>
+ <FUNCTION (N)
+ #DECL ((N) NODE)
+ <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE>
+ <PUT .N ,NODE-TYPE ,SEG-CODE>)>>
+ <KIDS .NOD>>
+ <COND (<AND <==? <LENGTH <SET K <KIDS .NOD>>> 1>
+ <==? <NODE-TYPE <1 .K>> ,SEG-CODE>
+ <==? <STRUCTYP <RESULT-TYPE <SET NN <1 <KIDS <1 .K>>>>>> LIST>>
+ <COND (<NOT <EMPTY? <PARENT .NOD>>>
+ <MAPR <>
+ <FUNCTION (L "AUX" (N <1 .L>))
+ #DECL ((N) NODE (L) <LIST [REST NODE]>)
+ <COND (<==? .NOD .N>
+ <PUT .L 1 .NN>
+ <MAPLEAVE>)>>
+ <KIDS <CHTYPE <PARENT .NOD> NODE>>>)>
+ <PUT .NN ,PARENT <CHTYPE <PARENT .NOD> NODE>>
+ <SET RT <RESULT-TYPE .NN>>)
+ (ELSE <PUT .NOD ,NODE-TYPE ,COPY-LIST-CODE>)>)
+ (ELSE
+ <MAPF <>
+ <FUNCTION (N)
+ #DECL ((N) NODE)
+ <COND (<==? <NODE-TYPE .N> ,SEG-CODE>
+ <PUT .N ,NODE-TYPE ,SEGMENT-CODE>)>>
+ <KIDS .NOD>>
+ <PUT .NOD ,NODE-TYPE ,COPY-CODE>)>
+ <TYPE-OK? .RT .RTYP>>
+
+" Analyze quoted objects, for structures hack type specs."
+
+<DEFINE QUOTE-ANA (NOD RTYP)
+ #DECL ((NOD) NODE)
+ <TYPE-OK? <GEN-DECL <NODE-NAME .NOD>> .RTYP>>
+
+<DEFINE QUOTE-ANA2 (NOD RTYP)
+ #DECL ((NOD) NODE)
+ <COND (<1? <LENGTH <KIDS .NOD>>>
+ <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
+ <PUT .NOD ,NODE-NAME <1 <KIDS .NOD>>>
+ <PUT .NOD ,KIDS ()>
+ <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>)
+ (ELSE <MESSAGE ERROR "BAD CALL TO QUOTE ">)>>
+
+<PUT ,QUOTE ANALYSIS ,QUOTE-ANA2>
+
+<DEFINE IRSUBR-ANA (NOD RTYP)
+ <RSUBRC-ANA .NOD .RTYP <>>>
+
+" Analyze a call to an RSUBR."
+
+<DEFINE RSUBR-ANA (NOD RTYP "AUX" ACST RN)
+ #DECL ((NOD RN FCN) NODE)
+ <COND (<AND <TYPE? <NODE-SUBR .NOD> FUNCTION>
+ <SET ACST <ACS <SET RN <GET <NODE-NAME .NOD> .IND>>>>
+ <OR <ASSIGNED? GROUP-NAME> <==? .FCN .RN>>>
+ <RSUBRC-ANA .NOD .RTYP .ACST>)
+ (ELSE <RSUBRC-ANA .NOD .RTYP <>>)>>
+
+<DEFINE RSUBRC-ANA (NOD RTYP ACST "AUX" (ARGS 0))
+ #DECL ((NOD N) NODE (ACST) <PRIMTYPE LIST> (ARGS) FIX)
+ <AND <=? .ACST '(STACK)> <SET ACST <>>>
+ <MAPF <>
+ <FUNCTION (ARG RT)
+ #DECL ((ARG NOD) NODE)
+ <COND (<==? <NODE-TYPE .ARG> ,SEGMENT-CODE>
+ <EANA <1 <KIDS .ARG>> .RT SEGMENT>
+ <PUT .NOD ,SEGS T>)
+ (ELSE
+ <EANA .ARG .RT <NODE-NAME .NOD>>
+ <COND (<AND <NOT <SEGS .NOD>> .ACST>
+ <SET ACST <REST .ACST>>)>
+ <SET ARGS <+ .ARGS 1>>)>>
+ <KIDS .NOD> <TYPE-INFO .NOD>>
+ <SPEC-FLUSH>
+ <PUT-FLUSH ALL>
+ <OR .ACST <PUT .NOD ,STACKS <* .ARGS 2>>>
+ <PUT .NOD ,SIDE-EFFECTS (ALL)>
+ <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>>
+
+" Analyze CHTYPE, in some cases do it at compile time."
+
+<DEFINE CHTYPE-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) NTN NT OBN OB)
+ #DECL ((NOD OBN NTN) NODE (K) <LIST [REST NODE]> (NT) ATOM)
+ <COND (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <ARGCHK <LENGTH .K> 2 CHTYPE>
+ <SET OB <ANA <SET OBN <1 .K>> ANY>>
+ <EANA <SET NTN <2 .K>> ATOM CHTYPE>
+ <COND (<==? <NODE-TYPE .NTN> ,QUOTE-CODE>
+ <OR <MEMQ <SET NT <NODE-NAME .NTN>> <ALLTYPES>>
+ <MESSAGE ERROR " 2D ARG CHTYPE NOT A TYPE " .NT .NOD>>
+ <OR <TYPE-OK? .OB <FORM PRIMTYPE <TYPEPRIM .NT>>>
+ <MESSAGE ERROR
+ " PRIMTYPES DIFFER CHTYPE"
+ .OB
+ .NT .NOD>>
+ <COND (<==? <NODE-TYPE .OBN> ,QUOTE-CODE>
+ <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
+ <PUT .NOD ,KIDS ()>
+ <PUT .NOD
+ ,NODE-NAME
+ <CHTYPE <NODE-NAME .OBN> .NT>>)
+ (ELSE <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>)>
+ <PUT .NOD ,RESULT-TYPE .NT>
+ <TYPE-OK? .NT .RTYP>)
+ (ELSE
+ <COND (.VERBOSE
+ <ADDVMESS .NOD
+ ("Can't open compile CHTYPE.")>)>
+ <TYPE-OK? ANY .RTYP>)>)>>
+
+<PUT ,CHTYPE ANALYSIS ,CHTYPE-ANA>
+
+" Analyze use of ASCII sometimes do at compile time."
+
+<DEFINE ASCII-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) ITM TYP TEM)
+ #DECL ((NOD ITM) NODE (K) <LIST [REST NODE]>)
+ <COND (<SEGFLUSH .NOD .RTYP>)
+ (ELSE
+ <ARGCHK <LENGTH .K> 1 ASCII>
+ <SET TYP <EANA <SET ITM <1 .K>> '<OR FIX CHARACTER> ASCII>>
+ <COND (<==? <NODE-TYPE .ITM> ,QUOTE-CODE>
+ <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
+ <PUT .NOD ,NODE-NAME <SET TEM <ASCII <NODE-NAME .ITM>>>>
+ <PUT .NOD ,RESULT-TYPE <TYPE .TEM>>
+ <PUT .NOD ,KIDS ()>)
+ (<==? <ISTYPE? .TYP> FIX>
+ <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>
+ <PUT .NOD ,RESULT-TYPE CHARACTER>)
+ (<==? .TYP CHARACTER>
+ <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>
+ <PUT .NOD ,RESULT-TYPE FIX>)
+ (ELSE
+ <PUT .NOD ,RESULT-TYPE '<OR FIX CHARACTER>>)>
+ <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>)>>
+
+<PUT ,ASCII ANALYSIS ,ASCII-ANA>
+
+<DEFINE UNWIND-ANA (NOD RTYP"AUX" (K <KIDS .NOD>) ITYP)
+ #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
+ <SET ITYP <EANA <1 .K> ANY UNWIND>>
+ <EANA <2 .K> ANY UNWIND>
+ <TYPE-OK? .ITYP .RTYP>>
+
+" Analyze ISTRING/ILIST/IVECTOR/IUVECTOR in cases of known and unknown last arg."
+
+<DEFINE ISTRUC-ANA (N R "AUX" (K <KIDS .N>) FM NUM TY (NEL REST) SIZ)
+ #DECL ((N FM NUM) NODE)
+ <COND (<==? <NODE-SUBR .N> ,IBYTES>
+ <EANA <1 .K> FIX <NODE-NAME .N>>
+ <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
+ <SET SIZ <NODE-NAME <1 .K>>>)>
+ <SET K <REST .K>>)>
+ <EANA <SET NUM <1 .K>> FIX <NODE-NAME .N>>
+ <SET TY
+ <EANA <SET FM <2 .K>>
+ <COND (<==? <NODE-NAME .FM> ISTRING> CHARACTER)
+ (<==? <NODE-NAME .FM> IBYTES> FIX)
+ (ELSE ANY)>
+ <NODE-NAME .N>>>
+ <COND (<TYPE-OK? .TY '<OR FORM LIST VECTOR UVECTOR>>
+ <MESSAGE WARNING "UNCERTAIN USE OF " <NODE-NAME .N> .N>
+ <SPEC-FLUSH>
+ <PUT-FLUSH ALL>)
+ (ELSE <PUT .N ,NODE-TYPE ,ISTRUC2-CODE>)>
+ <COND (<==? <NODE-TYPE .NUM> ,QUOTE-CODE> <SET NEL <NODE-NAME .NUM>>)>
+ <AND <TYPE-OK? .TY FORM> <SET TY ANY>>
+ <TYPE-OK? <COND (<==? <NODE-SUBR .N> ,IBYTES>
+ <COND (<ASSIGNED? SIZ>
+ <COND (<TYPE? .NEL FIX> <FORM BYTES .SIZ .NEL>)
+ (ELSE <FORM BYTES .SIZ>)>)
+ (ELSE BYTES)>)
+ (ELSE
+ <FORM <ISTYPE? <RESULT-TYPE .N>>
+ [.NEL .TY]
+ !<COND (<==? .TY ANY> ())
+ (ELSE ([REST .TY]))>>)>
+ .R>>
+
+<DEFINE ISTRUC2-ANA (N R "AUX" (K <KIDS .N>) GD NUM TY (NEL REST) SIZ)
+ #DECL ((N NUM GD) NODE)
+ <COND (<==? <NODE-SUBR .N> ,IBYTES>
+ <EANA <1 .K> FIX <NODE-NAME .N>>
+ <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
+ <SET SIZ <NODE-NAME <1 .K>>>)>
+ <SET K <REST .K>>)>
+ <EANA <SET NUM <1 .K>> FIX <NODE-NAME .N>>
+ <SET TY
+ <EANA <SET GD <2 .K>>
+ <COND (<==? <NODE-SUBR .N> ,ISTRING> CHARACTER)
+ (<==? <NODE-SUBR .N> ,IBYTES> FIX)
+ (ELSE ANY)>
+ <NODE-NAME .N>>>
+ <COND (<==? <NODE-TYPE .NUM> ,QUOTE-CODE> <SET NEL <NODE-NAME .NUM>>)>
+ <TYPE-OK? <COND (<==? <NODE-SUBR .N> ,IBYTES>
+ <COND (<ASSIGNED? SIZ>
+ <COND (<TYPE? .NEL FIX> <FORM BYTES .SIZ .NEL>)
+ (ELSE <FORM BYTES .SIZ>)>)
+ (ELSE BYTES)>)
+ (ELSE
+ <FORM <ISTYPE? <RESULT-TYPE .N>>
+ [.NEL .TY]
+ !<COND (<==? .TY ANY> ())
+ (ELSE ([REST .TY]))>>)>
+ .R>>
+
+" Analyze READ type SUBRS in two cases (print uncertain usage message maybe?)"
+
+<DEFINE READ-ANA (N R)
+ #DECL ((N) NODE)
+ <MAPF <>
+ <FUNCTION (NN "AUX" TY)
+ #DECL ((NN N) NODE)
+ <COND (<==? <NODE-TYPE .NN> ,EOF-CODE>
+ <SPEC-FLUSH> <PUT-FLUSH ALL>
+ <SET TY <EANAQ <1 <KIDS .NN>> ANY <NODE-NAME .N> .N>>
+ <COND (<TYPE-OK? .TY
+ '<OR FORM LIST VECTOR UVECTOR>>
+ <MESSAGE WARNING
+ " UNCERTAIN USE OF "
+ <NODE-NAME .N> .N>)
+ (ELSE <PUT .N ,NODE-TYPE ,READ-EOF2-CODE>)>)
+ (ELSE <EANA .NN ANY <NODE-NAME .N>>)>>
+ <KIDS .N>>
+ <SPEC-FLUSH><PUT-FLUSH ALL>
+ <TYPE-OK? ANY .R>>
+
+<DEFINE READ2-ANA (N R)
+ #DECL ((N) NODE)
+ <MAPF <>
+ <FUNCTION (NN)
+ #DECL ((NN N) NODE)
+ <COND (<==? <NODE-TYPE .NN> ,EOF-CODE>
+ <EANAQ <1 <KIDS .NN>> ANY <NODE-NAME .N> .N>)
+ (ELSE <EANA .NN ANY <NODE-NAME .N>>)>>
+ <KIDS .N>>
+ <SPEC-FLUSH><PUT-FLUSH ALL>
+ <TYPE-OK? ANY .R>>
+
+<DEFINE GET-ANA (N R "AUX" TY (K <KIDS .N>) (NAM <NODE-NAME .N>))
+ #DECL ((N) NODE (K) <LIST NODE NODE NODE>)
+ <EANA <1 .K> ANY .NAM>
+ <EANA <2 .K> ANY .NAM>
+ <SET TY <EANAQ <3 .K> ANY .NAM .N>>
+ <COND (<TYPE-OK? .TY '<OR LIST VECTOR UVECTOR FORM>>
+ <MESSAGE WARNING "UNCERTAIN USE OF " .NAM .N>
+ <SPEC-FLUSH> <PUT-FLUSH ALL>)
+ (ELSE <PUT .N ,NODE-TYPE ,GET2-CODE>)>
+ <TYPE-OK? ANY .R>>
+
+<DEFINE GET2-ANA (N R "AUX" (K <KIDS .N>) (NAM <NODE-NAME .N>) (LN <LENGTH .K>))
+ #DECL ((N) NODE (K) <LIST NODE NODE [REST NODE]> (LN) FIX)
+ <EANA <1 .K> ANY .NAM>
+ <EANA <2 .K> ANY .NAM>
+ <COND (<==? .LN 3> <EANAQ <3 .K> ANY .NAM .N>)>
+ <TYPE-OK? ANY .R>>
+
+<DEFINE EANAQ (N R NAM INOD "AUX" SPCD)
+ #DECL ((N) NODE (SPCD) LIST)
+ <SET SPCD <BUILD-TYPE-LIST .VARTBL>>
+ <SET R <EANA .N .R .NAM>>
+ <ASSERT-TYPES <ORUPC .VARTBL .SPCD>>
+ .R>
+
+<DEFINE USE-REG ()
+ #DECL ((TMPS HTMPS) FIX)
+ <COND (<0? ,REGS>
+ <AND <G? <SET TMPS <+ .TMPS 2>> .HTMPS> <SET HTMPS .TMPS>>)
+ (ELSE <SETG REGS <- ,REGS 1>>)>>
+
+<DEFINE UNUSE-REG ()
+ #DECL ((TMPS) FIX)
+ <COND (<==? ,REGS 5> <SET TMPS <- .TMPS 2>>)
+ (ELSE <SETG REGS <+ ,REGS 1>>)>>
+
+<DEFINE REGFLS ()
+ #DECL ((TMPS HTMPS) FIX)
+ <AND <G? <SET TMPS <+ .TMPS <* <- 5 ,REGS> 2>>> .HTMPS>
+ <SET HTMPS .TMPS>>
+ <SETG REGS 5>>
+
+<DEFINE ACTIV? (BST NOACT)
+ #DECL ((BST) <LIST [REST SYMTAB]>)
+ <REPEAT ()
+ <AND <EMPTY? .BST> <RETURN <>>>
+ <AND <==? <CODE-SYM <1 .BST>> 1>
+ <OR <NOT .NOACT>
+ <NOT <RET-AGAIN-ONLY <1 .BST>>>
+ <SPEC-SYM <1 .BST>>>
+ <RETURN T>>
+ <SET BST <REST .BST>>>>
+
+<DEFINE SAME-DECL? (D1 D2) <OR <=? .D1 .D2> <NOT <TYPE-OK? .D2 <NOTIFY .D1>>>>>
+
+<DEFINE SPECIALIZE (OBJ "AUX" T1 T2 SYM OB)
+ #DECL ((T1) FIX (OB) FORM (T2) <OR FALSE SYMTAB>)
+ <COND (<AND <TYPE? .OBJ FORM SEGMENT>
+ <SET OB <CHTYPE .OBJ FORM>>
+ <OR <AND <==? <SET T1 <LENGTH .OB>> 2>
+ <==? <1 .OB> LVAL>
+ <TYPE? <SET SYM <2 .OB>> ATOM>>
+ <AND <==? .T1 3>
+ <==? <1 .OB> SET>
+ <TYPE? <SET SYM <2 .OB>> ATOM>>>
+ <SET T2 <SRCH-SYM .SYM>>>
+ <COND (<NOT <SPEC-SYM .T2>>
+ <MESSAGE NOTE " REDCLARED SPECIAL " .SYM>
+ <PUT .T2 ,SPEC-SYM T>)>)>
+ <COND (<MEMQ <PRIMTYPE .OBJ> '![FORM LIST UVECTOR VECTOR!]>
+ <MAPF <> ,SPECIALIZE .OBJ>)>>
+
+<COND (<GASSIGNED? ARITH-ANA>
+ <SETG ANALYZERS
+ <DISPATCH ,SUBR-ANA
+ (,QUOTE-CODE ,QUOTE-ANA)
+ (,FUNCTION-CODE ,FUNC-ANA)
+ (,SEGMENT-CODE ,SEGMENT-ANA)
+ (,FORM-CODE ,FORM-AN)
+ (,PROG-CODE ,PRG-REP-ANA)
+ (,SUBR-CODE ,SUBR-ANA)
+ (,COND-CODE ,COND-ANA)
+ (,COPY-CODE ,COPY-AN)
+ (,RSUBR-CODE ,RSUBR-ANA)
+ (,ISTRUC-CODE ,ISTRUC-ANA)
+ (,ISTRUC2-CODE ,ISTRUC2-ANA)
+ (,READ-EOF-CODE ,READ-ANA)
+ (,READ-EOF2-CODE ,READ2-ANA)
+ (,GET-CODE ,GET-ANA)
+ (,GET2-CODE ,GET2-ANA)
+ (,MAP-CODE ,MAPPER-AN)
+ (,MARGS-CODE ,MARGS-ANA)
+ (,ARITH-CODE ,ARITH-ANA)
+ (,TEST-CODE ,ARITHP-ANA)
+ (,0-TST-CODE ,ARITHP-ANA)
+ (,1?-CODE ,ARITHP-ANA)
+ (,MIN-MAX-CODE ,ARITH-ANA)
+ (,ABS-CODE ,ABS-ANA)
+ (,FIX-CODE ,FIX-ANA)
+ (,FLOAT-CODE ,FLOAT-ANA)
+ (,MOD-CODE ,MOD-ANA)
+ (,LNTH-CODE ,LENGTH-ANA)
+ (,MT-CODE ,EMPTY?-ANA)
+ (,NTH-CODE ,NTH-ANA)
+ (,REST-CODE ,REST-ANA)
+ (,PUT-CODE ,PUT-ANA)
+ (,PUTR-CODE ,PUTREST-ANA)
+ (,UNWIND-CODE ,UNWIND-ANA)
+ (,FORM-F-CODE ,FORM-F-ANA)
+ (,IRSUBR-CODE ,IRSUBR-ANA)
+ (,ROT-CODE ,ROT-ANA)
+ (,LSH-CODE ,LSH-ANA)
+ (,BIT-TEST-CODE ,BIT-TEST-ANA)
+ (,CASE-CODE ,CASE-ANA)
+ (,COPY-LIST-CODE ,COPY-AN)>>)>
+
+<ENDPACKAGE>
--- /dev/null
+1<[..D:^I..D? A A A A A A A A A A A A A A A A A A A A A A A A A A A A | A AA A A ( ) A A A A AA A AA AA AA AA AA AA AA AA AA AA A ( A ) A A AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA ( / ) A A A AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA ( A ) A A ?
+FVYACC ===> SYNTAX CONVERTER RUNNING.
+\e[0[1J:K
+:Sint (*act[])() {
+ \e"EFVLOSSAGE act\e0;'\ 6 [\7f \e
+:S-1};
+\e"EFVLOSSAGE act END\e0;'\ 6]\e
+:Sint r1[] {
+ \e"EFVLOSSAGE r1\e0;'\ 6 ![\e
+:S-1};\e"EFVLOSSAGE r1 END\e0;'\ 6]\e
+:Sint r2[] {
+ \e"EFVLOSSAGE r2\e0;'\ 6 ![\e
+:S-1};\e"EFVLOSSAGE r2 END\e0;'\ 6]\e
+:Schar *sterm[] {
+ \e"EFVLOSSAGE sterm\e0;'\ 6 [\e
+:S0};\e"EFVLOSSAGE sterm END\e0;'\ 6]\e
+:Schar *snterm[] {
+ \e"EFVLOSSAGE snterm\e0;'\ 6 [\e
+:S0};\e"EFVLOSSAGE snterm END\e0;'\ 6]\e
+:Sint g[] {
+ \e"EFVLOSSAGE g\e0;'\ 6 ![\e
+:S-1};\e"EFVLOSSAGE g END\e0;'\ 6]\e
+:Sint pg[] {
+ \e"EFVLOSSAGE pg\e0;'\ 6 ![\e
+:S-1};\e"EFVLOSSAGE pg END\e0;'\ 6]\e
+:Sint sq[] {
+ \e"EFVLOSSAGE sq\e0;'\ 6 ![\e
+:S-1};\e"EFVLOSSAGE sq END\e0;'\ 6]\e
+:Sint nbpw {\e"EFVLOSSAGE npbw\e0;'\ 6 \e
+:S};\e"EFVLOSSAGE npbw END\e0;'\ 6\e
+:Sint nwpbt {\e"EFVLOSSAGE nwpbt\e0;'\ 6 \e
+:S};\e"EFVLOSSAGE nwpbt END\e0;'\ 6\e
+:Sint a[] {
+ \e"EFVLOSSAGE a\e0;'\ 6 ![\e
+:S-1};\e"EFVLOSSAGE a END\e0;'\ 6]\e
+:Sint pa[] {
+ \e"EFVLOSSAGE pa\e0;'\ 6 ![\e
+:S-1};\e"EFVLOSSAGE pa END\e0;'\ 6]]>
+\e.,ZK
+J<:S,\ f"\ f{\eU0 !'! Q0; R
+Q0+1"ED'
+Q0+2"EC.U0 :S",\ 2\e"EFVLOSSAGE string\e0;'3R !'!
+ Q0,.FSBOUND\e-Z+(BJ<:S"\ f\\e; !'! RI\\eC>WZJZ)FSBOUND\eWCD'
+Q0+3"EFLR'>
+JS\7f\e<:S]\ f\ 20\ 2\e+1;2RDI<>\e>
+<J:S
+ar\e;:S{\e"EFVLOSSAGE ar start\e0;'.U0RFLRQ0,.-1X1 0,.K
+:S\7f\e"EFVLOSSAGE act AGAIN\e0;':Sar\e"EFVLOSSAGE ar END\e0;'
+-2DFWK FQ1+(FSHPOS\e)-(FSWIDTH\e)"GI
+ \e' G1>
+JI<SETG TABLES!-SYNTAX!-PACKAGE!-
+ #TABLES!-SYNTAX!-PACKAGE!- [\e
+S\7f\e-DDJ]1]0]..D FVDONE
+\e>\ 3\ 3
\ No newline at end of file
--- /dev/null
+<PACKAGE "CARGEN">
+
+<ENTRY ARITH-GEN ABS-GEN FLOAT-GEN FIX-GEN MOD-GEN ROT-GEN LSH-GEN 1?-GEN
+ GEN-FLOAT GENFLOAT MIN-MAX PRED:BRANCH:GEN 0-TEST FLIP TEST-GEN>
+
+<USE "CACS" "CODGEN" "CHKDCL" "COMCOD" "COMPDEC" "CONFOR" "STRGEN"><DEFINE TEST-GEN (NOD WHERE
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
+ "AUX" (K <1 <KIDS .NOD>>) (K2 <2 <KIDS .NOD>>) REGT REGT2
+ (S <SW? <NODE-NAME .NOD>>) TRANSFORM ATYP ATYP2 B2
+ (SDIR .DIR) (RW .WHERE) TRANS1 (FLS <==? .RW FLUSHED>)
+ TEM (ONO .NO-KILL) (NO-KILL .ONO)
+ "ACT" TA)
+ #DECL ((NOD K K2) NODE (REGT) DATUM (TRANSFORM) <SPECIAL TRANS>
+ (TRANS1) TRANS (NO-KILL) <SPECIAL LIST>)
+ <SET WHERE
+ <COND (<==? .WHERE FLUSHED> FLUSHED)
+ (ELSE <UPDATE-WHERE .NOD .WHERE>)>>
+ <COND (<OR <==? <NODE-TYPE .K2> ,QUOTE-CODE>
+ <AND <NOT <MEMQ <NODE-TYPE .K> ,SNODES>>
+ <NOT <SIDE-EFFECTS .NOD>>
+ <MEMQ <NODE-TYPE .K2> ,SNODES>>>
+ <COND (<AND <==? <NODE-TYPE .K> ,LVAL-CODE>
+ <COND (<==? <LENGTH <SET TEM <TYPE-INFO .K>>> 2> <2 .TEM>)
+ (ELSE T)>
+ <SET TEM <NODE-NAME .K>>
+ <NOT <MAPF <>
+ <FUNCTION (LL)
+ <AND <==? <1 .LL> .TEM> <MAPLEAVE>>>
+ .NO-KILL>>>
+ <SET NO-KILL ((<NODE-NAME .K> <>) !.NO-KILL)>)>
+ <SET K .K2>
+ <SET K2 <1 <KIDS .NOD>>>
+ <PUT .NOD ,NODE-NAME <FLOP <NODE-NAME .NOD>>>)>
+ <SET ATYP <ISTYPE? <RESULT-TYPE .K2>>>
+ <SET ATYP2 <ISTYPE-GOOD? <RESULT-TYPE .K>>>
+ <SET REGT
+ <DATUM <COND (.ATYP .ATYP) (ELSE ANY-AC)> ANY-AC>>
+ <SET REGT2
+ <COND (<OR <==? <NODE-TYPE .K> ,QUOTE-CODE>
+ <NOT <SIDE-EFFECTS .K2>>>
+ DONT-CARE)
+ (.ATYP2 <DATUM .ATYP2 ANY-AC>)
+ (ELSE <DATUM ANY-AC ANY-AC>)>>
+ <COND (<N==? <NODE-TYPE .K> ,QUOTE-CODE>
+ <COND (<OR <==? .ATYP FLOAT> <==? .ATYP2 FLOAT>>)
+ (ELSE
+ <SET TRANSFORM <MAKE-TRANS .NOD 1 1 0 1 1 <+ 2 <- .S>> .S>>
+ <PUT <2 .TRANSFORM> 6 1>
+ <PUT <2 .TRANSFORM> 7 0>)>
+ <SET REGT2 <GEN .K .REGT2>>
+ <COND (<ASSIGNED? TRANSFORM>
+ <SET TRANS1 .TRANSFORM>
+ <SET TRANSFORM <UPDATE-TRANS .NOD .TRANS1>>)>
+ <COND (<TYPE? <DATVAL .REGT2> AC>
+ <SET REGT <GEN .K2 DONT-CARE>>
+ <COND (<TYPE? <DATVAL .REGT2> AC>
+ <PUT .NOD ,NODE-NAME <FLOP <NODE-NAME .NOD>>>
+ <SET TEM .REGT>
+ <SET REGT .REGT2>
+ <SET REGT2 .TEM>
+ <COND (<ASSIGNED? TRANSFORM>
+ <SET TEM .TRANS1>
+ <SET TRANS1 .TRANSFORM>
+ <SET TRANSFORM .TEM>)>
+ <SET TEM .ATYP>
+ <SET ATYP .ATYP2>
+ <SET ATYP2 .TEM>)
+ (ELSE <TOACV .REGT>)>)
+ (ELSE <SET REGT <GEN .K2 .REGT>>)>)
+ (ELSE
+ <COND (<OR <==? .ATYP FIX>
+ <0? <NODE-NAME .K>>
+ <1? <NODE-NAME .K>>>
+ <SET TRANSFORM <MAKE-TRANS .NOD 1 1 0 1 1 <+ 2 <- .S>> .S>>)>
+ <COND (<==? .ATYP FIX>
+ <PUT <PUT <2 .TRANSFORM> 2 1> 3 <FIX <NODE-NAME .K>>>)>
+ <COND (<LN-LST .K2> <SET REGT ,NO-DATUM>)
+ (ELSE
+ <SET REGT <GEN .K2 .REGT>>
+ <DATTYP-FLUSH .REGT>
+ <PUT .REGT ,DATTYP .ATYP>)>
+ <RETURN
+ <TEST-DISP .NOD
+ .WHERE
+ .NOTF
+ .BRANCH
+ .DIR
+ .REGT
+ <COND (<ASSIGNED? TRANSFORM>
+ <DO-TRANS <FIX <NODE-NAME .K>> .TRANSFORM>)
+ (ELSE <NODE-NAME .K>)>
+ <AND <ASSIGNED? TRANSFORM> <NOT <0? <1 <3 .TRANSFORM>>>>>>
+ .TA>)>
+ <DELAY-KILL .NO-KILL .ONO>
+ <AND <ASSIGNED? TRANSFORM>
+ <CONFORM .REGT .REGT2 .TRANSFORM .TRANS1>
+ <PUT .NOD ,NODE-NAME <FLOP <NODE-NAME .NOD>>>>
+ <COND (.BRANCH
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <VAR-STORE <>>
+ <GEN-COMP2 <NODE-NAME .NOD>
+ .ATYP2
+ .ATYP
+ .REGT2
+ .REGT
+ <COND (.FLS .DIR) (ELSE <NOT .DIR>)>
+ <COND (.FLS .BRANCH) (ELSE <SET B2 <MAKE:TAG>>)>>
+ <COND (<NOT .FLS>
+ <SET RW <MOVE:ARG <MOVE:ARG <REFERENCE .SDIR> .WHERE> .RW>>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B2>
+ .RW)>)
+ (ELSE
+ <VAR-STORE <>>
+ <GEN-COMP2 <NODE-NAME .NOD>
+ .ATYP2
+ .ATYP
+ .REGT2
+ .REGT
+ .NOTF
+ <SET BRANCH <MAKE:TAG>>>
+ <MOVE:ARG <REFERENCE T> .WHERE>
+ <RET-TMP-AC .WHERE>
+ <BRANCH:TAG <SET B2 <MAKE:TAG>>>
+ <LABEL:TAG .BRANCH>
+ <MOVE:ARG <REFERENCE <>> .WHERE>
+ <LABEL:TAG .B2>
+ <MOVE:ARG .WHERE .RW>)>>
+<ENDPACKAGE>
\ No newline at end of file
--- /dev/null
+<PACKAGE "STRGEN">
+
+<ENTRY NTH-GEN REST-GEN PUT-GEN LNTH-GEN MT-GEN PUTREST-GEN IPUT-GEN
+ IREMAS-GEN FLUSH-COMMON-SYMT COMMUTE-STRUC DEFER-IT PUT-COMMON-DAT
+ LIST-LNT-SPEC RCHK>
+
+<USE "CODGEN" "CACS" "COMCOD" "CHKDCL" "COMPDEC" "SPCGEN" "COMTEM" "CARGEN">
+<DEFINE PUTREST-GEN (NOD WHERE
+ "AUX" ST1 ST2 (K <KIDS .NOD>) (FLG T) N CD (ONO .NO-KILL)
+ (NO-KILL .ONO) (2RET <>))
+ #DECL ((NOD N) NODE (K) <LIST NODE NODE> (ST1 ST2) DATUM
+ (NO-KILL) <SPECIAL LIST> (ONO) LIST)
+ <COND (<==? <NODE-SUBR .NOD> ,REST>
+ <SET NOD <1 .K>>
+ <SET K <KIDS .NOD>>
+ <SET 2RET T>)> ;"Really <REST <PUTREST ...."
+ <COND (<AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+ <==? <NODE-NAME <2 .K>> ()>>
+ <SET ST1 <GEN <1 .K> <UPDATE-WHERE .NOD .WHERE>>>)
+ (<AND <NOT <SIDE-EFFECTS? <1 .K>>>
+ <NOT <SIDE-EFFECTS? <2 .K>>>
+ <MEMQ <NODE-TYPE <1 .K>> ,SNODES>>
+ <AND <==? <NODE-TYPE <SET N <1 .K>>> ,LVAL-CODE>
+ <COND (<==? <LENGTH <SET CD <TYPE-INFO .N>>> 2> <2 .CD>)
+ (ELSE T)>
+ <SET CD <NODE-NAME .N>>
+ <NOT <MAPF <>
+ <FUNCTION (LL)
+ #DECL ((LL) <LIST SYMTAB ANY>)
+ <AND <==? .CD <1 .LL>> <MAPLEAVE>>>
+ .NO-KILL>>
+ <SET NO-KILL ((.CD <>) !.NO-KILL)>>
+ <SET ST2
+ <GEN <2 .K>
+ <COND (.2RET <GOODACS <2 .K> .WHERE>)
+ (ELSE <DATUM LIST ANY-AC>)>>>
+ <SET ST1
+ <GEN <1 .K>
+ <COND (.2RET DONT-CARE)
+ (ELSE <UPDATE-WHERE .NOD .WHERE>)>>>
+ <DELAY-KILL .NO-KILL .ONO>)
+ (ELSE
+ <SET ST1
+ <GEN <1 .K>
+ <GOODACS .NOD
+ <COND (<OR <==? .WHERE FLUSHED> .2RET>
+ DONT-CARE)
+ (ELSE .WHERE)>>>>
+ <SET ST2 <GEN <2 .K> <DATUM LIST ANY-AC>>>)>
+ <KILL-COMMON LIST>
+ <AND .CAREFUL
+ <G? 1 <MINL <RESULT-TYPE <1 .K>>>>
+ <COND (<TYPE? <DATVAL .ST1> AC>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM <DATVAL .ST1>> |CERR2 >>)
+ (ELSE
+ <EMIT <INSTRUCTION `SKIPN !<ADDR:VALUE .ST1>>>
+ <BRANCH:TAG |CERR2 >)>>
+ <AND <ASSIGNED? ST2> <TOACV .ST2>>
+ <OR <TYPE? <DATVAL .ST1> AC> <SET FLG <>>>
+ <COND (<ASSIGNED? ST2>
+ <COND (.FLG
+ <EMIT <INSTRUCTION `HRRM
+ <ACSYM <CHTYPE <DATVAL .ST2> AC>>
+ (<ADDRSYM <CHTYPE <DATVAL .ST1> AC>>)>>)
+ (ELSE
+ <EMIT <INSTRUCTION `HRRM
+ <ACSYM <CHTYPE <DATVAL .ST2> AC>>
+ `@
+ !<ADDR:VALUE .ST1>>>)>
+ <RET-TMP-AC <COND (.2RET .ST1) (ELSE .ST2)>>)
+ (ELSE
+ <COND (.FLG
+ <EMIT <INSTRUCTION `HLLZS (<ADDRSYM <CHTYPE <DATVAL .ST1> AC>>)>>)
+ (ELSE
+ <EMIT <INSTRUCTION `HLLZS `@ !<ADDR:VALUE .ST1>>>)>)>
+ <MOVE:ARG <COND (.2RET .ST2) (ELSE .ST1)> .WHERE>>
+
+<PUT ,GENERATORS ,PUTREST-CODE ,PUTREST-GEN>
+<DEFINE FLUSH-COMMON-SYMT (SYMT)
+ #DECL ((SYMT) SYMTAB)
+ <MAPF <>
+ <FUNCTION (AC "AUX" ACR)
+ #DECL ((AC) AC)
+ <SET ACR
+ <COND (<SET ACR <ACRESIDUE .AC>>
+ <COND (<EQSYMT <1 .ACR> .SYMT> <REST .ACR>)
+ (<REPEAT ((PTR <REST .ACR>) (SACR .ACR))
+ <COND (<EMPTY? .PTR> <RETURN .SACR>)>
+ <COND (<EQSYMT <1 .PTR> .SYMT>
+ <PUTREST .ACR <REST .PTR>>
+ <RETURN .SACR>)>
+ <SET PTR <REST .PTR>>
+ <SET ACR <REST .ACR>>>)>)>>
+ <PUT .AC ,ACRESIDUE <COND (<EMPTY? .ACR> <>) (ELSE .ACR)>>>
+ ,ALLACS>>
+
+<ENDPACKAGE>
+<PACKAGE "CARGEN">
+
+<ENTRY ARITH-GEN ABS-GEN FLOAT-GEN FIX-GEN MOD-GEN ROT-GEN LSH-GEN 1?-GEN
+ GEN-FLOAT GENFLOAT MIN-MAX PRED:BRANCH:GEN 0-TEST FLIP TEST-GEN>
+
+<USE "CACS" "CODGEN" "CHKDCL" "COMCOD" "COMPDEC" "CONFOR" "STRGEN">
+
+<DEFINE TEST-GEN (NOD WHERE
+ "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>)
+ "AUX" (K <1 <KIDS .NOD>>) (K2 <2 <KIDS .NOD>>) REGT REGT2
+ (S <SW? <NODE-NAME .NOD>>) TRANSFORM ATYP ATYP2 B2
+ (SDIR .DIR) (RW .WHERE) TRANS1 (FLS <==? .RW FLUSHED>)
+ TEM (ONO .NO-KILL) (NO-KILL .ONO)
+ "ACT" TA)
+ #DECL ((NOD K K2) NODE (REGT) DATUM (TRANSFORM) <SPECIAL TRANS>
+ (TRANS1) TRANS (NO-KILL) <SPECIAL LIST>)
+ <SET WHERE
+ <COND (<==? .WHERE FLUSHED> FLUSHED)
+ (ELSE <UPDATE-WHERE .NOD .WHERE>)>>
+ <COND (<OR <==? <NODE-TYPE .K2> ,QUOTE-CODE>
+ <AND <NOT <MEMQ <NODE-TYPE .K> ,SNODES>>
+ <NOT <SIDE-EFFECTS .NOD>>
+ <MEMQ <NODE-TYPE .K2> ,SNODES>>>
+ <COND (<AND <==? <NODE-TYPE .K> ,LVAL-CODE>
+ <COND (<==? <LENGTH <SET TEM <TYPE-INFO .K>>> 2> <2 .TEM>)
+ (ELSE T)>
+ <SET TEM <NODE-NAME .K>>
+ <NOT <MAPF <>
+ <FUNCTION (LL)
+ <AND <==? <1 .LL> .TEM> <MAPLEAVE>>>
+ .NO-KILL>>>
+ <SET NO-KILL ((<NODE-NAME .K> <>) !.NO-KILL)>)>
+ <SET K .K2>
+ <SET K2 <1 <KIDS .NOD>>>
+ <PUT .NOD ,NODE-NAME <FLOP <NODE-NAME .NOD>>>)>
+ <SET ATYP <ISTYPE? <RESULT-TYPE .K2>>>
+ <SET ATYP2 <ISTYPE-GOOD? <RESULT-TYPE .K>>>
+ <SET REGT
+ <DATUM <COND (.ATYP .ATYP) (ELSE ANY-AC)> ANY-AC>>
+ <SET REGT2
+ <COND (<OR <==? <NODE-TYPE .K> ,QUOTE-CODE>
+ <NOT <SIDE-EFFECTS .K2>>>
+ DONT-CARE)
+ (.ATYP2 <DATUM .ATYP2 ANY-AC>)
+ (ELSE <DATUM ANY-AC ANY-AC>)>>
+ <COND (<N==? <NODE-TYPE .K> ,QUOTE-CODE>
+ <COND (<OR <==? .ATYP FLOAT> <==? .ATYP2 FLOAT>>)
+ (ELSE
+ <SET TRANSFORM <MAKE-TRANS .NOD 1 1 0 1 1 <+ 2 <- .S>> .S>>
+ <PUT <2 .TRANSFORM> 6 1>
+ <PUT <2 .TRANSFORM> 7 0>)>
+ <SET REGT2 <GEN .K .REGT2>>
+ <COND (<ASSIGNED? TRANSFORM>
+ <SET TRANS1 .TRANSFORM>
+ <SET TRANSFORM <UPDATE-TRANS .NOD .TRANS1>>)>
+ <COND (<TYPE? <DATVAL .REGT2> AC>
+ <SET REGT <GEN .K2 DONT-CARE>>
+ <COND (<TYPE? <DATVAL .REGT2> AC>
+ <PUT .NOD ,NODE-NAME <FLOP <NODE-NAME .NOD>>>
+ <SET TEM .REGT>
+ <SET REGT .REGT2>
+ <SET REGT2 .TEM>
+ <COND (<ASSIGNED? TRANSFORM>
+ <SET TEM .TRANS1>
+ <SET TRANS1 .TRANSFORM>
+ <SET TRANSFORM .TEM>)>
+ <SET TEM .ATYP>
+ <SET ATYP .ATYP2>
+ <SET ATYP2 .TEM>)
+ (ELSE <TOACV .REGT>)>)
+ (ELSE <SET REGT <GEN .K2 .REGT>>)>)
+ (ELSE
+ <COND (<OR <==? .ATYP FIX>
+ <0? <NODE-NAME .K>>
+ <1? <NODE-NAME .K>>>
+ <SET TRANSFORM <MAKE-TRANS .NOD 1 1 0 1 1 <+ 2 <- .S>> .S>>)>
+ <COND (<==? .ATYP FIX>
+ <PUT <PUT <2 .TRANSFORM> 2 1> 3 <FIX <NODE-NAME .K>>>)>
+ <COND (<LN-LST .K2> <SET REGT ,NO-DATUM>)
+ (ELSE
+ <SET REGT <GEN .K2 .REGT>>
+ <DATTYP-FLUSH .REGT>
+ <PUT .REGT ,DATTYP .ATYP>)>
+ <RETURN
+ <TEST-DISP .NOD
+ .WHERE
+ .NOTF
+ .BRANCH
+ .DIR
+ .REGT
+ <COND (<ASSIGNED? TRANSFORM>
+ <DO-TRANS <FIX <NODE-NAME .K>> .TRANSFORM>)
+ (ELSE <NODE-NAME .K>)>
+ <AND <ASSIGNED? TRANSFORM> <NOT <0? <1 <3 .TRANSFORM>>>>>>
+ .TA>)>
+ <DELAY-KILL .NO-KILL .ONO>
+ <AND <ASSIGNED? TRANSFORM>
+ <CONFORM .REGT .REGT2 .TRANSFORM .TRANS1>
+ <PUT .NOD ,NODE-NAME <FLOP <NODE-NAME .NOD>>>>
+ <COND (.BRANCH
+ <AND .NOTF <SET DIR <NOT .DIR>>>
+ <VAR-STORE <>>
+ <GEN-COMP2 <NODE-NAME .NOD>
+ .ATYP2
+ .ATYP
+ .REGT2
+ .REGT
+ <COND (.FLS .DIR) (ELSE <NOT .DIR>)>
+ <COND (.FLS .BRANCH) (ELSE <SET B2 <MAKE:TAG>>)>>
+ <COND (<NOT .FLS>
+ <SET RW <MOVE:ARG <MOVE:ARG <REFERENCE .SDIR> .WHERE> .RW>>
+ <BRANCH:TAG .BRANCH>
+ <LABEL:TAG .B2>
+ .RW)>)
+ (ELSE
+ <VAR-STORE <>>
+ <GEN-COMP2 <NODE-NAME .NOD>
+ .ATYP2
+ .ATYP
+ .REGT2
+ .REGT
+ .NOTF
+ <SET BRANCH <MAKE:TAG>>>
+ <MOVE:ARG <REFERENCE T> .WHERE>
+ <RET-TMP-AC .WHERE>
+ <BRANCH:TAG <SET B2 <MAKE:TAG>>>
+ <LABEL:TAG .BRANCH>
+ <MOVE:ARG <REFERENCE <>> .WHERE>
+ <LABEL:TAG .B2>
+ <MOVE:ARG .WHERE .RW>)>>
+
+<PUT ,GENERATORS ,TEST-CODE ,TEST-GEN>
+<ENDPACKAGE>
\ No newline at end of file
--- /dev/null
+<DEFINE MERGE-STATE (STATV)
+ #DECL ((STATV) SAVED-STATE)
+ <MAPF <>
+ <FUNCTION (STATV
+ "AUX" (AC <1 .STATV>) (DATS <REST .STATV 2>)
+ (STATAC <ACRESIDUE .AC>) (NINACS ()) (NRES ()))
+ #DECL ((STATV) <LIST AC ANY [REST <LIST SYMBOL ANY>]>
+ (AC) AC (DATS) <LIST [REST <LIST SYMBOL ANY>]>
+ (STATAC) <OR FALSE <LIST [REST SYMBOL]>>
+ (NRES) <LIST [REST SYMBOL]>
+ (NINACS) <LIST [REST <LIST SYMBOL ANY>]>)
+ <MAPF <>
+ <FUNCTION (ACX
+ "AUX" (SYMT <1 .ACX>) (INAC <2 .ACX>) (OINAC <SINACS .SYMT>)
+ (TEM <>) (PMERG T))
+ #DECL ((ACX) <LIST SYMBOL ANY>
+ (SYMT) SYMBOL
+ (INAC OINAC) <PRIMTYPE LIST>)
+ <COND (<TYPE? .SYMT SYMTAB>
+ <COND (<STORED .SYMT>
+ <PUT .SYMT
+ ,STORED
+ <GET-STORED .SYMT <3 .ACX> <4 .ACX>>>)>
+ <COND (<AND <SS-POTENT-SLOT .ACX> <NOT <PROG-AC .SYMT>>>
+ <SET PMERG <>>)>)>
+ <COND
+ (<AND <MEMQ .SYMT .STATAC>
+ .OINAC
+ .INAC
+ .PMERG
+ <==? <DATVAL .INAC> <DATVAL .OINAC>>
+ <OR <==? <DATTYP .INAC> <DATTYP .OINAC>>
+ <AND <TYPE? .SYMT SYMTAB>
+ <SET TEM
+ <ISTYPE? <1 <CHTYPE <DECL-SYM .SYMT>
+ LIST>>>>
+ <OR <==? <DATTYP .INAC> .TEM>
+ <==? <DATTYP .OINAC> .TEM>>>>>
+ <SET NRES (.SYMT !.NRES)>
+ <SET NINACS
+ ((.SYMT <DATUM <OR .TEM <DATTYP .INAC>> <DATVAL .INAC>>)
+ !.NINACS)>
+ <COND (<AND .TEM
+ <OR <TYPE? <SET TEM <DATTYP .INAC>> AC>
+ <TYPE? <SET TEM <DATTYP .OINAC>> AC>>>
+ <FLUSH-RESIDUE .TEM .SYMT>)>)>
+ <COND (<AND .OINAC
+ <OR <==? .AC <DATTYP .OINAC>>
+ <==? .AC <DATVAL .OINAC>>>>
+ <SMASH-INACS .SYMT <> <>>)>>
+ .DATS>
+ <MAPF <>
+ <FUNCTION (SYMT)
+ #DECL ((SYMT) SYMBOL)
+ <SMASH-INACS .SYMT <> <>>>
+ <ACRESIDUE .AC>>
+ <PUT .AC ,ACRESIDUE <COND (<NOT <EMPTY? .NRES>> .NRES)>>
+ <MAPF <>
+ <FUNCTION (SYMB "AUX" (SYMT <1 .SYMB>) (ELEIN <2 .SYMB>))
+ #DECL ((SYMT) SYMBOL)
+ <SMASH-INACS .SYMT .ELEIN>>
+ .NINACS>>
+ .STATV>>
+
+ <TITLE MERGE-STATE>
+
+ <DECLARE ("VALUE" <OR COMMON!-COMPDEC!-PACKAGE FALSE
+SYMTAB!-COMPDEC!-PACKAGE TEMP!-COMPDEC!-PACKAGE> SAVED-STATE!-COMPDEC!-PACKAGE)>
+ <PUSH TP* (AB) >
+ <PUSH TP* (AB) 1>
+ <PUSHJ P* TAG1>
+ <JRST |FINIS >
+TAG1 <SUBM M* (P) > ; 4
+ <PUSH TP* <MQUOTE %<TYPE-W SAVED-STATE!-COMPDEC!-PACKAGE LIST>>>; [2]
+ <PUSH TP* [0]> ; [3]
+ <INTGO>
+ <MOVE B* (TP) -2> ; (1)
+ <MOVEM B* (TP) > ; (3)
+ <MOVE A* <TYPE-WORD FALSE>>
+ <MOVEI B* 0>
+ <MOVE D* (TP) > ; (3)
+ <JUMPE D* TAG2>
+TAG25 <PUSH TP* [0]> ; 15 [4]
+ <PUSH TP* [0]> ; [5]
+ <MOVE PVP* (D) 1>
+ <PUSH TP* <MQUOTE %<TYPE-W AC!-COMPDEC!-PACKAGE VECTOR>>>; [6]
+ <PUSH TP* (PVP) 1> ; [7]
+ <HRRZ TVP* (PVP) >
+ <HRRZ TVP* (TVP) >
+ <PUSH TP* <TYPE-WORD LIST>> ; [8]
+ <PUSH TP* TVP> ; [9]
+ <MOVE SP* (TP) -2> ; (7)
+ <PUSH TP* (SP) 14> ; [10]
+ <PUSH TP* (SP) 15> ; [11]
+ <PUSH TP* <TYPE-WORD LIST>> ; [12]
+ <PUSH TP* [0]> ; [13]
+ <PUSH TP* <TYPE-WORD LIST>> ; [14]
+ <PUSH TP* [0]> ; [15]
+ <SKIPGE |INTFLG >
+ <TAG3>
+ <MOVE B* (TP) -6> ; (9)
+ <MOVEM D* (TP) -12> ; (3)
+ <JUMPE B* TAG4>
+TAG17 <PUSH TP* <TYPE-WORD LIST>> ; 36 [16]
+ <PUSH TP* [0]> ; [17]
+ <PUSH TP* [0]> ; [18]
+ <PUSH TP* [0]> ; [19]
+ <MOVE E* (B) 1>
+ <PUSH TP* (E) > ; [20]
+ <PUSH TP* (E) 1> ; [21]
+ <HRRZ TVP* (E) >
+ <PUSH TP* (TVP) > ; [22]
+ <PUSH TP* (TVP) 1> ; [23]
+ <PUSH TP* (TP) -3> ; (20) [24]
+ <PUSH TP* (TP) -3> ; (21) [25]
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (TP) -21> ; (4)
+ <MOVEM B* (TP) -20> ; (5)
+ <MOVEM E* (TP) -8> ; (17)
+ <MCALL 1 SINACS>
+ <PUSH TP* A> ; [24]
+ <PUSH TP* B> ; [25]
+ <PUSH TP* <TYPE-WORD FALSE>> ; [26]
+ <PUSH TP* [0]> ; [27]
+ <PUSH TP* <MQUOTE T> -1> ; [28]
+ <PUSH TP* <MQUOTE T>> ; [29]
+ <INTGO>
+ <GETYP O* (TP) -9> ; (20)
+ <CAIE O* <MQUOTE %<TYPE-C SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>
+ <JRST TAG5>
+ <MOVE B* (TP) -8> ; (21)
+ <SKIPL (B) 27>
+ <JRST TAG6>
+ <PUSH TP* <MQUOTE %<TYPE-W SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>; [30]
+ <PUSH TP* B> ; [31]
+ <MOVE D* (TP) -14> ; (17)
+ <JUMPE D* |CERR2 >
+ <HRRZ PVP* (D) >
+ <JUMPE PVP* |CERR2 >
+ <HRRZ PVP* (PVP) >
+ <JUMPE PVP* |CERR2 >
+ <PUSH TP* (PVP) > ; [32]
+ <PUSH TP* (PVP) 1> ; [33]
+ <MOVEI PVP* 3 >
+TAG7 <JUMPE D* |CERR2 > ; 78
+ <HRRZ D* (D) >
+ <SOJG PVP* TAG7>
+ <JUMPE D* |CERR2 >
+ <PUSH TP* (D) > ; [34]
+ <PUSH TP* (D) 1> ; [35]
+ <MOVE O* <MQUOTE %<TYPE-W SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>
+ <MOVEM O* (TP) -17> ; (18)
+ <MOVEM B* (TP) -16> ; (19)
+ <MCALL 3 GET-STORED>
+ <MOVE D* (TP) -10> ; (19)
+ <MOVEM A* (D) 26>
+ <MOVEM B* (D) 27>
+TAG6 <MOVE B* (TP) -12> ; 91 (17)
+ <MOVEI D* 3 >
+TAG8 <JUMPE B* |CERR2 > ; 93
+ <HRRZ B* (B) >
+ <SOJG D* TAG8>
+ <JUMPE B* |CERR2 >
+ <GETYP O* (B) 0>
+ <CAIN O* <TYPE-CODE DEFER>>
+ <MOVE B* (B) 1>
+ <GETYP O* (B) 0>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG5>
+ <MOVE B* (TP) -8> ; (21)
+ <GETYP O* (B) 32>
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG5>
+ <MOVE B* <TYPE-WORD FALSE>>
+ <MOVEI D* 0>
+ <MOVEM B* (TP) -1> ; (28)
+ <MOVEM D* (TP) > ; (29)
+TAG5 <MOVE B* (TP) -18> ; 111 (11)
+ <MOVE D* (TP) -8> ; (21)
+ <GETYP PVP* (TP) -9> ; (20)
+ <JUMPE B* TAG9>
+TAG11 <GETYP O* (B) 0> ; 115
+ <CAIN O* (PVP) 0>
+ <CAME D* (B) 1>
+ <SKIPA O>
+ <JRST TAG10>
+ <HRRZ B* (B) >
+ <JUMPN B* TAG11>
+ <JRST TAG9>
+TAG10 <GETYP O* (TP) -5> ; 123 (24)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG9>
+ <GETYP O* (TP) -7> ; (22)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <SKIPL (TP) > ; (29)
+ <JRST TAG9>
+ <MOVE B* (TP) -6> ; (23)
+ <HRRZ D* (B) >
+ <MOVE PVP* (D) >
+ <MOVE TVP* (D) 1>
+ <MOVE D* (TP) -4> ; (25)
+ <HRRZ A* (D) >
+ <GETYP O* (A) 0>
+ <GETYP C* PVP>
+ <CAMN TVP* (A) 1>
+ <CAIE O* (C) 0>
+ <JRST TAG9>
+ <MOVE E* (B) >
+ <MOVE C* (B) 1>
+ <GETYP O* (D) 0>
+ <GETYP A* E>
+ <CAMN C* (D) 1>
+ <CAIE O* (A) 0>
+ <SKIPA O>
+ <JRST TAG12>
+ <GETYP O* (TP) -9> ; (20)
+ <CAIE O* <MQUOTE %<TYPE-C SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>
+ <JRST TAG9>
+ <MOVE A* (TP) -8> ; (21)
+ <MOVE SP* (A) 13>
+ <JUMPE SP* |CERR2 >
+ <GETYP O* (SP) 0>
+ <CAIN O* <TYPE-CODE DEFER>>
+ <MOVE SP* (SP) 1>
+ <PUSH TP* (SP) > ; [30]
+ <PUSH TP* (SP) 1> ; [31]
+ <MCALL 1 ISTYPE?>
+ <MOVEM A* (TP) -3> ; (26)
+ <MOVEM B* (TP) -2> ; (27)
+ <GETYP O* A>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG9>
+ <MOVE D* (TP) -6> ; (23)
+ <MOVE PVP* (D) >
+ <MOVE TVP* (D) 1>
+ <GETYP O* A>
+ <GETYP E* PVP>
+ <CAMN TVP* B>
+ <CAIE O* (E) 0>
+ <SKIPA O>
+ <JRST TAG12>
+ <MOVE C* (TP) -4> ; (25)
+ <MOVE E* (C) >
+ <MOVE SP* (C) 1>
+ <GETYP O* A>
+ <GETYP C* E>
+ <CAMN SP* B>
+ <CAIE O* (C) 0>
+ <JRST TAG9>
+TAG12 <MOVE E* (TP) -14> ; 183 (15)
+ <MOVE C* (TP) -9> ; (20)
+ <MOVE D* (TP) -8> ; (21)
+ <PUSHJ P* |C1CONS >
+ <MOVE C* (TP) -9> ; (20)
+ <MOVE D* (TP) -8> ; (21)
+ <MOVEI E* 0>
+ <MOVEM B* (TP) -14> ; (15)
+ <PUSHJ P* |C1CONS >
+ <MOVEM B* (TP) -12> ; (17)
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (TP) -11> ; (18)
+ <MOVEM B* (TP) -10> ; (19)
+ <MOVE D* (TP) -3> ; (26)
+ <MOVE PVP* (TP) -2> ; (27)
+ <GETYP O* D>
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG13>
+ <MOVE TVP* (TP) -6> ; (23)
+ <MOVE D* (TVP) >
+ <MOVE PVP* (TVP) 1>
+TAG13 <PUSH TP* D> ; 204 [30]
+ <PUSH TP* PVP> ; [31]
+ <MOVE D* (TP) -8> ; (23)
+ <HRRZ PVP* (D) >
+ <PUSH TP* (PVP) > ; [32]
+ <PUSH TP* (PVP) 1> ; [33]
+ <MCALL 2 DATUM>
+ <MOVE C* A>
+ <MOVE D* B>
+ <MOVEI E* 0>
+ <PUSHJ P* |C1CONS >
+ <HRRM B* @ (TP) -10> ; (19)
+ <MOVEM B* (TP) -10> ; (19)
+ <MOVE C* <TYPE-WORD LIST>>
+ <MOVE D* (TP) -12> ; (17)
+ <MOVEI E* 0>
+ <PUSHJ P* |C1CONS >
+ <MOVEM B* (TP) -12> ; (17)
+ <MOVE D* (TP) -16> ; (13)
+ <HRRM D* @ B>
+ <MOVE B* (TP) -12> ; (17)
+ <MOVEM B* (TP) -16> ; (13)
+ <GETYP O* (TP) -3> ; (26)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG9>
+ <MOVE D* (TP) -6> ; (23)
+ <MOVE PVP* (D) >
+ <MOVE TVP* (D) 1>
+ <MOVEM PVP* (TP) -3> ; (26)
+ <MOVEM TVP* (TP) -2> ; (27)
+ <GETYP O* PVP>
+ <CAIN O* <MQUOTE %<TYPE-C AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <JRST TAG14>
+ <MOVE D* (TP) -4> ; (25)
+ <MOVE C* (D) >
+ <MOVE E* (D) 1>
+ <MOVEM C* (TP) -3> ; (26)
+ <MOVEM E* (TP) -2> ; (27)
+ <GETYP O* C>
+ <CAIE O* <MQUOTE %<TYPE-C AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <JRST TAG9>
+TAG14 <PUSH TP* (TP) -3> ; 245 (26) [30]
+ <PUSH TP* (TP) -3> ; (27) [31]
+ <PUSH TP* (TP) -11> ; (20) [32]
+ <PUSH TP* (TP) -11> ; (21) [33]
+ <MCALL 2 FLUSH-RESIDUE>
+TAG9 <GETYP O* (TP) -5> ; 250 (24)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG15>
+ <MOVE B* (TP) -4> ; (25)
+ <MOVE D* (B) >
+ <MOVE PVP* (B) 1>
+ <GETYP O* D>
+ <CAMN PVP* (TP) -22> ; (7)
+ <CAIE O* <MQUOTE %<TYPE-C AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <SKIPA O>
+ <JRST TAG16>
+ <HRRZ B* (B) >
+ <MOVE TVP* (B) >
+ <MOVE E* (B) 1>
+ <GETYP O* TVP>
+ <CAMN E* (TP) -22> ; (7)
+ <CAIE O* <MQUOTE %<TYPE-C AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <JRST TAG15>
+TAG16 <PUSH TP* (TP) -9> ; 268 (20) [30]
+ <PUSH TP* (TP) -9> ; (21) [31]
+ <PUSH TP* <TYPE-WORD FALSE>> ; [32]
+ <PUSH TP* [0]> ; [33]
+ <PUSH TP* <TYPE-WORD FALSE>> ; [34]
+ <PUSH TP* [0]> ; [35]
+ <MCALL 3 SMASH-INACS>
+TAG15 <SUB TP* [<(14) 14>]> ; 275
+ <MOVE B* (TP) -10> ; (5)
+ <HRRZ B* (B) >
+ <JUMPN B* TAG17>
+TAG4 <MOVE B* (TP) -8> ; 279 (7)
+ <MOVE D* (B) 14>
+ <MOVE PVP* (B) 15>
+ <JUMPE PVP* TAG18>
+TAG19 <MOVE TVP* (PVP) > ; 283
+ <MOVE A* (PVP) 1>
+ <SKIPGE |INTFLG >
+ <SAVAC O* [<(*71500*) 4>]>
+ <PUSH TP* TVP> ; [16]
+ <PUSH TP* A> ; [17]
+ <PUSH TP* <TYPE-WORD FALSE>> ; [18]
+ <PUSH TP* [0]> ; [19]
+ <PUSH TP* <TYPE-WORD FALSE>> ; [20]
+ <PUSH TP* [0]> ; [21]
+ <MOVEM D* (TP) -17> ; (4)
+ <MOVEM PVP* (TP) -16> ; (5)
+ <MCALL 3 SMASH-INACS>
+ <MOVE D* (TP) -11> ; (4)
+ <MOVE PVP* (TP) -10> ; (5)
+ <HRRZ PVP* (PVP) >
+ <JUMPN PVP* TAG19>
+TAG18 <MOVE B* (TP) > ; 300 (15)
+ <JUMPN B* TAG20>
+ <MOVE D* <TYPE-WORD FALSE>>
+ <MOVEI PVP* 0>
+ <JRST TAG21>
+TAG20 <MOVE D* <TYPE-WORD LIST>> ; 305
+ <MOVE PVP* B>
+TAG21 <MOVE TVP* (TP) -8> ; 307 (7)
+ <MOVEM D* (TVP) 14>
+ <MOVEM PVP* (TVP) 15>
+ <MOVE C* (TP) -2> ; (13)
+ <MOVE A* <TYPE-WORD FALSE>>
+ <MOVEI B* 0>
+ <JUMPE C* TAG22>
+TAG24 <MOVE E* (C) 1> ; 314
+ <PUSH TP* (E) > ; [16]
+ <PUSH TP* (E) 1> ; [17]
+ <HRRZ E* (E) >
+ <GETYP O* (E) 0>
+ <CAIN O* <TYPE-CODE DEFER>>
+ <MOVE E* (E) 1>
+ <PUSH TP* (E) > ; [18]
+ <PUSH TP* (E) 1> ; [19]
+ <SKIPGE |INTFLG >
+ <TAG23>
+ <PUSH TP* (TP) -3> ; (16) [20]
+ <PUSH TP* (TP) -3> ; (17) [21]
+ <PUSH TP* (TP) -3> ; (18) [22]
+ <PUSH TP* (TP) -3> ; (19) [23]
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (TP) -19> ; (4)
+ <MOVEM C* (TP) -18> ; (5)
+ <MCALL 2 SMASH-INACS>
+ <SUB TP* [<(4) 4>]>
+ <MOVE C* (TP) -10> ; (5)
+ <HRRZ C* (C) >
+ <JUMPN C* TAG24>
+TAG22 <SUB TP* [<(12) 12>]> ; 337
+ <HRRZ O* @ (TP) > ; (3)
+ <MOVEM O* (TP) > ; (3)
+ <JUMPN O* TAG25>
+TAG2 <SUB TP* [<(4) 4>]> ; 341
+ <JRST |MPOPJ >
+ <0>
+TAG3 <*120012*> ; 344
+ <(*121500*) 0>
+ <IMULI TB* (TP) -9> ; (-10)
+ <IMULI TB* (B) 0>
+ <IMULI TB* (B) 0>
+ <IMULI TB* (B) 32>
+ <IMULI TB* (B) 0>
+ <IMULI TB* (TP) -5> ; (-6)
+ <IMULI TB* (TP) -7> ; (-8)
+ <IMULI TB* (A) 0>
+ <IMULI TB* 6 >
+ <IMULI TB* (D) 0>
+ <IMULI TB* 5 >
+ <IMULI TB* (SP) 0>
+ <IMULI TB* 1 >
+ <IMULI TB* 4 >
+ <IMULI TB* (TP) -3> ; (-4)
+ <IMULI TB* 3 >
+ <IMULI TB* 7 >
+ <(14) 14>
+ <(*71500*) 4>
+ <IMULI TB* (E) 0>
+TAG23 <(*12*) 0> ; 366
+ <FSB O* O>
+ <(4) 4>
+ <(12) 12>
+ <(1) 4>
+ <(*61661*) *632265*>
+ <0>
+ <(1) 2>
+
+\f
+<DEFINE RESTORE-STATE (STATV
+ "OPTIONAL" (NORET T)
+ "AUX" (MUNGED-SYMS ()) PA OACR)
+ #DECL ((STATV) SAVED-STATE (PA) <OR FALSE <LIST NODE>> (OACR) <OR FALSE LIST>)
+ <MAPF <>
+ <FUNCTION (ACLST
+ "AUX" (AC <1 .ACLST>) (SMT <2 .ACLST>) (SYMT <REST .ACLST 2>))
+ #DECL ((ACLST)
+ <LIST AC
+ <OR FALSE <LIST [REST SYMBOL]>>
+ [REST <LIST SYMBOL ANY>]>
+ (SYMT)
+ <LIST [REST <LIST SYMBOL ANY>]>
+ (AC)
+ AC
+ (SMT)
+ <OR FALSE <LIST [REST SYMBOL]>>)
+ <AND .SMT <EMPTY? .SMT> <SET SMT <>>>
+ <MAPF <>
+ <FUNCTION (ST)
+ <OR <MEMQ .ST .MUNGED-SYMS> <SMASH-INACS .ST <> <>>>>
+ <ACRESIDUE .AC>>
+ <AND .SMT <SET SMT <LIST !.SMT>>>
+ <SET OACR <ACRESIDUE .AC>>
+ <PUT .AC ,ACRESIDUE .SMT>
+ <MAPF <>
+ <FUNCTION (SYMB "AUX" (SYMT <1 .SYMB>) (INAC <2 .SYMB>))
+ #DECL ((SYMB) <LIST SYMBOL ANY> (SYMT) SYMBOL)
+ <COND (<TYPE? .SYMT SYMTAB>
+ <PUT .SYMT
+ ,STORED
+ <GET-STORED .SYMT <3 .SYMB> <4 .SYMB>>>
+ <COND (<SET PA <PROG-AC .SYMT>>
+ <AND <STORED .SYMT>
+ <NOT <MEMQ .SYMT <LOOP-VARS <1 .PA>>>>
+ <NOT .NORET>
+ <NOT <MEMQ .SYMT .OACR>>
+ <KILL-LOOP-AC .SYMT>
+ <FLUSH-RESIDUE .AC .SYMT>
+ <SET INAC <>>>)
+ (<4 .SYMB>
+ <FLUSH-RESIDUE .AC .SYMT>
+ <SET INAC <>>)>)>
+ <OR <MEMQ .SYMT .MUNGED-SYMS>
+ <SET MUNGED-SYMS (.SYMT !.MUNGED-SYMS)>>
+ <SMASH-INACS .SYMT .INAC>>
+ .SYMT>>
+ .STATV>>
+\f
+ <TITLE RESTORE-STATE>
+
+ <DECLARE ("VALUE" <OR COMMON!-COMPDEC!-PACKAGE FALSE
+SYMTAB!-COMPDEC!-PACKAGE TEMP!-COMPDEC!-PACKAGE> SAVED-STATE!-COMPDEC!-PACKAGE
+"OPTIONAL" ANY)>
+ <MOVE A* AB>
+TAG1 <PUSH TP* (AB) > ; 1
+ <PUSH TP* (AB) 1>
+ <ADD AB* [<(2) 2>]>
+ <JUMPL AB* TAG1>
+ <HLRES A>
+ <ASH A* -1 >
+ <ADDI A* TAG2>
+ <PUSHJ P* @ (A) 1 >
+ <JRST |FINIS >
+ <TAG3>
+TAG2 <TAG4> ; 11
+TAG4 <PUSH TP* <MQUOTE T> -1> ; 12 [2]
+ <PUSH TP* <MQUOTE T>> ; [3]
+TAG3 <SUBM M* (P) > ; 14
+ <PUSH TP* [0]> ; [4]
+ <PUSH TP* [0]> ; [5]
+ <PUSH TP* <MQUOTE %<TYPE-W SAVED-STATE!-COMPDEC!-PACKAGE LIST>>>; [6]
+ <PUSH TP* [0]> ; [7]
+ <PUSH TP* <TYPE-WORD LIST>> ; [8]
+ <PUSH TP* [0]> ; [9]
+ <INTGO>
+ <MOVE B* (TP) -8> ; (1)
+ <MOVEM B* (TP) -2> ; (7)
+ <MOVE A* <TYPE-WORD FALSE>>
+ <MOVEI B* 0>
+ <MOVE D* (TP) -2> ; (7)
+ <JUMPE D* TAG5>
+TAG29 <PUSH TP* [0]> ; 29 [10]
+ <PUSH TP* [0]> ; [11]
+ <MOVE PVP* (D) 1>
+ <PUSH TP* <MQUOTE %<TYPE-W AC!-COMPDEC!-PACKAGE VECTOR>>>; [12]
+ <PUSH TP* (PVP) 1> ; [13]
+ <HRRZ TVP* (PVP) >
+ <PUSH TP* (TVP) > ; [14]
+ <PUSH TP* (TVP) 1> ; [15]
+ <HRRZ TVP* (PVP) >
+ <HRRZ TVP* (TVP) >
+ <PUSH TP* <TYPE-WORD LIST>> ; [16]
+ <PUSH TP* TVP> ; [17]
+ <SKIPGE |INTFLG >
+ <TAG6>
+ <MOVEM D* (TP) -10> ; (7)
+ <GETYP O* (TP) -3> ; (14)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG7>
+ <MOVE B* (TP) -2> ; (15)
+ <JUMPN B* TAG7>
+ <MOVE C* <TYPE-WORD FALSE>>
+ <MOVEI E* 0>
+ <MOVEM C* (TP) -3> ; (14)
+ <MOVEM E* (TP) -2> ; (15)
+TAG7 <MOVE B* (TP) -4> ; 53 (13)
+ <MOVE D* (B) 14>
+ <MOVE PVP* (B) 15>
+ <JUMPE PVP* TAG8>
+TAG12 <MOVE A* PVP> ; 57
+ <GETYP O* (PVP) 0>
+ <CAIN O* <TYPE-CODE DEFER>>
+ <MOVE A* (A) 1>
+ <MOVE TVP* (A) >
+ <MOVE A* (A) 1>
+ <SKIPGE |INTFLG >
+ <SAVAC O* [<(*71500*) 4>]>
+ <MOVEM D* (TP) -7> ; (10)
+ <MOVEM PVP* (TP) -6> ; (11)
+ <MOVE C* (TP) -8> ; (9)
+ <GETYP E* TVP>
+ <JUMPE C* TAG9>
+TAG11 <GETYP O* (C) 0> ; 70
+ <MOVE SP* C>
+ <CAIN O* <TYPE-CODE DEFER>>
+ <MOVE SP* (SP) 1>
+ <GETYP O* (SP) 0>
+ <CAIN O* (E) 0>
+ <CAME A* (SP) 1>
+ <SKIPA O>
+ <JRST TAG10>
+ <HRRZ C* (C) >
+ <JUMPN C* TAG11>
+TAG9 <PUSH TP* TVP> ; 81 [18]
+ <PUSH TP* A> ; [19]
+ <PUSH TP* <TYPE-WORD FALSE>> ; [20]
+ <PUSH TP* [0]> ; [21]
+ <PUSH TP* <TYPE-WORD FALSE>> ; [22]
+ <PUSH TP* [0]> ; [23]
+ <MCALL 3 SMASH-INACS>
+TAG10 <MOVE D* (TP) -7> ; 88 (10)
+ <MOVE PVP* (TP) -6> ; (11)
+ <HRRZ PVP* (PVP) >
+ <JUMPN PVP* TAG12>
+TAG8 <GETYP O* (TP) -3> ; 92 (14)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG13>
+ <MOVE A* (TP) -3> ; (14)
+ <MOVE B* (TP) -2> ; (15)
+ <PUSH P* [0]>
+ <MOVEI O* |SEGMNT >
+ <PUSHJ P* |RCALL >
+ <POP P* A>
+ <PUSHJ P* |IILIST >
+ <MOVEM A* (TP) -3> ; (14)
+ <MOVEM B* (TP) -2> ; (15)
+TAG13 <MOVE B* (TP) -4> ; 104 (13)
+ <MOVE D* (B) 14>
+ <MOVE PVP* (B) 15>
+ <MOVE O* (TP) -3> ; (14)
+ <MOVEM O* (B) 14>
+ <MOVE O* (TP) -2> ; (15)
+ <MOVEM O* (B) 15>
+ <MOVE TVP* (TP) > ; (17)
+ <MOVE A* <TYPE-WORD FALSE>>
+ <MOVEI B* 0>
+ <MOVEM D* (TP) -13> ; (4)
+ <MOVEM PVP* (TP) -12> ; (5)
+ <JUMPE TVP* TAG14>
+TAG28 <PUSH TP* <TYPE-WORD LIST>> ; 117 [18]
+ <PUSH TP* [0]> ; [19]
+ <PUSH TP* <MQUOTE %<TYPE-W SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>; [20]
+ <PUSH TP* [0]> ; [21]
+ <MOVE E* (TVP) 1>
+ <PUSH TP* (E) > ; [22]
+ <PUSH TP* (E) 1> ; [23]
+ <HRRZ C* (E) >
+ <GETYP O* (C) 0>
+ <CAIN O* <TYPE-CODE DEFER>>
+ <MOVE C* (C) 1>
+ <PUSH TP* (C) > ; [24]
+ <PUSH TP* (C) 1> ; [25]
+ <SKIPGE |INTFLG >
+ <TAG15>
+ <MOVEM E* (TP) -6> ; (19)
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (TP) -15> ; (10)
+ <MOVEM TVP* (TP) -14> ; (11)
+ <GETYP O* (TP) -3> ; (22)
+ <CAIE O* <MQUOTE %<TYPE-C SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>
+ <JRST TAG16>
+ <MOVE B* (TP) -2> ; (23)
+ <PUSH TP* <MQUOTE %<TYPE-W SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>; [26]
+ <PUSH TP* B> ; [27]
+ <JUMPE E* |CERR2 >
+ <HRRZ C* (E) >
+ <JUMPE C* |CERR2 >
+ <HRRZ C* (C) >
+ <JUMPE C* |CERR2 >
+ <PUSH TP* (C) > ; [28]
+ <PUSH TP* (C) 1> ; [29]
+ <MOVEI C* 3 >
+TAG17 <JUMPE E* |CERR2 > ; 150
+ <HRRZ E* (E) >
+ <SOJG C* TAG17>
+ <JUMPE E* |CERR2 >
+ <PUSH TP* (E) > ; [30]
+ <PUSH TP* (E) 1> ; [31]
+ <MOVEM B* (TP) -10> ; (21)
+ <MCALL 3 GET-STORED>
+ <MOVE D* (TP) -4> ; (21)
+ <MOVEM A* (D) 26>
+ <MOVEM B* (D) 27>
+ <MOVE D* (TP) -2> ; (23)
+ <MOVE PVP* (D) 32>
+ <MOVE TVP* (D) 33>
+ <GETYP O* PVP>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG18>
+ <JUMPGE B* TAG16>
+ <MOVE C* (TVP) 1>
+ <ADD C* [<(60) 60>]>
+ <JUMPGE C* |CERR2 >
+ <MOVE E* (C) 1>
+ <JUMPE E* TAG19>
+TAG20 <GETYP O* (E) 0> ; 173
+ <CAIN O* <MQUOTE %<TYPE-C SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>
+ <CAME D* (E) 1>
+ <SKIPA O>
+ <JRST TAG16>
+ <HRRZ E* (E) >
+ <JUMPN E* TAG20>
+TAG19 <GETYP O* (TP) -23> ; 180 (2)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG16>
+ <MOVE C* (TP) -20> ; (5)
+ <JUMPE C* TAG21>
+TAG22 <GETYP O* (C) 0> ; 185
+ <CAIN O* <MQUOTE %<TYPE-C SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>
+ <CAME D* (C) 1>
+ <SKIPA O>
+ <JRST TAG16>
+ <HRRZ C* (C) >
+ <JUMPN C* TAG22>
+TAG21 <PUSH TP* <MQUOTE %<TYPE-W SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>; 192 [26
+]
+ <PUSH TP* D> ; [27]
+ <MCALL 1 KILL-LOOP-AC>
+ <JUMPGE B* TAG16>
+ <PUSH TP* <MQUOTE %<TYPE-W AC!-COMPDEC!-PACKAGE VECTOR>>>; [26]
+ <PUSH TP* (TP) -13> ; (13) [27]
+ <PUSH TP* (TP) -5> ; (22) [28]
+ <PUSH TP* (TP) -5> ; (23) [29]
+ <MCALL 2 FLUSH-RESIDUE>
+ <JUMPGE B* TAG16>
+ <JRST TAG23>
+TAG18 <MOVE C* (TP) -6> ; 203 (19)
+ <MOVEI E* 3 >
+TAG24 <JUMPE C* |CERR2 > ; 205
+ <HRRZ C* (C) >
+ <SOJG E* TAG24>
+ <JUMPE C* |CERR2 >
+ <GETYP O* (C) 0>
+ <CAIN O* <TYPE-CODE DEFER>>
+ <MOVE C* (C) 1>
+ <GETYP O* (C) 0>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG16>
+ <PUSH TP* <MQUOTE %<TYPE-W AC!-COMPDEC!-PACKAGE VECTOR>>>; [26]
+ <PUSH TP* (TP) -13> ; (13) [27]
+ <PUSH TP* <MQUOTE %<TYPE-W SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>; [28]
+ <PUSH TP* D> ; [29]
+ <MCALL 2 FLUSH-RESIDUE>
+TAG23 <MOVE B* <TYPE-WORD FALSE>> ; 220
+ <MOVEI D* 0>
+ <MOVEM B* (TP) -1> ; (24)
+ <MOVEM D* (TP) > ; (25)
+TAG16 <MOVE B* (TP) -16> ; 224 (9)
+ <MOVE D* (TP) -2> ; (23)
+ <GETYP PVP* (TP) -3> ; (22)
+ <JUMPE B* TAG25>
+TAG27 <GETYP O* (B) 0> ; 228
+ <CAIN O* (PVP) 0>
+ <CAME D* (B) 1>
+ <SKIPA O>
+ <JRST TAG26>
+ <HRRZ B* (B) >
+ <JUMPN B* TAG27>
+TAG25 <MOVE E* (TP) -16> ; 235 (9)
+ <MOVE C* (TP) -3> ; (22)
+ <MOVE D* (TP) -2> ; (23)
+ <PUSHJ P* |C1CONS >
+ <MOVEM A* (TP) -17> ; (8)
+ <MOVEM B* (TP) -16> ; (9)
+TAG26 <PUSH TP* (TP) -3> ; 241 (22) [26]
+ <PUSH TP* (TP) -3> ; (23) [27]
+ <PUSH TP* (TP) -3> ; (24) [28]
+ <PUSH TP* (TP) -3> ; (25) [29]
+ <MCALL 2 SMASH-INACS>
+ <SUB TP* [<(8) 8>]>
+ <MOVE TVP* (TP) -6> ; (11)
+ <HRRZ TVP* (TVP) >
+ <JUMPN TVP* TAG28>
+TAG14 <SUB TP* [<(8) 8>]> ; 250
+ <HRRZ O* @ (TP) -2> ; (7)
+ <MOVEM O* (TP) -2> ; (7)
+ <JUMPN O* TAG29>
+TAG5 <SUB TP* [<(10) 10>]> ; 254
+ <JRST |MPOPJ >
+ <(2) 2>
+ <0>
+TAG6 <*120012*> ; 258
+ <(*120000*) 0>
+ <IMULI TB* (TP) -3> ; (-4)
+ <IMULI TB* (PVP) 0>
+ <(*71500*) 4>
+ <IMULI TB* 7 >
+ <IMULI TB* (C) 0>
+ <IMULI TB* (SP) 0>
+TAG15 <*1204*> ; 266
+ <(*120000*) 0>
+ <IMULI TB* 6 >
+ <(60) 60>
+ <IMULI TB* (E) 0>
+ <IMULI TB* (TP) -23> ; (-24)
+ <IMULI TB* (C) 0>
+ <IMULI TB* (C) 0>
+ <IMULI TB* (B) 0>
+ <(8) 8>
+ <(10) 10>
+ <(2) *16*>
+ <(1) *14*>
+ <(*65523*) *200604*>
+ <0>
+ <(2) 2>
+
+\f
+<DEFINE ASSERT-TYPES (L)
+ #DECL ((L) <LIST [REST <LIST SYMTAB ANY ANY>]>)
+ <MAPF <>
+ <FUNCTION (LL) <SET-CURRENT-TYPE <1 .LL> <2 .LL>>>
+ .L>>
+\f
+ <TITLE ASSERT-TYPES>
+
+ <DECLARE ("VALUE" <OR FALSE SYMTAB!-COMPDEC!-PACKAGE> <LIST [REST <LIST
+SYMTAB!-COMPDEC!-PACKAGE ANY ANY>]>)>
+ <PUSH TP* (AB) >
+ <PUSH TP* (AB) 1>
+ <PUSHJ P* TAG1>
+ <JRST |FINIS >
+TAG1 <SUBM M* (P) > ; 4
+ <PUSH TP* <TYPE-WORD LIST>> ; [2]
+ <PUSH TP* [0]> ; [3]
+ <INTGO>
+ <MOVE B* (TP) -2> ; (1)
+ <MOVEM B* (TP) > ; (3)
+ <MOVE A* <TYPE-WORD FALSE>>
+ <MOVEI B* 0>
+ <MOVE D* (TP) > ; (3)
+ <JUMPE D* TAG2>
+TAG3 <MOVE PVP* (D) 1> ; 15
+ <SKIPGE |INTFLG >
+ <SAVAC O* [*120012*]>
+ <PUSH TP* <MQUOTE %<TYPE-W SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>; [4]
+ <PUSH TP* (PVP) 1> ; [5]
+ <HRRZ PVP* (PVP) >
+ <GETYP O* (PVP) 0>
+ <CAIN O* <TYPE-CODE DEFER>>
+ <MOVE PVP* (PVP) 1>
+ <PUSH TP* (PVP) > ; [6]
+ <PUSH TP* (PVP) 1> ; [7]
+ <MOVEM D* (TP) -4> ; (3)
+ <MCALL 2 SET-CURRENT-TYPE>
+ <HRRZ O* @ (TP) > ; (3)
+ <MOVEM O* (TP) > ; (3)
+ <JUMPN O* TAG3>
+TAG2 <SUB TP* [<(4) 4>]> ; 31
+ <JRST |MPOPJ >
+ <0>
+ <*120012*>
+ <IMULI TB* (PVP) 0>
+ <(4) 4>
+ <(1) 4>
+ <(*50753*) *202076*>
+ <0>
+ <(1) 2>
+
+\f
+<DEFINE SAME-DECL? (D1 D2) <OR <=? .D1 .D2> <NOT <TYPE-OK? .D2 <NOTIFY .D1>>>>>
+
+ <TITLE SAME-DECL?>
+
+ <DECLARE ("VALUE" <OR ATOM FALSE> ANY ANY)>
+ <PUSH TP* (AB) > ; [0]
+ <PUSH TP* (AB) 1> ; [1]
+ <PUSH TP* (AB) 2> ; [2]
+ <PUSH TP* (AB) 3> ; [3]
+ <PUSHJ P* TAG1>
+ <JRST |FINIS >
+TAG1 <SUBM M* (P) > ; 6
+ <INTGO>
+ <MOVE A* (TP) -3> ; (0)
+ <MOVE B* (TP) -2> ; (1)
+ <MOVE C* (TP) -1> ; (2)
+ <MOVE D* (TP) > ; (3)
+ <PUSHJ P* |CIEQUA >
+ <JRST TAG2>
+ <JRST TAG3>
+TAG2 <PUSH TP* (TP) -1> ; 16 (2) [4]
+ <PUSH TP* (TP) -1> ; (3) [5]
+ <PUSH TP* (TP) -5> ; (0) [6]
+ <PUSH TP* (TP) -5> ; (1) [7]
+ <MCALL 1 NOTIFY>
+ <PUSH TP* A> ; [6]
+ <PUSH TP* B> ; [7]
+ <MCALL 2 TYPE-OK?>
+ <GETYP O* A>
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG4>
+ <MOVE A* <MQUOTE T> -1>
+ <MOVE B* <MQUOTE T>>
+ <JRST TAG3>
+TAG4 <MOVE A* <TYPE-WORD FALSE>> ; 30
+ <MOVEI B* 0>
+TAG3 <SUB TP* [<(4) 4>]> ; 32
+ <JRST |MPOPJ >
+ <IMULI TB* 1 >
+ <(4) 4>
+ <(2) 6>
+ <(*66261*) *202777*>
+ <0>
+ <(1) 2>
+
+\f
+<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>>
+\f
+ <TITLE AC?>
+
+ <DECLARE ("VALUE" ANY SYMTAB!-COMPDEC!-PACKAGE LIST)>
+ <PUSH TP* (AB) >
+ <PUSH TP* (AB) 1>
+ <PUSH TP* (AB) 2>
+ <PUSH TP* (AB) 3>
+ <PUSHJ P* TAG1>
+ <JRST |FINIS >
+TAG1 <SUBM M* (P) > ; 6
+ <PUSH TP* <TYPE-WORD LIST>> ; [4]
+ <PUSH TP* [0]> ; [5]
+ <INTGO>
+ <MOVE B* (TP) -2> ; (3)
+ <MOVEM B* (TP) > ; (5)
+ <MOVE A* <TYPE-WORD FALSE>>
+ <MOVEI B* 0>
+ <MOVE D* (TP) > ; (5)
+ <JUMPE D* TAG2>
+TAG8 <MOVE PVP* (D) 1> ; 17
+ <SKIPGE |INTFLG >
+ <SAVAC O* [*120012*]>
+ <PUSH TP* <TYPE-WORD LIST>> ; [6]
+ <PUSH TP* [0]> ; [7]
+ <MOVEM D* (TP) -2> ; (5)
+TAG7 <SKIPGE |INTFLG > ; 23
+ <SAVAC O* [*120012*]>
+ <JUMPN PVP* TAG3>
+ <MOVEI B* 0>
+ <SUB TP* [<(2) 2>]>
+ <JRST TAG4>
+TAG3 <MOVEM PVP* (TP) > ; 29 (7)
+ <GETYP O* (PVP) 0>
+ <CAIN O* <TYPE-CODE DEFER>>
+ <MOVE PVP* (PVP) 1>
+ <MOVE B* (PVP) >
+ <MOVE TVP* (PVP) 1>
+ <GETYP O* B>
+ <CAMN TVP* (TP) -6> ; (1)
+ <CAIE O* <MQUOTE %<TYPE-C SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>
+ <JRST TAG5>
+ <MOVE E* (TP) > ; (7)
+ <JUMPE E* |CERR2 >
+ <HRRZ E* (E) >
+ <JUMPE E* |CERR2 >
+ <GETYP O* (E) 0>
+ <CAIN O* <TYPE-CODE DEFER>>
+ <MOVE E* (E) 1>
+ <MOVE A* (E) >
+ <MOVE B* (E) 1>
+ <SUB TP* [<(2) 2>]>
+ <JRST TAG2>
+TAG5 <MOVE E* (TP) > ; 50 (7)
+ <MOVEI C* 4 >
+TAG6 <JUMPE E* |CERR2 > ; 52
+ <HRRZ E* (E) >
+ <SOJG C* TAG6>
+ <MOVE PVP* E>
+ <JRST TAG7>
+TAG4 <MOVE A* <TYPE-WORD FALSE>> ; 57
+ <HRRZ O* @ (TP) > ; (5)
+ <MOVEM O* (TP) > ; (5)
+ <JUMPN O* TAG8>
+TAG2 <SUB TP* [<(6) 6>]> ; 61
+ <JRST |MPOPJ >
+ <0>
+ <*120012*>
+ <(2) 2>
+ <IMULI TB* (PVP) 0>
+ <IMULI TB* 2 >
+ <IMULI TB* (E) 0>
+ <(6) 6>
+ <(2) 6>
+ <(*50507*) *650000*>
+ <0>
+ <(1) 2>
+
+\f
+<DEFINE FIXUP-STORES (STATE)
+ #DECL ((STATE) <LIST [REST REP-STATE <PRIMTYPE LIST> LIST <OR ATOM FALSE>]>)
+ <REPEAT ((PTR .STATE))
+ <COND (<EMPTY? .PTR> <RETURN>)>
+ <MAPR <>
+ <FUNCTION (STATE-ITEMS "AUX" SYMT PAC (STATE-ITEM <1 .STATE-ITEMS>))
+ <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>>>>
+\f
+ <TITLE FIXUP-STORES>
+
+ <DECLARE ("VALUE" ATOM <LIST [REST REP-STATE!-COMPDEC!-PACKAGE <PRIMTYPE
+LIST> LIST <OR ATOM FALSE>]>)>
+ <PUSH TP* (AB) >
+ <PUSH TP* (AB) 1>
+ <PUSHJ P* TAG1>
+ <JRST |FINIS >
+TAG1 <SUBM M* (P) > ; 4
+ <INTGO>
+ <PUSH TP* <TYPE-WORD LIST>> ; [2]
+ <PUSH TP* (TP) -1> ; (1) [3]
+TAG31 <INTGO> ; 9
+ <MOVE B* (TP) > ; (3)
+ <JUMPN B* TAG2>
+ <MOVE B* <MQUOTE T>>
+ <SUB TP* [<(2) 2>]>
+ <JRST TAG3>
+TAG2 <PUSH TP* <TYPE-WORD FALSE>> ; 16 [4]
+ <PUSH TP* [0]> ; [5]
+ <GETYP O* (B) 0>
+ <CAIN O* <TYPE-CODE DEFER>>
+ <MOVE B* (B) 1>
+ <PUSH TP* (B) > ; [6]
+ <PUSH TP* (B) 1> ; [7]
+ <PUSH P* [-1]>
+TAG29 <MOVEI O* 6 > ; 24
+ <PUSHJ P* |NTPALO >
+ <MOVE A* (TP) -7> ; (6)
+ <MOVE B* (TP) -6> ; (7)
+ <PUSHJ P* |TYPSEG >
+ <SKIPL (P) >
+ <XCT (C) |INCR1 >
+ <XCT (C) |TESTR >
+ <JRST TAG4>
+ <MOVE A* |DSTORE >
+ <MOVE B* D>
+ <MOVE O* |DSTORE >
+ <MOVEM O* (TP) -7> ; (6)
+ <MOVEM D* (TP) -6> ; (7)
+ <SETZM |DSTORE >
+ <MOVEI C* 1 >
+ <MOVEM A* (TP) -5> ; (8)
+ <MOVEM B* (TP) -4> ; (9)
+ <PUSHJ P* |CINTH >
+ <PUSH TP* A> ; [14]
+ <PUSH TP* B> ; [15]
+ <INTGO>
+ <PUSH TP* [0]> ; [16]
+ <PUSH TP* [0]> ; [17]
+TAG16 <INTGO> ; 49
+ <MOVE A* (TP) -5> ; (12)
+ <MOVE B* (TP) -4> ; (13)
+ <PUSHJ P* |CEMPTY >
+ <JRST TAG5>
+TAG13 <SUB TP* [<(2) 2>]> ; 55
+ <JRST TAG6>
+TAG5 <MOVE A* (TP) -5> ; 57 (12)
+ <MOVE B* (TP) -4> ; (13)
+ <MOVEI C* 1 >
+ <PUSHJ P* |CINTH >
+ <MOVEM A* (TP) -7> ; (10)
+ <MOVEM B* (TP) -6> ; (11)
+ <MOVE A* (TP) -5> ; (12)
+ <MOVE B* (TP) -4> ; (13)
+ <MOVEI C* 4 >
+ <PUSHJ P* |CINTH >
+ <GETYP O* A>
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG7>
+ <MOVE A* (TP) -5> ; (12)
+ <MOVE B* (TP) -4> ; (13)
+ <MOVEI C* 3 >
+ <PUSHJ P* |CINTH >
+ <GETYP O* A>
+ <CAMN B* <MQUOTE T>>
+ <CAIE O* <TYPE-CODE ATOM>>
+ <SKIPA O>
+ <JRST TAG8>
+TAG7 <MOVE A* (TP) -5> ; 79 (12)
+ <MOVE B* (TP) -4> ; (13)
+ <MOVEI C* 3 >
+ <PUSHJ P* |CINTH >
+ <GETYP O* A>
+ <CAMN B* <MQUOTE T>>
+ <CAIE O* <TYPE-CODE ATOM>>
+ <SKIPA O>
+ <JRST TAG9>
+ <MOVE A* (TP) -5> ; (12)
+ <MOVE B* (TP) -4> ; (13)
+ <MOVEI C* 3 >
+ <PUSHJ P* |CINTH >
+ <MOVEM A* (TP) -1> ; (16)
+ <MOVEM B* (TP) > ; (17)
+ <MOVE B* <MQUOTE KILL-LIST!-CACS!-PACKAGE>>
+ <PUSHJ P* |CILVAL >
+ <MOVE C* A>
+ <MOVE D* B>
+ <MOVE A* (TP) -1> ; (16)
+ <MOVE B* (TP) > ; (17)
+ <PUSHJ P* |CIMEMQ >
+ <SKIPA O>
+ <JRST TAG10>
+TAG9 <MOVE A* (TP) -5> ; 103 (12)
+ <MOVE B* (TP) -4> ; (13)
+ <MOVEI C* 4 >
+ <PUSHJ P* |CINTH >
+ <GETYP O* A>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG8>
+ <MOVE A* (TP) -5> ; (12)
+ <MOVE B* (TP) -4> ; (13)
+ <MOVEI C* 3 >
+ <PUSHJ P* |CINTH >
+ <GETYP O* A>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG8>
+ <MOVE B* (TP) -6> ; (11)
+ <MOVE D* (B) 32>
+ <MOVE PVP* (B) 33>
+ <MOVEM D* (TP) -5> ; (12)
+ <MOVEM PVP* (TP) -4> ; (13)
+ <GETYP O* D>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG8>
+ <MOVE A* D>
+ <MOVE B* PVP>
+ <MOVEI C* 1 >
+ <PUSHJ P* |CINTH >
+ <ADD B* [<(60) 60>]>
+ <JUMPGE B* |CERR2 >
+ <MOVE D* (B) 1>
+ <MOVE B* (TP) -6> ; (11)
+ <GETYP PVP* (TP) -7> ; (10)
+ <JUMPE D* TAG8>
+TAG12 <GETYP O* (D) 0> ; 135
+ <MOVE TVP* D>
+ <CAIN O* <TYPE-CODE DEFER>>
+ <MOVE TVP* (TVP) 1>
+ <GETYP O* (TVP) 0>
+ <CAIN O* (PVP) 0>
+ <CAME B* (TVP) 1>
+ <SKIPA O>
+ <JRST TAG11>
+ <HRRZ D* (D) >
+ <JUMPN D* TAG12>
+ <JRST TAG8>
+TAG11 <MOVE A* (TP) -5> ; 147 (12)
+ <MOVE B* (TP) -4> ; (13)
+ <MOVEI C* 3 >
+ <PUSHJ P* |CINTH >
+ <GETYP O* A>
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG8>
+TAG10 <MOVE A* (TP) -5> ; 154 (12)
+ <MOVE B* (TP) -4> ; (13)
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVEI D* 3 >
+ <PUSH TP* <TYPE-WORD FALSE>> ; [18]
+ <PUSH TP* [0]> ; [19]
+ <PUSHJ P* |CIPUT >
+TAG8 <MOVE A* (TP) -5> ; 161 (12)
+ <MOVE B* (TP) -4> ; (13)
+ <MOVEI C* 4 >
+ <PUSHJ P* |CINTH >
+ <GETYP O* A>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG13>
+ <MOVE B* (TP) -6> ; (11)
+ <MOVE D* (B) 32>
+ <MOVE PVP* (B) 33>
+ <MOVEM D* (TP) -5> ; (12)
+ <MOVEM PVP* (TP) -4> ; (13)
+ <GETYP O* D>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG14>
+ <MOVE A* D>
+ <MOVE B* PVP>
+ <MOVEI C* 1 >
+ <PUSHJ P* |CINTH >
+ <ADD B* [<(60) 60>]>
+ <JUMPGE B* |CERR2 >
+ <MOVE D* (B) 1>
+ <MOVE B* (TP) -6> ; (11)
+ <GETYP PVP* (TP) -7> ; (10)
+ <JUMPE D* TAG14>
+TAG15 <GETYP O* (D) 0> ; 186
+ <MOVE TVP* D>
+ <CAIN O* <TYPE-CODE DEFER>>
+ <MOVE TVP* (TVP) 1>
+ <GETYP O* (TVP) 0>
+ <CAIN O* (PVP) 0>
+ <CAME B* (TVP) 1>
+ <SKIPA O>
+ <JRST TAG13>
+ <HRRZ D* (D) >
+ <JUMPN D* TAG15>
+TAG14 <MOVE A* (TP) -5> ; 197 (12)
+ <MOVE B* (TP) -4> ; (13)
+ <MOVEI C* 4 >
+ <PUSHJ P* |CIREST >
+ <MOVEM A* (TP) -5> ; (12)
+ <MOVEM B* (TP) -4> ; (13)
+ <JRST TAG16>
+TAG6 <MOVE A* (TP) -3> ; 204 (12)
+ <MOVE B* (TP) -2> ; (13)
+ <PUSHJ P* |CEMPTY >
+ <SKIPA O>
+ <JRST TAG17>
+ <PUSH TP* [0]> ; [16]
+ <PUSH TP* [0]> ; [17]
+ <PUSH TP* (TP) -5> ; (12) [18]
+ <PUSH TP* (TP) -5> ; (13) [19]
+ <MOVE A* (TP) -7> ; (12)
+ <MOVE B* (TP) -6> ; (13)
+ <MOVEI C* 4 >
+ <PUSHJ P* |CIREST >
+ <PUSH TP* A> ; [20]
+ <PUSH TP* B> ; [21]
+TAG28 <INTGO> ; 219
+ <MOVE A* (TP) -3> ; (18)
+ <MOVE B* (TP) -2> ; (19)
+ <PUSHJ P* |CEMPTY >
+ <JRST TAG18>
+ <SUB TP* [<(6) 6>]>
+ <JRST TAG17>
+TAG18 <MOVE A* (TP) -3> ; 227 (18)
+ <MOVE B* (TP) -2> ; (19)
+ <MOVEI C* 1 >
+ <PUSHJ P* |CINTH >
+ <MOVEM A* (TP) -11> ; (10)
+ <MOVEM B* (TP) -10> ; (11)
+ <MOVE A* (TP) -3> ; (18)
+ <MOVE B* (TP) -2> ; (19)
+ <MOVEI C* 4 >
+ <PUSHJ P* |CINTH >
+ <GETYP O* A>
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG19>
+ <MOVE A* (TP) -3> ; (18)
+ <MOVE B* (TP) -2> ; (19)
+ <MOVEI C* 3 >
+ <PUSHJ P* |CINTH >
+ <GETYP O* A>
+ <CAMN B* <MQUOTE T>>
+ <CAIE O* <TYPE-CODE ATOM>>
+ <SKIPA O>
+ <JRST TAG20>
+TAG19 <MOVE A* (TP) -3> ; 249 (18)
+ <MOVE B* (TP) -2> ; (19)
+ <MOVEI C* 3 >
+ <PUSHJ P* |CINTH >
+ <GETYP O* A>
+ <CAMN B* <MQUOTE T>>
+ <CAIE O* <TYPE-CODE ATOM>>
+ <SKIPA O>
+ <JRST TAG21>
+ <MOVE A* (TP) -3> ; (18)
+ <MOVE B* (TP) -2> ; (19)
+ <MOVEI C* 3 >
+ <PUSHJ P* |CINTH >
+ <MOVEM A* (TP) -5> ; (16)
+ <MOVEM B* (TP) -4> ; (17)
+ <MOVE B* <MQUOTE KILL-LIST!-CACS!-PACKAGE>>
+ <PUSHJ P* |CILVAL >
+ <MOVE C* A>
+ <MOVE D* B>
+ <MOVE A* (TP) -5> ; (16)
+ <MOVE B* (TP) -4> ; (17)
+ <PUSHJ P* |CIMEMQ >
+ <SKIPA O>
+ <JRST TAG22>
+TAG21 <MOVE A* (TP) -3> ; 273 (18)
+ <MOVE B* (TP) -2> ; (19)
+ <MOVEI C* 4 >
+ <PUSHJ P* |CINTH >
+ <GETYP O* A>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG20>
+ <MOVE A* (TP) -3> ; (18)
+ <MOVE B* (TP) -2> ; (19)
+ <MOVEI C* 3 >
+ <PUSHJ P* |CINTH >
+ <GETYP O* A>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG20>
+ <MOVE B* (TP) -10> ; (11)
+ <MOVE D* (B) 32>
+ <MOVE PVP* (B) 33>
+ <MOVEM D* (TP) -9> ; (12)
+ <MOVEM PVP* (TP) -8> ; (13)
+ <GETYP O* D>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG20>
+ <MOVE A* D>
+ <MOVE B* PVP>
+ <MOVEI C* 1 >
+ <PUSHJ P* |CINTH >
+ <ADD B* [<(60) 60>]>
+ <JUMPGE B* |CERR2 >
+ <MOVE D* (B) 1>
+ <MOVE B* (TP) -10> ; (11)
+ <GETYP PVP* (TP) -11> ; (10)
+ <JUMPE D* TAG20>
+TAG24 <GETYP O* (D) 0> ; 305
+ <MOVE TVP* D>
+ <CAIN O* <TYPE-CODE DEFER>>
+ <MOVE TVP* (TVP) 1>
+ <GETYP O* (TVP) 0>
+ <CAIN O* (PVP) 0>
+ <CAME B* (TVP) 1>
+ <SKIPA O>
+ <JRST TAG23>
+ <HRRZ D* (D) >
+ <JUMPN D* TAG24>
+ <JRST TAG20>
+TAG23 <MOVE A* (TP) -9> ; 317 (12)
+ <MOVE B* (TP) -8> ; (13)
+ <MOVEI C* 3 >
+ <PUSHJ P* |CINTH >
+ <GETYP O* A>
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG20>
+TAG22 <MOVE A* (TP) -3> ; 324 (18)
+ <MOVE B* (TP) -2> ; (19)
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVEI D* 3 >
+ <PUSH TP* <TYPE-WORD FALSE>> ; [22]
+ <PUSH TP* [0]> ; [23]
+ <PUSHJ P* |CIPUT >
+TAG20 <MOVE A* (TP) -3> ; 331 (18)
+ <MOVE B* (TP) -2> ; (19)
+ <MOVEI C* 4 >
+ <PUSHJ P* |CINTH >
+ <GETYP O* A>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG25>
+ <MOVE B* (TP) -10> ; (11)
+ <MOVE D* (B) 32>
+ <MOVE PVP* (B) 33>
+ <MOVEM D* (TP) -9> ; (12)
+ <MOVEM PVP* (TP) -8> ; (13)
+ <GETYP O* D>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG26>
+ <MOVE A* D>
+ <MOVE B* PVP>
+ <MOVEI C* 1 >
+ <PUSHJ P* |CINTH >
+ <ADD B* [<(60) 60>]>
+ <JUMPGE B* |CERR2 >
+ <MOVE D* (B) 1>
+ <MOVE B* (TP) -10> ; (11)
+ <GETYP PVP* (TP) -11> ; (10)
+ <JUMPE D* TAG26>
+TAG27 <GETYP O* (D) 0> ; 356
+ <MOVE TVP* D>
+ <CAIN O* <TYPE-CODE DEFER>>
+ <MOVE TVP* (TVP) 1>
+ <GETYP O* (TVP) 0>
+ <CAIN O* (PVP) 0>
+ <CAME B* (TVP) 1>
+ <SKIPA O>
+ <JRST TAG25>
+ <HRRZ D* (D) >
+ <JUMPN D* TAG27>
+TAG26 <MOVE A* (TP) -3> ; 367 (18)
+ <MOVE B* (TP) -2> ; (19)
+ <MOVEI C* 4 >
+ <PUSHJ P* |CIREST >
+ <SKIPN (TP) -4> ; (17)
+ <JRST |CERR2 >
+ <HRRM B* @ (TP) -4> ; (17)
+TAG25 <MOVE A* (TP) -3> ; 374 (18)
+ <MOVE B* (TP) -2> ; (19)
+ <MOVEI C* 4 >
+ <PUSHJ P* |CIREST >
+ <MOVEM A* (TP) -3> ; (18)
+ <MOVEM B* (TP) -2> ; (19)
+ <MOVE A* (TP) -5> ; (16)
+ <MOVE B* (TP) -4> ; (17)
+ <MOVEI C* 4 >
+ <PUSHJ P* |CIREST >
+ <MOVEM A* (TP) -5> ; (16)
+ <MOVEM B* (TP) -4> ; (17)
+ <JRST TAG28>
+TAG17 <MOVE A* (TP) -7> ; 387 (8)
+ <MOVE B* (TP) -6> ; (9)
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVEI D* 1 >
+ <PUSH TP* (TP) -3> ; (12) [16]
+ <PUSH TP* (TP) -3> ; (13) [17]
+ <PUSHJ P* |CIPUT >
+ <SUB TP* [<(8) 8>]>
+ <SETZM (P) >
+ <JRST TAG29>
+TAG4 <SUB TP* [<(6) 6>]> ; 397
+ <SETZM |DSTORE >
+ <SUB TP* [<(4) 4>]>
+ <SUB P* [<(1) 1>]>
+ <MOVE B* (TP) > ; (3)
+ <MOVEI D* 4 >
+TAG30 <JUMPE B* |CERR2 > ; 403
+ <HRRZ B* (B) >
+ <SOJG D* TAG30>
+ <MOVEM B* (TP) > ; (3)
+ <JRST TAG31>
+TAG3 <SUB TP* [<(2) 2>]> ; 408
+ <MOVE A* <TYPE-WORD ATOM>>
+ <JRST |MPOPJ >
+ <(2) 2>
+ <0>
+ <IMULI TB* (B) 0>
+ <-1>
+ <IMULI TB* 1 >
+ <IMULI TB* 4 >
+ <(60) 60>
+ <IMULI TB* (TP) -7> ; (-8)
+ <IMULI TB* (D) 0>
+ <IMULI TB* (TVP) 0>
+ <(6) 6>
+ <IMULI TB* (TP) -11> ; (-12)
+ <(8) 8>
+ <(4) 4>
+ <(1) 1>
+ <(1) 4>
+ <(*54454*) *24755*>
+ <0>
+ <(1) 2>
+\f
+<DEFINE HMAPFR (MNOD WHERE K
+ "AUX" XX (NTSLOTS .NTSLOTS)
+ (NTMPS
+ <COND (.PRE .TMPS) (<STACK:L .STK .BSTB>) (ELSE (0))>)
+ TEM NSLOTS (SPECD <>) STB (DTEM <DATUM FIX ANY-AC>)
+ (STKOFFS <>) (FAP <1 .K>) (INRAP <2 .K>) F? (POFF 0)
+ (ANY? <>) (NARG <LENGTH <SET K <REST .K 2>>>) START:TAG
+ (R? <==? <NODE-SUBR .MNOD> ,MAPR>) STRV (FF? <>)
+ (MAPEND <ILIST .NARG '<MAKE:TAG "MAP">>) (OSTK .STK)
+ (MAPLP <MAKE:TAG "MAP">) (MAPL2 <MAKE:TAG "MAP">) MAP:OFF
+ (SUBRC <AP? .FAP>) STOP (STK (0 !.STK)) (TMPS .TMPS) BTP
+ (BASEF .BASEF) (FRMS .FRMS) (MAYBE-FALSE <>) (OPRE .PRE)
+ (OTAG ()) DEST CD (AC-HACK .AC-HACK)
+ (EXIT <MAKE:TAG "MAPEX">) (APPLTAG <MAKE:TAG "MAPAP">) TT
+ GMF (OUTD .WHERE) OUTSAV CHF (FLS <==? .WHERE FLUSHED>)
+ (RTAG <MAKE:TAG "MAP">) (NEED-INT T) FSYM OS NS (DOIT T)
+ RV GSTK)
+ #DECL ((NTSLOTS) <SPECIAL LIST> (DTEM) DATUM
+ (SPECD) <SPECIAL <OR FALSE ATOM>> (TEM) <OR ATOM DATUM> (OFFS) FIX
+ (TMPS) <SPECIAL LIST> (POFF NSLOTS NARG) <SPECIAL FIX> (FAP) NODE
+ (BASEF MNOD INRAP) <SPECIAL NODE> (K) <LIST [REST NODE]>
+ (MAPEND) <LIST [REST ATOM]> (MAP:OFF) ATOM
+ (EXIT MAPLP RTAG APPLTAG) <SPECIAL ATOM> (OSTK) LIST
+ (DEST CD) <SPECIAL <OR ATOM DATUM>> (FRMS) <SPECIAL LIST>
+ (STOP STRV STB BTP STK GSTK) <SPECIAL LIST>
+ (AC-HACK START:TAG) <SPECIAL ANY>
+ (GMF MAYBE-FALSE ANY?) <SPECIAL ANY> (FSYM) SYMTAB)
+ <PUT .INRAP ,SPECS-START <- <SPECS-START .INRAP> .TOT-SPEC>>
+ <PROG ((PRE .PRE))
+ #DECL ((PRE) <SPECIAL ANY>)
+ <COND (<AND <NOT <EMPTY? .K>>
+ <MAPF <>
+ <FUNCTION (Z)
+ <AND <TYPE-OK? <RESULT-TYPE .Z>
+ '<PRIMTYPE LIST>>
+ <MAPLEAVE <>>>
+ T>
+ .K>>
+ <SET NEED-INT <>>)>
+ <COND (<AND <NOT <AND <EMPTY? .K> <NODE-NAME .FAP>>>
+ <OR <==? <NODE-NAME .FAP> <>>
+ <AND <==? <NODE-TYPE .FAP> ,MFIRST-CODE>
+ <N==? <NODE-SUBR .FAP> 5>>
+ .SUBRC>
+ <OR <EMPTY? .K>
+ <==? <NAME-SYM <1 <BINDING-STRUCTURE .INRAP>>>
+ DUMMY-MAPF>>>
+ <SET GMF T>)
+ (ELSE <SET GMF <>>)>
+ <COND (<AND <NOT <EMPTY? .K>>
+ <L=? <MAPF ,MIN
+ <FUNCTION (N)
+ #DECL ((N) NODE)
+ <MINL <RESULT-TYPE .N>>>
+ .K>
+ 0>>
+ <SET CHF T>)
+ (ELSE <SET CHF <>>)>
+ <SET DEST <SET OUTD <COND (.FLS FLUSHED) (ELSE <GOODACS .MNOD .WHERE>)>>>
+ <OR .PRE <EMIT-PRE <NOT <OR <ACTIVATED .INRAP> <0? <SSLOTS .BASEF>>>>>>
+ <SET STOP .STK>
+ <SET STK (0 !.STK)>
+ <SET F?
+ <DO-FIRST-SETUP
+ .FAP
+ .DEST
+ <COND (.GMF
+ <SET FSYM <1 <BINDING-STRUCTURE .INRAP>>>
+ <PUT .INRAP ,BINDING-STRUCTURE <REST <BINDING-STRUCTURE .INRAP>>>
+ .FSYM)>
+ .CHF
+ <1? .NARG>
+ .FLS>>
+ <OR .F? <SET FF? <==? <NODE-TYPE .FAP> ,MFIRST-CODE>>>
+ <SET ANY? <PUSH-STRUCS .K T .GMF <BINDING-STRUCTURE .INRAP>>>
+ <DO-FIRST-SETUP-2 .FAP .DEST <COND (.GMF .FSYM)> .CHF <1? .NARG> .FLS>
+ <AND .GMF <NOT .FLS> <INACS .FSYM> <SET OUTD <INACS .FSYM>>>
+ <BEGIN-FRAME <TMPLS .INRAP> <ACTIVATED .INRAP> <PRE-ALLOC .INRAP>>
+ <SET TMPS <COND (.PRE .NTMPS) (ELSE <STACK:L .STK <2 .FRMS>>)>>
+ <SET STK (0 !.STK)>
+ <SET STB .STK>
+ <SET STK (0 !.STK)>
+ <COND (.F? <SET MAYBE-FALSE <DO-FINAL-SETUP .FAP .SUBRC>>)>
+ <PROG-START-AC .INRAP>
+ <LABEL:TAG .MAPLP>
+ <COND (<AND .F? <NOT .GMF>>
+ <SET STKOFFS
+ <FIND-FIRST-STRUC
+ .DTEM .STB <AND <NOT .PRE> <NOT <ACTIVATED .INRAP>>>>>)>
+ <AND <ACTIVATED .INRAP> <ACT:INITIAL> <ADD:STACK 2>>
+ <SET STK (0 !.STK)>
+ <SET STRV .STK>
+ <OR .PRE
+ <AND .GMF <1? .NARG>>
+ <PROG ()
+ <SALLOC:SLOTS <TMPLS .INRAP>>
+ <ADD:STACK <TMPLS .INRAP>>
+ <COND (<NOT .PRE>
+ <SET NTSLOTS (<FORM GVAL <TMPLS .INRAP>> !.NTSLOTS)>)>
+ <COND (.GMF <SET GSTK .STK> <SET STK (0 !.STK)>)>>>
+ <AND .PRE .GMF <NOT <1? .NARG>> <SET GSTK .STK> <SET STK (0 !.STK)>>
+ <SET POFF <COND (.MAYBE-FALSE -2) (.F? -1) (ELSE 0)>>
+ <COND (<AND .GMF <OR .CHF <NOT <1? .NARG>>> <NOT .FLS>> <LVAL-UP .FSYM>)>
+ <REPEAT ((KK .K) (BS <BINDING-STRUCTURE .INRAP>)
+ (BST
+ <COND
+ (<EMPTY? .BS> ())
+ (ELSE
+ <MAPR <>
+ <FUNCTION (S)
+ #DECL ((S) <LIST SYMTAB>)
+ <COND (<N==? <NAME-SYM <1 .S>> DUMMY-MAPF>
+ <MAPLEAVE .S>)
+ (ELSE ())>>
+ .BS>)>) (OFFSET (<- 1 <* .NARG 2>> ())) TEM
+ (TOFF (0 ())) (GOFF '(0)))
+ #DECL ((BST) <LIST [REST SYMTAB]> (TOFF OFFSET) <LIST FIX LIST>
+ (KK) <LIST [REST NODE]>)
+ <COND
+ (<EMPTY? .KK>
+ <AND .GMF <NOT <1? .NARG>> <NOT .FF?> <NOT .FLS> <RET-TMP-AC .OUTD>>
+ <COND (<AND .F? <NOT .STKOFFS>> <RET-TMP-AC .DTEM>)>
+ <MAPF <>
+ <FUNCTION (SYM)
+ #DECL ((SYM) SYMTAB)
+ <APPLY <NTH ,MBINDERS <CODE-SYM .SYM>> .SYM>>
+ .BST>
+ <RETURN>)
+ (ELSE
+ <SET RV <TYPE? <ADDR-SYM <1 .BST>> TEMPV>>
+ <COND (.GMF)
+ (.F?
+ <COND (.STKOFFS
+ <SET TEM
+ <ADDRESS:C .STKOFFS
+ <COND (.AC-HACK `(FRM) ) (`(TB) )>
+ <COND (.AC-HACK 1) (ELSE 0)>>>
+ <OR .RV <SET STKOFFS <+ .STKOFFS 2>>>)
+ (ELSE
+ <SET TEM
+ <SPEC-OFFPTR <1 .OFFSET>
+ .DTEM
+ VECTOR
+ (!<2 .OFFSET>
+ !<STACK:L .STK .STRV>)>>
+ <OR .RV
+ <SET OFFSET
+ <STFIXIT .OFFSET
+ (2
+ <- <1 .TOFF>>
+ <FORM - 0 !<2 .TOFF>>)>>>)>)
+ (ELSE
+ <SET TEM
+ <ADDRESS:C <FORM - <1 .OFFSET> !<STACK:L .STK .STRV>>
+ '`(TP)
+ !<2 .OFFSET>>>
+ <SET OFFSET <STFIXIT .OFFSET (2)>>)>
+ <AND <==? <CODE-SYM <1 .BST>> 4>
+ <MESSAGE ERROR "NOT IMPLEMENTED MAPF/R TUPLES ">>
+ <SET OTAG
+ ((<1 .MAPEND>
+ <COND (.GMF (<FORM + !.GOFF>))
+ ((<FORM - 0 <1 .TOFF> !<2 .TOFF>>
+ <1 <SET TOFF <STFIXIT (0 ()) <STACK:L .STK .STRV>>>>
+ !<2 .TOFF>))>)
+ !.OTAG)>
+ <COND (.GMF
+ <ISET <RESULT-TYPE <1 .KK>>
+ <1 .BS>
+ <1 .BST>
+ .R?
+ <1 .MAPEND>
+ .CHF
+ .NARG
+ .MAPL2>
+ <SET BS <REST .BS>>
+ <SET GOFF <STACK:L .STK .GSTK>>)
+ (.RV
+ <RETURN-UP .INRAP .STK>
+ <IISET <RESULT-TYPE <1 .KK>>
+ <1 .BST>
+ <STACKM <1 .KK> <DATUM .TEM .TEM> .R? <1 .MAPEND> .POFF>
+ .R?>)
+ (ELSE
+ <BINDUP <1 .BST>
+ <STACKM <1 .KK>
+ <DATUM .TEM .TEM>
+ .R?
+ <1 .MAPEND>
+ .POFF>>)>
+ <SET MAPEND <REST .MAPEND>>
+ <SET KK <REST .KK>>
+ <SET BST <REST .BST>>)>>
+ <COND
+ (<AND .GMF <OR .CHF <NOT <1? .NARG>>> <NOT .FLS> <NOT .FF?>>
+ <PROG ((S .FSYM))
+ <PUT .S ,STORED T>
+ <COND (<INACS .S>
+ <COND (<TYPE? <DATTYP <INACS .S>> AC>
+ <FLUSH-RESIDUE <DATTYP <INACS .S>> .S>)>
+ <COND (<TYPE? <DATVAL <INACS .S>> AC>
+ <FLUSH-RESIDUE <DATVAL <INACS .S>> .S>)>
+ <PUT .S ,INACS <>>)>>)>
+ <COND (<AND .GMF <NOT .CHF> <1? .NARG> <NOT .FLS>> <LVAL-UP .FSYM>)>
+ <OR .PRE
+ <0? <SET NSLOTS <SSLOTS .INRAP>>>
+ <PROG ()
+ <SALLOC:SLOTS .NSLOTS>
+ <ADD:STACK .NSLOTS>
+ <EMIT-PRE <SET PRE T>>>>
+ <AND <ACTIVATED .INRAP> <ACT:FINAL>>
+ <SET BTP .STK>
+ <OR .OPRE <SET BASEF .INRAP>>
+ <SET STK (0 !.STK)>
+ <AND .NEED-INT <CALL-INTERRUPT>>
+ <COND
+ (<AND .R?
+ <NOT .F?>
+ <NOT .FF?>
+ .FLS
+ <1? .NARG>
+ <BLT-HACK <KIDS .INRAP>
+ <BINDING-STRUCTURE .INRAP>
+ <MINL <RESULT-TYPE <1 .K>>>>>
+ <SET DOIT <>>)
+ (<OR .F? .FF?>
+ <SET TEM <SEQ-GEN <KIDS .INRAP> <GOODACS .INRAP DONT-CARE> T>>)
+ (<NOT .FLS>
+ <SET TEM
+ <SEQ-GEN
+ <KIDS .INRAP>
+ <COND (.GMF .OUTD)
+ (ELSE
+ <DATUM <SET TT
+ <ADDRESS:C <FORM -
+ -1
+ <* 2 .NARG>
+ !<STACK:L .STK .STRV>>
+ '`(TP) >>
+ .TT>)>
+ T>>
+ <SET OUTD .TEM>)
+ (ELSE <RET-TMP-AC <SET TEM <SEQ-GEN <KIDS .INRAP> FLUSHED T>>>)>
+ <COND
+ (<AND .DOIT <N==? .TEM ,NO-DATUM>>
+ <COND (<ACTIVATED .INRAP> <PROG:END> <LABEL:OFF .MAP:OFF>)
+ (<OR .OPRE .F?>
+ <AND .SPECD
+ <OR .OPRE <SET TEM <MOVE:ARG .TEM <DATUM ,AC-A ,AC-B>>>>>
+ <POP:LOCS .STK .STRV>
+ <UNBIND:FUNNY <SPECS-START .INRAP> !.NTSLOTS>)
+ (ELSE <UNBIND:LOCS .STK .STB>)>
+ <COND
+ (.F? <DO-STACK-ARGS .MAYBE-FALSE .TEM>)
+ (<AND .GMF .FF?>
+ <OR .PRE
+ <PROG ()
+ <SET NTSLOTS <REST <SET NS .NTSLOTS>>>
+ <SET OS .STK>
+ <SET STK .STB>>>
+ <DO-EVEN-FUNNIER-HACK .TEM
+ .FSYM
+ .MNOD
+ .FAP
+ .INRAP
+ <LOOP-VARS .INRAP>>)
+ (<AND .GMF <NOT .FLS>>
+ <RET-TMP-AC .TEM>
+ <PUT .FSYM ,INACS .TEM>
+ <PUT .FSYM ,STORED <>>
+ <COND (<TYPE? <DATTYP .TEM> AC>
+ <PUT <DATTYP .TEM>
+ ,ACRESIDUE
+ (.FSYM !<ACRESIDUE <DATTYP .TEM>>)>)>
+ <PUT <DATVAL .TEM> ,ACRESIDUE (.FSYM !<ACRESIDUE <DATVAL .TEM>>)>
+ <PUT .FSYM ,STORED <>>
+ <COND
+ (<NOT <MEMQ .FSYM <LOOP-VARS .INRAP>>>
+ <REPEAT ((L <LOOP-VARS .INRAP>) LL)
+ #DECL ((L) LIST (LL) DATUM)
+ <COND (<EMPTY? .L> <RETURN>)>
+ <COND (<TYPE? <DATVAL <SET LL <LINACS-SLOT .L>>> AC>
+ <PUT <DATVAL .LL> ,ACPROT T>)>
+ <COND (<TYPE? <DATTYP .LL> AC>
+ <PUT <DATTYP .LL> ,ACPROT T>)>
+ <SET L <REST .L ,LOOPVARS-LENGTH>>>
+ <PUT
+ .INRAP
+ ,LOOP-VARS
+ (.FSYM
+ <PROG (R R2 D)
+ <SET D
+ <DATUM
+ <COND (<ISTYPE-GOOD? <RESULT-TYPE .MNOD>>)
+ (<AND <TYPE? .WHERE DATUM>
+ <TYPE? <SET R <DATTYP .WHERE>> AC>
+ <NOT <ACPROT .R>>>
+ <PUT <SGETREG .R <>> ,ACPROT T>)
+ (ELSE <PUT <SET R <GETREG <>>> ,ACPROT T>)>
+ <COND (<AND <TYPE? .WHERE DATUM>
+ <TYPE? <SET R2 <DATVAL .WHERE>> AC>
+ <NOT <ACPROT .R2>>>
+ <SGETREG .R2 <>>)
+ (ELSE <SET R2 <GETREG <>>>)>>>
+ <COND (<AND <ASSIGNED? R>>
+ <TYPE? .R AC>
+ <PUT .R ,ACPROT <>>)>
+ .D>
+ !<LOOP-VARS .INRAP>)>
+ <REPEAT ((L <LOOP-VARS .INRAP>) LL)
+ #DECL ((L) LIST (LL) DATUM)
+ <COND (<EMPTY? .L> <RETURN>)>
+ <COND (<TYPE? <DATVAL <SET LL <LINACS-SLOT .L>>> AC>
+ <PUT <DATVAL .LL> ,ACPROT <>>)>
+ <COND (<TYPE? <DATTYP .LL> AC>
+ <PUT <DATTYP .LL> ,ACPROT <>>)>
+ <SET L <REST .L ,LOOPVARS-LENGTH>>>)>)
+ (.FF? <DO-FUNNY-HACK .TEM (<* .NARG -2> ()) .MNOD .FAP .INRAP>)>
+ <COND (.ANY? <EMIT <INSTRUCTION `SETZM .POFF '`(P) >>)>
+ <OR .PRE
+ <AND .GMF .FF?>
+ <PROG ()
+ <SET NTSLOTS <REST <SET NS .NTSLOTS>>>
+ <SET STK .STB>>>)>
+ <COND
+ (.DOIT
+ <AGAIN-UP .INRAP <AND .GMF <1? .NARG>>>
+ <LABEL:TAG .RTAG>
+ <COND (.GMF
+ <REST-STRUCS <BINDING-STRUCTURE .INRAP>
+ .K
+ <LOOP-VARS .INRAP>
+ .NARG
+ .MAPL2
+ .R?>)>
+ <COND (<NOT <AND .GMF <1? .NARG>>> <BRANCH:TAG .MAPLP>)>
+ <GEN-TAGS .OTAG .SPECD>
+ <COND (<AND .GMF <NOT .PRE>> <SET STK .GSTK> <SET NTSLOTS .NS>)>
+ <COND (<AND .GMF <NOT <1? .NARG>>>
+ <COND (<OR .OPRE .F?>
+ <POP:LOCS .STK .STRV>
+ <UNBIND:FUNNY <SPECS-START .INRAP> !.NTSLOTS>)
+ (ELSE <UNBIND:LOCS .STK .STB>)>)>
+ <MAPF <>
+ <FUNCTION (N)
+ #DECL ((N) NODE)
+ <COND (<NOT <ISTYPE? <STRUCTYP <RESULT-TYPE .N>>>>
+ <EMIT '<`SETZM |DSTORE >>
+ <MAPLEAVE>)>>
+ .K>)
+ (ELSE <GEN-TAGS .OTAG .SPECD>)>
+ <CLEANUP-STATE .INRAP>
+ <LABEL:TAG .APPLTAG>
+ <COND
+ (<TYPE? .DEST DATUM>
+ <SET CD
+ <COND (.F? <DO-LAST .SUBRC .MAYBE-FALSE <DATUM !.DEST>>)
+ (<AND .FF? .GMF>
+ <MOVE:ARG <LADDR .FSYM <> <>> <DATUM !.DEST>>)
+ (.FF? <DO-FUNNY-LAST .FAP <- -1 <* 2 .NARG>> <DATUM !.DEST>>)
+ (.GMF <MOVE:ARG .OUTD <DATUM !.DEST>>)
+ (ELSE
+ <MOVE:ARG
+ <DATUM <SET TT <ADDRESS:C <- -1 <* 2 .NARG>> '`(TP) >> .TT>
+ <DATUM !.DEST>>)>>
+ <ACFIX .DEST .CD>
+ <AND <ISTYPE? <DATTYP .DEST>>
+ <TYPE? <DATTYP .CD> AC>
+ <RET-TMP-AC <DATTYP .CD> .CD>>)
+ (.F? <DO-LAST .SUBRC .MAYBE-FALSE <FUNCTION:VALUE>>)
+ (<AND .FF? .GMF> <MOVE:ARG .OUTD <FUNCTION:VALUE>>)
+ (<AND .GMF .FF?> <MOVE:ARG .OUTD <FUNCTION:VALUE>>)
+ (.FF? <DO-FUNNY-LAST .FAP <- -1 <* 2 .NARG>> <FUNCTION:VALUE>>)>
+ <POP:LOCS .STB .STOP>
+ <LABEL:TAG .EXIT>>
+ <COND (<ASSIGNED? CD>
+ <AND <TYPE? <DATTYP .DEST> AC> <FIX-ACLINK <DATTYP .DEST> .DEST .CD>>
+ <AND <TYPE? <DATVAL .DEST> AC>
+ <FIX-ACLINK <DATVAL .DEST> .DEST .CD>>)>
+ <SET STK .OSTK>
+ <SET XX <MOVE:ARG .DEST .WHERE>>
+ <END-FRAME>
+ .XX>
+\f
+ <TITLE HMAPFR>
+
+ <DECLARE ("VALUE" ANY NODE!-COMPDEC!-PACKAGE ANY <LIST [REST
+NODE!-COMPDEC!-PACKAGE]>)>
+ <PUSH TP* (AB) >
+ <PUSH TP* (AB) 1>
+ <PUSH TP* (AB) 2>
+ <PUSH TP* (AB) 3>
+ <PUSH TP* (AB) 4>
+ <PUSH TP* (AB) 5>
+ <PUSHJ P* TAG1>
+ <JRST |FINIS >
+TAG1 <SUBM M* (P) > ; 8
+ <PUSH TP* [<(*35*) *10*>]> ; [6]
+ <PUSH TP* FRM> ; [7]
+ <MOVE FRM* TP>
+ <MOVEI O* *20* >
+ <PUSHJ P* |NTPALO >
+ <PUSH TP* <MQUOTE %<TYPE-W SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>; [24]
+ <PUSH TP* [0]> ; [25]
+ <PUSH TP* [0]> ; [26]
+ <PUSH TP* [0]> ; [27]
+ <PUSH TP* [0]> ; [28]
+ <PUSH TP* [0]> ; [29]
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [30]
+ <PUSH TP* <MQUOTE MNOD!-IMAPGEN!-MAPGEN!-PACKAGE>>; [31]
+ <PUSH TP* (FRM) -7> ; (-7) [32]
+ <PUSH TP* (FRM) -6> ; (-6) [33]
+ <PUSH TP* <MQUOTE (NODE!-COMPDEC!-PACKAGE)> -1> ; [34]
+ <PUSH TP* <MQUOTE (NODE!-COMPDEC!-PACKAGE)>> ; [35]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [36]
+ <PUSH TP* <MQUOTE NTSLOTS!-IMAPGEN!-MAPGEN!-PACKAGE>>; [37]
+ <MOVE B* <MQUOTE NTSLOTS!-IMAPGEN!-MAPGEN!-PACKAGE>>
+ <PUSHJ P* |CILVAL >
+ <PUSH TP* A> ; [38]
+ <PUSH TP* B> ; [39]
+ <PUSH TP* <MQUOTE (LIST)> -1> ; [40]
+ <PUSH TP* <MQUOTE (LIST)>> ; [41]
+ <PUSHJ P* |SPECBN >
+ <MOVE B* <MQUOTE PRE!-IMAPGEN!-MAPGEN!-PACKAGE>>
+ <PUSHJ P* |CILVAL >
+ <GETYP O* A>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG2>
+ <MOVE B* <MQUOTE TMPS!-COMPDEC!-PACKAGE>>
+ <PUSHJ P* |CILVAL >
+ <JRST TAG3>
+TAG2 <MOVE B* <MQUOTE STK!-IMAPGEN!-MAPGEN!-PACKAGE>> ; 44
+ <PUSHJ P* |CILVAL >
+ <PUSH TP* A> ; [42]
+ <PUSH TP* B> ; [43]
+ <MOVE B* <MQUOTE BSTB!-IMAPGEN!-MAPGEN!-PACKAGE>>
+ <PUSHJ P* |CILVAL >
+ <PUSH TP* A> ; [44]
+ <PUSH TP* B> ; [45]
+ <MCALL 2 STACK:L>
+ <GETYP O* A>
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG3>
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVEI D* 0>
+ <MOVEI E* 0>
+ <PUSHJ P* |C1CONS >
+TAG3 <PUSH TP* A> ; 60 [42]
+ <PUSH TP* B> ; [43]
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [44]
+ <PUSH TP* <MQUOTE NSLOTS!-IMAPGEN!-MAPGEN!-PACKAGE>>; [45]
+ <PUSH TP* <TYPE-WORD UNBOUND>> ; [46]
+ <PUSH TP* [-1]> ; [47]
+ <PUSH TP* <MQUOTE (FIX)> -1> ; [48]
+ <PUSH TP* <MQUOTE (FIX)>> ; [49]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [50]
+ <PUSH TP* <MQUOTE SPECD!-IMAPGEN!-MAPGEN!-PACKAGE>>; [51]
+ <PUSH TP* <TYPE-WORD FALSE>> ; [52]
+ <PUSH TP* [0]> ; [53]
+ <PUSH TP* <MQUOTE (<OR FALSE ATOM>)> -1> ; [54]
+ <PUSH TP* <MQUOTE (<OR FALSE ATOM>)>> ; [55]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [56]
+ <PUSH TP* <MQUOTE STB!-IMAPGEN!-MAPGEN!-PACKAGE>> ; [57]
+ <PUSH TP* <TYPE-WORD UNBOUND>> ; [58]
+ <PUSH TP* [-1]> ; [59]
+ <PUSH TP* <MQUOTE (LIST)> -1> ; [60]
+ <PUSH TP* <MQUOTE (LIST)>> ; [61]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* <MQUOTE FIX> -1> ; [62]
+ <PUSH TP* <MQUOTE FIX>> ; [63]
+ <PUSH TP* <MQUOTE ANY-AC!-COMPDEC!-PACKAGE> -1> ; [64]
+ <PUSH TP* <MQUOTE ANY-AC!-COMPDEC!-PACKAGE>> ; [65]
+ <MCALL 2 DATUM>
+ <PUSH TP* A> ; [62]
+ <PUSH TP* B> ; [63]
+ <PUSH TP* <TYPE-WORD FALSE>> ; [64]
+ <PUSH TP* [0]> ; [65]
+ <MOVE B* (FRM) -2> ; (-2)
+ <JUMPE B* |CERR2 >
+ <PUSH TP* <MQUOTE %<TYPE-W NODE!-COMPDEC!-PACKAGE VECTOR>>>; [66]
+ <PUSH TP* (B) 1> ; [67]
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [68]
+ <PUSH TP* <MQUOTE INRAP!-IMAPGEN!-MAPGEN!-PACKAGE>>; [69]
+ <JUMPE B* |CERR2 >
+ <HRRZ D* (B) >
+ <JUMPE D* |CERR2 >
+ <PUSH TP* <MQUOTE %<TYPE-W NODE!-COMPDEC!-PACKAGE VECTOR>>>; [70]
+ <PUSH TP* (D) 1> ; [71]
+ <PUSH TP* <MQUOTE (NODE!-COMPDEC!-PACKAGE)> -1> ; [72]
+ <PUSH TP* <MQUOTE (NODE!-COMPDEC!-PACKAGE)>> ; [73]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [74]
+ <PUSH TP* <MQUOTE POFF!-IMAPGEN!-MAPGEN!-PACKAGE>>; [75]
+ <PUSH TP* <TYPE-WORD FIX>> ; [76]
+ <PUSH TP* [0]> ; [77]
+ <PUSH TP* <MQUOTE (FIX)> -1> ; [78]
+ <PUSH TP* <MQUOTE (FIX)>> ; [79]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [80]
+ <PUSH TP* <MQUOTE ANY?!-IMAPGEN!-MAPGEN!-PACKAGE>>; [81]
+ <PUSH TP* <TYPE-WORD FALSE>> ; [82]
+ <PUSH TP* [0]> ; [83]
+ <PUSH TP* <MQUOTE (ANY)> -1> ; [84]
+ <PUSH TP* <MQUOTE (ANY)>> ; [85]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [86]
+ <PUSH TP* <MQUOTE NARG!-IMAPGEN!-MAPGEN!-PACKAGE>>; [87]
+ <MOVE B* (FRM) -2> ; (-2)
+ <JUMPE B* |CERR2 >
+ <HRRZ B* (B) >
+ <JUMPE B* |CERR2 >
+ <HRRZ B* (B) >
+ <MOVE D* B>
+ <JRST TAG4>
+TAG5 <HRR D* (D) -1> ; 129
+TAG4 <TRNE D* -1 > ; 130
+ <AOBJP D* TAG5>
+ <HLRZS D>
+ <PUSH TP* <TYPE-WORD FIX>> ; [88]
+ <PUSH TP* D> ; [89]
+ <PUSH TP* <MQUOTE (FIX)> -1> ; [90]
+ <PUSH TP* <MQUOTE (FIX)>> ; [91]
+ <MOVEM B* (FRM) -2> ; (-2)
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [92]
+ <PUSH TP* <MQUOTE START:TAG!-IMAPGEN!-MAPGEN!-PACKAGE>>; [93]
+ <PUSH TP* <TYPE-WORD UNBOUND>> ; [94]
+ <PUSH TP* [-1]> ; [95]
+ <PUSH TP* <MQUOTE (ANY)> -1> ; [96]
+ <PUSH TP* <MQUOTE (ANY)>> ; [97]
+ <PUSHJ P* |SPECBN >
+ <MOVE B* (FRM) 26> ; (26)
+ <ADD B* [<(18) 18>]>
+ <JUMPGE B* |CERR2 >
+ <MOVE D* (B) >
+ <MOVE PVP* (B) 1>
+ <MOVE B* <MQUOTE %<RGLOC MAPR T>>>
+ <ADD B* |GLOTOP 1>
+ <GETYP O* (B) 0>
+ <GETYP TVP* D>
+ <CAMN PVP* (B) 1>
+ <CAIE O* (TVP) 0>
+ <JRST TAG6>
+ <MOVE B* <MQUOTE T> -1>
+ <MOVE TVP* <MQUOTE T>>
+ <JRST TAG7>
+TAG6 <MOVE B* <TYPE-WORD FALSE>> ; 161
+ <MOVEI TVP* 0>
+TAG7 <PUSH TP* B> ; 163 [98]
+ <PUSH TP* TVP> ; [99]
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [100]
+ <PUSH TP* <MQUOTE STRV!-IMAPGEN!-MAPGEN!-PACKAGE>>; [101]
+ <PUSH TP* <TYPE-WORD UNBOUND>> ; [102]
+ <PUSH TP* [-1]> ; [103]
+ <PUSH TP* <MQUOTE (LIST)> -1> ; [104]
+ <PUSH TP* <MQUOTE (LIST)>> ; [105]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* <TYPE-WORD FALSE>> ; [106]
+ <PUSH TP* [0]> ; [107]
+ <PUSH P* (FRM) 82> ; (82)
+ <PUSH TP* <TYPE-WORD LIST>> ; [108]
+ <PUSH TP* [0]> ; [109]
+ <PUSH TP* <TYPE-WORD LIST>> ; [110]
+ <PUSH TP* [0]> ; [111]
+TAG9 <SOSGE (P) > ; 179
+ <JRST TAG8>
+ <PUSH TP* <MQUOTE "MAP"> -1> ; [112]
+ <PUSH TP* <MQUOTE "MAP">> ; [113]
+ <MCALL 1 MAKE:TAG>
+ <MOVE C* A>
+ <MOVE D* B>
+ <MOVEI E* 0>
+ <PUSHJ P* |CICONS >
+ <SKIPE (TP) > ; (111)
+ <HRRM B* @ (TP) > ; (111)
+ <MOVEM B* (TP) > ; (111)
+ <SKIPN (TP) -2> ; (109)
+ <MOVEM B* (TP) -2> ; (109)
+ <JRST TAG9>
+TAG8 <MOVE B* (TP) -2> ; 194 (109)
+ <SUB TP* [<(4) 4>]>
+ <SUB P* [<(1) 1>]>
+ <PUSH TP* <TYPE-WORD LIST>> ; [108]
+ <PUSH TP* B> ; [109]
+ <MOVE B* <MQUOTE STK!-IMAPGEN!-MAPGEN!-PACKAGE>>
+ <PUSHJ P* |CILVAL >
+ <PUSH TP* A> ; [110]
+ <PUSH TP* B> ; [111]
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [112]
+ <PUSH TP* <MQUOTE MAPLP!-IMAPGEN!-MAPGEN!-PACKAGE>>; [113]
+ <PUSH TP* <MQUOTE "MAP"> -1> ; [114]
+ <PUSH TP* <MQUOTE "MAP">> ; [115]
+ <MCALL 1 MAKE:TAG>
+ <PUSH TP* A> ; [114]
+ <PUSH TP* B> ; [115]
+ <PUSH TP* <MQUOTE (ATOM)> -1> ; [116]
+ <PUSH TP* <MQUOTE (ATOM)>> ; [117]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* <MQUOTE "MAP"> -1> ; [118]
+ <PUSH TP* <MQUOTE "MAP">> ; [119]
+ <MCALL 1 MAKE:TAG>
+ <PUSH TP* A> ; [118]
+ <PUSH TP* B> ; [119]
+ <PUSH TP* (FRM) 59> ; (59) [120]
+ <PUSH TP* (FRM) 60> ; (60) [121]
+ <MCALL 1 AP?>
+ <PUSH TP* A> ; [120]
+ <PUSH TP* B> ; [121]
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [122]
+ <PUSH TP* <MQUOTE STOP!-IMAPGEN!-MAPGEN!-PACKAGE>>; [123]
+ <PUSH TP* <TYPE-WORD UNBOUND>> ; [124]
+ <PUSH TP* [-1]> ; [125]
+ <PUSH TP* <MQUOTE (LIST)> -1> ; [126]
+ <PUSH TP* <MQUOTE (LIST)>> ; [127]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [128]
+ <PUSH TP* <MQUOTE STK!-IMAPGEN!-MAPGEN!-PACKAGE>> ; [129]
+ <PUSH TP* <TYPE-WORD FIX>> ; [130]
+ <PUSH TP* [0]> ; [131]
+ <MOVE B* <MQUOTE STK!-IMAPGEN!-MAPGEN!-PACKAGE>>
+ <PUSHJ P* |CILVAL >
+ <PUSH P* [1]>
+ <MOVEI O* |SEGLST >
+ <PUSHJ P* |RCALL >
+ <SUB P* [<(1) 1>]>
+ <PUSH TP* A> ; [130]
+ <PUSH TP* B> ; [131]
+ <PUSH TP* <MQUOTE (LIST)> -1> ; [132]
+ <PUSH TP* <MQUOTE (LIST)>> ; [133]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [134]
+ <PUSH TP* <MQUOTE TMPS!-COMPDEC!-PACKAGE>> ; [135]
+ <MOVE B* <MQUOTE TMPS!-COMPDEC!-PACKAGE>>
+ <PUSHJ P* |CILVAL >
+ <PUSH TP* A> ; [136]
+ <PUSH TP* B> ; [137]
+ <PUSH TP* <MQUOTE (LIST)> -1> ; [138]
+ <PUSH TP* <MQUOTE (LIST)>> ; [139]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [140]
+ <PUSH TP* <MQUOTE BTP!-IMAPGEN!-MAPGEN!-PACKAGE>> ; [141]
+ <PUSH TP* <TYPE-WORD UNBOUND>> ; [142]
+ <PUSH TP* [-1]> ; [143]
+ <PUSH TP* <MQUOTE (LIST)> -1> ; [144]
+ <PUSH TP* <MQUOTE (LIST)>> ; [145]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [146]
+ <PUSH TP* <MQUOTE BASEF!-IMAPGEN!-MAPGEN!-PACKAGE>>; [147]
+ <MOVE B* <MQUOTE BASEF!-IMAPGEN!-MAPGEN!-PACKAGE>>
+ <PUSHJ P* |CILVAL >
+ <PUSH TP* A> ; [148]
+ <PUSH TP* B> ; [149]
+ <PUSH TP* <MQUOTE (NODE!-COMPDEC!-PACKAGE)> -1> ; [150]
+ <PUSH TP* <MQUOTE (NODE!-COMPDEC!-PACKAGE)>> ; [151]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [152]
+ <PUSH TP* <MQUOTE FRMS!-IMAPGEN!-MAPGEN!-PACKAGE>>; [153]
+ <MOVE B* <MQUOTE FRMS!-IMAPGEN!-MAPGEN!-PACKAGE>>
+ <PUSHJ P* |CILVAL >
+ <PUSH TP* A> ; [154]
+ <PUSH TP* B> ; [155]
+ <PUSH TP* <MQUOTE (LIST)> -1> ; [156]
+ <PUSH TP* <MQUOTE (LIST)>> ; [157]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [158]
+ <PUSH TP* <MQUOTE MAYBE-FALSE!-IMAPGEN!-MAPGEN!-PACKAGE>>; [159]
+ <PUSH TP* <TYPE-WORD FALSE>> ; [160]
+ <PUSH TP* [0]> ; [161]
+ <PUSH TP* <MQUOTE (ANY)> -1> ; [162]
+ <PUSH TP* <MQUOTE (ANY)>> ; [163]
+ <PUSHJ P* |SPECBN >
+ <MOVE B* <MQUOTE PRE!-IMAPGEN!-MAPGEN!-PACKAGE>>
+ <PUSHJ P* |CILVAL >
+ <PUSH TP* A> ; [164]
+ <PUSH TP* B> ; [165]
+ <PUSH TP* <TYPE-WORD LIST>> ; [166]
+ <PUSH TP* [0]> ; [167]
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [168]
+ <PUSH TP* <MQUOTE DEST!-IMAPGEN!-MAPGEN!-PACKAGE>>; [169]
+ <PUSH TP* <TYPE-WORD UNBOUND>> ; [170]
+ <PUSH TP* [-1]> ; [171]
+ <PUSH TP* <MQUOTE (<OR ATOM DATUM!-COMPDEC!-PACKAGE>)> -1>; [172]
+ <PUSH TP* <MQUOTE (<OR ATOM DATUM!-COMPDEC!-PACKAGE>)>>; [173]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [174]
+ <PUSH TP* <MQUOTE CD!-IMAPGEN!-MAPGEN!-PACKAGE>> ; [175]
+ <PUSH TP* <TYPE-WORD UNBOUND>> ; [176]
+ <PUSH TP* [-1]> ; [177]
+ <PUSH TP* <MQUOTE (<OR ATOM DATUM!-COMPDEC!-PACKAGE>)> -1>; [178]
+ <PUSH TP* <MQUOTE (<OR ATOM DATUM!-COMPDEC!-PACKAGE>)>>; [179]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [180]
+ <PUSH TP* <MQUOTE AC-HACK!-IMAPGEN!-MAPGEN!-PACKAGE>>; [181]
+ <MOVE B* <MQUOTE AC-HACK!-IMAPGEN!-MAPGEN!-PACKAGE>>
+ <PUSHJ P* |CILVAL >
+ <PUSH TP* A> ; [182]
+ <PUSH TP* B> ; [183]
+ <PUSH TP* <MQUOTE (ANY)> -1> ; [184]
+ <PUSH TP* <MQUOTE (ANY)>> ; [185]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [186]
+ <PUSH TP* <MQUOTE EXIT!-IMAPGEN!-MAPGEN!-PACKAGE>>; [187]
+ <PUSH TP* <MQUOTE "MAPEX"> -1> ; [188]
+ <PUSH TP* <MQUOTE "MAPEX">> ; [189]
+ <MCALL 1 MAKE:TAG>
+ <PUSH TP* A> ; [188]
+ <PUSH TP* B> ; [189]
+ <PUSH TP* <MQUOTE (ATOM)> -1> ; [190]
+ <PUSH TP* <MQUOTE (ATOM)>> ; [191]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [192]
+ <PUSH TP* <MQUOTE APPLTAG!-IMAPGEN!-MAPGEN!-PACKAGE>>; [193]
+ <PUSH TP* <MQUOTE "MAPAP"> -1> ; [194]
+ <PUSH TP* <MQUOTE "MAPAP">> ; [195]
+ <MCALL 1 MAKE:TAG>
+ <PUSH TP* A> ; [194]
+ <PUSH TP* B> ; [195]
+ <PUSH TP* <MQUOTE (ATOM)> -1> ; [196]
+ <PUSH TP* <MQUOTE (ATOM)>> ; [197]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [198]
+ <PUSH TP* <MQUOTE GMF!-IMAPGEN!-MAPGEN!-PACKAGE>> ; [199]
+ <PUSH TP* <TYPE-WORD UNBOUND>> ; [200]
+ <PUSH TP* [-1]> ; [201]
+ <PUSH TP* <MQUOTE (ANY)> -1> ; [202]
+ <PUSH TP* <MQUOTE (ANY)>> ; [203]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* (FRM) -5> ; (-5) [204]
+ <PUSH TP* (FRM) -4> ; (-4) [205]
+ <MOVE B* (FRM) -5> ; (-5)
+ <MOVE D* (FRM) -4> ; (-4)
+ <GETYP O* B>
+ <CAMN D* <MQUOTE FLUSHED!-COMPDEC!-PACKAGE>>
+ <CAIE O* <TYPE-CODE ATOM>>
+ <JRST TAG10>
+ <MOVE PVP* <MQUOTE T> -1>
+ <MOVE TVP* <MQUOTE T>>
+ <JRST TAG11>
+TAG10 <MOVE PVP* <TYPE-WORD FALSE>> ; 353
+ <MOVEI TVP* 0>
+TAG11 <PUSH TP* PVP> ; 355 [206]
+ <PUSH TP* TVP> ; [207]
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [208]
+ <PUSH TP* <MQUOTE RTAG!-COMPDEC!-PACKAGE>> ; [209]
+ <PUSH TP* <MQUOTE "MAP"> -1> ; [210]
+ <PUSH TP* <MQUOTE "MAP">> ; [211]
+ <MCALL 1 MAKE:TAG>
+ <PUSH TP* A> ; [210]
+ <PUSH TP* B> ; [211]
+ <PUSH TP* <MQUOTE (ATOM)> -1> ; [212]
+ <PUSH TP* <MQUOTE (ATOM)>> ; [213]
+ <PUSHJ P* |SPECBN >
+ <PUSH TP* <MQUOTE T> -1> ; [214]
+ <PUSH TP* <MQUOTE T>> ; [215]
+ <PUSH TP* <MQUOTE T> -1> ; [216]
+ <PUSH TP* <MQUOTE T>> ; [217]
+ <PUSH TP* [<(%<TYPE-CODE ATOM>) -1>]> ; [218]
+ <PUSH TP* <MQUOTE GSTK!-IMAPGEN!-MAPGEN!-PACKAGE>>; [219]
+ <PUSH TP* <TYPE-WORD UNBOUND>> ; [220]
+ <PUSH TP* [-1]> ; [221]
+ <PUSH TP* <MQUOTE (LIST)> -1> ; [222]
+ <PUSH TP* <MQUOTE (LIST)>> ; [223]
+ <PUSHJ P* |SPECBN >
+ <MOVEI O* *22* >
+ <PUSHJ P* |NTPALO >
+ <INTGO>
+ <MOVE B* (FRM) 64> ; (64)
+ <ADD B* [<(22) 22>]>
+ <JUMPGE B* |CERR2 >
+ <PUSH TP* <TYPE-WORD FIX>> ; [242]
+ <PUSH TP* (B) 1> ; [243]
+ <MOVE B* <MQUOTE TOT-SPEC!-IMAPGEN!-MAPGEN!-PACKAGE>>
+ <PUSHJ P* |CILVAL >
+ <PUSH TP* A> ; [244]
+ <PUSH TP* B> ; [245]
+ <MOVEI A* 2 >
+ <PUSHJ P* |CMINUS >
+ <MOVE D* (FRM) 64> ; (64)
+ <ADD D* [<(22) 22>]>
+ <JUMPGE D* |CERR2 >
+ <MOVEM A* (D) >
+ <MOVEM B* (D) 1>
+ <MOVE B* <MQUOTE PRE!-IMAPGEN!-MAPGEN!-PACKAGE>>
+ <PUSHJ P* |CILVAL >
+ <MOVEI E* (FRM) 217> ; (217)
+ <MOVE C* <MQUOTE PRE!-IMAPGEN!-MAPGEN!-PACKAGE>>
+ <MOVE D* <MQUOTE (ANY)>>
+ <PUSHJ P* |IBIND >
+ <MOVE B* (FRM) -2> ; (-2)
+ <JUMPE B* TAG12>
+ <MOVE D* <TYPE-WORD FALSE>>
+ <MOVEI PVP* 0>
+ <JUMPE B* TAG13>
+TAG17 <MOVE TVP* (B) 1> ; 409
+ <SKIPGE |INTFLG >
+ <TAG14>
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (FRM) 5> ; (5)
+ <MOVEM B* (FRM) 6> ; (6)
+ <PUSH TP* (TVP) 4> ; [242]
+ <PUSH TP* (TVP) 5> ; [243]
+ <PUSH TP* <MQUOTE <PRIMTYPE LIST>> -1> ; [244]
+ <PUSH TP* <MQUOTE <PRIMTYPE LIST>>> ; [245]
+ <MCALL 2 TYPE-OK?>
+ <GETYP O* A>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG15>
+ <MOVE B* <TYPE-WORD FALSE>>
+ <MOVEI D* 0>
+ <JRST TAG16>
+TAG15 <MOVE B* <MQUOTE T> -1> ; 426
+ <MOVE D* <MQUOTE T>>
+ <MOVE D* B>
+ <MOVE PVP* D>
+ <MOVE B* (FRM) 6> ; (6)
+ <HRRZ B* (B) >
+ <JUMPN B* TAG17>
+TAG13 <MOVE B* PVP> ; 433
+TAG16 <JUMPGE D* TAG12> ; 434
+ <MOVE B* <TYPE-WORD FALSE>>
+ <MOVEI D* 0>
+ <MOVEM B* (FRM) 207> ; (207)
+ <MOVEM D* (FRM) 208> ; (208)
+TAG12 <MOVE B* (FRM) -2> ; 439 (-2)
+ <JUMPN B* TAG18>
+ <MOVE D* (FRM) 60> ; (60)
+ <GETYP O* (D) 6>
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG19>
+TAG18 <MOVE D* (FRM) 60> ; 445 (60)
+ <MOVE PVP* (D) 6>
+ <MOVE TVP* (D) 7>
+ <GETYP O* PVP>
+ <CAIN TVP* 0>
+ <CAIE O* <TYPE-CODE FALSE>>
+ <SKIPA O>
+ <JRST TAG20>
+ <MOVE C* (D) 1>
+ <CAIE C* *107* >
+ <JRST TAG21>
+ <ADD D* [<(18) 18>]>
+ <JUMPGE D* |CERR2 >
+ <MOVE E* (D) >
+ <MOVE A* (D) 1>
+ <GETYP O* E>
+ <CAIN A* 5 >
+ <CAIE O* <TYPE-CODE FIX>>
+ <JRST TAG20>
+TAG21 <GETYP O* (FRM) 113> ; 464 (113)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG19>
+TAG20 <JUMPE B* TAG22> ; 467
+ <MOVE D* (FRM) 64> ; (64)
+ <ADD D* [<(20) 20>]>
+ <JUMPGE D* |CERR2 >
+ <MOVE C* (D) 1>
+ <JUMPE C* |CERR2 >
+ <MOVE E* (C) 1>
+ <MOVE D* (E) 3>
+ <CAME D* <MQUOTE DUMMY-MAPF!-COMPDEC!-PACKAGE>>
+ <JRST TAG19>
+TAG22 <MOVE D* <MQUOTE T> -1> ; 477
+ <MOVE PVP* <MQUOTE T>>
+ <JRST TAG23>
+TAG19 <MOVE D* <TYPE-WORD FALSE>> ; 480
+ <MOVEI PVP* 0>
+TAG23 <MOVEM D* (FRM) 193> ; 482 (193)
+ <MOVEM PVP* (FRM) 194> ; (194)
+ <JUMPE B* TAG24>
+ <PUSH P* [0]>
+ <JUMPE B* TAG25>
+TAG27 <MOVE TVP* (B) 1> ; 487
+ <SKIPGE |INTFLG >
+ <TAG26>
+ <PUSH TP* (TVP) 4> ; [242]
+ <PUSH TP* (TVP) 5> ; [243]
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (FRM) 3> ; (3)
+ <MOVEM B* (FRM) 4> ; (4)
+ <MCALL 1 MINL>
+ <PUSH TP* A> ; [242]
+ <PUSH TP* B> ; [243]
+ <AOS (P) >
+ <MOVE B* (FRM) 4> ; (4)
+ <HRRZ B* (B) >
+ <JUMPN B* TAG27>
+TAG25 <POP P* A> ; 502
+ <PUSHJ P* |CMIN >
+ <JUMPG B* TAG24>
+ <MOVE B* <MQUOTE T> -1>
+ <MOVE D* <MQUOTE T>>
+ <JRST TAG28>
+TAG24 <MOVE B* <TYPE-WORD FALSE>> ; 508
+ <MOVEI D* 0>
+TAG28 <MOVEM B* (FRM) 15> ; 510 (15)
+ <MOVEM D* (FRM) 16> ; (16)
+ <GETYP O* (FRM) 199> ; (199)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG29>
+ <MOVE PVP* <MQUOTE FLUSHED!-COMPDEC!-PACKAGE> -1>
+ <MOVE TVP* <MQUOTE FLUSHED!-COMPDEC!-PACKAGE>>
+ <JRST TAG30>
+TAG29 <PUSH TP* (FRM) 25> ; 518 (25) [238]
+ <PUSH TP* (FRM) 26> ; (26) [239]
+ <PUSH TP* (FRM) -5> ; (-5) [240]
+ <PUSH TP* (FRM) -4> ; (-4) [241]
+ <MCALL 2 GOODACS>
+ <MOVE PVP* A>
+ <MOVE TVP* B>
+TAG30 <MOVEM PVP* (FRM) 163> ; 525 (163)
+ <MOVEM TVP* (FRM) 164> ; (164)
+ <MOVEM PVP* (FRM) 197> ; (197)
+ <MOVEM TVP* (FRM) 198> ; (198)
+ <GETYP O* (FRM) 219> ; (219)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG31>
+ <MOVE B* (FRM) 64> ; (64)
+ <ADD B* [<(30) 30>]>
+ <JUMPGE B* |CERR2 >
+ <SKIPGE (B) 1>
+ <JRST TAG32>
+ <MOVE B* (FRM) 142> ; (142)
+ <ADD B* [<(26) 26>]>
+ <JUMPGE B* |CERR2 >
+ <SKIPE (B) 1>
+ <JRST TAG33>
+TAG32 <MOVE B* <TYPE-WORD FALSE>> ; 542
+ <MOVEI D* 0>
+ <JRST TAG34>
+TAG33 <MOVE B* <MQUOTE T> -1> ; 545
+ <MOVE D* <MQUOTE T>>
+TAG34 <PUSH TP* B> ; 547 [238]
+ <PUSH TP* D> ; [239]
+ <MCALL 1 EMIT-PRE>
+TAG31 <MOVE B* (FRM) 123> ; 550 (123)
+ <MOVE D* (FRM) 124> ; (124)
+ <MOVE E* D>
+ <MOVEM B* (FRM) 117> ; (117)
+ <MOVEM D* (FRM) 118> ; (118)
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVEI D* 0>
+ <PUSHJ P* |C1CONS >
+ <PUSH TP* (FRM) 59> ; (59) [238]
+ <PUSH TP* (FRM) 60> ; (60) [239]
+ <PUSH TP* (FRM) 163> ; (163) [240]
+ <PUSH TP* (FRM) 164> ; (164) [241]
+ <MOVE D* (FRM) 193> ; (193)
+ <MOVE PVP* (FRM) 194> ; (194)
+ <GETYP O* D>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG35>
+ <MOVE TVP* (FRM) 64> ; (64)
+ <ADD TVP* [<(20) 20>]>
+ <JUMPGE TVP* |CERR2 >
+ <MOVE C* (TVP) 1>
+ <JUMPE C* |CERR2 >
+ <MOVE TVP* (C) 1>
+ <MOVE C* (FRM) 64> ; (64)
+ <ADD C* [<(20) 20>]>
+ <JUMPGE C* |CERR2 >
+ <MOVE E* (C) 1>
+ <JUMPE E* |CERR2 >
+ <HRRZ C* (E) >
+ <MOVE SP* (FRM) 64> ; (64)
+ <ADD SP* [<(20) 20>]>
+ <JUMPGE SP* |CERR2 >
+ <MOVEM C* (SP) 1>
+ <MOVE D* <MQUOTE %<TYPE-W SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>
+ <MOVE PVP* TVP>
+ <MOVEM TVP* (FRM) 18> ; (18)
+TAG35 <PUSH TP* D> ; 586 [242]
+ <PUSH TP* PVP> ; [243]
+ <PUSH TP* (FRM) 15> ; (15) [244]
+ <PUSH TP* (FRM) 16> ; (16) [245]
+ <MOVE D* (FRM) 82> ; (82)
+ <MOVEM A* (FRM) 123> ; (123)
+ <MOVEM B* (FRM) 124> ; (124)
+ <SOJN D* TAG36>
+ <MOVE D* <MQUOTE T> -1>
+ <MOVE PVP* <MQUOTE T>>
+ <JRST TAG37>
+TAG36 <MOVE D* <TYPE-WORD FALSE>> ; 597
+ <MOVEI PVP* 0>
+TAG37 <PUSH TP* D> ; 599 [246]
+ <PUSH TP* PVP> ; [247]
+ <PUSH TP* (FRM) 199> ; (199) [248]
+ <PUSH TP* (FRM) 200> ; (200) [249]
+ <MCALL 6 DO-FIRST-SETUP>
+ <GETYP O* A>
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG38>
+ <MOVE D* (FRM) 60> ; (60)
+ <MOVE PVP* (D) 1>
+ <CAIE PVP* *107* >
+ <JRST TAG39>
+ <MOVE TVP* <MQUOTE T> -1>
+ <MOVE C* <MQUOTE T>>
+ <JRST TAG40>
+TAG39 <MOVE TVP* <TYPE-WORD FALSE>> ; 614
+ <MOVEI C* 0>
+TAG40 <MOVEM TVP* (FRM) 99> ; 616 (99)
+ <MOVEM C* (FRM) 100> ; (100)
+TAG38 <PUSH TP* <TYPE-WORD LIST>> ; 618 [238]
+ <PUSH TP* (FRM) -2> ; (-2) [239]
+ <PUSH TP* <MQUOTE T> -1> ; [240]
+ <PUSH TP* <MQUOTE T>> ; [241]
+ <PUSH TP* (FRM) 193> ; (193) [242]
+ <PUSH TP* (FRM) 194> ; (194) [243]
+ <MOVE D* (FRM) 64> ; (64)
+ <ADD D* [<(20) 20>]>
+ <JUMPGE D* |CERR2 >
+ <PUSH TP* <TYPE-WORD LIST>> ; [244]
+ <PUSH TP* (D) 1> ; [245]
+ <MOVEM A* (FRM) 13> ; (13)
+ <MOVEM B* (FRM) 14> ; (14)
+ <MCALL 4 PUSH-STRUCS>
+ <PUSH TP* (FRM) 59> ; (59) [238]
+ <PUSH TP* (FRM) 60> ; (60) [239]
+ <PUSH TP* (FRM) 163> ; (163) [240]
+ <PUSH TP* (FRM) 164> ; (164) [241]
+ <MOVE D* (FRM) 193> ; (193)
+ <MOVE PVP* (FRM) 194> ; (194)
+ <GETYP O* D>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG41>
+ <MOVE D* (FRM) 17> ; (17)
+ <MOVE PVP* (FRM) 18> ; (18)
+TAG41 <PUSH TP* D> ; 643 [242]
+ <PUSH TP* PVP> ; [243]
+ <PUSH TP* (FRM) 15> ; (15) [244]
+ <PUSH TP* (FRM) 16> ; (16) [245]
+ <MOVE D* (FRM) 82> ; (82)
+ <MOVEM A* (FRM) 75> ; (75)
+ <MOVEM B* (FRM) 76> ; (76)
+ <SOJN D* TAG42>
+ <MOVE D* <MQUOTE T> -1>
+ <MOVE PVP* <MQUOTE T>>
+ <JRST TAG43>
+TAG42 <MOVE D* <TYPE-WORD FALSE>> ; 654
+ <MOVEI PVP* 0>
+TAG43 <PUSH TP* D> ; 656 [246]
+ <PUSH TP* PVP> ; [247]
+ <PUSH TP* (FRM) 199> ; (199) [248]
+ <PUSH TP* (FRM) 200> ; (200) [249]
+ <MCALL 6 DO-FIRST-SETUP-2>
+ <GETYP O* (FRM) 193> ; (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG44>
+ <GETYP O* (FRM) 199> ; (199)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG44>
+ <MOVE B* (FRM) 18> ; (18)
+ <GETYP O* (B) 24>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG44>
+ <MOVE D* (B) 24>
+ <MOVE PVP* (B) 25>
+ <MOVEM D* (FRM) 197> ; (197)
+ <MOVEM PVP* (FRM) 198> ; (198)
+TAG44 <MOVE B* (FRM) 64> ; 675 (64)
+ <ADD B* [<(32) 32>]>
+ <JUMPGE B* |CERR2 >
+ <PUSH TP* <TYPE-WORD ATOM>> ; [238]
+ <PUSH TP* (B) 1> ; [239]
+ <MOVE B* (FRM) 64> ; (64)
+ <ADD B* [<(30) 30>]>
+ <JUMPGE B* |CERR2 >
+ <PUSH TP* (B) > ; [240]
+ <PUSH TP* (B) 1> ; [241]
+ <MOVE B* (FRM) 64> ; (64)
+ <ADD B* [<(34) 34>]>
+ <JUMPGE B* |CERR2 >
+ <PUSH TP* (B) > ; [242]
+ <PUSH TP* (B) 1> ; [243]
+ <MCALL 3 BEGIN-FRAME>
+ <GETYP O* (FRM) 219> ; (219)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG45>
+ <MOVE B* (FRM) 36> ; (36)
+ <JRST TAG46>
+TAG45 <PUSH TP* (FRM) 123> ; 696 (123) [238]
+ <PUSH TP* (FRM) 124> ; (124) [239]
+ <MOVE B* (FRM) 148> ; (148)
+ <JUMPE B* |CERR2 >
+ <HRRZ D* (B) >
+ <JUMPE D* |CERR2 >
+ <GETYP O* (D) 0>
+ <CAIN O* <TYPE-CODE DEFER>>
+ <MOVE D* (D) 1>
+ <PUSH TP* (D) > ; [240]
+ <PUSH TP* (D) 1> ; [241]
+ <MCALL 2 STACK:L>
+TAG46 <MOVE E* (FRM) 124> ; 708 (124)
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVEI D* 0>
+ <MOVEM B* (FRM) 130> ; (130)
+ <PUSHJ P* |C1CONS >
+ <MOVE E* B>
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVEI D* 0>
+ <MOVEM A* (FRM) 51> ; (51)
+ <MOVEM B* (FRM) 52> ; (52)
+ <MOVEM A* (FRM) 123> ; (123)
+ <MOVEM B* (FRM) 124> ; (124)
+ <PUSHJ P* |C1CONS >
+ <MOVEM A* (FRM) 123> ; (123)
+ <MOVEM B* (FRM) 124> ; (124)
+ <GETYP O* (FRM) 13> ; (13)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG47>
+ <PUSH TP* (FRM) 59> ; (59) [238]
+ <PUSH TP* (FRM) 60> ; (60) [239]
+ <PUSH TP* (FRM) 113> ; (113) [240]
+ <PUSH TP* (FRM) 114> ; (114) [241]
+ <MCALL 2 DO-FINAL-SETUP>
+ <MOVEM A* (FRM) 153> ; (153)
+ <MOVEM B* (FRM) 154> ; (154)
+TAG47 <PUSH TP* (FRM) 63> ; 733 (63) [238]
+ <PUSH TP* (FRM) 64> ; (64) [239]
+ <MCALL 1 PROG-START-AC>
+ <PUSH TP* (FRM) 107> ; (107) [238]
+ <PUSH TP* (FRM) 108> ; (108) [239]
+ <MCALL 1 LABEL:TAG>
+ <GETYP O* (FRM) 13> ; (13)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG48>
+ <GETYP O* (FRM) 193> ; (193)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG48>
+ <PUSH TP* (FRM) 55> ; (55) [238]
+ <PUSH TP* (FRM) 56> ; (56) [239]
+ <PUSH TP* (FRM) 51> ; (51) [240]
+ <PUSH TP* (FRM) 52> ; (52) [241]
+ <GETYP O* (FRM) 219> ; (219)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG49>
+TAG51 <MOVE B* <TYPE-WORD FALSE>> ; 752
+ <MOVEI D* 0>
+ <JRST TAG50>
+TAG49 <MOVE B* (FRM) 64> ; 755 (64)
+ <ADD B* [<(30) 30>]>
+ <JUMPGE B* |CERR2 >
+ <SKIPGE (B) 1>
+ <JRST TAG51>
+ <MOVE B* <MQUOTE T> -1>
+ <MOVE D* <MQUOTE T>>
+TAG50 <PUSH TP* B> ; 762 [242]
+ <PUSH TP* D> ; [243]
+ <MCALL 3 FIND-FIRST-STRUC>
+ <MOVEM A* (FRM) 57> ; (57)
+ <MOVEM B* (FRM) 58> ; (58)
+TAG48 <MOVE B* (FRM) 64> ; 767 (64)
+ <ADD B* [<(30) 30>]>
+ <JUMPGE B* |CERR2 >
+ <SKIPL (B) 1>
+ <JRST TAG52>
+ <MCALL 0 ACT:INITIAL>
+ <GETYP O* A>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG52>
+ <PUSH TP* <TYPE-WORD FIX>> ; [238]
+ <PUSH TP* [2]> ; [239]
+ <MCALL 1 ADD:STACK>
+TAG52 <MOVE E* (FRM) 124> ; 779 (124)
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVEI D* 0>
+ <PUSHJ P* |C1CONS >
+ <MOVEM A* (FRM) 95> ; (95)
+ <MOVEM B* (FRM) 96> ; (96)
+ <MOVEM A* (FRM) 123> ; (123)
+ <MOVEM B* (FRM) 124> ; (124)
+ <GETYP O* (FRM) 219> ; (219)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG53>
+ <GETYP O* (FRM) 193> ; (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG54>
+ <MOVE D* (FRM) 82> ; (82)
+ <SOJE D* TAG53>
+TAG54 <MOVE D* (FRM) 64> ; 795 (64)
+ <ADD D* [<(32) 32>]>
+ <JUMPGE D* |CERR2 >
+ <PUSH TP* <TYPE-WORD ATOM>> ; [238]
+ <PUSH TP* (D) 1> ; [239]
+ <MCALL 1 SALLOC:SLOTS>
+ <MOVE B* (FRM) 64> ; (64)
+ <ADD B* [<(32) 32>]>
+ <JUMPGE B* |CERR2 >
+ <PUSH TP* <TYPE-WORD ATOM>> ; [238]
+ <PUSH TP* (B) 1> ; [239]
+ <MCALL 1 ADD:STACK>
+ <GETYP O* (FRM) 219> ; (219)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG55>
+ <PUSH TP* <MQUOTE GVAL> -1> ; [238]
+ <PUSH TP* <MQUOTE GVAL>> ; [239]
+ <MOVE B* (FRM) 64> ; (64)
+ <ADD B* [<(32) 32>]>
+ <JUMPGE B* |CERR2 >
+ <PUSH TP* <TYPE-WORD ATOM>> ; [240]
+ <PUSH TP* (B) 1> ; [241]
+ <MOVEI A* 2 >
+ <PUSHJ P* |IIFORM >
+ <MOVE C* A>
+ <MOVE D* B>
+ <MOVEI E* 0>
+ <PUSHJ P* |C1CONS >
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (FRM) 1> ; (1)
+ <MOVEM B* (FRM) 2> ; (2)
+ <MOVE D* (FRM) 32> ; (32)
+ <HRRM D* @ B>
+ <MOVE B* (FRM) 2> ; (2)
+ <MOVEM B* (FRM) 32> ; (32)
+TAG55 <GETYP O* (FRM) 193> ; 830 (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG53>
+ <MOVE B* (FRM) 123> ; (123)
+ <MOVE D* (FRM) 124> ; (124)
+ <MOVE E* D>
+ <MOVEM B* (FRM) 213> ; (213)
+ <MOVEM D* (FRM) 214> ; (214)
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVEI D* 0>
+ <PUSHJ P* |C1CONS >
+ <MOVEM A* (FRM) 123> ; (123)
+ <MOVEM B* (FRM) 124> ; (124)
+TAG53 <GETYP O* (FRM) 219> ; 843 (219)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG56>
+ <GETYP O* (FRM) 193> ; (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG56>
+ <MOVE B* (FRM) 82> ; (82)
+ <SOJE B* TAG56>
+ <MOVE B* (FRM) 123> ; (123)
+ <MOVE D* (FRM) 124> ; (124)
+ <MOVEM B* (FRM) 213> ; (213)
+ <MOVEM D* (FRM) 214> ; (214)
+ <MOVE E* D>
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVEI D* 0>
+ <PUSHJ P* |C1CONS >
+ <MOVEM A* (FRM) 123> ; (123)
+ <MOVEM B* (FRM) 124> ; (124)
+TAG56 <GETYP O* (FRM) 153> ; 861 (153)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG57>
+ <MOVNI B* 2 >
+ <JRST TAG58>
+TAG57 <GETYP O* (FRM) 13> ; 866 (13)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG59>
+ <MOVNI B* 1 >
+ <JRST TAG58>
+TAG59 <MOVEI B* 0> ; 871
+TAG58 <MOVEM B* (FRM) 70> ; 872 (70)
+ <GETYP O* (FRM) 193> ; (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG60>
+ <GETYP O* (FRM) 15> ; (15)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG61>
+ <MOVE D* (FRM) 82> ; (82)
+ <SOJE D* TAG60>
+TAG61 <GETYP O* (FRM) 199> ; 881 (199)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG60>
+ <PUSH TP* (FRM) 17> ; (17) [238]
+ <PUSH TP* (FRM) 18> ; (18) [239]
+ <MCALL 1 LVAL-UP>
+TAG60 <MOVE O* <TYPE-WORD LIST>> ; 887
+ <MOVEM O* (FRM) 223> ; (223)
+ <MOVE O* (FRM) -2> ; (-2)
+ <MOVEM O* (FRM) 224> ; (224)
+ <MOVE B* (FRM) 64> ; (64)
+ <ADD B* [<(20) 20>]>
+ <JUMPGE B* |CERR2 >
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (FRM) 225> ; (225)
+ <MOVE O* (B) 1>
+ <MOVEM O* (FRM) 226> ; (226)
+ <MOVE A* (FRM) 225> ; (225)
+ <MOVE B* (FRM) 226> ; (226)
+ <PUSHJ P* |CEMPTY >
+ <JRST TAG62>
+ <MOVEI B* 0>
+ <JRST TAG63>
+TAG62 <PUSH TP* <TYPE-WORD FALSE>> ; 904 [238]
+ <PUSH TP* [0]> ; [239]
+ <PUSH TP* (FRM) 225> ; (225) [240]
+ <PUSH TP* (FRM) 226> ; (226) [241]
+ <PUSH P* [-1]>
+TAG66 <MOVE A* (TP) -1> ; 909 (240)
+ <MOVE B* (TP) > ; (241)
+ <PUSHJ P* |TYPSEG >
+ <SKIPL (P) >
+ <XCT (C) |INCR1 >
+ <XCT (C) |TESTR >
+ <JRST TAG64>
+ <MOVE A* |DSTORE >
+ <MOVE B* D>
+ <MOVE O* |DSTORE >
+ <MOVEM O* (TP) -1> ; (240)
+ <MOVEM D* (TP) > ; (241)
+ <SETZM |DSTORE >
+ <SKIPGE |INTFLG >
+ <SAVAC O* [<(*100*) 0>]>
+ <MOVE D* (B) 1>
+ <MOVE PVP* (D) 3>
+ <CAME PVP* <MQUOTE DUMMY-MAPF!-COMPDEC!-PACKAGE>>
+ <JRST TAG65>
+ <MOVEI TVP* 0>
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (TP) -3> ; (238)
+ <MOVEM TVP* (TP) -2> ; (239)
+ <SETZM (P) >
+ <JRST TAG66>
+TAG64 <SETZM |DSTORE > ; 934
+ <MOVE B* (TP) -2> ; (239)
+TAG65 <SUB TP* [<(4) 4>]> ; 936
+ <SUB P* [<(1) 1>]>
+TAG63 <MOVE O* <TYPE-WORD LIST>> ; 938
+ <MOVEM O* (FRM) 227> ; (227)
+ <MOVEM B* (FRM) 228> ; (228)
+ <MOVE C* <TYPE-WORD LIST>>
+ <MOVEI D* 0>
+ <MOVEI E* 0>
+ <PUSHJ P* |C1CONS >
+ <MOVEI D* 1 >
+ <MOVE PVP* (FRM) 82> ; (82)
+ <ASH PVP* A>
+ <SUB D* PVP>
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVE E* B>
+ <PUSHJ P* |C1CONS >
+ <MOVEM A* (FRM) 229> ; (229)
+ <MOVEM B* (FRM) 230> ; (230)
+ <MOVE C* <TYPE-WORD LIST>>
+ <MOVEI D* 0>
+ <MOVEI E* 0>
+ <PUSHJ P* |C1CONS >
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVEI D* 0>
+ <MOVE E* B>
+ <PUSHJ P* |C1CONS >
+ <MOVEM A* (FRM) 231> ; (231)
+ <MOVEM B* (FRM) 232> ; (232)
+ <MOVE O* <MQUOTE (0)> -1>
+ <MOVEM O* (FRM) 233> ; (233)
+ <MOVE O* <MQUOTE (0)>>
+ <MOVEM O* (FRM) 234> ; (234)
+TAG88 <INTGO> ; 968
+ <MOVE B* (FRM) 224> ; (224)
+ <JUMPN B* TAG67>
+ <GETYP O* (FRM) 193> ; (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG68>
+ <MOVE D* (FRM) 82> ; (82)
+ <SOJE D* TAG68>
+ <GETYP O* (FRM) 99> ; (99)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG68>
+ <GETYP O* (FRM) 199> ; (199)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG68>
+ <PUSH TP* (FRM) 197> ; (197) [238]
+ <PUSH TP* (FRM) 198> ; (198) [239]
+ <MCALL 1 RET-TMP-AC>
+TAG68 <GETYP O* (FRM) 13> ; 986 (13)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG69>
+ <GETYP O* (FRM) 57> ; (57)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG69>
+ <PUSH TP* (FRM) 55> ; (55) [238]
+ <PUSH TP* (FRM) 56> ; (56) [239]
+ <MCALL 1 RET-TMP-AC>
+TAG69 <MOVE B* (FRM) 228> ; 995 (228)
+ <JUMPE B* TAG70>
+TAG71 <MOVE D* (B) 1> ; 997
+ <SKIPGE |INTFLG >
+ <SAVAC O* [<(*1200*) *150000*>]>
+ <MOVE PVP* <MQUOTE %<RGLOC MBINDERS!-MAPGEN!-PACKAGE T>>>
+ <ADD PVP* |GLOTOP 1>
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (FRM) 5> ; (5)
+ <MOVEM B* (FRM) 6> ; (6)
+ <MOVE A* (PVP) >
+ <MOVE B* (PVP) 1>
+ <MOVE C* (D) 7>
+ <MOVE O* <MQUOTE %<TYPE-W SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>
+ <MOVEM O* (FRM) 1> ; (1)
+ <MOVEM D* (FRM) 2> ; (2)
+ <PUSHJ P* |CINTH >
+ <PUSH TP* A> ; [238]
+ <PUSH TP* B> ; [239]
+ <PUSH TP* (FRM) 1> ; (1) [240]
+ <PUSH TP* (FRM) 2> ; (2) [241]
+ <MCALL 2 APPLY>
+ <MOVE B* (FRM) 6> ; (6)
+ <HRRZ B* (B) >
+ <JUMPN B* TAG71>
+ <JRST TAG70>
+TAG67 <MOVE D* (FRM) 228> ; 1021 (228)
+ <JUMPE D* |CERR2 >
+ <MOVE PVP* (D) 1>
+ <GETYP O* (PVP) 14>
+ <CAIE O* <MQUOTE %<TYPE-C TEMPV!-COMPDEC!-PACKAGE LIST>>>
+ <JRST TAG72>
+ <MOVE TVP* <MQUOTE TEMPV!-COMPDEC!-PACKAGE>>
+ <MOVE C* <TYPE-WORD ATOM>>
+ <JRST TAG73>
+TAG72 <MOVE C* <TYPE-WORD FALSE>> ; 1030
+ <MOVEI TVP* 0>
+TAG73 <MOVEM C* (FRM) 21> ; 1032 (21)
+ <MOVEM TVP* (FRM) 22> ; (22)
+ <GETYP O* (FRM) 193> ; (193)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG74>
+ <GETYP O* (FRM) 13> ; (13)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG75>
+ <GETYP O* (FRM) 57> ; (57)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG76>
+ <PUSH TP* (FRM) 57> ; (57) [238]
+ <PUSH TP* (FRM) 58> ; (58) [239]
+ <GETYP O* (FRM) 175> ; (175)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG77>
+ <MOVSI E* <TYPE-CODE FORM>>
+ <JRST TAG78>
+TAG77 <MOVSI E* <TYPE-CODE TIME>> ; 1050
+TAG78 <PUSH TP* <MQUOTE %<TYPE-W OPCODE!-OP!-PACKAGE WORD>>>; 1051 [240]
+ <PUSH TP* E> ; [241]
+ <GETYP O* (FRM) 175> ; (175)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG79>
+ <MOVEI E* 1 >
+ <JRST TAG80>
+TAG79 <MOVEI E* 0> ; 1058
+TAG80 <PUSH TP* <TYPE-WORD FIX>> ; 1059 [242]
+ <PUSH TP* E> ; [243]
+ <MCALL 3 ADDRESS:C>
+ <MOVEM A* (FRM) 3> ; (3)
+ <MOVEM B* (FRM) 4> ; (4)
+ <GETYP O* (FRM) 21> ; (21)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG74>
+ <PUSH TP* (FRM) 57> ; (57) [238]
+ <PUSH TP* (FRM) 58> ; (58) [239]
+ <PUSH TP* <TYPE-WORD FIX>> ; [240]
+ <PUSH TP* [2]> ; [241]
+ <MOVEI A* 2 >
+ <PUSHJ P* |CPLUS >
+ <MOVEM A* (FRM) 57> ; (57)
+ <MOVEM B* (FRM) 58> ; (58)
+ <JRST TAG74>
+TAG76 <MOVE E* (FRM) 230> ; 1076 (230)
+ <PUSH TP* <TYPE-WORD FIX>> ; [238]
+ <PUSH TP* (E) 1> ; [239]
+ <PUSH TP* (FRM) 55> ; (55) [240]
+ <PUSH TP* (FRM) 56> ; (56) [241]
+ <PUSH TP* <MQUOTE VECTOR> -1> ; [242]
+ <PUSH TP* <MQUOTE VECTOR>> ; [243]
+ <HRRZ A* (E) >
+ <MOVE B* (A) 1>
+ <MOVE A* <TYPE-WORD LIST>>
+ <PUSH P* [0]>
+ <MOVEI O* |SEGMNT >
+ <PUSHJ P* |RCALL >
+ <PUSH TP* (FRM) 123> ; (123) [244]
+ <PUSH TP* (FRM) 124> ; (124) [245]
+ <PUSH TP* (FRM) 95> ; (95) [246]
+ <PUSH TP* (FRM) 96> ; (96) [247]
+ <MCALL 2 STACK:L>
+ <MOVEI O* |SEGLST >
+ <PUSHJ P* |RCALL >
+ <SUB P* [<(1) 1>]>
+ <PUSH TP* A> ; [244]
+ <PUSH TP* B> ; [245]
+ <MCALL 4 SPEC-OFFPTR>
+ <MOVEM A* (FRM) 3> ; (3)
+ <MOVEM B* (FRM) 4> ; (4)
+ <GETYP O* (FRM) 21> ; (21)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG74>
+ <PUSH TP* <TYPE-WORD LIST>> ; [238]
+ <PUSH TP* (FRM) 230> ; (230) [239]
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVEI D* 2 >
+ <MOVEI E* 0>
+ <PUSHJ P* |C1CONS >
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (FRM) 5> ; (5)
+ <MOVEM B* (FRM) 6> ; (6)
+ <MOVE D* (FRM) 232> ; (232)
+ <MOVN D* (D) 1>
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVEI E* 0>
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (FRM) 1> ; (1)
+ <MOVEM B* (FRM) 2> ; (2)
+ <PUSHJ P* |C1CONS >
+ <HRRM B* @ (FRM) 2> ; (2)
+ <MOVEM B* (FRM) 2> ; (2)
+ <PUSH TP* <MQUOTE -> -1> ; [240]
+ <PUSH TP* <MQUOTE ->> ; [241]
+ <PUSH TP* <TYPE-WORD FIX>> ; [242]
+ <PUSH TP* [0]> ; [243]
+ <MOVE B* (FRM) 232> ; (232)
+ <HRRZ D* (B) >
+ <MOVE A* <TYPE-WORD LIST>>
+ <MOVE B* (D) 1>
+ <PUSH P* [2]>
+ <MOVEI O* |SEGMNT >
+ <PUSHJ P* |RCALL >
+ <POP P* A>
+ <PUSHJ P* |IIFORM >
+ <MOVE C* A>
+ <MOVE D* B>
+ <MOVEI E* 0>
+ <PUSHJ P* |C1CONS >
+ <HRRM B* @ (FRM) 2> ; (2)
+ <MOVEM B* (FRM) 2> ; (2)
+ <PUSH TP* <TYPE-WORD LIST>> ; [240]
+ <PUSH TP* (FRM) 6> ; (6) [241]
+ <JRST TAG81>
+TAG75 <PUSH TP* <MQUOTE -> -1> ; 1146 [238]
+ <PUSH TP* <MQUOTE ->> ; [239]
+ <MOVE E* (FRM) 230> ; (230)
+ <PUSH TP* <TYPE-WORD FIX>> ; [240]
+ <PUSH TP* (E) 1> ; [241]
+ <PUSH TP* (FRM) 123> ; (123) [242]
+ <PUSH TP* (FRM) 124> ; (124) [243]
+ <PUSH TP* (FRM) 95> ; (95) [244]
+ <PUSH TP* (FRM) 96> ; (96) [245]
+ <MCALL 2 STACK:L>
+ <PUSH P* [2]>
+ <MOVEI O* |SEGMNT >
+ <PUSHJ P* |RCALL >
+ <POP P* A>
+ <PUSHJ P* |IIFORM >
+ <PUSH TP* A> ; [238]
+ <PUSH TP* B> ; [239]
+ <PUSH TP* <MQUOTE %<TYPE-W OPCODE!-OP!-PACKAGE WORD>>>; [240]
+ <PUSH TP* [<(*13*) 0>]> ; [241]
+ <MOVE B* (FRM) 230> ; (230)
+ <HRRZ D* (B) >
+ <MOVE A* <TYPE-WORD LIST>>
+ <MOVE B* (D) 1>
+ <PUSH P* [2]>
+ <MOVEI O* |SEGMNT >
+ <PUSHJ P* |RCALL >
+ <POP P* A>
+ <ACALL A* ADDRESS:C>
+ <PUSH TP* <TYPE-WORD LIST>> ; [238]
+ <PUSH TP* (FRM) 230> ; (230) [239]
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVEI D* 2 >
+ <MOVEI E* 0>
+ <MOVEM A* (FRM) 3> ; (3)
+ <MOVEM B* (FRM) 4> ; (4)
+ <PUSHJ P* |C1CONS >
+ <PUSH TP* A> ; [240]
+ <PUSH TP* B> ; [241]
+TAG81 <MCALL 2 STFIXIT> ; 1184
+ <MOVEM B* (FRM) 230> ; (230)
+TAG74 <MOVE B* (FRM) 228> ; 1186 (228)
+ <JUMPE B* |CERR2 >
+ <MOVE D* (B) 1>
+ <MOVE PVP* (D) 7>
+ <CAIE PVP* 4 >
+ <JRST TAG82>
+ <PUSH TP* <MQUOTE ERROR> -1> ; [238]
+ <PUSH TP* <MQUOTE ERROR>> ; [239]
+ <PUSH TP* <MQUOTE "NOT IMPLEMENTED MAPF/R TUPLES "> -1>; [240]
+ <PUSH TP* <MQUOTE "NOT IMPLEMENTED MAPF/R TUPLES ">>; [241]
+ <MCALL 2 MESSAGE>
+TAG82 <GETYP O* (FRM) 193> ; 1197 (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG83>
+ <PUSH TP* <MQUOTE +> -1> ; [238]
+ <PUSH TP* <MQUOTE +>> ; [239]
+ <MOVE A* (FRM) 233> ; (233)
+ <MOVE B* (FRM) 234> ; (234)
+ <PUSH P* [1]>
+ <MOVEI O* |SEGMNT >
+ <PUSHJ P* |RCALL >
+ <POP P* A>
+ <PUSHJ P* |IIFORM >
+ <MOVE C* A>
+ <MOVE D* B>
+ <MOVEI E* 0>
+ <PUSHJ P* |C1CONS >
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (FRM) 5> ; (5)
+ <MOVEM B* (FRM) 6> ; (6)
+ <JRST TAG84>
+TAG83 <PUSH TP* <MQUOTE -> -1> ; 1217 [238]
+ <PUSH TP* <MQUOTE ->> ; [239]
+ <PUSH TP* <TYPE-WORD FIX>> ; [240]
+ <PUSH TP* [0]> ; [241]
+ <MOVE B* (FRM) 232> ; (232)
+ <PUSH TP* <TYPE-WORD FIX>> ; [242]
+ <PUSH TP* (B) 1> ; [243]
+ <HRRZ B* (B) >
+ <MOVE A* <TYPE-WORD LIST>>
+ <MOVE B* (B) 1>
+ <PUSH P* [3]>
+ <MOVEI O* |SEGMNT >
+ <PUSHJ P* |RCALL >
+ <POP P* A>
+ <PUSHJ P* |IIFORM >
+ <MOVE C* A>
+ <MOVE D* B>
+ <MOVEI E* 0>
+ <PUSHJ P* |C1CONS >
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (FRM) 5> ; (5)
+ <MOVEM B* (FRM) 6> ; (6)
+ <MOVE C* <TYPE-WORD LIST>>
+ <MOVEI D* 0>
+ <MOVEI E* 0>
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (FRM) 1> ; (1)
+ <MOVEM B* (FRM) 2> ; (2)
+ <PUSHJ P* |C1CONS >
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVEI D* 0>
+ <MOVE E* B>
+ <PUSHJ P* |C1CONS >
+ <PUSH TP* A> ; [238]
+ <PUSH TP* B> ; [239]
+ <PUSH TP* (FRM) 123> ; (123) [240]
+ <PUSH TP* (FRM) 124> ; (124) [241]
+ <PUSH TP* (FRM) 95> ; (95) [242]
+ <PUSH TP* (FRM) 96> ; (96) [243]
+ <MCALL 2 STACK:L>
+ <PUSH TP* A> ; [240]
+ <PUSH TP* B> ; [241]
+ <MCALL 2 STFIXIT>
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVE D* (B) 1>
+ <MOVEI E* 0>
+ <MOVEM B* (FRM) 232> ; (232)
+ <PUSHJ P* |C1CONS >
+ <HRRM B* @ (FRM) 2> ; (2)
+ <MOVEM B* (FRM) 2> ; (2)
+ <MOVE B* (FRM) 232> ; (232)
+ <HRRZ D* (B) >
+ <MOVE PVP* (D) 1>
+ <HRRM PVP* @ (FRM) 2> ; (2)
+TAG84 <MOVE D* (FRM) 6> ; 1271 (6)
+ <MOVE C* <TYPE-WORD LIST>>
+ <MOVEI E* 0>
+ <PUSHJ P* |C1CONS >
+ <MOVE D* (FRM) 102> ; (102)
+ <JUMPE D* |CERR2 >
+ <MOVE C* <TYPE-WORD ATOM>>
+ <MOVE D* (D) 1>
+ <MOVE E* B>
+ <PUSHJ P* |C1CONS >
+ <PUSH TP* A> ; [238]
+ <PUSH TP* B> ; [239]
+ <MOVE A* (FRM) 159> ; (159)
+ <MOVE B* (FRM) 160> ; (160)
+ <PUSH P* [1]>
+ <MOVEI O* |SEGLST >
+ <PUSHJ P* |RCALL >
+ <SUB P* [<(1) 1>]>
+ <MOVEM A* (FRM) 159> ; (159)
+ <MOVEM B* (FRM) 160> ; (160)
+ <GETYP O* (FRM) 193> ; (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG85>
+ <MOVE D* (FRM) 224> ; (224)
+ <JUMPE D* |CERR2 >
+ <MOVE PVP* (D) 1>
+ <PUSH TP* (PVP) 4> ; [238]
+ <PUSH TP* (PVP) 5> ; [239]
+ <MOVE A* (FRM) 225> ; (225)
+ <MOVE B* (FRM) 226> ; (226)
+ <MOVEI C* 1 >
+ <PUSHJ P* |CINTH >
+ <PUSH TP* A> ; [240]
+ <PUSH TP* B> ; [241]
+ <MOVE B* (FRM) 228> ; (228)
+ <JUMPE B* |CERR2 >
+ <PUSH TP* <MQUOTE %<TYPE-W SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>; [242]
+ <PUSH TP* (B) 1> ; [243]
+ <PUSH TP* (FRM) 91> ; (91) [244]
+ <PUSH TP* (FRM) 92> ; (92) [245]
+ <MOVE D* (FRM) 102> ; (102)
+ <JUMPE D* |CERR2 >
+ <PUSH TP* <TYPE-WORD ATOM>> ; [246]
+ <PUSH TP* (D) 1> ; [247]
+ <PUSH TP* (FRM) 15> ; (15) [248]
+ <PUSH TP* (FRM) 16> ; (16) [249]
+ <PUSH TP* (FRM) 81> ; (81) [250]
+ <PUSH TP* (FRM) 82> ; (82) [251]
+ <PUSH TP* (FRM) 111> ; (111) [252]
+ <PUSH TP* (FRM) 112> ; (112) [253]
+ <MCALL *10* ISET>
+ <MOVE A* (FRM) 225> ; (225)
+ <MOVE B* (FRM) 226> ; (226)
+ <MOVEI C* 1 >
+ <PUSHJ P* |CIREST >
+ <PUSH TP* (FRM) 123> ; (123) [238]
+ <PUSH TP* (FRM) 124> ; (124) [239]
+ <PUSH TP* (FRM) 213> ; (213) [240]
+ <PUSH TP* (FRM) 214> ; (214) [241]
+ <MOVEM A* (FRM) 225> ; (225)
+ <MOVEM B* (FRM) 226> ; (226)
+ <MCALL 2 STACK:L>
+ <MOVEM A* (FRM) 233> ; (233)
+ <MOVEM B* (FRM) 234> ; (234)
+ <JRST TAG86>
+TAG85 <GETYP O* (FRM) 21> ; 1336 (21)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG87>
+ <PUSH TP* (FRM) 63> ; (63) [238]
+ <PUSH TP* (FRM) 64> ; (64) [239]
+ <PUSH TP* (FRM) 123> ; (123) [240]
+ <PUSH TP* (FRM) 124> ; (124) [241]
+ <MCALL 2 RETURN-UP>
+ <MOVE B* (FRM) 224> ; (224)
+ <JUMPE B* |CERR2 >
+ <MOVE D* (B) 1>
+ <PUSH TP* (D) 4> ; [238]
+ <PUSH TP* (D) 5> ; [239]
+ <MOVE PVP* (FRM) 228> ; (228)
+ <JUMPE PVP* |CERR2 >
+ <PUSH TP* <MQUOTE %<TYPE-W SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>; [240]
+ <PUSH TP* (PVP) 1> ; [241]
+ <PUSH TP* <MQUOTE %<TYPE-W NODE!-COMPDEC!-PACKAGE VECTOR>>>; [242]
+ <PUSH TP* D> ; [243]
+ <PUSH TP* (FRM) 3> ; (3) [244]
+ <PUSH TP* (FRM) 4> ; (4) [245]
+ <PUSH TP* (FRM) 3> ; (3) [246]
+ <PUSH TP* (FRM) 4> ; (4) [247]
+ <MCALL 2 DATUM>
+ <PUSH TP* A> ; [244]
+ <PUSH TP* B> ; [245]
+ <PUSH TP* (FRM) 91> ; (91) [246]
+ <PUSH TP* (FRM) 92> ; (92) [247]
+ <MOVE B* (FRM) 102> ; (102)
+ <JUMPE B* |CERR2 >
+ <PUSH TP* <TYPE-WORD ATOM>> ; [248]
+ <PUSH TP* (B) 1> ; [249]
+ <PUSH TP* (FRM) 69> ; (69) [250]
+ <PUSH TP* (FRM) 70> ; (70) [251]
+ <MCALL 5 STACKM>
+ <PUSH TP* A> ; [242]
+ <PUSH TP* B> ; [243]
+ <PUSH TP* (FRM) 91> ; (91) [244]
+ <PUSH TP* (FRM) 92> ; (92) [245]
+ <MCALL 4 IISET>
+ <JRST TAG86>
+TAG87 <MOVE D* (FRM) 228> ; 1377 (228)
+ <JUMPE D* |CERR2 >
+ <PUSH TP* <MQUOTE %<TYPE-W SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>; [238]
+ <PUSH TP* (D) 1> ; [239]
+ <MOVE PVP* (FRM) 224> ; (224)
+ <JUMPE PVP* |CERR2 >
+ <PUSH TP* <MQUOTE %<TYPE-W NODE!-COMPDEC!-PACKAGE VECTOR>>>; [240]
+ <PUSH TP* (PVP) 1> ; [241]
+ <PUSH TP* (FRM) 3> ; (3) [242]
+ <PUSH TP* (FRM) 4> ; (4) [243]
+ <PUSH TP* (FRM) 3> ; (3) [244]
+ <PUSH TP* (FRM) 4> ; (4) [245]
+ <MCALL 2 DATUM>
+ <PUSH TP* A> ; [242]
+ <PUSH TP* B> ; [243]
+ <PUSH TP* (FRM) 91> ; (91) [244]
+ <PUSH TP* (FRM) 92> ; (92) [245]
+ <MOVE B* (FRM) 102> ; (102)
+ <JUMPE B* |CERR2 >
+ <PUSH TP* <TYPE-WORD ATOM>> ; [246]
+ <PUSH TP* (B) 1> ; [247]
+ <PUSH TP* (FRM) 69> ; (69) [248]
+ <PUSH TP* (FRM) 70> ; (70) [249]
+ <MCALL 5 STACKM>
+ <PUSH TP* A> ; [240]
+ <PUSH TP* B> ; [241]
+ <MCALL 2 BINDUP>
+TAG86 <MOVE B* (FRM) 102> ; 1404 (102)
+ <JUMPE B* |CERR2 >
+ <HRRZ B* (B) >
+ <MOVE D* (FRM) 224> ; (224)
+ <JUMPE D* |CERR2 >
+ <HRRZ D* (D) >
+ <MOVE PVP* (FRM) 228> ; (228)
+ <JUMPE PVP* |CERR2 >
+ <HRRZ PVP* (PVP) >
+ <MOVEM B* (FRM) 102> ; (102)
+ <MOVEM D* (FRM) 224> ; (224)
+ <MOVEM PVP* (FRM) 228> ; (228)
+ <JRST TAG88>
+TAG70 <GETYP O* (FRM) 193> ; 1417 (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG89>
+ <GETYP O* (FRM) 15> ; (15)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG90>
+ <MOVE B* (FRM) 82> ; (82)
+ <SOJE B* TAG89>
+TAG90 <GETYP O* (FRM) 199> ; 1425 (199)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG89>
+ <GETYP O* (FRM) 99> ; (99)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG89>
+ <MOVE O* (FRM) 17> ; (17)
+ <MOVEM O* (FRM) 223> ; (223)
+ <MOVE O* (FRM) 18> ; (18)
+ <MOVEM O* (FRM) 224> ; (224)
+ <MOVE B* (FRM) 224> ; (224)
+ <MOVE O* <MQUOTE T> -1>
+ <MOVEM O* (B) 26>
+ <MOVE O* <MQUOTE T>>
+ <MOVEM O* (B) 27>
+ <GETYP O* (B) 24>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG89>
+ <MOVE D* (B) 25>
+ <GETYP O* (D) 0>
+ <CAIE O* <MQUOTE %<TYPE-C AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <JRST TAG91>
+ <PUSH TP* (D) > ; [238]
+ <PUSH TP* (D) 1> ; [239]
+ <PUSH TP* <MQUOTE %<TYPE-W SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>; [240]
+ <PUSH TP* B> ; [241]
+ <MCALL 2 FLUSH-RESIDUE>
+TAG91 <MOVE B* (FRM) 224> ; 1452 (224)
+ <MOVE D* (B) 25>
+ <HRRZ PVP* (D) >
+ <GETYP O* (PVP) 0>
+ <CAIE O* <MQUOTE %<TYPE-C AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <JRST TAG92>
+ <HRRZ PVP* (D) >
+ <PUSH TP* (PVP) > ; [238]
+ <PUSH TP* (PVP) 1> ; [239]
+ <PUSH TP* <MQUOTE %<TYPE-W SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>; [240]
+ <PUSH TP* B> ; [241]
+ <MCALL 2 FLUSH-RESIDUE>
+TAG92 <MOVE B* (FRM) 224> ; 1464 (224)
+ <MOVE O* <TYPE-WORD FALSE>>
+ <MOVEM O* (B) 24>
+ <SETZM (B) 25>
+TAG89 <GETYP O* (FRM) 193> ; 1468 (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG93>
+ <GETYP O* (FRM) 15> ; (15)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG93>
+ <MOVE B* (FRM) 82> ; (82)
+ <SOJN B* TAG93>
+ <GETYP O* (FRM) 199> ; (199)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG93>
+ <PUSH TP* (FRM) 17> ; (17) [238]
+ <PUSH TP* (FRM) 18> ; (18) [239]
+ <MCALL 1 LVAL-UP>
+TAG93 <GETYP O* (FRM) 219> ; 1482 (219)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG94>
+ <MOVE B* (FRM) 64> ; (64)
+ <ADD B* [<(26) 26>]>
+ <JUMPGE B* |CERR2 >
+ <MOVE D* <TYPE-WORD FIX>>
+ <MOVE PVP* (B) 1>
+ <MOVEM D* (FRM) 39> ; (39)
+ <MOVEM PVP* (FRM) 40> ; (40)
+ <JUMPE PVP* TAG94>
+ <PUSH TP* D> ; [238]
+ <PUSH TP* PVP> ; [239]
+ <MCALL 1 SALLOC:SLOTS>
+ <PUSH TP* (FRM) 39> ; (39) [238]
+ <PUSH TP* (FRM) 40> ; (40) [239]
+ <MCALL 1 ADD:STACK>
+ <MOVE B* <MQUOTE T> -1>
+ <MOVE D* <MQUOTE T>>
+ <PUSH TP* B> ; [238]
+ <PUSH TP* D> ; [239]
+ <MOVEM B* (FRM) 219> ; (219)
+ <MOVEM D* (FRM) 220> ; (220)
+ <MCALL 1 EMIT-PRE>
+TAG94 <MOVE B* (FRM) 64> ; 1506 (64)
+ <ADD B* [<(30) 30>]>
+ <JUMPGE B* |CERR2 >
+ <SKIPGE (B) 1>
+ <MCALL 0 ACT:FINAL>
+ <MOVE B* (FRM) 123> ; (123)
+ <MOVE D* (FRM) 124> ; (124)
+ <MOVEM B* (FRM) 135> ; (135)
+ <MOVEM D* (FRM) 136> ; (136)
+ <GETYP O* (FRM) 157> ; (157)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG95>
+ <MOVE PVP* (FRM) 64> ; (64)
+ <MOVEM PVP* (FRM) 142> ; (142)
+TAG95 <MOVE E* (FRM) 124> ; 1520 (124)
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVEI D* 0>
+ <PUSHJ P* |C1CONS >
+ <MOVEM A* (FRM) 123> ; (123)
+ <MOVEM B* (FRM) 124> ; (124)
+ <GETYP O* (FRM) 207> ; (207)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <MCALL 0 CALL-INTERRUPT>
+ <GETYP O* (FRM) 91> ; (91)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG96>
+ <GETYP O* (FRM) 13> ; (13)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG96>
+ <GETYP O* (FRM) 99> ; (99)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG96>
+ <GETYP O* (FRM) 199> ; (199)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG96>
+ <MOVE B* (FRM) 82> ; (82)
+ <SOJN B* TAG96>
+ <MOVE B* (FRM) 64> ; (64)
+ <PUSH TP* <TYPE-WORD LIST>> ; [238]
+ <PUSH TP* (B) 9> ; [239]
+ <ADD B* [<(20) 20>]>
+ <JUMPGE B* |CERR2 >
+ <PUSH TP* <TYPE-WORD LIST>> ; [240]
+ <PUSH TP* (B) 1> ; [241]
+ <MOVE B* (FRM) -2> ; (-2)
+ <JUMPE B* |CERR2 >
+ <MOVE D* (B) 1>
+ <PUSH TP* (D) 4> ; [242]
+ <PUSH TP* (D) 5> ; [243]
+ <MCALL 1 MINL>
+ <PUSH TP* A> ; [242]
+ <PUSH TP* B> ; [243]
+ <MCALL 3 BLT-HACK>
+ <JUMPGE B* TAG96>
+ <MOVE B* <TYPE-WORD FALSE>>
+ <MOVEI D* 0>
+ <MOVEM B* (FRM) 209> ; (209)
+ <MOVEM D* (FRM) 210> ; (210)
+ <JRST TAG97>
+TAG96 <GETYP O* (FRM) 13> ; 1565 (13)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG98>
+ <GETYP O* (FRM) 99> ; (99)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG99>
+TAG98 <MOVE B* (FRM) 64> ; 1571 (64)
+ <PUSH TP* <TYPE-WORD LIST>> ; [238]
+ <PUSH TP* (B) 9> ; [239]
+ <PUSH TP* <MQUOTE %<TYPE-W NODE!-COMPDEC!-PACKAGE VECTOR>>>; [240]
+ <PUSH TP* B> ; [241]
+ <PUSH TP* <MQUOTE DONT-CARE!-COMPDEC!-PACKAGE> -1>; [242]
+ <PUSH TP* <MQUOTE DONT-CARE!-COMPDEC!-PACKAGE>> ; [243]
+ <MCALL 2 GOODACS>
+ <PUSH TP* A> ; [240]
+ <PUSH TP* B> ; [241]
+ <PUSH TP* <MQUOTE T> -1> ; [242]
+ <PUSH TP* <MQUOTE T>> ; [243]
+ <MCALL 3 SEQ-GEN>
+TAG103 <MOVEM A* (FRM) 11> ; 1584 (11)
+ <MOVEM B* (FRM) 12> ; (12)
+ <JRST TAG97>
+TAG99 <GETYP O* (FRM) 199> ; 1587 (199)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG100>
+ <MOVE B* (FRM) 64> ; (64)
+ <PUSH TP* <TYPE-WORD LIST>> ; [238]
+ <PUSH TP* (B) 9> ; [239]
+ <GETYP O* (FRM) 193> ; (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG101>
+ <MOVE D* (FRM) 197> ; (197)
+ <MOVE PVP* (FRM) 198> ; (198)
+ <JRST TAG102>
+TAG101 <PUSH TP* <MQUOTE -> -1> ; 1599 [240]
+ <PUSH TP* <MQUOTE ->> ; [241]
+ <PUSH TP* <TYPE-WORD FIX>> ; [242]
+ <PUSH TP* [-1]> ; [243]
+ <MOVE D* (FRM) 82> ; (82)
+ <ASH D* A>
+ <PUSH TP* <TYPE-WORD FIX>> ; [244]
+ <PUSH TP* D> ; [245]
+ <PUSH TP* (FRM) 123> ; (123) [246]
+ <PUSH TP* (FRM) 124> ; (124) [247]
+ <PUSH TP* (FRM) 95> ; (95) [248]
+ <PUSH TP* (FRM) 96> ; (96) [249]
+ <MCALL 2 STACK:L>
+ <PUSH P* [3]>
+ <MOVEI O* |SEGMNT >
+ <PUSHJ P* |RCALL >
+ <POP P* A>
+ <PUSHJ P* |IIFORM >
+ <PUSH TP* A> ; [240]
+ <PUSH TP* B> ; [241]
+ <PUSH TP* <MQUOTE %<TYPE-W OPCODE!-OP!-PACKAGE WORD>>>; [242]
+ <PUSH TP* [<(*13*) 0>]> ; [243]
+ <MCALL 2 ADDRESS:C>
+ <PUSH TP* A> ; [240]
+ <PUSH TP* B> ; [241]
+ <PUSH TP* A> ; [242]
+ <PUSH TP* B> ; [243]
+ <MCALL 2 DATUM>
+ <MOVE D* A>
+ <MOVE PVP* B>
+TAG102 <PUSH TP* D> ; 1629 [240]
+ <PUSH TP* PVP> ; [241]
+ <PUSH TP* <MQUOTE T> -1> ; [242]
+ <PUSH TP* <MQUOTE T>> ; [243]
+ <MCALL 3 SEQ-GEN>
+ <MOVEM A* (FRM) 197> ; (197)
+ <MOVEM B* (FRM) 198> ; (198)
+ <JRST TAG103>
+TAG100 <MOVE B* (FRM) 64> ; 1637 (64)
+ <PUSH TP* <TYPE-WORD LIST>> ; [238]
+ <PUSH TP* (B) 9> ; [239]
+ <PUSH TP* <MQUOTE FLUSHED!-COMPDEC!-PACKAGE> -1> ; [240]
+ <PUSH TP* <MQUOTE FLUSHED!-COMPDEC!-PACKAGE>> ; [241]
+ <PUSH TP* <MQUOTE T> -1> ; [242]
+ <PUSH TP* <MQUOTE T>> ; [243]
+ <MCALL 3 SEQ-GEN>
+ <PUSH TP* A> ; [238]
+ <PUSH TP* B> ; [239]
+ <MOVEM A* (FRM) 11> ; (11)
+ <MOVEM B* (FRM) 12> ; (12)
+ <MCALL 1 RET-TMP-AC>
+TAG97 <GETYP O* (FRM) 209> ; 1650 (209)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG104>
+ <MOVE B* <MQUOTE %<RGLOC NO-DATUM!-COMPDEC!-PACKAGE T>>>
+ <ADD B* |GLOTOP 1>
+ <MOVE D* (B) >
+ <MOVE PVP* (B) 1>
+ <GETYP O* (FRM) 11> ; (11)
+ <GETYP B* D>
+ <CAMN PVP* (FRM) 12> ; (12)
+ <CAIE O* (B) 0>
+ <SKIPA O>
+ <JRST TAG104>
+ <MOVE B* (FRM) 64> ; (64)
+ <ADD B* [<(30) 30>]>
+ <JUMPGE B* |CERR2 >
+ <SKIPL (B) 1>
+ <JRST TAG105>
+ <MCALL 0 PROG:END>
+ <PUSH TP* (FRM) 7> ; (7) [238]
+ <PUSH TP* (FRM) 8> ; (8) [239]
+ <MCALL 1 LABEL:OFF>
+ <JRST TAG106>
+TAG105 <GETYP O* (FRM) 157> ; 1673 (157)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG107>
+ <GETYP O* (FRM) 13> ; (13)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG108>
+TAG107 <SKIPL (FRM) 46> ; 1679 (46)
+ <JRST TAG109>
+ <GETYP O* (FRM) 157> ; (157)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG109>
+ <PUSH TP* (FRM) 11> ; (11) [238]
+ <PUSH TP* (FRM) 12> ; (12) [239]
+ <MOVE B* <MQUOTE %<RGLOC AC-A!-COMPDEC!-PACKAGE T>>>
+ <ADD B* |GLOTOP 1>
+ <PUSH TP* <MQUOTE %<TYPE-W AC!-COMPDEC!-PACKAGE VECTOR>>>; [240]
+ <PUSH TP* (B) 1> ; [241]
+ <MOVE B* <MQUOTE %<RGLOC AC-B!-COMPDEC!-PACKAGE T>>>
+ <ADD B* |GLOTOP 1>
+ <PUSH TP* <MQUOTE %<TYPE-W AC!-COMPDEC!-PACKAGE VECTOR>>>; [242]
+ <PUSH TP* (B) 1> ; [243]
+ <MCALL 2 DATUM>
+ <PUSH TP* A> ; [240]
+ <PUSH TP* B> ; [241]
+ <MCALL 2 MOVE:ARG>
+ <MOVEM A* (FRM) 11> ; (11)
+ <MOVEM B* (FRM) 12> ; (12)
+TAG109 <PUSH TP* (FRM) 123> ; 1700 (123) [238]
+ <PUSH TP* (FRM) 124> ; (124) [239]
+ <PUSH TP* (FRM) 95> ; (95) [240]
+ <PUSH TP* (FRM) 96> ; (96) [241]
+ <MCALL 2 POP:LOCS>
+ <MOVE B* (FRM) 64> ; (64)
+ <ADD B* [<(22) 22>]>
+ <JUMPGE B* |CERR2 >
+ <PUSH TP* <TYPE-WORD FIX>> ; [238]
+ <PUSH TP* (B) 1> ; [239]
+ <MOVE A* (FRM) 31> ; (31)
+ <MOVE B* (FRM) 32> ; (32)
+ <PUSH P* [1]>
+ <MOVEI O* |SEGMNT >
+ <PUSHJ P* |RCALL >
+ <POP P* A>
+ <ACALL A* UNBIND:FUNNY>
+ <JRST TAG106>
+TAG108 <PUSH TP* (FRM) 123> ; 1718 (123) [238]
+ <PUSH TP* (FRM) 124> ; (124) [239]
+ <PUSH TP* (FRM) 51> ; (51) [240]
+ <PUSH TP* (FRM) 52> ; (52) [241]
+ <MCALL 2 UNBIND:LOCS>
+TAG106 <GETYP O* (FRM) 13> ; 1723 (13)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG110>
+ <PUSH TP* (FRM) 153> ; (153) [238]
+ <PUSH TP* (FRM) 154> ; (154) [239]
+ <PUSH TP* (FRM) 11> ; (11) [240]
+ <PUSH TP* (FRM) 12> ; (12) [241]
+ <MCALL 2 DO-STACK-ARGS>
+ <JRST TAG111>
+TAG110 <GETYP O* (FRM) 193> ; 1732 (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG112>
+ <GETYP O* (FRM) 99> ; (99)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG112>
+ <GETYP O* (FRM) 219> ; (219)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG113>
+ <MOVE B* (FRM) 31> ; (31)
+ <MOVE D* (FRM) 32> ; (32)
+ <JUMPE D* |CERR2 >
+ <HRRZ PVP* (D) >
+ <MOVE TVP* (FRM) 123> ; (123)
+ <MOVE C* (FRM) 124> ; (124)
+ <MOVE E* (FRM) 52> ; (52)
+ <MOVEM B* (FRM) 19> ; (19)
+ <MOVEM D* (FRM) 20> ; (20)
+ <MOVEM E* (FRM) 102> ; (102)
+ <MOVEM PVP* (FRM) 10> ; (10)
+TAG113 <PUSH TP* (FRM) 11> ; 1752 (11) [238]
+ <PUSH TP* (FRM) 12> ; (12) [239]
+ <PUSH TP* (FRM) 17> ; (17) [240]
+ <PUSH TP* (FRM) 18> ; (18) [241]
+ <PUSH TP* (FRM) 25> ; (25) [242]
+ <PUSH TP* (FRM) 26> ; (26) [243]
+ <PUSH TP* (FRM) 59> ; (59) [244]
+ <PUSH TP* (FRM) 60> ; (60) [245]
+ <PUSH TP* (FRM) 63> ; (63) [246]
+ <PUSH TP* (FRM) 64> ; (64) [247]
+ <MOVE B* (FRM) 64> ; (64)
+ <ADD B* [<(60) 60>]>
+ <JUMPGE B* |CERR2 >
+ <PUSH TP* <TYPE-WORD LIST>> ; [248]
+ <PUSH TP* (B) 1> ; [249]
+ <MCALL 6 DO-EVEN-FUNNIER-HACK>
+ <JRST TAG111>
+TAG112 <GETYP O* (FRM) 193> ; 1769 (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG114>
+ <GETYP O* (FRM) 199> ; (199)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG114>
+ <PUSH TP* (FRM) 11> ; (11) [238]
+ <PUSH TP* (FRM) 12> ; (12) [239]
+ <MCALL 1 RET-TMP-AC>
+ <MOVE B* (FRM) 18> ; (18)
+ <MOVE O* (FRM) 11> ; (11)
+ <MOVEM O* (B) 24>
+ <MOVE O* (FRM) 12> ; (12)
+ <MOVEM O* (B) 25>
+ <MOVE O* <TYPE-WORD FALSE>>
+ <MOVEM O* (B) 26>
+ <SETZM (B) 27>
+ <MOVE D* (FRM) 12> ; (12)
+ <GETYP O* (D) 0>
+ <CAIE O* <MQUOTE %<TYPE-C AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <JRST TAG115>
+ <MOVE PVP* (D) 1>
+ <MOVE E* (PVP) 15>
+ <MOVE C* <MQUOTE %<TYPE-W SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>
+ <MOVE D* B>
+ <MOVE O* <MQUOTE %<TYPE-W AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <MOVEM O* (FRM) 3> ; (3)
+ <MOVEM PVP* (FRM) 4> ; (4)
+ <PUSHJ P* |C1CONS >
+ <MOVE D* (FRM) 4> ; (4)
+ <MOVEM A* (D) 14>
+ <MOVEM B* (D) 15>
+TAG115 <MOVE B* (FRM) 12> ; 1801 (12)
+ <HRRZ D* (B) >
+ <MOVE PVP* (D) 1>
+ <MOVE E* (PVP) 15>
+ <MOVE C* (FRM) 17> ; (17)
+ <MOVE D* (FRM) 18> ; (18)
+ <MOVE O* <MQUOTE %<TYPE-W AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <MOVEM O* (FRM) 3> ; (3)
+ <MOVEM PVP* (FRM) 4> ; (4)
+ <PUSHJ P* |C1CONS >
+ <MOVE D* (FRM) 4> ; (4)
+ <MOVEM A* (D) 14>
+ <MOVEM B* (D) 15>
+ <MOVE B* (FRM) 18> ; (18)
+ <MOVE O* <TYPE-WORD FALSE>>
+ <MOVEM O* (B) 26>
+ <SETZM (B) 27>
+ <MOVE D* (FRM) 64> ; (64)
+ <ADD D* [<(60) 60>]>
+ <JUMPGE D* |CERR2 >
+ <MOVE PVP* (D) 1>
+ <JUMPE PVP* TAG116>
+TAG117 <GETYP O* (PVP) 0> ; 1823
+ <CAIN O* <MQUOTE %<TYPE-C SYMTAB!-COMPDEC!-PACKAGE VECTOR>>>
+ <CAME B* (PVP) 1>
+ <SKIPA O>
+ <JRST TAG111>
+ <HRRZ PVP* (PVP) >
+ <JUMPN PVP* TAG117>
+TAG116 <MOVE D* (FRM) 64> ; 1830 (64)
+ <ADD D* [<(60) 60>]>
+ <JUMPGE D* |CERR2 >
+ <MOVE PVP* (D) 1>
+TAG121 <SKIPGE |INTFLG > ; 1834
+ <SAVAC O* [<(*1500*) *12*>]>
+ <JUMPE PVP* TAG118>
+ <JUMPE PVP* |CERR2 >
+ <HRRZ D* (PVP) >
+ <JUMPE D* |CERR2 >
+ <MOVE TVP* (D) 1>
+ <HRRZ D* (TVP) >
+ <GETYP O* (D) 0>
+ <CAIE O* <MQUOTE %<TYPE-C AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <JRST TAG119>
+ <HRRZ D* (TVP) >
+ <MOVE C* (D) 1>
+ <MOVE O* <MQUOTE T> -1>
+ <MOVEM O* (C) 10>
+ <MOVE O* <MQUOTE T>>
+ <MOVEM O* (C) 11>
+TAG119 <GETYP O* (TVP) 0> ; 1851
+ <CAIE O* <MQUOTE %<TYPE-C AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <JRST TAG120>
+ <MOVE D* (TVP) 1>
+ <MOVE O* <MQUOTE T> -1>
+ <MOVEM O* (D) 10>
+ <MOVE O* <MQUOTE T>>
+ <MOVEM O* (D) 11>
+TAG120 <JUMPE PVP* |CERR2 > ; 1859
+ <HRRZ PVP* (PVP) >
+ <JUMPE PVP* |CERR2 >
+ <HRRZ PVP* (PVP) >
+ <JRST TAG121>
+TAG118 <MOVE B* (FRM) 64> ; 1864 (64)
+ <MOVE C* (FRM) 17> ; (17)
+ <MOVE D* (FRM) 18> ; (18)
+ <MOVEI E* 0>
+ <MOVE O* <MQUOTE %<TYPE-W NODE!-COMPDEC!-PACKAGE VECTOR>>>
+ <MOVEM O* (FRM) 3> ; (3)
+ <MOVEM B* (FRM) 4> ; (4)
+ <PUSHJ P* |C1CONS >
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (FRM) 1> ; (1)
+ <MOVEM B* (FRM) 2> ; (2)
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (FRM) 7> ; (7)
+ <MOVEM B* (FRM) 8> ; (8)
+ <MOVE O* <TYPE-WORD UNBOUND>>
+ <MOVEM O* (FRM) 223> ; (223)
+ <SETOM (FRM) 224> ; (224)
+ <MOVE D* (FRM) 26> ; (26)
+ <PUSH TP* (D) 4> ; [238]
+ <PUSH TP* (D) 5> ; [239]
+ <MCALL 1 ISTYPE-GOOD?>
+ <GETYP O* A>
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG122>
+ <GETYP O* (FRM) -5> ; (-5)
+ <CAIE O* <MQUOTE %<TYPE-C DATUM!-COMPDEC!-PACKAGE LIST>>>
+ <JRST TAG123>
+ <MOVE B* (FRM) -4> ; (-4)
+ <MOVE D* (B) >
+ <MOVE PVP* (B) 1>
+ <MOVEM D* (FRM) 223> ; (223)
+ <MOVEM PVP* (FRM) 224> ; (224)
+ <GETYP O* D>
+ <CAIN O* <MQUOTE %<TYPE-C AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <SKIPGE (PVP) 11>
+ <JRST TAG123>
+ <PUSH TP* (FRM) 223> ; (223) [238]
+ <PUSH TP* (FRM) 224> ; (224) [239]
+ <PUSH TP* <TYPE-WORD FALSE>> ; [240]
+ <PUSH TP* [0]> ; [241]
+ <MCALL 2 SGETREG>
+ <MOVE O* <MQUOTE T> -1>
+ <MOVEM O* (B) 10>
+ <MOVE O* <MQUOTE T>>
+ <MOVEM O* (B) 11>
+ <JRST TAG122>
+TAG123 <PUSH TP* <TYPE-WORD FALSE>> ; 1910 [238]
+ <PUSH TP* [0]> ; [239]
+ <MCALL 1 GETREG>
+ <MOVE O* <MQUOTE T> -1>
+ <MOVEM O* (B) 10>
+ <MOVE O* <MQUOTE T>>
+ <MOVEM O* (B) 11>
+ <MOVEM A* (FRM) 223> ; (223)
+ <MOVEM B* (FRM) 224> ; (224)
+TAG122 <PUSH TP* A> ; 1919 [238]
+ <PUSH TP* B> ; [239]
+ <GETYP O* (FRM) -5> ; (-5)
+ <CAIE O* <MQUOTE %<TYPE-C DATUM!-COMPDEC!-PACKAGE LIST>>>
+ <JRST TAG124>
+ <MOVE B* (FRM) -4> ; (-4)
+ <HRRZ D* (B) >
+ <MOVE PVP* (D) >
+ <MOVE TVP* (D) 1>
+ <MOVEM PVP* (FRM) 5> ; (5)
+ <MOVEM TVP* (FRM) 6> ; (6)
+ <GETYP O* PVP>
+ <CAIN O* <MQUOTE %<TYPE-C AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <SKIPGE (TVP) 11>
+ <JRST TAG124>
+ <PUSH TP* (FRM) 5> ; (5) [240]
+ <PUSH TP* (FRM) 6> ; (6) [241]
+ <PUSH TP* <TYPE-WORD FALSE>> ; [242]
+ <PUSH TP* [0]> ; [243]
+ <MCALL 2 SGETREG>
+ <JRST TAG125>
+TAG124 <PUSH TP* <TYPE-WORD FALSE>> ; 1940 [240]
+ <PUSH TP* [0]> ; [241]
+ <MCALL 1 GETREG>
+ <MOVEM A* (FRM) 5> ; (5)
+ <MOVEM B* (FRM) 6> ; (6)
+TAG125 <PUSH TP* A> ; 1945 [240]
+ <PUSH TP* B> ; [241]
+ <MCALL 2 DATUM>
+ <GETYP O* (FRM) 223> ; (223)
+ <CAIN O* <TYPE-CODE UNBOUND>>
+ <JRST TAG126>
+ <GETYP O* (FRM) 223> ; (223)
+ <CAIN O* <MQUOTE %<TYPE-C AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <MOVE D* <MQUOTE AC!-COMPDEC!-PACKAGE>>
+ <MOVE D* (FRM) 224> ; (224)
+ <MOVE O* <TYPE-WORD FALSE>>
+ <MOVEM O* (D) 10>
+ <SETZM (D) 11>
+TAG126 <MOVE C* A> ; 1958
+ <MOVE D* B>
+ <MOVEI E* 0>
+ <PUSHJ P* |CICONS >
+ <HRRM B* @ (FRM) 8> ; (8)
+ <MOVEM B* (FRM) 8> ; (8)
+ <MOVE B* (FRM) 64> ; (64)
+ <ADD B* [<(60) 60>]>
+ <JUMPGE B* |CERR2 >
+ <MOVE D* (B) 1>
+ <HRRM D* @ (FRM) 8> ; (8)
+ <MOVE B* (FRM) 4> ; (4)
+ <ADD B* [<(60) 60>]>
+ <JUMPGE B* |CERR2 >
+ <MOVE O* (FRM) 2> ; (2)
+ <MOVEM O* (B) 1>
+TAG129 <SKIPGE |INTFLG > ; 1974
+ <SAVAC O* [*120000*]>
+ <JUMPE D* TAG111>
+ <JUMPE D* |CERR2 >
+ <HRRZ B* (D) >
+ <JUMPE B* |CERR2 >
+ <MOVE PVP* (B) 1>
+ <HRRZ B* (PVP) >
+ <GETYP O* (B) 0>
+ <CAIE O* <MQUOTE %<TYPE-C AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <JRST TAG127>
+ <HRRZ B* (PVP) >
+ <MOVE TVP* (B) 1>
+ <MOVE O* <TYPE-WORD FALSE>>
+ <MOVEM O* (TVP) 10>
+ <SETZM (TVP) 11>
+TAG127 <GETYP O* (PVP) 0> ; 1990
+ <CAIE O* <MQUOTE %<TYPE-C AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <JRST TAG128>
+ <MOVE B* (PVP) 1>
+ <MOVE O* <TYPE-WORD FALSE>>
+ <MOVEM O* (B) 10>
+ <SETZM (B) 11>
+TAG128 <JUMPE D* |CERR2 > ; 1997
+ <HRRZ D* (D) >
+ <JUMPE D* |CERR2 >
+ <HRRZ D* (D) >
+ <JRST TAG129>
+TAG114 <GETYP O* (FRM) 99> ; 2002 (99)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG111>
+ <PUSH TP* (FRM) 11> ; (11) [238]
+ <PUSH TP* (FRM) 12> ; (12) [239]
+ <MOVE C* <TYPE-WORD LIST>>
+ <MOVEI D* 0>
+ <MOVEI E* 0>
+ <PUSHJ P* |C1CONS >
+ <MOVE D* (FRM) 82> ; (82)
+ <IMUL D* [-2]>
+ <MOVE C* <TYPE-WORD FIX>>
+ <MOVE E* B>
+ <PUSHJ P* |C1CONS >
+ <PUSH TP* A> ; [240]
+ <PUSH TP* B> ; [241]
+ <PUSH TP* (FRM) 25> ; (25) [242]
+ <PUSH TP* (FRM) 26> ; (26) [243]
+ <PUSH TP* (FRM) 59> ; (59) [244]
+ <PUSH TP* (FRM) 60> ; (60) [245]
+ <PUSH TP* (FRM) 63> ; (63) [246]
+ <PUSH TP* (FRM) 64> ; (64) [247]
+ <MCALL 5 DO-FUNNY-HACK>
+TAG111 <GETYP O* (FRM) 75> ; 2025 (75)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG130>
+ <PUSH TP* <MQUOTE %<TYPE-W OPCODE!-OP!-PACKAGE WORD>>>; [238]
+ <PUSH TP* [<(*402000*) 0>]> ; [239]
+ <PUSH TP* (FRM) 69> ; (69) [240]
+ <PUSH TP* (FRM) 70> ; (70) [241]
+ <PUSH TP* <MQUOTE %<TYPE-W OPCODE!-OP!-PACKAGE WORD>>>; [242]
+ <PUSH TP* [<(*17*) 0>]> ; [243]
+ <MOVEI A* 3 >
+ <PUSHJ P* |IIFORM >
+ <PUSH TP* A> ; [238]
+ <PUSH TP* B> ; [239]
+ <MCALL 1 EMIT>
+TAG130 <GETYP O* (FRM) 219> ; 2039 (219)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG104>
+ <GETYP O* (FRM) 193> ; (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG131>
+ <GETYP O* (FRM) 99> ; (99)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG104>
+TAG131 <MOVE B* (FRM) 31> ; 2048 (31)
+ <MOVE D* (FRM) 32> ; (32)
+ <JUMPE D* |CERR2 >
+ <HRRZ PVP* (D) >
+ <MOVE TVP* (FRM) 52> ; (52)
+ <MOVEM B* (FRM) 19> ; (19)
+ <MOVEM D* (FRM) 20> ; (20)
+ <MOVEM PVP* (FRM) 10> ; (10)
+ <MOVEM TVP* (FRM) 102> ; (102)
+TAG104 <GETYP O* (FRM) 209> ; 2057 (209)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG132>
+ <PUSH TP* (FRM) 63> ; (63) [238]
+ <PUSH TP* (FRM) 64> ; (64) [239]
+ <MOVE B* (FRM) 193> ; (193)
+ <MOVE D* (FRM) 194> ; (194)
+ <GETYP O* B>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG133>
+ <MOVE PVP* (FRM) 82> ; (82)
+ <SOJN PVP* TAG134>
+ <MOVE B* <MQUOTE T> -1>
+ <MOVE D* <MQUOTE T>>
+ <JRST TAG133>
+TAG134 <MOVE B* <TYPE-WORD FALSE>> ; 2072
+ <MOVEI D* 0>
+TAG133 <PUSH TP* B> ; 2074 [240]
+ <PUSH TP* D> ; [241]
+ <MCALL 2 AGAIN-UP>
+ <PUSH TP* (FRM) 203> ; (203) [238]
+ <PUSH TP* (FRM) 204> ; (204) [239]
+ <MCALL 1 LABEL:TAG>
+ <GETYP O* (FRM) 193> ; (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG135>
+ <MOVE B* (FRM) 64> ; (64)
+ <ADD B* [<(20) 20>]>
+ <JUMPGE B* |CERR2 >
+ <PUSH TP* <TYPE-WORD LIST>> ; [238]
+ <PUSH TP* (B) 1> ; [239]
+ <PUSH TP* <TYPE-WORD LIST>> ; [240]
+ <PUSH TP* (FRM) -2> ; (-2) [241]
+ <MOVE B* (FRM) 64> ; (64)
+ <ADD B* [<(60) 60>]>
+ <JUMPGE B* |CERR2 >
+ <PUSH TP* <TYPE-WORD LIST>> ; [242]
+ <PUSH TP* (B) 1> ; [243]
+ <PUSH TP* (FRM) 81> ; (81) [244]
+ <PUSH TP* (FRM) 82> ; (82) [245]
+ <PUSH TP* (FRM) 111> ; (111) [246]
+ <PUSH TP* (FRM) 112> ; (112) [247]
+ <PUSH TP* (FRM) 91> ; (91) [248]
+ <PUSH TP* (FRM) 92> ; (92) [249]
+ <MCALL 6 REST-STRUCS>
+TAG135 <GETYP O* (FRM) 193> ; 2102 (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG136>
+ <MOVE B* (FRM) 82> ; (82)
+ <SOJE B* TAG137>
+TAG136 <PUSH TP* (FRM) 107> ; 2107 (107) [238]
+ <PUSH TP* (FRM) 108> ; (108) [239]
+ <MCALL 1 BRANCH:TAG>
+TAG137 <PUSH TP* (FRM) 159> ; 2110 (159) [238]
+ <PUSH TP* (FRM) 160> ; (160) [239]
+ <PUSH TP* (FRM) 45> ; (45) [240]
+ <PUSH TP* (FRM) 46> ; (46) [241]
+ <MCALL 2 GEN-TAGS>
+ <GETYP O* (FRM) 193> ; (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG138>
+ <GETYP O* (FRM) 219> ; (219)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG138>
+ <MOVE B* (FRM) 214> ; (214)
+ <MOVE D* (FRM) 20> ; (20)
+ <MOVEM B* (FRM) 124> ; (124)
+ <MOVEM D* (FRM) 32> ; (32)
+TAG138 <GETYP O* (FRM) 193> ; 2125 (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG139>
+ <MOVE B* (FRM) 82> ; (82)
+ <SOJE B* TAG139>
+ <GETYP O* (FRM) 157> ; (157)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG140>
+ <GETYP O* (FRM) 13> ; (13)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG141>
+TAG140 <PUSH TP* (FRM) 123> ; 2136 (123) [238]
+ <PUSH TP* (FRM) 124> ; (124) [239]
+ <PUSH TP* (FRM) 95> ; (95) [240]
+ <PUSH TP* (FRM) 96> ; (96) [241]
+ <MCALL 2 POP:LOCS>
+ <MOVE B* (FRM) 64> ; (64)
+ <ADD B* [<(22) 22>]>
+ <JUMPGE B* |CERR2 >
+ <PUSH TP* <TYPE-WORD FIX>> ; [238]
+ <PUSH TP* (B) 1> ; [239]
+ <MOVE A* (FRM) 31> ; (31)
+ <MOVE B* (FRM) 32> ; (32)
+ <PUSH P* [1]>
+ <MOVEI O* |SEGMNT >
+ <PUSHJ P* |RCALL >
+ <POP P* A>
+ <ACALL A* UNBIND:FUNNY>
+ <JRST TAG139>
+TAG141 <PUSH TP* (FRM) 123> ; 2154 (123) [238]
+ <PUSH TP* (FRM) 124> ; (124) [239]
+ <PUSH TP* (FRM) 51> ; (51) [240]
+ <PUSH TP* (FRM) 52> ; (52) [241]
+ <MCALL 2 UNBIND:LOCS>
+TAG139 <MOVE B* (FRM) -2> ; 2159 (-2)
+ <JUMPE B* TAG142>
+TAG144 <MOVE D* (B) 1> ; 2161
+ <SKIPGE |INTFLG >
+ <SAVAC O* [<(*1200*) *150000*>]>
+ <MOVE O* <TYPE-WORD LIST>>
+ <MOVEM O* (FRM) 7> ; (7)
+ <MOVEM B* (FRM) 8> ; (8)
+ <PUSH TP* (D) 4> ; [238]
+ <PUSH TP* (D) 5> ; [239]
+ <MCALL 1 STRUCTYP>
+ <PUSH TP* A> ; [238]
+ <PUSH TP* B> ; [239]
+ <MCALL 1 ISTYPE?>
+ <GETYP O* A>
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG143>
+ <PUSH TP* <MQUOTE <`SETZM |DSTORE >> -1> ; [238]
+ <PUSH TP* <MQUOTE <`SETZM |DSTORE >>> ; [239]
+ <MCALL 1 EMIT>
+ <JRST TAG142>
+TAG143 <MOVE B* (FRM) 8> ; 2180 (8)
+ <HRRZ B* (B) >
+ <JUMPN B* TAG144>
+ <JRST TAG142>
+TAG132 <PUSH TP* (FRM) 159> ; 2184 (159) [238]
+ <PUSH TP* (FRM) 160> ; (160) [239]
+ <PUSH TP* (FRM) 45> ; (45) [240]
+ <PUSH TP* (FRM) 46> ; (46) [241]
+ <MCALL 2 GEN-TAGS>
+TAG142 <PUSH TP* (FRM) 63> ; 2189 (63) [238]
+ <PUSH TP* (FRM) 64> ; (64) [239]
+ <MCALL 1 CLEANUP-STATE>
+ <PUSH TP* (FRM) 187> ; (187) [238]
+ <PUSH TP* (FRM) 188> ; (188) [239]
+ <MCALL 1 LABEL:TAG>
+ <GETYP O* (FRM) 163> ; (163)
+ <CAIE O* <MQUOTE %<TYPE-C DATUM!-COMPDEC!-PACKAGE LIST>>>
+ <JRST TAG145>
+ <GETYP O* (FRM) 13> ; (13)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG146>
+ <PUSH TP* (FRM) 113> ; (113) [238]
+ <PUSH TP* (FRM) 114> ; (114) [239]
+ <PUSH TP* (FRM) 153> ; (153) [240]
+ <PUSH TP* (FRM) 154> ; (154) [241]
+ <MOVE A* (FRM) 163> ; (163)
+ <MOVE B* (FRM) 164> ; (164)
+ <PUSH P* [0]>
+ <MOVEI O* |SEGMNT >
+ <PUSHJ P* |RCALL >
+ <POP P* A>
+ <ACALL A* DATUM>
+ <PUSH TP* A> ; [242]
+ <PUSH TP* B> ; [243]
+ <MCALL 3 DO-LAST>
+ <JRST TAG147>
+TAG146 <GETYP O* (FRM) 99> ; 2216 (99)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG148>
+ <GETYP O* (FRM) 193> ; (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG148>
+ <PUSH TP* (FRM) 17> ; (17) [238]
+ <PUSH TP* (FRM) 18> ; (18) [239]
+ <PUSH TP* <TYPE-WORD FALSE>> ; [240]
+ <PUSH TP* [0]> ; [241]
+ <PUSH TP* <TYPE-WORD FALSE>> ; [242]
+ <PUSH TP* [0]> ; [243]
+ <MCALL 3 LADDR>
+ <PUSH TP* A> ; [238]
+ <PUSH TP* B> ; [239]
+ <MOVE A* (FRM) 163> ; (163)
+ <MOVE B* (FRM) 164> ; (164)
+ <PUSH P* [0]>
+ <MOVEI O* |SEGMNT >
+ <PUSHJ P* |RCALL >
+ <POP P* A>
+ <JRST TAG149>
+TAG148 <GETYP O* (FRM) 99> ; 2238 (99)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG150>
+ <PUSH TP* (FRM) 59> ; (59) [238]
+ <PUSH TP* (FRM) 60> ; (60) [239]
+ <MOVNI B* 1 >
+ <MOVE D* (FRM) 82> ; (82)
+ <ASH D* A>
+ <SUB B* D>
+ <PUSH TP* <TYPE-WORD FIX>> ; [240]
+ <PUSH TP* B> ; [241]
+ <MOVE A* (FRM) 163> ; (163)
+ <MOVE B* (FRM) 164> ; (164)
+ <PUSH P* [0]>
+ <MOVEI O* |SEGMNT >
+ <PUSHJ P* |RCALL >
+ <POP P* A>
+ <ACALL A* DATUM>
+ <PUSH TP* A> ; [242]
+ <PUSH TP* B> ; [243]
+ <MCALL 3 DO-FUNNY-LAST>
+ <JRST TAG147>
+TAG150 <GETYP O* (FRM) 193> ; 2260 (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG151>
+ <PUSH TP* (FRM) 197> ; (197) [238]
+ <PUSH TP* (FRM) 198> ; (198) [239]
+ <MOVE A* (FRM) 163> ; (163)
+ <MOVE B* (FRM) 164> ; (164)
+ <PUSH P* [0]>
+ <MOVEI O* |SEGMNT >
+ <PUSHJ P* |RCALL >
+ <POP P* A>
+ <JRST TAG149>
+TAG151 <MOVNI B* 1 > ; 2272
+ <MOVE D* (FRM) 82> ; (82)
+ <ASH D* A>
+ <SUB B* D>
+ <PUSH TP* <TYPE-WORD FIX>> ; [238]
+ <PUSH TP* B> ; [239]
+ <PUSH TP* <MQUOTE %<TYPE-W OPCODE!-OP!-PACKAGE WORD>>>; [240]
+ <PUSH TP* [<(*13*) 0>]> ; [241]
+ <MCALL 2 ADDRESS:C>
+ <PUSH TP* A> ; [238]
+ <PUSH TP* B> ; [239]
+ <PUSH TP* A> ; [240]
+ <PUSH TP* B> ; [241]
+ <MCALL 2 DATUM>
+ <PUSH TP* A> ; [238]
+ <PUSH TP* B> ; [239]
+ <MOVE A* (FRM) 163> ; (163)
+ <MOVE B* (FRM) 164> ; (164)
+ <PUSH P* [0]>
+ <MOVEI O* |SEGMNT >
+ <PUSHJ P* |RCALL >
+ <POP P* A>
+TAG149 <ACALL A* DATUM> ; 2294
+ <PUSH TP* A> ; [240]
+ <PUSH TP* B> ; [241]
+ <MCALL 2 MOVE:ARG>
+TAG147 <PUSH TP* (FRM) 163> ; 2298 (163) [238]
+ <PUSH TP* (FRM) 164> ; (164) [239]
+ <PUSH TP* A> ; [240]
+ <PUSH TP* B> ; [241]
+ <MOVEM A* (FRM) 169> ; (169)
+ <MOVEM B* (FRM) 170> ; (170)
+ <MCALL 2 ACFIX>
+ <MOVE B* (FRM) 164> ; (164)
+ <PUSH TP* (B) > ; [238]
+ <PUSH TP* (B) 1> ; [239]
+ <MCALL 1 ISTYPE?>
+ <GETYP O* A>
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG152>
+ <MOVE B* (FRM) 170> ; (170)
+ <GETYP O* (B) 0>
+ <CAIE O* <MQUOTE %<TYPE-C AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <JRST TAG152>
+ <PUSH TP* (B) > ; [238]
+ <PUSH TP* (B) 1> ; [239]
+ <PUSH TP* <MQUOTE %<TYPE-W DATUM!-COMPDEC!-PACKAGE LIST>>>; [240]
+ <PUSH TP* B> ; [241]
+ <MCALL 2 RET-TMP-AC>
+ <JRST TAG152>
+TAG145 <GETYP O* (FRM) 13> ; 2322 (13)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG153>
+ <PUSH TP* (FRM) 113> ; (113) [238]
+ <PUSH TP* (FRM) 114> ; (114) [239]
+ <PUSH TP* (FRM) 153> ; (153) [240]
+ <PUSH TP* (FRM) 154> ; (154) [241]
+ <MCALL 0 FUNCTION:VALUE>
+ <PUSH TP* A> ; [242]
+ <PUSH TP* B> ; [243]
+ <MCALL 3 DO-LAST>
+ <JRST TAG152>
+TAG153 <GETYP O* (FRM) 99> ; 2334 (99)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG154>
+ <GETYP O* (FRM) 193> ; (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG154>
+TAG156 <PUSH TP* (FRM) 197> ; 2340 (197) [238]
+ <PUSH TP* (FRM) 198> ; (198) [239]
+ <MCALL 0 FUNCTION:VALUE>
+ <PUSH TP* A> ; [240]
+ <PUSH TP* B> ; [241]
+ <MCALL 2 MOVE:ARG>
+ <JRST TAG152>
+TAG154 <GETYP O* (FRM) 193> ; 2347 (193)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG155>
+ <GETYP O* (FRM) 99> ; (99)
+ <CAIE O* <TYPE-CODE FALSE>>
+ <JRST TAG156>
+TAG155 <GETYP O* (FRM) 99> ; 2353 (99)
+ <CAIN O* <TYPE-CODE FALSE>>
+ <JRST TAG152>
+ <PUSH TP* (FRM) 59> ; (59) [238]
+ <PUSH TP* (FRM) 60> ; (60) [239]
+ <MOVNI B* 1 >
+ <MOVE D* (FRM) 82> ; (82)
+ <ASH D* A>
+ <SUB B* D>
+ <PUSH TP* <TYPE-WORD FIX>> ; [240]
+ <PUSH TP* B> ; [241]
+ <MCALL 0 FUNCTION:VALUE>
+ <PUSH TP* A> ; [242]
+ <PUSH TP* B> ; [243]
+ <MCALL 3 DO-FUNNY-LAST>
+TAG152 <PUSH TP* (FRM) 51> ; 2368 (51) [238]
+ <PUSH TP* (FRM) 52> ; (52) [239]
+ <PUSH TP* (FRM) 117> ; (117) [240]
+ <PUSH TP* (FRM) 118> ; (118) [241]
+ <MCALL 2 POP:LOCS>
+ <PUSH TP* (FRM) 181> ; (181) [238]
+ <PUSH TP* (FRM) 182> ; (182) [239]
+ <MCALL 1 LABEL:TAG>
+ <MOVEI E* (FRM) 217> ; (217)
+ <PUSHJ P* |SSPEC1 >
+ <GETYP O* (FRM) 169> ; (169)
+ <CAIN O* <TYPE-CODE UNBOUND>>
+ <JRST TAG157>
+ <MOVE B* (FRM) 164> ; (164)
+ <GETYP O* (B) 0>
+ <CAIE O* <MQUOTE %<TYPE-C AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <JRST TAG158>
+ <PUSH TP* (B) > ; [238]
+ <PUSH TP* (B) 1> ; [239]
+ <PUSH TP* <MQUOTE %<TYPE-W DATUM!-COMPDEC!-PACKAGE LIST>>>; [240]
+ <PUSH TP* B> ; [241]
+ <PUSH TP* (FRM) 169> ; (169) [242]
+ <PUSH TP* (FRM) 170> ; (170) [243]
+ <MCALL 3 FIX-ACLINK>
+TAG158 <MOVE B* (FRM) 164> ; 2392 (164)
+ <HRRZ D* (B) >
+ <GETYP O* (D) 0>
+ <CAIE O* <MQUOTE %<TYPE-C AC!-COMPDEC!-PACKAGE VECTOR>>>
+ <JRST TAG157>
+ <HRRZ D* (B) >
+ <PUSH TP* (D) > ; [238]
+ <PUSH TP* (D) 1> ; [239]
+ <PUSH TP* <MQUOTE %<TYPE-W DATUM!-COMPDEC!-PACKAGE LIST>>>; [240]
+ <PUSH TP* B> ; [241]
+ <PUSH TP* (FRM) 169> ; (169) [242]
+ <PUSH TP* (FRM) 170> ; (170) [243]
+ <MCALL 3 FIX-ACLINK>
+TAG157 <MOVE B* (FRM) 104> ; 2405 (104)
+ <PUSH TP* (FRM) 163> ; (163) [238]
+ <PUSH TP* (FRM) 164> ; (164) [239]
+ <PUSH TP* (FRM) -5> ; (-5) [240]
+ <PUSH TP* (FRM) -4> ; (-4) [241]
+ <MOVEM B* (FRM) 124> ; (124)
+ <MCALL 2 MOVE:ARG>
+ <MOVEM A* (FRM) 9> ; (9)
+ <MOVEM B* (FRM) 10> ; (10)
+ <MCALL 0 END-FRAME>
+ <MOVE A* (FRM) 9> ; (9)
+ <MOVE B* (FRM) 10> ; (10)
+ <MOVE TP* FRM>
+ <PUSHJ P* |SSPECS >
+ <JRST |FMPOPJ >
+ <TAG1>
+ <0>
+ <(*47*) -1>
+ <IMULI TB* 1 >
+ <-1>
+ <(18) 18>
+ <IMULI TB* (B) 0>
+ <IMULI TB* 4 >
+ <(4) 4>
+ <(1) 1>
+ <1>
+ <IMULI TB* 2 >
+ <(22) 22>
+ <(22) 22>
+TAG14 <(*1200*) 0> ; 2434
+ <FSB O* O>
+ <IMULI TB* (D) 6>
+ <IMULI TB* 6 >
+ <IMULI TB* 5 >
+ <IMULI TB* (FRM) 113> ; (113)
+ <(20) 20>
+TAG26 <(*1200*) 4> ; 2441
+ <FSB O* O>
+ <IMULI TB* (FRM) 199> ; (199)
+ <IMULI TB* (FRM) 219> ; (219)
+ <(30) 30>
+ <(26) 26>
+ <(20) 20>
+ <IMULI TB* (FRM) 193> ; (193)
+ <IMULI TB* (B) 24>
+ <(32) 32>
+ <(34) 34>
+ <IMULI TB* (D) 0>
+ <IMULI TB* (FRM) 13> ; (13)
+ <2>
+ <IMULI TB* (FRM) 153> ; (153)
+ <IMULI TB* (FRM) 15> ; (15)
+ <(*100*) 0>
+ <(4) 4>
+ <IMULI TB* (FRM) 99> ; (99)
+ <IMULI TB* (FRM) 57> ; (57)
+ <(*1200*) *150000*>
+ <IMULI TB* (PVP) 14>
+ <IMULI TB* (FRM) 175> ; (175)
+ <IMULI TB* (FRM) 21> ; (21)
+ <(*13*) 0>
+ <3>
+ <IMULI TB* (D) 0>
+ <IMULI TB* (PVP) 0>
+ <IMULI TB* (FRM) 157> ; (157)
+ <IMULI TB* (FRM) 207> ; (207)
+ <IMULI TB* (FRM) 91> ; (91)
+ <IMULI TB* (FRM) 209> ; (209)
+ <IMULI TB* (FRM) 11> ; (11)
+ <(60) 60>
+ <IMULI TB* (PVP) 0>
+ <(*1500*) *12*>
+ <IMULI TB* (TVP) 0>
+ <IMULI TB* (FRM) -5> ; (-5)
+ <IMULI TB* (FRM) 223> ; (223)
+ <(60) 60>
+ <*120000*>
+ <-2>
+ <IMULI TB* (FRM) 75> ; (75)
+ <SETZM O>
+ <(*17*) 0>
+ <IMULI TB* (FRM) 163> ; (163)
+ <IMULI TB* (FRM) 169> ; (169)
+ <(3) *10*>
+ <(*56132*) *551434*>
+ <0>
+ <(1) 2>
+\1a
\ No newline at end of file
--- /dev/null
+<PACKAGE "VARANA">
+
+<ENTRY VARS>
+
+<USE "COMPDEC" "CHKDCL" "ADVMESS" "SUBRTY">
+
+
+<SETG TEMPSTRT #TEMPV ()>
+
+<DEFINE VARS REVAR (FCN
+ "AUX" GFRMID NOA ACC LARG (BPRE <>) (UNPRE <>) (NOACT T)
+ (OV .VERBOSE) (NNEW T))
+ #DECL ((FCN) <SPECIAL NODE>
+ (GFRMID NOA ACC LARG REVAR BPRE UNPRE NOACT NNEW) <SPECIAL ANY>)
+ <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
+ <SET NOA <ACS .FCN>>
+ <SET ACC <AND .NOA <N=? .NOA '(STACK)> <N=? .NOA '(FUNNY-STACK)>>>
+ <SET LARG <>>
+ <SET GFRMID 0>
+ <COND (<AND .VERBOSE <NOT .NOA>>
+ <ADDVMESS .FCN ("Frame being generated.")>)>
+ <FUNC-VAR .FCN>>
+
+<DEFINE FUNC-VAR (BASEF
+ "AUX" (PRE <>) (BST <BINDING-STRUCTURE .BASEF>)
+ (FRMID <SET GFRMID <+ .GFRMID 1>>) (SVIOFF 0) TA
+ (IOFF
+ <+
+ <COND (<OR <ACTIV? .BST .NOACT> <ACTIVATED .BASEF>>
+ <PUT .BASEF ,ACTIVATED T>
+ 2)
+ (ELSE 0)>
+ <COND
+ (<=? .NOA '(STACK)>
+ <* 2
+ <COND (<L? <SET TA <TOTARGS .BASEF>> 0> 0)
+ (ELSE .TA)>>)
+ (ELSE 0)>>) (USOFF 0) (FUZZ <>) (HSLOT 0))
+ #DECL ((BASEF) <SPECIAL NODE> (BST) <LIST [REST SYMTAB]>
+ (FRMID GFRMID SVIOFF IOFF USOFF HSLOT) <SPECIAL FIX>
+ (PRE FUZZ) <SPECIAL ANY>)
+ <COND (<AND .NOACT <ACTIVATED .BASEF>>
+ <SET NOACT <>>
+ <AGAIN .REVAR>)>
+ <AND <==? .FCN .BASEF>
+ .NOA
+ <ACTIVATED .BASEF>
+ .NNEW
+ <PUT .BASEF ,ACS <CHTYPE (<ACS .FCN>) FALSE>>
+ <AGAIN .REVAR>>
+ <PUT .BASEF ,BINDING-STRUCTURE <DOREG .BST>>
+ <SET PRE <OR .PRE .BPRE>>
+ <AND .ACC <NOT .LARG> <SET LARG T>>
+ <AND .PRE <G? .USOFF .HSLOT> <SET HSLOT .USOFF>>
+ <SET SVIOFF .IOFF>
+ <MAPF <> ,VAR-ANA <KIDS .BASEF>>
+ <AND .PRE <PUT .BASEF ,SSLOTS <COND (<0? .HSLOT> -1)(ELSE .HSLOT)>>>>
+
+<DEFINE VAR-ANA (N)
+ #DECL ((N FCN) NODE)
+ <COND (<AND .FUZZ <ACS .FCN> .NNEW <NOT <=? <ACS .FCN> '(FUNNY-STACK)>>>
+ <COND (<G=? <TOTARGS .FCN> 0> <PUT .FCN ,ACS '(FUNNY-STACK)>)
+ (<PUT .FCN ,ACS <CHTYPE (<ACS .FCN>) FALSE>>)>
+ <AGAIN .REVAR>)>
+ <COND (<VAR-ANA1 .N .FUZZ> <SET FUZZ T>)>>
+
+<DEFINE VAR-ANA1 (N OFUZZ
+ "AUX" (FUZZ .OFUZZ) (SIOFF .IOFF) (COD <NODE-TYPE .N>) FL K RN
+ ACST)
+ #DECL ((N RN) NODE (FUZZ) <SPECIAL ANY> (SIOFF) FIX (IOFF COD) FIX
+ (K) <LIST [REST NODE]>)
+ <COND
+ (<==? .COD ,MAP-CODE>
+ <PROG ((GMF ,NUMACS))
+ #DECL ((GMF) <SPECIAL ANY>)
+ <VAR-ANA <1 <SET K <KIDS .N>>>>
+ <SET COD <NODE-TYPE <1 .K>>>
+ <SET FL <==? <NODE-TYPE <2 .K>> ,MFCN-CODE>>
+ <COND
+ (<AND
+ <OR
+ <EMPTY? <REST .K 2>>
+ <MAPF <>
+ <FUNCTION (N)
+ #DECL ((N) NODE)
+ <COND (<AND <SET TEM <STRUCTYP <RESULT-TYPE .N>>>
+ <N==? .TEM TEMPLATE>>
+ <SET GMF
+ <- .GMF
+ <COND (<OR <==? .TEM STRING>
+ <==? .TEM BYTES>>
+ 2)
+ (ELSE 1)>>>)
+ (ELSE <MAPLEAVE <>>)>>
+ <REST .K 2>>>
+ <OR <==? <ISTYPE? <RESULT-TYPE <1 .K>>> FALSE>
+ <AND <AP? <1 .K>> <N==? <NODE-SUBR <1 .K>> 5>>>
+ .FL>)
+ (ELSE <SET GMF <>>)>
+ <COND (<AND .FL
+ <NOT <EMPTY? <BINDING-STRUCTURE <2 .K>>>>
+ <==? <NAME-SYM <1 <BINDING-STRUCTURE <2 .K>>>> DUMMY-MAPF>>
+ <REPEAT ((B <REST <BINDING-STRUCTURE <2 .K>> <- <LENGTH .K> 1>>)
+ (N <- <LENGTH .K> 2>))
+ <COND (<L? <SET N <- .N 1>> 0> <RETURN>)>
+ <PUT <1 .B> ,CODE-SYM 3>>)>
+ <COND (<AND .FL
+ <NOT .GMF>
+ <NOT <EMPTY? <BINDING-STRUCTURE <2 .K>>>>
+ <==? <NAME-SYM <1 <BINDING-STRUCTURE <2 .K>>>> DUMMY-MAPF>>
+ <PUT <2 .K>
+ ,BINDING-STRUCTURE
+ <REST <BINDING-STRUCTURE <2 .K>> <- <LENGTH .K> 1>>>)>
+ <COND (<NOT <OR .GMF .FUZZ .PRE>>
+ <COND (<==? .COD ,MFIRST-CODE>
+ <COND (<==? <NODE-SUBR <1 .K>> 5> <SET IOFF <+ .IOFF 4>>)
+ (ELSE <SET IOFF <+ .IOFF 2>>)>)
+ (<NOT <NODE-NAME <1 .K>>> <SET IOFF <+ .IOFF 2>>)>
+ <COND (<AND <NOT .FL>
+ <N==? <NODE-TYPE <2 .K>> ,MPSBR-CODE>
+ <NOT <AP? <2 .K>>>>
+ <SET IOFF <+ .IOFF 2>>)>)
+ (<AND <NOT <OR .FUZZ .PRE>>
+ <==? .COD ,MFIRST-CODE>
+ <==? <NODE-SUBR <1 .K>> 5>>
+ <SET IOFF <+ .IOFF 4>>)>
+ <AND .FL <VARMAP .K <OR .GMF .OFUZZ>>>
+ <SET FUZZ <OR .FUZZ <AND <NODE-NAME <1 .K>> <N==? .COD ,MFIRST-CODE>>>>
+ <VAR-ANA <2 .K>>
+ <SET FUZZ .OFUZZ>
+ <OR .FL <VARMAP .K .OFUZZ>>>)
+ (<==? .COD ,STACKFORM-CODE>
+ <VAR-ANA <1 <SET K <KIDS .N>>>>
+ <SET OFUZZ .FUZZ>
+ <SET FUZZ T>
+ <VAR-ANA <2 .K>>
+ <VAR-ANA <3 .K>>
+ <SET FUZZ .OFUZZ>)
+ (<OR <==? .COD ,PROG-CODE> <==? .COD ,MFCN-CODE>> <PROG-REP-VAR .N .OFUZZ>)
+ (<OR <==? .COD ,SUBR-CODE>
+ <==? .COD ,COPY-CODE>
+ <AND <==? .COD ,ISUBR-CODE> <==? <4 <GET-TMP <NODE-SUBR .N>>> STACK>>
+ <AND <==? .COD ,RSUBR-CODE>
+ <OR <AND <TYPE? <NODE-SUBR .N> FUNCTION>
+ <SET ACST <ACS <SET RN <GET <NODE-NAME .N> .IND>>>>
+ <OR <ASSIGNED? GROUP-NAME> <==? .FCN .RN>>
+ <=? .ACST '(STACK)>>
+ <TYPE? <NODE-SUBR .N> RSUBR RSUBR-ENTRY>>>>
+ <MAPF <>
+ <FUNCTION (N)
+ #DECL ((N) NODE (IOFF) FIX)
+ <OR <VAR-ANA .N> .OFUZZ .PRE <SET IOFF <+ .IOFF 2>>>>
+ <KIDS .N>>)
+ (<OR <==? .COD ,ISTRUC-CODE> <==? .COD ,ISTRUC2-CODE>>
+ <VAR-ANA <1 <KIDS .N>>>
+ <OR .PRE
+ .OFUZZ
+ <SET IOFF <+ .IOFF <COND (<==? <NODE-SUBR .N> ,ISTRING> 2) (ELSE 4)>>>>
+ <MAPF <> ,VAR-ANA <REST <KIDS .N>>>)
+ (<==? .COD ,UNWIND-CODE>
+ <OR .PRE .OFUZZ <SET IOFF <+ .IOFF 10>>>
+ <VAR-ANA <1 <KIDS .N>>>
+ <VAR-ANA <2 <KIDS .N>>>)
+ (ELSE
+ <AND <==? <NODE-TYPE .N> ,BRANCH-CODE> <VAR-ANA <PREDIC .N>>>
+ <MAPF <> ,VAR-ANA <KIDS .N>>)>
+ <SET IOFF .SIOFF>
+ <==? <NODE-TYPE .N> ,SEGMENT-CODE>>
+
+<DEFINE VARMAP (K OFUZZ)
+ #DECL ((K) <LIST [REST NODE]> (OFUZZ) ANY)
+ <MAPF <>
+ <FUNCTION (N)
+ #DECL ((N) NODE (IOFF) FIX)
+ <VAR-ANA .N>
+ <OR .PRE .OFUZZ <SET IOFF <+ .IOFF 2>>>>
+ <REST .K 2>>>
+
+<DEFINE PROG-REP-VAR (PNOD FUZZ
+ "AUX" (BST <BINDING-STRUCTURE .PNOD>) (SVIOFF .SVIOFF)
+ (USOFF .USOFF) (IOFF .IOFF) (NOA <>)
+ (PROG-REP
+ <OR <==? <NODE-SUBR .PNOD> ,PROG>
+ <==? <NODE-SUBR .PNOD> ,REPEAT>>))
+ #DECL ((PNOD) <SPECIAL NODE> (FUZZ NOA) <SPECIAL ANY>
+ (BST) <LIST [REST SYMTAB]> (SVIOFF USOFF IOFF) <SPECIAL FIX>)
+ <COND (<OR <ACTIV? .BST .NOACT> <ACTIVATED .PNOD>>
+ <AND .NOACT <PROG ()
+ <SET NOACT <>>
+ <AGAIN .REVAR>>>
+ <PUT .PNOD ,ACTIVATED T>
+ <AND .FUZZ
+ <NOT .PRE>
+ <SET PRE T>
+ <OR <ASSIGNED? INARG> .UNPRE>
+ <NOT .BPRE>
+ <SET BPRE T>
+ <NOT <SET UNPRE <>>>
+ <AGAIN .REVAR>>
+ <AND .PRE
+ .NOA
+ .NNEW
+ <PUT .BASEF ,ACS (FUNNY-STACK)>
+ <AGAIN .REVAR>>
+ <PROG REVAR ((BPRE <>) (UNPRE <>) (OG .GFRMID) (OV .VERBOSE)
+ (NNEW <>))
+ #DECL ((REVAR BPRE NNEW UNPRE) <SPECIAL ANY>)
+ <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
+ <SET GFRMID .OG>
+ <SET NOA <>>
+ <COND (.VERBOSE
+ <ADDVMESS .PNOD ("Internal FRAME generated.")>)>
+ <FUNC-VAR .PNOD>>)
+ (ELSE
+ <COND (<OR .PRE .FUZZ>
+ <AND <NOT .PRE>
+ <OR <ASSIGNED? INARG> .UNPRE>
+ <NOT .BPRE>
+ <SET BPRE T>
+ <NOT <SET UNPRE <>>>
+ <AGAIN .REVAR>>
+ <SET PRE T>
+ <OR <ASSIGNED? INARG> <SET IOFF .SVIOFF>>
+ <PUT .PNOD ,SPECS-START <+ .IOFF .USOFF>>
+ <PUT .PNOD ,USLOTS <+ .IOFF .USOFF>>
+ <PUT .PNOD ,BINDING-STRUCTURE <DOUNREG .BST .BST .BST T>>
+ <MAPF <> ,VAR-ANA <KIDS .PNOD>>
+ <AND <ASSIGNED? INARG> <SET IOFF .SVIOFF>>
+ <AND <G? .USOFF .HSLOT> <SET HSLOT .USOFF>>)
+ (ELSE
+ <PROG ((BASEF .PNOD) (HSLOT 0) (PRE <>))
+ #DECL ((BASEF) <SPECIAL NODE> (PRE) <SPECIAL ANY>
+ (HSLOT) <SPECIAL FIX>)
+ <PUT .BASEF ,BINDING-STRUCTURE <DOREG .BST T>>
+ <SET SVIOFF .IOFF>
+ <AND .PRE <G? .USOFF .HSLOT> <SET HSLOT .USOFF>>
+ <MAPF <> ,VAR-ANA <KIDS .BASEF>>
+ <COND (<AND .PRE .UNPRE>
+ <SET BPRE T>
+ <SET UNPRE <>>
+ <AGAIN .REVAR>)
+ (<NOT .BPRE> <SET UNPRE T>)>
+ <COND (.PRE
+ <AND <G? .USOFF .HSLOT> <SET HSLOT .USOFF>>
+ <PUT .BASEF
+ ,SSLOTS
+ <COND (<0? .HSLOT> -1)
+ (ELSE .HSLOT)>>)>>)>)>>
+
+<DEFINE ARG? (SYM) #DECL ((SYM) SYMTAB) <1? <NTH ,ARGTBL <CODE-SYM .SYM>>>>
+
+<SETG ARGTBL ![0 0 0 0 1 0 0 0 0 1 0 1 1!]>
+
+<DEFINE ACTIV? (BST NOACT)
+ #DECL ((BST) <LIST [REST SYMTAB]>)
+ <REPEAT ()
+ <AND <EMPTY? .BST> <RETURN <>>>
+ <AND <==? <CODE-SYM <1 .BST>> 1>
+ <OR <NOT .NOACT>
+ <NOT <RET-AGAIN-ONLY <1 .BST>>>
+ <SPEC-SYM <1 .BST>>>
+ <RETURN T>>
+ <SET BST <REST .BST>>>>
+
+<DEFINE INITV? (SYM)
+ #DECL ((SYM) SYMTAB)
+ <1? <NTH '![0 1 0 0 0 1 1 0 0 0 0 0 0!] <CODE-SYM .SYM>>>>
+
+<DEFINE NONARG (SYM)
+ #DECL ((SYM) SYMTAB)
+ <1? <NTH '![1 1 1 0 0 0 0 0 0 0 1 0 0!] <CODE-SYM .SYM>>>>
+
+<DEFINE TUPLE? (TUP-NOD)
+ <AND .TUP-NOD
+ <OR <==? <NODE-NAME .TUP-NOD> ITUPLE>
+ <==? <NODE-NAME .TUP-NOD> TUPLE>>>>
+
+<DEFINE GOOD-TUPLE (TUP "AUX" (K <KIDS .TUP>) NT (WD 0))
+ #DECL ((NT) FIX (TUP) NODE (K) <LIST [REST NODE]>)
+ <AND <NOT <==? <NODE-TYPE .TUP> ,ISTRUC-CODE>>
+ <COND (<==? <NODE-SUBR .TUP> ,ITUPLE>
+ <AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
+ <OR <==? <SET NT <NODE-TYPE <2 .K>>> ,QUOTE-CODE>
+ <==? .NT ,FLVAL-CODE>
+ <==? .NT ,FGVAL-CODE>
+ <==? .NT ,GVAL-CODE>
+ <==? .NT ,LVAL-CODE>>
+ <* <NODE-NAME <1 .K>> 2>>)
+ (ELSE
+ <MAPF <>
+ <FUNCTION (K)
+ <COND (<==? <NODE-TYPE .K> ,SEGMENT-CODE>
+ <MAPLEAVE <>>)
+ (ELSE <SET WD <+ .WD 2>>)>>
+ .K>)>>>
+
+<DEFINE DOREG (BST
+ "OPTIONAL" (HACK-INITS <>)
+ "AUX" TUP SYM COD (RQRG 0) (TRG 0) (COOL <AND .NOA <NOT .ACC>>)
+ (INARG T) INIT-LIST)
+ #DECL ((BST) <LIST [REST SYMTAB]> (SYM) SYMTAB (COD IOFF RQRG TRG) FIX
+ (BASEF) NODE (INARG) <SPECIAL ANY> (INIT-LIST) LIST)
+ <COND (<AND <ASSIGNED? GMF> .GMF <L=? .GMF 0>> <SET HACK-INITS <>>)>
+ <COND (<==? <NODE-TYPE .BASEF> ,FUNCTION-CODE>
+ <SET RQRG <REQARGS .BASEF>>
+ <SET TRG <TOTARGS .BASEF>>)>
+ <COND
+ (.HACK-INITS
+ <SET INIT-LIST
+ <MAPF ,LIST
+ <FUNCTION (SYM)
+ #DECL ((SYM) SYMTAB)
+ <COND
+ (<OR
+ <AND <ASSIGNED? GMF> .GMF <==? <NAME-SYM .SYM> DUMMY-MAPF>>
+ <AND
+ <OR <INIT-SYM .SYM> <==? <CODE-SYM .SYM> 13>>
+ <NOT <ASS? .SYM>>
+ <NOT <SPEC-SYM .SYM>>
+ <ISTYPE-GOOD?
+ <COND (<COMPOSIT-TYPE .SYM>
+ <TYPE-AND <1 <DECL-SYM .SYM>> <COMPOSIT-TYPE .SYM>>)
+ (<1 <DECL-SYM .SYM>>)>>
+ <USAGE-SYM .SYM>
+ <NOT <0? <USAGE-SYM .SYM>>>>>
+ <MAPRET .SYM>)
+ (<MAPRET>)>>
+ .BST>>
+ <REPEAT ((L <LENGTH .INIT-LIST>) (REMPTR .INIT-LIST)
+ (NA <COND (<AND <ASSIGNED? GMF> .GMF> .GMF) (ELSE ,NUMACS)>))
+ #DECL ((L NA) FIX (REMPTR) LIST)
+ <COND (<L? .L .NA> <RETURN>)>
+ <REPEAT ((PTR .INIT-LIST) (MIN-CNT <CHTYPE <MIN> FIX>) SYM)
+ <SET SYM <1 .PTR>>
+ <COND (<L? <USAGE-SYM .SYM> .MIN-CNT>
+ <SET MIN-CNT <USAGE-SYM .SYM>>
+ <RETURN>)>
+ <SET REMPTR <SET PTR <REST .PTR>>>>
+ <SET L <- .L 1>>
+ <COND (<==? .REMPTR .INIT-LIST> <SET INIT-LIST <REST .INIT-LIST>>)
+ (<PUTREST .REMPTR <REST .REMPTR 2>>)>>)>
+ <REPEAT ((FB .BST) (PB .BST))
+ <AND <EMPTY? .BST> <RETURN .FB>>
+ <PUT <SET SYM <1 .BST>> ,CODE-SYM <SET COD <ABS <CODE-SYM .SYM>>>>
+ <COND
+ (<AND <COMPOSIT-TYPE .SYM> <N==? <COMPOSIT-TYPE .SYM> T>>
+ <COND
+ (<NOT <SPEC-SYM .SYM>>
+ <COND (<NOT <ASS? .SYM>>
+ <PUT .SYM
+ ,COMPOSIT-TYPE
+ <TYPE-AND '<NOT UNBOUND> <COMPOSIT-TYPE .SYM>>>)>
+ <SET DC <1 <DECL-SYM .SYM>>>
+ <PUT .SYM ,DECL-SYM (<TYPE-AND <COMPOSIT-TYPE .SYM> .DC>)>
+ <COND (<AND .VERBOSE
+ <N==? <COMPOSIT-TYPE .SYM> T>
+ <N==? <COMPOSIT-TYPE .SYM> NO-RETURN>
+ <NOT <SAME-DECL?
+ <TYPE-AND .DC <COMPOSIT-TYPE .SYM>> .DC>>>
+ <VMESS "Computed decl of variable: "
+ <NAME-SYM .SYM>
+ " is: "
+ <COMPOSIT-TYPE .SYM>>)>)>
+ <PUT .SYM ,COMPOSIT-TYPE T>)>
+ <PUT .SYM ,CURRENT-TYPE <>>
+ <COND
+ (<NOT <OR <AND <1? <CODE-SYM .SYM>>
+ <NOT <SPEC-SYM .SYM>>
+ <RET-AGAIN-ONLY .SYM>
+ <NOT <ACTIVATED .BASEF>>>
+ <AND <NOT <USED-AT-ALL .SYM>>
+ <PROG ()
+ <PUT .SYM ,USED-AT-ALL T>
+ <COND (<SPEC-SYM .SYM>
+ <MESSAGE NOTE
+ "Special variable never used: "
+ <NAME-SYM .SYM>>)
+ (ELSE
+ <MESSAGE WARNING
+ "VARIABLE NEVER USED: "
+ <NAME-SYM .SYM>>)>
+ T>
+ <NONARG .SYM>
+ <NOT <SPEC-SYM .SYM>>
+ <NOT <INIT-SYM .SYM>>
+ <PURE-SYM .SYM>
+ <SET FB <FLUSH-SYM .BST <SET BST .PB> .FB>>>>>
+ <COND (<SPEC-SYM .SYM>
+ <PUT .SYM ,ADDR-SYM <+ .USOFF .IOFF 2>>
+ <AND <OR <NONARG .SYM> <ASSIGNED? PNOD>>
+ <PUT .SYM ,ARGNUM-SYM <TMPLS .BASEF>>>
+ <SET USOFF <+ .USOFF 6>>)>
+ <COND (<INITV? .SYM>
+ <COND (<TUPLE? <INIT-SYM .SYM>>
+ <COND (<AND <NOT <OR <==? <CODE-SYM .SYM> 7>
+ <==? <CODE-SYM .SYM> 8>
+ <==? <CODE-SYM .SYM> 9>
+ <SPEC-SYM .SYM>>>
+ <SET TUP <GOOD-TUPLE <INIT-SYM .SYM>>>>
+ <SET IOFF <+ .IOFF .TUP 2>>)
+ (ELSE
+ <SET PRE T>
+ <COND (<ACS .FCN>
+ <PUT .FCN ,ACS <CHTYPE (<ACS .FCN>) FALSE>>
+ <AGAIN .REVAR>)>
+ <RETURN <DOUNREG .BST .FB .PB .HACK-INITS>>)>)>
+ <COND (<SPEC-SYM .SYM>
+ <SET IOFF <+ .IOFF 2>>
+ <VAR-ANA <INIT-SYM .SYM>>
+ <SET IOFF <- .IOFF 2>>)
+ (ELSE <VAR-ANA <INIT-SYM .SYM>>)>
+ <COND (.PRE
+ <OR <SPEC-SYM .SYM> <SET USOFF <+ .USOFF 2>>>
+ <SET COD <- .COD>>)>)>
+ <COND (<AND .ACC <NOT .LARG> <NONARG .SYM>> <SET LARG T>)>
+ <COND (<AND <NOT .NOA>
+ <ARG? .SYM>
+ <NOT <SPEC-SYM .SYM>>
+ <PURE-SYM .SYM>>
+ <PUT .SYM ,ADDR-SYM <REFERENCE:ARG <ARGNUM-SYM .SYM>>>)
+ (<AND .COOL <NOT <NONARG .SYM>> <NOT <SPEC-SYM .SYM>>>
+ <PUT .SYM ,FRMNO .FRMID>
+ <PUT .SYM
+ ,ADDR-SYM
+ <COND (<=? .NOA '(FUNNY-STACK)>
+ <- -2 <* <- <TOTARGS .FCN> <ARGNUM-SYM .SYM>> 2>>)
+ (ELSE <* 2 <- <ARGNUM-SYM .SYM> 1>>)>>)
+ (<AND <TUPLE? <INIT-SYM .SYM>> <NOT .TUP>>
+ <SET PRE T>
+ <COND (<ACS .FCN>
+ <PUT .FCN ,ACS <CHTYPE (<ACS .FCN>) FALSE>>
+ <AGAIN .REVAR>)>
+ <RETURN <DOUNREG .BST .FB .PB .HACK-INITS>>)
+ (ELSE
+ <PUT .SYM ,FRMNO .FRMID>
+ <COND (<AND <OR <==? <CODE-SYM .SYM> 2>
+ <==? <CODE-SYM .SYM> 3>
+ <==? <CODE-SYM .SYM> 13>>
+ <NOT <SPEC-SYM .SYM>>
+ <NOT <ASS? .SYM>>
+ <OR <==? <CODE-SYM .SYM> 3>
+ <AND .HACK-INITS <MEMQ .SYM .INIT-LIST>>>>
+ <PUT .SYM ,ADDR-SYM ,TEMPSTRT>)
+ (ELSE
+ <PUT .SYM
+ ,ADDR-SYM
+ <+ .IOFF <COND (<SPEC-SYM .SYM> 2) (ELSE 0)>>>
+ <AND <OR <NONARG .SYM> <ASSIGNED? PNOD>>
+ <PUT .SYM ,ARGNUM-SYM <TMPLS .BASEF>>>
+ <OR .PRE
+ <SET IOFF
+ <+ .IOFF
+ <COND (<SPEC-SYM .SYM> 6) (ELSE 2)>>>>)>)>)>
+ <SET BST <REST <SET PB .BST>>>
+ <PUT .SYM ,CODE-SYM .COD>
+ <COND (.PRE <RETURN <DOUNREG .BST .FB .PB .HACK-INITS>>)>>>
+
+<DEFINE DOUNREG (BST FB PB
+ "OPTIONAL" (HACK-INITS <>)
+ "AUX" SYM (INARG T) INIT-LIST)
+ #DECL ((BST) <LIST [REST SYMTAB]> (SYM) SYMTAB (USOFF IOFF) FIX
+ (INARG) <SPECIAL ANY> (INIT-LIST) LIST)
+ <COND (<AND <ASSIGNED? GMF> .GMF <L=? .GMF 0>> <SET HACK-INITS <>>)>
+ <COND
+ (.HACK-INITS
+ <SET INIT-LIST
+ <MAPF ,LIST
+ <FUNCTION (SYM)
+ #DECL ((SYM) SYMTAB)
+ <COND
+ (<AND <INIT-SYM .SYM>
+ <NOT <ASS? .SYM>>
+ <NOT <SPEC-SYM .SYM>>
+ <ISTYPE-GOOD?
+ <COND (<COMPOSIT-TYPE .SYM>
+ <TYPE-AND <1 <DECL-SYM .SYM>> <COMPOSIT-TYPE .SYM>>)
+ (<1 <DECL-SYM .SYM>>)>>
+ <USAGE-SYM .SYM>
+ <NOT <0? <USAGE-SYM .SYM>>>>
+ <MAPRET .SYM>)
+ (<MAPRET>)>>
+ .BST>>
+ <REPEAT ((L <LENGTH .INIT-LIST>) (REMPTR .INIT-LIST)
+ (NA <COND (<AND <ASSIGNED? GMF> .GMF> .GMF) (ELSE 5)>))
+ #DECL ((L NA) FIX (REMPTR) LIST)
+ <COND (<L? .L .NA> <RETURN>)>
+ <REPEAT ((PTR .INIT-LIST) (MIN-CNT <CHTYPE <MIN> FIX>) SYM)
+ <SET SYM <1 .PTR>>
+ <COND (<L? <USAGE-SYM .SYM> .MIN-CNT>
+ <SET MIN-CNT <USAGE-SYM .SYM>>
+ <RETURN>)>
+ <SET REMPTR <SET PTR <REST .PTR>>>>
+ <SET L <- .L 1>>
+ <COND (<==? .REMPTR .INIT-LIST> <SET INIT-LIST <REST .INIT-LIST>>)
+ (<PUTREST .REMPTR <REST .REMPTR 2>>)>>)>
+ <PROG ()
+ <AND <EMPTY? .BST> <RETURN .FB>>
+ <REPEAT ((BST .BST))
+ <COND
+ (<AND <COMPOSIT-TYPE <SET SYM <1 .BST>>> <N==? <COMPOSIT-TYPE .SYM> T>>
+ <COND
+ (<NOT <SPEC-SYM .SYM>>
+ <COND (<NOT <ASS? .SYM>>
+ <PUT .SYM
+ ,COMPOSIT-TYPE
+ <TYPE-AND '<NOT UNBOUND> <COMPOSIT-TYPE .SYM>>>)>
+ <SET DC <1 <DECL-SYM .SYM>>>
+ <PUT .SYM ,DECL-SYM (<TYPE-AND <COMPOSIT-TYPE .SYM> .DC>)>
+ <COND
+ (<AND .VERBOSE
+ <N==? <COMPOSIT-TYPE .SYM> T>
+ <N==? <COMPOSIT-TYPE .SYM> NO-RETURN>
+ <NOT <SAME-DECL? <TYPE-AND .DC <COMPOSIT-TYPE .SYM>> .DC>>>
+ <VMESS "Computed decl of variable: "
+ <NAME-SYM .SYM>
+ " is: "
+ <COMPOSIT-TYPE .SYM>>)>)>
+ <PUT .SYM ,COMPOSIT-TYPE T>)>
+ <PUT .SYM ,CURRENT-TYPE <>>
+ <PUT .SYM ,FRMNO .FRMID>
+ <COND (<NOT <OR <AND <1? <CODE-SYM .SYM>>
+ <NOT <SPEC-SYM .SYM>>
+ <RET-AGAIN-ONLY .SYM>
+ <NOT <ACTIVATED .BASEF>>>
+ <AND <NOT <USED-AT-ALL .SYM>>
+ <PROG ()
+ <PUT .SYM ,USED-AT-ALL T>
+ <COND (<SPEC-SYM .SYM>
+ <MESSAGE NOTE
+
+"Special variable never used: "
+ <NAME-SYM .SYM>>)
+ (ELSE
+ <MESSAGE WARNING
+ "VARIABLE NEVER USED: "
+ <NAME-SYM .SYM>>)>
+ T>
+ <NONARG .SYM>
+ <NOT <SPEC-SYM .SYM>>
+ <NOT <INIT-SYM .SYM>>
+ <PURE-SYM .SYM>
+ <SET FB <FLUSH-SYM .BST <SET BST .PB> .FB>>>>>
+ <AND <INITV? .SYM> <VAR-ANA <INIT-SYM .SYM>>>
+ <COND (<OR <AND <ASSIGNED? GMF>
+ .GMF
+ <==? <NAME-SYM .SYM> DUMMY-MAPF>>
+ <AND .NOACT
+ <OR <==? <CODE-SYM .SYM> 3>
+ <==? <CODE-SYM .SYM> 2>
+ <==? <CODE-SYM .SYM> 13>>
+ <NOT <SPEC-SYM .SYM>>
+ <NOT <ASS? .SYM>>
+ <OR <==? <CODE-SYM .SYM> 3>
+ <AND .HACK-INITS <MEMQ .SYM .INIT-LIST>>>>>
+ <PUT .SYM ,ADDR-SYM ,TEMPSTRT>)
+ (ELSE
+ <PUT .SYM
+ ,ADDR-SYM
+ <+ .IOFF .USOFF <COND (<SPEC-SYM .SYM> 2) (ELSE 0)>>>
+ <AND <OR <NONARG .SYM> <ASSIGNED? PNOD>>
+ <PUT .SYM ,ARGNUM-SYM <TMPLS .BASEF>>>
+ <SET USOFF
+ <+ .USOFF <COND (<SPEC-SYM .SYM> 6) (ELSE 2)>>>)>)>
+ <AND <EMPTY? <SET BST <REST <SET PB .BST>>>> <RETURN .FB>>>>>
+
+<DEFINE FLUSH-SYM (B P F)
+ #DECL ((B P F) <LIST [REST SYMTAB]>)
+ <COND (<==? .B .F> <REST .B>)
+ (ELSE <PUTREST .P <REST .B>> .F)>>
+
+<DEFINE AP? (N "AUX" AT)
+ #DECL ((N) NODE)
+ <AND <==? <NODE-TYPE .N> ,GVAL-CODE>
+ <==? <NODE-TYPE <SET N <1 <KIDS .N>>>> ,QUOTE-CODE>
+ <SET AT <NODE-NAME .N>>
+ <OR .REASONABLE
+ <AND <GASSIGNED? .AT> <TYPE? ,.AT SUBR RSUBR RSUBR-ENTRY>>
+ <AND <GASSIGNED? .AT>
+ <TYPE? ,.AT FUNCTION>
+ <OR <==? .AT .FCNS>
+ <AND <TYPE? .FCNS LIST> <MEMQ .AT .FCNS>>>>>
+ .AT>>
+
+
+<DEFINE REFERENCE:ARG (NUMBER "AUX" TEM)
+ #DECL ((VALUE) <DATUM ADDRESS:C ADDRESS:C> (NUMBER) FIX)
+ <SET TEM <ADDRESS:C `(AB) <* 2 <- .NUMBER 1>>>>
+ <DATUM .TEM .TEM>>
+\f
+
+<DEFINE GET-TMP (SUB "AUX" (LS <MEMQ .SUB ,SUBRS>))
+ #DECL ((VALUE) <LIST ANY ANY>)
+ <COND (.LS <NTH ,TEMPLATES <LENGTH .LS>>)
+ (ELSE '(ANY ANY))>>
+
+<DEFINE SAME-DECL? (D1 D2) <OR <=? .D1 .D2> <NOT <TYPE-OK? .D2 <NOTIFY .D1>>>>>
+
+<DEFINE NOTIFY (D)
+ <COND (<AND <TYPE? .D FORM> <==? <LENGTH .D> 2> <==? <1 .D> NOT>>
+ <2 .D>)
+ (ELSE <FORM NOT .D>)>>
+
+<ENDPACKAGE>
`<mdl.int>` contains Muddle for TOPS-20, from around 1981.
There should also be support for ITS, but it won't build as is.
+`<mdl.comp>` contains a TOPS-20 Muddle compiler from around 1982.
+
`MUDDLE` contains Muddle for ITS, from around 1973.
`mim` contains Machine-Independent MDL for TOPS-20 and VAX.
projects / pdp10-muddle.git / commitdiff