From: Lars Brinkhoff Date: Sun, 13 May 2018 18:27:48 +0000 (+0200) Subject: Files from TOPS-20 . X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=3395a5e4ef72d59cdb6832af7808dc9c2cf2a413;p=pdp10-muddle.git Files from TOPS-20 . --- diff --git a//ac.bug.1 b//ac.bug.1 new file mode 100644 index 0000000..09efe9b --- /dev/null +++ b//ac.bug.1 @@ -0,0 +1,46 @@ +;"need to fload init.mud in order to compile this" + +) + ;"no. of nodes" + TEMP) + #DECL ((TR) transaction_type_desc (PS) + (TEMP) FALSE> (NN) FIX) + .NN> .PS) + ( + > + >) + (ELSE )>> + .X> ,rcn_c>>> + > )>> + .PS>) + ( + .X> ,pn_c>)) + #DECL ((X) FIX (Y) ) + >> + >)>> + .PS>) + (ELSE ;"look for unrestricted children nodes" + + + > + >)>> + .X> ,ucn_c>>> + )>> + >>)>> + diff --git a//advmes.mud.9 b//advmes.mud.9 new file mode 100644 index 0000000..ef08602 --- /dev/null +++ b//advmes.mud.9 @@ -0,0 +1,40 @@ + + + + + + + + + ) (ELSE )>> + .MSG> + > + +) + )) + #DECL ((LL) ) + )> + + + ) + ( ) + (ELSE )>> + <2 .LL>> + + > + >>> + +) + > + > <- -1>> .L>) + (ELSE + 2>>)>> + + + \ No newline at end of file diff --git a//allr.mud.14 b//allr.mud.14 new file mode 100644 index 0000000..d8a618c --- /dev/null +++ b//allr.mud.14 @@ -0,0 +1,79 @@ + + + + + + + ,REST>) SAC NAC TEM STR NUM + (K ) (SS ) T1 T2 CAC) + #DECL ((N) NODE (K) (SAC CAC NAC) AC (STR NUM) DATUM + (SS) ) + + ) (ELSE )>>> + AC>> + |COMPERR>>)> + >> >>> + >)> + + > + > + + > 1) (ELSE 0)>> + .NUM> + + > ,ACPROT T> + + > + >)> + >)> + >) (ELSE ,ACO)>> + >> + ()>> + >>> + >> + >)> + + .T1>>) + (ELSE )> + + + > + >> >>> + + 1>>)> + > + )> + ) + (ELSE + > + > + >) (ELSE .TEM)> + .TEM> + .W>)>> + +) + + ) + (TY + >> + > + >>>>)) + #DECL ((S) SYMTAB) + <==? .D .D1>> + >>>)> + > + >> + )>> + .L> + )> + > + + \ No newline at end of file diff --git a//atosq.mud.1 b//atosq.mud.1 new file mode 100644 index 0000000..a2c043e --- /dev/null +++ b//atosq.mud.1 @@ -0,0 +1,24 @@ + + + + + <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> +  \ No newline at end of file diff --git a/<mdl.comp>/backan.mud.3 b/<mdl.comp>/backan.mud.3 new file mode 100644 index 0000000..528f74c --- /dev/null +++ b/<mdl.comp>/backan.mud.3 @@ -0,0 +1,196 @@ +<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> + \ No newline at end of file diff --git a/<mdl.comp>/bitana.mud.5 b/<mdl.comp>/bitana.mud.5 new file mode 100644 index 0000000..e349c4e --- /dev/null +++ b/<mdl.comp>/bitana.mud.5 @@ -0,0 +1,84 @@ + +<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> + diff --git a/<mdl.comp>/bits.mud.1 b/<mdl.comp>/bits.mud.1 new file mode 100644 index 0000000..26c2b9e --- /dev/null +++ b/<mdl.comp>/bits.mud.1 @@ -0,0 +1,383 @@ + +"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>])>> + \ No newline at end of file diff --git a/<mdl.comp>/bitsge.mud.2 b/<mdl.comp>/bitsge.mud.2 new file mode 100644 index 0000000..ee4543f --- /dev/null +++ b/<mdl.comp>/bitsge.mud.2 @@ -0,0 +1,314 @@ +<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>])>> + +<ENDPACKAGE> diff --git a/<mdl.comp>/bitsgen.mud.1 b/<mdl.comp>/bitsgen.mud.1 new file mode 100644 index 0000000..ee4543f --- /dev/null +++ b/<mdl.comp>/bitsgen.mud.1 @@ -0,0 +1,314 @@ +<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>])>> + +<ENDPACKAGE> diff --git a/<mdl.comp>/bittst.mud.9 b/<mdl.comp>/bittst.mud.9 new file mode 100644 index 0000000..8518dbe --- /dev/null +++ b/<mdl.comp>/bittst.mud.9 @@ -0,0 +1,59 @@ +<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 diff --git a/<mdl.comp>/bophac.mud.3 b/<mdl.comp>/bophac.mud.3 new file mode 100644 index 0000000..1475eb1 --- /dev/null +++ b/<mdl.comp>/bophac.mud.3 @@ -0,0 +1,27 @@ + +<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> + + \ No newline at end of file diff --git a/<mdl.comp>/build-dir.mud.4 b/<mdl.comp>/build-dir.mud.4 new file mode 100644 index 0000000..729e002 --- /dev/null +++ b/<mdl.comp>/build-dir.mud.4 @@ -0,0 +1,2278 @@ +;"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"> + + +;" " +;"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" +" " +;"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.">>)>> +;" " +;"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>)>> +;" " +;"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>> +;" " + +;"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" + <>> +;" " +;"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>)> +;" " +;"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)> + + + + +;" " +;"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>>)>> +;" " + + ;"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>> +;" " +;"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>> +;" " +;"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"> + <>> +;" " +;"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 ())> + + + + +;" " +;"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>)> +;" " + + + + +;"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)> + + + + +;" " +;"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.">>)>> + + + + +;" " +;"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>>)>> + + + + +;" " +;"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)> +;" " +;"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)> + + + +;" " + + +;"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> +> + + + +;" " +;"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>> + + + + +;" " +;"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)> + + + + +;" " +;"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>> +" " +;"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>> +" " +;"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>> +;" " +;"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>)>> +;" " +<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>)> +> +;" " +;"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>> +;" " +;"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>)>> +;" " +<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 ">)> +> +;" " +;"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>> +;" " +;"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>> +;" " +;"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>> +;" " +;"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" + + +� \ No newline at end of file diff --git a/<mdl.comp>/buildl.mud.19 b/<mdl.comp>/buildl.mud.19 new file mode 100644 index 0000000..5118798 --- /dev/null +++ b/<mdl.comp>/buildl.mud.19 @@ -0,0 +1,260 @@ +<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> \ No newline at end of file diff --git a/<mdl.comp>/cacs.mud.28 b/<mdl.comp>/cacs.mud.28 new file mode 100644 index 0000000..5724a07 --- /dev/null +++ b/<mdl.comp>/cacs.mud.28 @@ -0,0 +1,859 @@ +<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 diff --git a/<mdl.comp>/carana.mud.337 b/<mdl.comp>/carana.mud.337 new file mode 100644 index 0000000..096e350 --- /dev/null +++ b/<mdl.comp>/carana.mud.337 @@ -0,0 +1,393 @@ +<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> \ No newline at end of file diff --git a/<mdl.comp>/cargen.mud.31 b/<mdl.comp>/cargen.mud.31 new file mode 100644 index 0000000..97bfcf4 --- /dev/null +++ b/<mdl.comp>/cargen.mud.31 @@ -0,0 +1,1332 @@ +<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> diff --git a/<mdl.comp>/case.mud.59 b/<mdl.comp>/case.mud.59 new file mode 100644 index 0000000..60865d6 --- /dev/null +++ b/<mdl.comp>/case.mud.59 @@ -0,0 +1,380 @@ +<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)>> + +<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> + + \ No newline at end of file diff --git a/<mdl.comp>/caseld.mud.1 b/<mdl.comp>/caseld.mud.1 new file mode 100644 index 0000000..e81cef4 --- /dev/null +++ b/<mdl.comp>/caseld.mud.1 @@ -0,0 +1,37 @@ + + +<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> +  \ No newline at end of file diff --git a/<mdl.comp>/cback.mud.18 b/<mdl.comp>/cback.mud.18 new file mode 100644 index 0000000..71439d2 --- /dev/null +++ b/<mdl.comp>/cback.mud.18 @@ -0,0 +1,145 @@ +<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> + \ No newline at end of file diff --git a/<mdl.comp>/cdrive.mud.12 b/<mdl.comp>/cdrive.mud.12 new file mode 100644 index 0000000..e5df0dd --- /dev/null +++ b/<mdl.comp>/cdrive.mud.12 @@ -0,0 +1,270 @@ +<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> \ No newline at end of file diff --git a/<mdl.comp>/chkdcl.mud.44 b/<mdl.comp>/chkdcl.mud.44 new file mode 100644 index 0000000..91046b4 --- /dev/null +++ b/<mdl.comp>/chkdcl.mud.44 @@ -0,0 +1,1343 @@ + +<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>>>>>> + +" " + +<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))>> + +" " + +<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)>)>)>> + +" " + +<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>)>> +" " + +<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)>)>)>)>> + +" " + +<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 <>)>>)>>> + +" " + +<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)>)>> + +" " + +<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>)>)>>)>)>> + +" " + +<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))>> + +" " + +<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>>> +" " + +<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)>>> + +" " + +<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>)>)>> + +" " + +<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 " + +" " + +<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." + +" " + +<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>)>>)>> + +" " + +<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." + +" " + +<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>>>)>)>>>> +" " + +<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> diff --git a/<mdl.comp>/cleanac.mud.2 b/<mdl.comp>/cleanac.mud.2 new file mode 100644 index 0000000..80d22a6 --- /dev/null +++ b/<mdl.comp>/cleanac.mud.2 @@ -0,0 +1,45 @@ +<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> diff --git a/<mdl.comp>/codgen.mud.8 b/<mdl.comp>/codgen.mud.8 new file mode 100644 index 0000000..c7c216e --- /dev/null +++ b/<mdl.comp>/codgen.mud.8 @@ -0,0 +1,2192 @@ +<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)>> + )> + +<ENDPACKAGE> \ No newline at end of file diff --git a/<mdl.comp>/combat.tailor.6 b/<mdl.comp>/combat.tailor.6 new file mode 100644 index 0000000..800847d Binary files /dev/null and b/<mdl.comp>/combat.tailor.6 differ diff --git a/<mdl.comp>/comcod.mud.45 b/<mdl.comp>/comcod.mud.45 new file mode 100644 index 0000000..c92c715 --- /dev/null +++ b/<mdl.comp>/comcod.mud.45 @@ -0,0 +1,936 @@ +<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> diff --git a/<mdl.comp>/comfil.mud.3 b/<mdl.comp>/comfil.mud.3 new file mode 100644 index 0000000..5326279 --- /dev/null +++ b/<mdl.comp>/comfil.mud.3 @@ -0,0 +1,650 @@ + +<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))>> + + diff --git a/<mdl.comp>/comp106.save.1 b/<mdl.comp>/comp106.save.1 new file mode 100644 index 0000000..4c22666 Binary files /dev/null and b/<mdl.comp>/comp106.save.1 differ diff --git a/<mdl.comp>/compde.mud.32 b/<mdl.comp>/compde.mud.32 new file mode 100644 index 0000000..17ca1b5 --- /dev/null +++ b/<mdl.comp>/compde.mud.32 @@ -0,0 +1,1205 @@ + +<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>> + + +<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> diff --git a/<mdl.comp>/compdec.mud.1 b/<mdl.comp>/compdec.mud.1 new file mode 100644 index 0000000..31830b0 --- /dev/null +++ b/<mdl.comp>/compdec.mud.1 @@ -0,0 +1,1204 @@ + +<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>> + + +<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> + \ No newline at end of file diff --git a/<mdl.comp>/comsub.mud.10 b/<mdl.comp>/comsub.mud.10 new file mode 100644 index 0000000..5e57e37 --- /dev/null +++ b/<mdl.comp>/comsub.mud.10 @@ -0,0 +1,451 @@ +<PACKAGE "COMSUB"> + +<ENTRY SUBSTRUC-GEN> + +<USE "CODGEN" "CACS" "CHKDCL" "COMCOD" "COMPDEC" "STRGEN"> + + +"ROUTINES TO GENERATE SUBSTRUCT FOR THE COMPILER. CURRENTLY ONLY + 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">)>> + +\ + +"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>> + +\ + +"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>> + +\ + +"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>> + +\ + +"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> diff --git a/<mdl.comp>/comtem.mud.2 b/<mdl.comp>/comtem.mud.2 new file mode 100644 index 0000000..8894fb4 --- /dev/null +++ b/<mdl.comp>/comtem.mud.2 @@ -0,0 +1,361 @@ +<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)>> + +\ + +<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> diff --git a/<mdl.comp>/confor.mud.1 b/<mdl.comp>/confor.mud.1 new file mode 100644 index 0000000..a9dddc2 --- /dev/null +++ b/<mdl.comp>/confor.mud.1 @@ -0,0 +1,88 @@ + +<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>>)>> +  \ No newline at end of file diff --git a/<mdl.comp>/cprint.mud.1 b/<mdl.comp>/cprint.mud.1 new file mode 100644 index 0000000..4ffd540 --- /dev/null +++ b/<mdl.comp>/cprint.mud.1 @@ -0,0 +1,145 @@ + +<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!]> +  \ No newline at end of file diff --git a/<mdl.comp>/cup.mud.57 b/<mdl.comp>/cup.mud.57 new file mode 100644 index 0000000..c2bdd5d --- /dev/null +++ b/<mdl.comp>/cup.mud.57 @@ -0,0 +1,598 @@ +<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>>> + +\ + +<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>>)>> + +\ + +"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)>> + +\ + +"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>)>> + +\ + +<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>>> + +\ + +"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> + +<DEFINE ADDON (AD OB) + #DECL ((AD OB) <PRIMTYPE LIST>) + <COND (<EMPTY? .OB> .AD) + (ELSE <PUTREST <REST .OB <- <LENGTH .OB> 1>> .AD> .OB)>> + + +<ENDPACKAGE> diff --git a/<mdl.comp>/etmp.mud.1 b/<mdl.comp>/etmp.mud.1 new file mode 100644 index 0000000..21985b8 --- /dev/null +++ b/<mdl.comp>/etmp.mud.1 @@ -0,0 +1,30 @@ + +<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 diff --git a/<mdl.comp>/eupdat.mud.1 b/<mdl.comp>/eupdat.mud.1 new file mode 100644 index 0000000..01a37c2 --- /dev/null +++ b/<mdl.comp>/eupdat.mud.1 @@ -0,0 +1,122 @@ +<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)>> +  \ No newline at end of file diff --git a/<mdl.comp>/help.compil.7 b/<mdl.comp>/help.compil.7 new file mode 100644 index 0000000..5b6f25a --- /dev/null +++ b/<mdl.comp>/help.compil.7 @@ -0,0 +1,42 @@ + + +<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"> diff --git a/<mdl.comp>/infcmp.mud.21 b/<mdl.comp>/infcmp.mud.21 new file mode 100644 index 0000000..3828c1a --- /dev/null +++ b/<mdl.comp>/infcmp.mud.21 @@ -0,0 +1,257 @@ +<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> + \ No newline at end of file diff --git a/<mdl.comp>/istruc.mud.102 b/<mdl.comp>/istruc.mud.102 new file mode 100644 index 0000000..3ebdd8d --- /dev/null +++ b/<mdl.comp>/istruc.mud.102 @@ -0,0 +1,484 @@ +<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> \ No newline at end of file diff --git a/<mdl.comp>/lnqgen.mud.9 b/<mdl.comp>/lnqgen.mud.9 new file mode 100644 index 0000000..896d143 --- /dev/null +++ b/<mdl.comp>/lnqgen.mud.9 @@ -0,0 +1,230 @@ +<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> +  \ No newline at end of file diff --git a/<mdl.comp>/mapana.mud.231 b/<mdl.comp>/mapana.mud.231 new file mode 100644 index 0000000..e66683f --- /dev/null +++ b/<mdl.comp>/mapana.mud.231 @@ -0,0 +1,398 @@ +<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>)>)>> + +\ + +<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> +\ + +<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> + +\ + +<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> diff --git a/<mdl.comp>/mapgen.mud.71 b/<mdl.comp>/mapgen.mud.71 new file mode 100644 index 0000000..c2772a0 --- /dev/null +++ b/<mdl.comp>/mapgen.mud.71 @@ -0,0 +1,1565 @@ +<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> + +\ + +<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> +\ + +<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>>)>> + +\ + +<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>)>)>> + +\ + +<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]> + +\ + +<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> + <>)>> + +\ + +<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)>> + +\ + +<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> + +\ + +<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>>>)>)>> + +\ + +<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>>)>> + +\ + +<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>)>> + +\ + +<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> + +\ + +<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>> + + + +<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> diff --git a/<mdl.comp>/mapps1.mud.207 b/<mdl.comp>/mapps1.mud.207 new file mode 100644 index 0000000..67cbd70 --- /dev/null +++ b/<mdl.comp>/mapps1.mud.207 @@ -0,0 +1,126 @@ +<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>> + +\ + +<DEFINE PMARGS (O) #DECL ((VALUE) NODE) <NODEFM ,MARGS-CODE .PARENT <> <> () <>>> + +<PUT ,MAPF PAPPLY-OBJECT ,PMAPF-R> + +<PUT ,MAPR PAPPLY-OBJECT ,PMAPF-R> + +<ENDPACKAGE> diff --git a/<mdl.comp>/mmqgen.mud.27 b/<mdl.comp>/mmqgen.mud.27 new file mode 100644 index 0000000..c870df3 --- /dev/null +++ b/<mdl.comp>/mmqgen.mud.27 @@ -0,0 +1,271 @@ +<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> +  \ No newline at end of file diff --git a/<mdl.comp>/mobyg.mud.8 b/<mdl.comp>/mobyg.mud.8 new file mode 100644 index 0000000..268084f --- /dev/null +++ b/<mdl.comp>/mobyg.mud.8 @@ -0,0 +1,196 @@ +<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> + diff --git a/<mdl.comp>/mudhak.mud.2 b/<mdl.comp>/mudhak.mud.2 new file mode 100644 index 0000000..afa1c73 --- /dev/null +++ b/<mdl.comp>/mudhak.mud.2 @@ -0,0 +1,17 @@ + +<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> + + \ No newline at end of file diff --git a/<mdl.comp>/mudref.mud.1 b/<mdl.comp>/mudref.mud.1 new file mode 100644 index 0000000..32ab1b4 --- /dev/null +++ b/<mdl.comp>/mudref.mud.1 @@ -0,0 +1,135 @@ + + <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> + + +  \ No newline at end of file diff --git a/<mdl.comp>/ncomfi.mud.2 b/<mdl.comp>/ncomfi.mud.2 new file mode 100644 index 0000000..4bb4bc2 --- /dev/null +++ b/<mdl.comp>/ncomfi.mud.2 @@ -0,0 +1,65 @@ + +<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 diff --git a/<mdl.comp>/newcmp.mud.1 b/<mdl.comp>/newcmp.mud.1 new file mode 100644 index 0000000..132ce2e --- /dev/null +++ b/<mdl.comp>/newcmp.mud.1 @@ -0,0 +1,43 @@ + + <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> + +  \ No newline at end of file diff --git a/<mdl.comp>/newop.mud.1 b/<mdl.comp>/newop.mud.1 new file mode 100644 index 0000000..dd82d0f --- /dev/null +++ b/<mdl.comp>/newop.mud.1 @@ -0,0 +1,48 @@ +;"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 + + + + + <ENDBLOCK!-> + + + + ;"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> + + + +  \ No newline at end of file diff --git a/<mdl.comp>/newrep.mud.60 b/<mdl.comp>/newrep.mud.60 new file mode 100644 index 0000000..4e998d0 --- /dev/null +++ b/<mdl.comp>/newrep.mud.60 @@ -0,0 +1,998 @@ +<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." + + +" " + +<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> + +" " + +" 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>)>>>> + +" " + +" 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>)>> + +" " + +"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)> +" " + +"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>>>)>> + +" " + +<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>)>)>> + +" " + +<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>>>> + +" " + +<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>>> + +" " + +<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> + \ No newline at end of file diff --git a/<mdl.comp>/nhelp.mud.4 b/<mdl.comp>/nhelp.mud.4 new file mode 100644 index 0000000..c3aba06 --- /dev/null +++ b/<mdl.comp>/nhelp.mud.4 @@ -0,0 +1,36 @@ +<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"> + \ No newline at end of file diff --git a/<mdl.comp>/nn.mud.1 b/<mdl.comp>/nn.mud.1 new file mode 100644 index 0000000..d3c1ccb --- /dev/null +++ b/<mdl.comp>/nn.mud.1 @@ -0,0 +1,332 @@ + +<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>]>> + + +  \ No newline at end of file diff --git a/<mdl.comp>/nnupda.mud.1 b/<mdl.comp>/nnupda.mud.1 new file mode 100644 index 0000000..7aa3530 --- /dev/null +++ b/<mdl.comp>/nnupda.mud.1 @@ -0,0 +1,110 @@ +<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)>> +  \ No newline at end of file diff --git a/<mdl.comp>/notana.mud.116 b/<mdl.comp>/notana.mud.116 new file mode 100644 index 0000000..39dbc9e --- /dev/null +++ b/<mdl.comp>/notana.mud.116 @@ -0,0 +1,132 @@ +<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> + +<ENDPACKAGE> \ No newline at end of file diff --git a/<mdl.comp>/notgen.mud.119 b/<mdl.comp>/notgen.mud.119 new file mode 100644 index 0000000..121989c --- /dev/null +++ b/<mdl.comp>/notgen.mud.119 @@ -0,0 +1,330 @@ +<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>>>>> + +<ENDPACKAGE> + \ No newline at end of file diff --git a/<mdl.comp>/nprint.mud.21 b/<mdl.comp>/nprint.mud.21 new file mode 100644 index 0000000..cdc6250 --- /dev/null +++ b/<mdl.comp>/nprint.mud.21 @@ -0,0 +1,207 @@ +<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> + \ No newline at end of file diff --git a/<mdl.comp>/pass1.mud.45 b/<mdl.comp>/pass1.mud.45 new file mode 100644 index 0000000..241f431 --- /dev/null +++ b/<mdl.comp>/pass1.mud.45 @@ -0,0 +1,1145 @@ +<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>> + +"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>> + + +"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 '<-object>-." + +<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>)>>> + + +<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>>>> + + +;"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)>)>)>> + + + +"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> + diff --git a/<mdl.comp>/pcomp.load.13 b/<mdl.comp>/pcomp.load.13 new file mode 100644 index 0000000..508e9a9 --- /dev/null +++ b/<mdl.comp>/pcomp.load.13 @@ -0,0 +1,176 @@ +<SNAME "MDL.COMP"> + +<LINK '<ERRET T> "" <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> "" <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 <>> + \ No newline at end of file diff --git a/<mdl.comp>/pcomp.pure.3 b/<mdl.comp>/pcomp.pure.3 new file mode 100644 index 0000000..69bf57f --- /dev/null +++ b/<mdl.comp>/pcomp.pure.3 @@ -0,0 +1,13 @@ +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>> diff --git a/<mdl.comp>/pdmp.part.2 b/<mdl.comp>/pdmp.part.2 new file mode 100644 index 0000000..e3b64fb --- /dev/null +++ b/<mdl.comp>/pdmp.part.2 @@ -0,0 +1,29 @@ +CONN CMP: + + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "CODGEN.NBIN"> +<QUIT> +RES . + + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "STRGEN.NBIN"> +<QUIT> +RES . + + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "INFCMP.NBIN"> +<QUIT> +RES . + + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "NEWREP.NBIN"> +<QUIT> +RES . diff --git a/<mdl.comp>/pdmp.save.6 b/<mdl.comp>/pdmp.save.6 new file mode 100644 index 0000000..9cb22a6 Binary files /dev/null and b/<mdl.comp>/pdmp.save.6 differ diff --git a/<mdl.comp>/pdmp.xxfile.2 b/<mdl.comp>/pdmp.xxfile.2 new file mode 100644 index 0000000..75df133 --- /dev/null +++ b/<mdl.comp>/pdmp.xxfile.2 @@ -0,0 +1,279 @@ +CONN CMP: + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "ADVMES.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "ALLR.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "BACKAN.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "BITANA.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "BITSGE.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "BITTST.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "BUILDL.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "CACS.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "CACS.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "CARANA.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "CARGEN.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "CASE.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "CBACK.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "CDUP.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "CHKDCL.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "CODGEN.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "COMCOD.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "COMPDE.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "COMSUB.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "CUP.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "CUP.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "GETORD.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "INFCMP.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "INFCMP.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "ISTRUC.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "LNQGEN.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "MAPANA.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "MAPGEN.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "MAPPS1.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "MMQGEN.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "MMQGEN.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "NEWREP.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "NOTANA.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "NOTGEN.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "NPRINT.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "PASS1.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "PEEPH.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "PRCOD.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "PRNTYP.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "PUREQ.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "SBRNAM.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "STRANA.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "STRGEN.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "SUBRTY.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "SYMANA.NBIN"> +<QUIT> +RES . + +MDL105 +<RESTORE "PDMP"> +<DUMP-EM "VARANA.NBIN"> +<QUIT> +RES . + + diff --git a/<mdl.comp>/peeph.mud.92 b/<mdl.comp>/peeph.mud.92 new file mode 100644 index 0000000..3851ae2 --- /dev/null +++ b/<mdl.comp>/peeph.mud.92 @@ -0,0 +1,807 @@ +<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> + +\ + +"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>)>> + +\ + +<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>)>> + +<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> + +<ENDPACKAGE> + \ No newline at end of file diff --git a/<mdl.comp>/peeph.record.92 b/<mdl.comp>/peeph.record.92 new file mode 100644 index 0000000..ddf81ed --- /dev/null +++ b/<mdl.comp>/peeph.record.92 @@ -0,0 +1,276 @@ +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 diff --git a/<mdl.comp>/ppcomp.save.5 b/<mdl.comp>/ppcomp.save.5 new file mode 100644 index 0000000..fe70cd0 Binary files /dev/null and b/<mdl.comp>/ppcomp.save.5 differ diff --git a/<mdl.comp>/prntyp.mud.5 b/<mdl.comp>/prntyp.mud.5 new file mode 100644 index 0000000..3c3f140 --- /dev/null +++ b/<mdl.comp>/prntyp.mud.5 @@ -0,0 +1,59 @@ +<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 ")">)>> +<PRINTTYPE AC ,AC-PRINT> + +<PRINTTYPE SYMTAB ,SYMTAB-PRINT> + +<ENDPACKAGE> +  \ No newline at end of file diff --git a/<mdl.comp>/rest.gen.1 b/<mdl.comp>/rest.gen.1 new file mode 100644 index 0000000..e0aefba --- /dev/null +++ b/<mdl.comp>/rest.gen.1 @@ -0,0 +1,177 @@ + + + <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> diff --git a/<mdl.comp>/rhack.mud.1 b/<mdl.comp>/rhack.mud.1 new file mode 100644 index 0000000..c51e009 --- /dev/null +++ b/<mdl.comp>/rhack.mud.1 @@ -0,0 +1,56 @@ +<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))>> + +  \ No newline at end of file diff --git a/<mdl.comp>/sbrnam.mud.1 b/<mdl.comp>/sbrnam.mud.1 new file mode 100644 index 0000000..d6cc393 --- /dev/null +++ b/<mdl.comp>/sbrnam.mud.1 @@ -0,0 +1,20 @@ + + + <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> + + + + \ No newline at end of file diff --git a/<mdl.comp>/spcgen.mud.2 b/<mdl.comp>/spcgen.mud.2 new file mode 100644 index 0000000..1eaeb83 Binary files /dev/null and b/<mdl.comp>/spcgen.mud.2 differ diff --git a/<mdl.comp>/strana.mud.362 b/<mdl.comp>/strana.mud.362 new file mode 100644 index 0000000..7bf5030 --- /dev/null +++ b/<mdl.comp>/strana.mud.362 @@ -0,0 +1,537 @@ +<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> + + \ No newline at end of file diff --git a/<mdl.comp>/strgen.mud.33 b/<mdl.comp>/strgen.mud.33 new file mode 100644 index 0000000..f2c7640 --- /dev/null +++ b/<mdl.comp>/strgen.mud.33 @@ -0,0 +1,1867 @@ +<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> + +\ + +"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> + +<ENDPACKAGE> diff --git a/<mdl.comp>/subrty.mud.61 b/<mdl.comp>/subrty.mud.61 new file mode 100644 index 0000000..692d3d8 --- /dev/null +++ b/<mdl.comp>/subrty.mud.61 @@ -0,0 +1,252 @@ +<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> + +<ENDPACKAGE> diff --git a/<mdl.comp>/symana.mud.70 b/<mdl.comp>/symana.mud.70 new file mode 100644 index 0000000..b76945f --- /dev/null +++ b/<mdl.comp>/symana.mud.70 @@ -0,0 +1,1835 @@ +<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> diff --git a/<mdl.comp>/syntax.macro.1 b/<mdl.comp>/syntax.macro.1 new file mode 100644 index 0000000..8e85e79 --- /dev/null +++ b/<mdl.comp>/syntax.macro.1 @@ -0,0 +1,54 @@ +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. +[0[1J:K +:Sint (*act[])() { + "EFVLOSSAGE act0;' [  +:S-1}; +"EFVLOSSAGE act END0;'] +:Sint r1[] { + "EFVLOSSAGE r10;' ![ +:S-1};"EFVLOSSAGE r1 END0;'] +:Sint r2[] { + "EFVLOSSAGE r20;' ![ +:S-1};"EFVLOSSAGE r2 END0;'] +:Schar *sterm[] { + "EFVLOSSAGE sterm0;' [ +:S0};"EFVLOSSAGE sterm END0;'] +:Schar *snterm[] { + "EFVLOSSAGE snterm0;' [ +:S0};"EFVLOSSAGE snterm END0;'] +:Sint g[] { + "EFVLOSSAGE g0;' ![ +:S-1};"EFVLOSSAGE g END0;'] +:Sint pg[] { + "EFVLOSSAGE pg0;' ![ +:S-1};"EFVLOSSAGE pg END0;'] +:Sint sq[] { + "EFVLOSSAGE sq0;' ![ +:S-1};"EFVLOSSAGE sq END0;'] +:Sint nbpw {"EFVLOSSAGE npbw0;'  +:S};"EFVLOSSAGE npbw END0;' +:Sint nwpbt {"EFVLOSSAGE nwpbt0;'  +:S};"EFVLOSSAGE nwpbt END0;' +:Sint a[] { + "EFVLOSSAGE a0;' ![ +:S-1};"EFVLOSSAGE a END0;'] +:Sint pa[] { + "EFVLOSSAGE pa0;' ![ +:S-1};"EFVLOSSAGE pa END0;']]> +.,ZK +J<:S,"{U0 !'! Q0; R +Q0+1"ED' +Q0+2"EC.U0 :S","EFVLOSSAGE string0;'3R !'! + Q0,.FSBOUND-Z+(BJ<:S"\; !'! RI\C>WZJZ)FSBOUNDWCD' +Q0+3"EFLR'> +JS<:S]0+1;2RDI<>> +<J:S +ar;:S{"EFVLOSSAGE ar start0;'.U0RFLRQ0,.-1X1 0,.K +:S"EFVLOSSAGE act AGAIN0;':Sar"EFVLOSSAGE ar END0;' +-2DFWK FQ1+(FSHPOS)-(FSWIDTH)"GI + ' G1> +JI<SETG TABLES!-SYNTAX!-PACKAGE!- + #TABLES!-SYNTAX!-PACKAGE!- [ +S-DDJ]1]0]..D FVDONE +> \ No newline at end of file diff --git a/<mdl.comp>/temp.getord.1 b/<mdl.comp>/temp.getord.1 new file mode 100644 index 0000000..4a8bca4 Binary files /dev/null and b/<mdl.comp>/temp.getord.1 differ diff --git a/<mdl.comp>/terst.gen.1 b/<mdl.comp>/terst.gen.1 new file mode 100644 index 0000000..9cf1ba4 --- /dev/null +++ b/<mdl.comp>/terst.gen.1 @@ -0,0 +1,129 @@ +<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 diff --git a/<mdl.comp>/test.gen.3 b/<mdl.comp>/test.gen.3 new file mode 100644 index 0000000..3eef8e8 --- /dev/null +++ b/<mdl.comp>/test.gen.3 @@ -0,0 +1,230 @@ +<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 diff --git a/<mdl.comp>/undassm.crud.2 b/<mdl.comp>/undassm.crud.2 new file mode 100644 index 0000000..ad3346a --- /dev/null +++ b/<mdl.comp>/undassm.crud.2 @@ -0,0 +1,4329 @@ +<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> + + +<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>> + + <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> + + +<DEFINE ASSERT-TYPES (L) + #DECL ((L) <LIST [REST <LIST SYMTAB ANY ANY>]>) + <MAPF <> + <FUNCTION (LL) <SET-CURRENT-TYPE <1 .LL> <2 .LL>>> + .L>> + + <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> + + +<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> + + +<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>> + + <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> + + +<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>>>> + + <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> + +<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> + + <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> + \ No newline at end of file diff --git a/<mdl.comp>/varana.mud.43 b/<mdl.comp>/varana.mud.43 new file mode 100644 index 0000000..7c8a71e --- /dev/null +++ b/<mdl.comp>/varana.mud.43 @@ -0,0 +1,603 @@ +<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>> + + +<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> diff --git a/README.md b/README.md index c57f055..27e1c61 100644 --- a/README.md +++ b/README.md @@ -3,6 +3,8 @@ `<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.