3 <ENTRY BACK-ANA TOP-ANA SUBSTRUC-ANA>
5 <USE "CHKDCL" "COMPDEC" "SYMANA">
7 <DEFINE BACK-ANA (NOD RTYP "AUX" TF TS (K <KIDS .NOD>) (LN <LENGTH .K>) TPS)
8 #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX)
10 (<SEGFLUSH .NOD .RTYP>)
15 <SET K (<1 .K> <NODE1 ,QUOTE-CODE .NOD FIX 1 ()>)>>)
16 (ELSE <ARGCHK .LN 2 BACK>)>
17 <SET TS <EANA <1 .K> STRUCTURED BACK>>
18 <SET TF <EANA <2 .K> FIX BACK>>
19 <COND (<NOT <OR <NOT <SET TPS <STRUCTYP .TS>>>
25 <MESSAGE ERROR "BAD 1ST ARG TO BACK" .NOD>)>
27 <COND (<OR <NOT .TPS> <==? .TPS STRING> <==? .TPS TEMPLATE>>
28 <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>
31 <PUT .NOD ,NODE-TYPE ,BACK-CODE>
32 <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
33 <TYPE-AND <REST-DECL .TS <NODE-NAME <2 .K>>> .TPS>)
37 <PUT ,BACK ANALYSIS ,BACK-ANA>
39 <DEFINE TOP-ANA (N R "AUX" (K <KIDS .N>) TS TPS) #DECL ((N) NODE (K) <LIST [REST NODE]>)
40 <COND (<SEGFLUSH .N .R>)
42 <ARGCHK <LENGTH .K> 1 TOP>
43 <SET TS <EANA <1 .K> STRUCTURED TOP>>
44 <COND (<AND <SET TPS <STRUCTYP .TS>>
45 <MEMQ .TPS '![VECTOR UVECTOR TUPLE]>>
46 <PUT .N ,NODE-TYPE ,TOP-CODE>
49 <MESSAGE ERROR " BAD ARG TO TOP ">)
51 <PUT .N ,NODE-TYPE ,ISUBR-CODE>
52 <TYPE-OK? .R <COND (.TPS)(ELSE STRUCTURED)>>)>)>>
54 <PUT ,TOP ANALYSIS ,TOP-ANA>
56 "ROUTINE TO ANALYZE SUBSTRUCS"
58 <DEFINE SUBSTRUC-ANA (NOD RTYP
59 "AUX" RNODE K FRST-ARG TS TF TYP LN FD TPS NUM NN SN
60 (ALRDY <==? <NODE-TYPE .NOD> ,SUBSTRUC-CODE>) TEM)
61 #DECL ((FRST-ARG RNODE NOD) NODE (K) <LIST [REST NODE]>
62 (FLG) <OR ATOM FALSE> (NUM) FIX)
64 (<SEGFLUSH .NOD .RTYP>)
67 <COND (<0? <SET LN <LENGTH .K>>>
68 <MESSAGE ERROR "TOO FEW ARGS TO SUBSTRUC">)>
69 <SET FD <EANA <SET FRST-ARG <1 .K>> STRUCTURED SUBSTRUC>>
70 <COND (<AND .ALRDY <G? .LN 1> <==? <NODE-TYPE <1 .K>> ,REST-CODE>>
71 <SET SN <1 <KIDS <1 .K>>>>
72 <SET NN <2 <KIDS <1 .K>>>>
73 <PUT .NN ,PARENT .NOD>
74 <PUT .SN ,PARENT .NOD>
76 <PUT .NOD ,KIDS <SET K (.SN .NN !<REST .K>)>>)>
77 <AND <G? .LN 1> <EANA <2 .K> FIX SUBSTRUC>>
78 <AND <G? .LN 2> <EANA <3 .K> FIX SUBSTRUC>>
79 <AND <G? .LN 3> <EANA <4 .K> STRUCTURED SUBSTRUC>>
81 (<OR <==? <SET TPS <STRUCTYP .FD>> VECTOR>
86 (<1? .LN> <PUT .NOD ,NODE-TYPE ,SUBSTRUC-CODE> <GET-ELE-TYPE .FD 0 T>)
87 (<G? .LN 4> <MESSAGE ERROR "TOO MANY ARGS TO SUBSTRUC">)
89 <COND (<OR <SUB-CASE-1 .FRST-ARG <4 .K>>
90 <SUB-CASE-2 .FRST-ARG <4 .K>>>)>>
91 <PUT .NOD ,NODE-TYPE ,SUBSTRUC-CODE>
92 <SET RNODE <BUILD-REST-NODE <1 .K> <2 .K> .NOD>>
93 <SPLICE-IN-SUB .K .RNODE>
94 <SET TF <EANA .RNODE .TPS SUBSTRUC>>
95 <COND (<==? .LN 4> <SET TS <RESULT-TYPE <3 .K>>>) (<SET TS .TF>)>
97 <COND (<AND <N=? .LN 2> <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
98 <SET NUM <NODE-NAME <2 .K>>>
99 <TYPE-OK? .TF <FORM STRUCTURED [.NUM ANY]>>)
104 (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
110 <COND (<0? .NUM> <MAPSTOP>)
112 <SET X <GET-ELE-TYPE .TF .NUM>>
116 (ELSE <SET TF .TPS>)>)>)
117 (ELSE <PUT .NOD ,NODE-TYPE ,ISUBR-CODE> .TPS)>>
120 <AND <==? .TPS TUPLE> <SET TPS VECTOR>>
123 (<AND <TYPE? .TF FORM SEGMENT> <ISTYPE? .TF>>
130 <COND (<TYPE? .D FORM>
131 <CHTYPE (.TPS !<REST .D>) FORM>)
133 <CHTYPE (.TPS !<REST .D>) SEGMENT>)
137 (<TYPE? .TF FORM> <CHTYPE (.TPS !<REST .TF>) FORM>)
138 (ELSE <CHTYPE (.TPS !<REST .TF>) SEGMENT>)>)
140 <TYPE-OK? .TF .RTYP>)
141 (ELSE <PUT .NOD ,NODE-TYPE ,ISUBR-CODE> <TYPE-OK? STRUCTURED .RTYP>)>)>>
143 <PUT ,SUBSTRUC ANALYSIS ,SUBSTRUC-ANA>
147 <DEFINE BUILD-REST-NODE (NODE NUM PAR)
148 <NODEFM ,SUBR-CODE .PAR ANY REST (.NODE .NUM) ,REST>>
150 "SPICE IN A REST NODE"
152 <DEFINE SPLICE-IN-SUB (K NNODE)
153 #DECL ((K) <LIST [REST NODE]> (NNODE) NODE)
155 <PUTREST .K <REST .K 2>>>
158 "SUB-CASE-1 LOOKS FOR <SUBSTRUC <REST .X> .N1 .N2 .X> AND SIMILAR CASES WHERE
159 BLTS ARE ALWAYS POSSIBLE.
160 STRNOD== NODE OF STRUCTURE
161 CPYNOD== NODE OF STRUCTURE TO COPY INTO"
163 <DEFINE SUB-CASE-1 (STRNOD CPYNOD
164 "AUX" (DATA <GET-SUB-DATA .STRNOD>)
165 (DATAC <GET-SUB-DATA .CPYNOD>))
166 #DECL ((STRNOD CPYNOD) NODE (DATAC DATA) <OR FALSE LIST>)
169 <==? <1 .DATA> <1 .DATAC>>
170 <TYPE? <2 .DATAC> FIX>
172 <AND <TYPE? <2 .DATA> FIX> <G=? <2 .DATA> <2 .DATAC>>>>>>
174 <DEFINE SUB-CASE-2 (STRNOD CPYNOD
175 "AUX" (DATA <GET-SUB-DATA .STRNOD>)
176 (DATAC <GET-SUB-DATA .CPYNOD>))
177 #DECL ((STRNOD CPYNOD) NODE (DATAC DATA) <OR FALSE LIST>)
180 <==? <1 .DATA> <1 .DATAC>>
181 <TYPE? <2 .DATA> FIX>
183 <AND <TYPE? <2 .DATAC> FIX> <L? <2 .DATA> <2 .DATAC>>>>>>
186 <DEFINE GET-SUB-DATA (NOD "AUX" SYM TNOD (NTYP <NODE-TYPE .NOD>))
187 #DECL ((NOD TNOD) NODE (SYM) SYMTAB (NTYP) FIX)
188 <COND (<OR <==? .NTYP ,LVAL-CODE> <==? .NTYP ,SET-CODE>>
189 (<NODE-NAME .NOD> 0))
190 (<AND <==? .NTYP ,REST-CODE>
191 <COND (<OR <==? <SET NTYP <NODE-TYPE <SET TNOD <1 <KIDS .NOD>>>>>
193 <==? .NTYP ,SET-CODE>>
194 <SET SYM <NODE-NAME .TNOD>>)>>
195 (.SYM <NODE-NAME <2 <KIDS .NOD>>>))>><ENDPACKAGE>