3 <ENTRY LENGTH-ANA EMPTY?-ANA LENGTH?-ANA NTH-ANA REST-ANA PUT-ANA PUTREST-ANA
6 <USE "SYMANA" "CHKDCL" "COMPDEC" "ADVMESS">
8 "Structure hackers for the compiler (analyzers)"
10 <DEFINE LNTH-MT-ANA (NOD RTYP COD
11 "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM (WHO ())
13 <AND <OR <AND <==? .COD ,LNTH-CODE>
15 <ANCEST .GLN <PARENT .NOD>>>
16 <AND <==? .PRED <PARENT .NOD>>
19 #DECL ((NOD) NODE (LN COD) FIX (K) <LIST [REST NODE]>
20 (WHO) <SPECIAL LIST> (WHON) <SPECIAL <OR NODE FALSE>>)
21 <COND (<SEGFLUSH .NOD .RTYP>)
23 <ARGCHK .LN 1 <NODE-NAME .NOD>>
24 <SET TEM <EANA <1 .K> STRUCTURED <NODE-NAME .NOD>>>
25 <COND (<SET TEM <STRUCTYP .TEM>> <PUT .NOD ,NODE-TYPE .COD>)
29 ("Not open compiled because type is: "
30 <RESULT-TYPE <1 .K>>)>)>
31 <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>)>
32 <COND (<==? .COD ,MT-CODE>
34 <FUNCTION (L "AUX" (SYM <2 .L>) (FLG <1 .L>))
35 #DECL ((L) <LIST <OR FALSE ATOM> SYMTAB>
53 (ELSE <SET GLE .WHO>)>
54 <TYPE-OK? <COND (<==? <NODE-SUBR .NOD> ,LENGTH> <FORM FIX (0 ,PLUSINF)>)
55 (ELSE '<OR FALSE ATOM>)>
58 <DEFINE ANCEST (N1 N2)
61 <COND (<==? .N1 .N2> <RETURN>)>
62 <OR <==? <NODE-TYPE .N2> ,SET-CODE> <RETURN <>>>
63 <COND (<TYPE? <PARENT .N2> NODE> <SET N2 <PARENT .N2>>)
66 <DEFINE LENGTH-ANA (N R) <LNTH-MT-ANA .N .R ,LNTH-CODE>>
68 <PUT ,LENGTH ANALYSIS ,LENGTH-ANA>
70 <DEFINE EMPTY?-ANA (N R) <LNTH-MT-ANA .N .R ,MT-CODE>>
72 <PUT ,EMPTY? ANALYSIS ,EMPTY?-ANA>
74 <DEFINE LENGTH?-ANA (NOD RTYP
75 "AUX" (K <KIDS .NOD>) TEM (WHO ())
76 (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>))
77 #DECL ((NOD) NODE (K) <LIST [REST NODE]> (WHON) <SPECIAL ANY>
80 (<SEGFLUSH .NOD .RTYP>)
82 <ARGCHK <LENGTH .K> 2 LENGTH?>
83 <SET TEM <EANA <1 .K> STRUCTURED LENGTH?>>
85 <EANA <2 .K> FIX LENGTH?>
86 <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> ;"Constant 2d arg?"
88 <FUNCTION (L "AUX" (SYM <2 .L>) (FLG <1 .L>))
89 #DECL ((L) <LIST ANY SYMTAB> (SYM) SYMTAB)
93 [<NODE-NAME <2 .K>> ANY]>
98 <COND (<SET TEM <STRUCTYP .TEM>>
99 <PUT .NOD ,NODE-TYPE ,LENGTH?-CODE>)
103 ("Not open compiled because type is: "
104 <RESULT-TYPE <1 .K>>)>)>
105 <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
106 <TYPE-OK? <FORM OR <FORM FIX
108 <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
114 <PUT ,LENGTH? ANALYSIS ,LENGTH?-ANA>
116 <DEFINE NTH-REST-ANA (NOD RTYP COD
118 "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TS VAL TPS
119 (RV <OR .TF <==? <NODE-NAME .NOD> INTH>>)
121 (NM <COND (.RV NTH) (ELSE <NODE-NAME .NOD>)>) XX
122 (OWHON <AND <==? .WHON <PARENT .NOD>> .NOD>) NUMB)
123 #DECL ((COD NUMB LN) FIX (NOD WHON PRED) NODE (K) <LIST [REST NODE]>
126 <PROG ((WHO ()) (WHON <>))
127 #DECL ((WHON) <SPECIAL ANY> (WHO) <SPECIAL LIST>)
129 (<SEGFLUSH .NOD .RTYP>)
134 <SET K (<1 .K> <NODE1 ,QUOTE-CODE .NOD FIX 1 ()>)>>)
135 (ELSE <ARGCHK .LN 2 <NODE-NAME .NOD>>)>
137 <OR .TF <SET TF <EANA <2 .K> '<OR FIX OFFSET> .NM>>>
139 <SET TS <EANA <1 .K> STRUCTURED .NM>>)
142 <SET TS <EANA <1 .K> STRUCTURED .NM>>
144 <OR .TF <SET TF <EANA <2 .K> '<OR FIX OFFSET> .NM>>>)>
145 <COND (<AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> <==? <ISTYPE? .TF> OFFSET>>
146 <SET TS <TYPE-AND .TS <GET-DECL <NODE-NAME <2 .K>>>>>
147 <PUT <1 .K> ,RESULT-TYPE .TS>)>
148 <SET TPS <STRUCTYP .TS>>
149 <COND (<AND .TPS <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
153 <OR <==? <ISTYPE? .TF> FIX>
154 <AND <==? <ISTYPE? .TF> OFFSET>
155 <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>>
156 <N==? <ISTYPE? .TS> TEMPLATE>
157 <OR <NOT <==? .TPS TEMPLATE>>
158 <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> <ISTYPE? .TS>>>>
159 <PUT .NOD ,NODE-TYPE .COD>)
161 <AND <==? .COD ,NTH-CODE> <PUT .NOD ,NODE-NAME NTH>>
163 <ADDVMESS .NOD ("Not open compiled because type is: " .TS)>)>
164 <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
168 <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
170 <COND (<==? <ISTYPE? .TF> OFFSET>
171 <INDEX <NODE-NAME <2 .K>>>)
172 (ELSE <NODE-NAME <2 .K>>)>>)
174 <==? <NODE-SUBR .NOD> ,REST>>
177 <FUNCTION (L "AUX" (SYM <2 .L>) (FL <1 .L>) T1 T2)
178 #DECL ((L) <LIST ANY SYMTAB [REST ATOM FIX]> (SYM) SYMTAB)
179 <SET XX (.NM .NUMB !<REST .L 2>)>
182 <TYPE-AND <GET-CURRENT-TYPE .SYM> <TYPE-NTH-REST .VAL .XX>>>
183 <COND (.OWHON <SET WHO ((.FL .SYM !.XX) !.WHO)>)>
184 <COND (<AND <==? .PRED <PARENT .NOD>>
185 <SET T1 <TYPE-OK? .VAL FALSE>>
186 <SET T2 <TYPE-OK? .VAL '<NOT FALSE>>>>
187 <SET TRUTH <ADD-TYPE-LIST .SYM .T2 .TRUTH .FL .XX>>
189 <ADD-TYPE-LIST .SYM .T1 .UNTRUTH .FL .XX>>)>>
191 <COND (<AND <==? .TPS LIST>
192 <OR <==? <NODE-TYPE <1 .K>> ,LVAL-CODE>
193 <==? <NODE-TYPE <1 .K>> ,SET-CODE>>
194 <LOOK-FOR .NOD <1 .K> <2 .K> <==? <NODE-SUBR .NOD> ,REST>>>
195 <PUT .NOD ,NODE-TYPE ,ALL-REST-CODE>)
196 (<AND <==? .TPS LIST>
197 <==? .COD ,REST-CODE>
198 <GASSIGNED? PUT-SAME-CODE>
199 <==? <NODE-TYPE <1 .K>> ,PUTR-CODE>
200 <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
202 <PUT .NOD ,NODE-TYPE ,PUTR-CODE>)>
205 <DEFINE LOOK-FOR (MN N1 N RFLG "AUX" TT K (S ()) (SS (() () ())))
206 #DECL ((S) <LIST [REST NODE]> (N MN N1) NODE (TT) <OR FALSE NODE>
207 (K) <LIST [REST NODE]>)
209 <COND (<==? <NODE-TYPE .N1> ,LVAL-CODE>
212 (<==? <NODE-TYPE .N1> ,SET-CODE>
214 <SET N1 <2 <KIDS .N1>>>)
217 <SET TT <SET-SEARCH .N ,ARITH-CODE .S .SS>>
218 <==? <NODE-SUBR <SET N .TT>> ,->
219 <==? <LENGTH <SET K <KIDS .N>>> 2>
220 <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
221 <==? <NODE-NAME <2 .K>> 1>
224 <SET TT <SET-SEARCH .N ,LNTH-CODE .S <REST .SS>>>
226 <SET-SEARCH <1 <KIDS .TT>> ,LVAL-CODE .S <REST .SS 2>>>
227 <SMEMQ <NODE-NAME .TT> .S>
228 <PUT .MN ,TYPE-INFO .SS>>>
230 <DEFINE SET-SEARCH (N C S SS "AUX" (L ()))
231 #DECL ((N) NODE (C) FIX (S) <LIST [REST NODE]> (L SS) LIST)
233 <COND (<==? .C <NODE-TYPE .N>> <PUT .SS 1 .L> <RETURN .N>)>
234 <COND (<OR <N==? <NODE-TYPE .N> ,SET-CODE>
235 <SMEMQ <NODE-NAME .N> .S>>
238 <SET N <2 <KIDS .N>>>>>
240 <DEFINE SMEMQ (SYM L)
241 #DECL ((SYM) SYMTAB (L) LIST)
243 <FUNCTION (LL "AUX" (N <1 .LL>))
245 <COND (<==? <NODE-NAME .N> .SYM> <MAPLEAVE .LL>)>>
248 <DEFINE NTH-ANA (N R) <NTH-REST-ANA .N .R ,NTH-CODE>>
250 <PUT ,NTH ANALYSIS ,NTH-ANA>
252 <DEFINE REST-ANA (N R) <NTH-REST-ANA .N .R ,REST-CODE>>
254 <PUT ,REST ANALYSIS ,REST-ANA>
256 <DEFINE PUT-ANA (NOD RTYP
258 "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) (TS ANY) TV (TPS <>) VAL
259 (SVWHO ()) WHICH NS TVO TEM (P ()) TFF NUMB
260 (RV <OR .TF <==? <NODE-NAME .NOD> IPUT>>)
261 (NM <COND (.RV PUT) (ELSE <NODE-NAME .NOD>)>))
262 #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN NUMB) FIX (WHO P SVWHO) LIST)
264 <PROG ((WHO ()) (WHON <>))
265 #DECL ((WHO) <SPECIAL LIST> (WHON) <SPECIAL <OR FALSE NODE>>)
267 (<SEGFLUSH .NOD .RTYP>)
269 <EANA <1 .K> ANY <NODE-NAME .NOD>>
270 <EANA <2 .K> ANY <NODE-NAME .NOD>>
271 <COND (<AND .VERBOSE <==? <NODE-SUBR .NOD> ,PUT>>
272 <ADDVMESS .NOD ("PUT being used to remove association.")>)>
273 <PUT .NOD ,NODE-TYPE ,IREMAS-CODE>)
275 <ARGCHK .LN 3 <NODE-NAME .NOD>>
278 <OR .TF <SET TF <SET TFF <ANA <2 .K> ANY>>>>
280 <SET TS <ANA <1 .K> <OR <AND .TF STRUCTURED> ANY>>>
284 <SET TS <ANA <1 .K> ANY>>
286 <OR .TF <SET TFF <SET TF <ANA <2 .K> ANY>>>>)>
287 <SET TV <ANA <3 .K> ANY>>
288 <COND (<AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> <==? <ISTYPE? .TF> OFFSET>>
289 <SET TS <TYPE-AND .TS <GET-DECL <NODE-NAME <2 .K>>>>>
290 <PUT <1 .K> ,RESULT-TYPE .TS>)>
291 <AND <TYPE-OK? .TS '<NOT STRUCTURED>> <SET TS <>>>
292 <OR <AND <OR <==? <ISTYPE? .TF> FIX>
293 <AND <==? <ISTYPE? .TF> OFFSET>
294 <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>>
295 <==? <NODE-SUBR .NOD> ,PUT>>
298 <COND (<AND .TF .TS <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
300 <COND (<==? <ISTYPE? .TF> FIX> <NODE-NAME <2 .K>>)
301 (ELSE <INDEX <NODE-NAME <2 .K>>>)>>
303 !<COND (<1? .WHICH> (.TV))
304 (ELSE ([<- .WHICH 1> ANY] .TV))>>)
305 (ELSE <SET WHICH ALL> '<STRUCTURED [REST ANY]>)>>
307 (<AND .TS .TF <NOT <EMPTY? .WHO>>>
310 <FUNCTION (L "AUX" (S <2 .L>) (ND <1 <DECL-SYM .S>>))
311 #DECL ((L) <LIST ANY SYMTAB> (S) SYMTAB)
312 <SET ND <DECL-DOWN .ND !<REST .L 2>>>
313 <OR <TYPE-OK? .ND .NS> <MESSAGE ERROR "BAD ARG TO PUT" .NOD>>
317 <GET-ELE-TYPE .ND .WHICH <> .TV>
318 <TOP-TYPE <DECL-DOWN <GET-CURRENT-TYPE .S> !<REST .L 2>>>>
321 <SET TV <TYPE-AND .TV <GET-ELE-TYPE .NS .WHICH>>>)
322 (<NOT <EMPTY? .WHO>> <SET TV ANY>)>
324 <PUT <1 .K> ,RESULT-TYPE <SET TS <TYPE-AND <TOP-TYPE .NS> .TS>>>>
326 <SET TVO <GET-ELE-TYPE .TS .WHICH>>
327 <SET TS <GET-ELE-TYPE .TS .WHICH <> .TV>>)>
328 <COND (<AND .TS .TF <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
331 <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>)>
335 <SET TPS <STRUCTYP .TS>>
336 <OR <==? <ISTYPE? .TF> FIX> <==? <ISTYPE? .TF> OFFSET>>
337 <N==? <ISTYPE? .TS> TEMPLATE>
338 <OR <NOT <==? .TPS TEMPLATE>>
339 <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> <ISTYPE? .TS>>>
340 <OR <NOT <==? .TPS LIST>>
341 <0? <SET TEM <DEFERN .TV>>>
342 <AND <==? .TEM 1> <1? <DEFERN .TVO>>>>>
343 <PUT .NOD ,NODE-TYPE ,PUT-CODE>
344 <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
345 <MESSAGE ERROR " ATTEMPT TO MUNG QUOTED OBJECT " .NOD>)>)
348 (<AND .VERBOSE <==? <NODE-SUBR .NOD> ,PUT>>
353 <COND (<==? .TPS LIST> ("Not open compiled because of defer."))
354 (ELSE ("Not open compiled because type is: " .TS))>)
355 (<NOT <TYPE-OK? .TFF FIX>>
356 ("PUT used for association manipulation."))
358 ("PUT maybe structure or association. Type of 1st arg is: "
360 " and that of 2d arg is: "
362 <PUT .NOD ,NODE-TYPE ,IPUT-CODE>)>)>
363 <PUT-FLUSH <OR .TPS ALL>>
364 <TYPE-OK? <COND (.TS .TS) (ELSE ANY)> .RTYP>>>
366 (<==? <NODE-TYPE .NOD> ,PUT-CODE>
368 <FUNCTION (L "AUX" (SYM <2 .L>))
369 #DECL ((L) <LIST ANY SYMTAB [REST ATOM FIX]> (SYM) SYMTAB)
372 <PUT-TYPE-HACK <GET-CURRENT-TYPE .SYM>
378 <COND (<AND <==? <NODE-TYPE .NOD> ,PUT-CODE>
379 <GASSIGNED? PUT-SAME-CODE>
380 <MEMQ .TPS '![LIST VECTOR UVECTOR TUPLE!]>
383 <COND (<AND <G=? <LENGTH .N>
384 <INDEX ,SIDE-EFFECTS>>
389 <MEMQ <NODE-TYPE <3 .K>> ,HACK-NODES>
390 <==? <ISTYPE? <RESULT-TYPE <3 .K>>> FIX>
391 <NOT <EMPTY? <SET TEM <KIDS <3 .K>>>>>
392 <NOT <OR <==? <NODE-SUBR <3 .K>> ,/>
393 <AND <==? <NODE-SUBR <3 .K>> ,->
394 <NOT <AND <==? <LENGTH .TEM> 2>
395 <==? <NODE-NAME <2 .TEM>> 1>>>>>>
397 <FUNCTION (L "AUX" (N <1 .L>))
398 <COND (<AND <==? <NODE-TYPE .N> ,NTH-CODE>
399 <SAME-OBJ <1 .K> <1 <KIDS .N>>>
400 <SAME-OBJ <2 .K> <2 <KIDS .N>>>>
401 <COND (<NOT <EMPTY? .P>>
402 <PUTREST .P <REST .L>>
403 <SET TEM (.N !.TEM)>)>
408 <PUT <3 .K> ,KIDS .TEM>
409 <PUT .NOD ,NODE-TYPE ,PUT-SAME-CODE>)>
412 <DEFINE PUT-TYPE-HACK (TY TS L WHICH EX)
413 #DECL ((L) <LIST [REST FIX ATOM]>)
414 <COND (<EMPTY? .L> .TS)
415 (<AND <EMPTY? <REST .L 2>> <==? <2 .L> REST>>
420 <PUT-TYPE-HACK <GET-ELE-TYPE .TS .WHICH>
426 <PUT-TYPE-HACK .TY .TS <REST .L 2> .WHICH <1 .L>>)
432 <PUT-TYPE-HACK <GET-ELE-TYPE .TY <+ <1 .L> .EX>>
440 <COND (<EMPTY? .L> .L) (ELSE (!<LPR <REST .L>> <1 .L>))>>
442 <SETG HACK-NODES ![,ABS-CODE ,ARITH-CODE!]>
444 <PUT ,PUT ANALYSIS ,PUT-ANA>
446 <PUT ,PUTPROP ANALYSIS ,PUT-ANA>
448 <DEFINE SAME-OBJ (N1 N2)
450 <COND (<==? <NODE-TYPE .N1> <NODE-TYPE .N2>>
451 <COND (<MEMQ <NODE-TYPE .N1> ,SNODES>
452 <==? <NODE-NAME .N1> <NODE-NAME .N2>>)
456 <COND (<SAME-OBJ .N3 .N4>)
457 (ELSE <MAPLEAVE <>>)>>
461 <DEFINE DECL-DOWN ("TUPLE" TUP "AUX" (ND <1 .TUP>) (LN <- <LENGTH .TUP> 1>))
462 #DECL ((TUP) TUPLE (LN) FIX)
464 <COND (<L? .LN 2> <RETURN .ND>)
470 <==? <NTH .TUP .LN> REST>>>)>
473 <DEFINE DECL-UP (NX L)
475 <REPEAT ((FIRST T) (NUM 0))
476 #DECL ((NUM) FIX (L) LIST)
477 <COND (<EMPTY? .L> <RETURN .NX>)>
478 <COND (<==? <1 .L> NTH>
481 !<COND (<0? <SET NUM <+ .NUM <2 .L> -1>>> ())
487 (.FIRST <SET NX <REST-DECL .NX <2 .L>>>)
488 (ELSE <SET NUM <+ .NUM <2 .L>>>)>
489 <SET L <REST .L 2>>>>
491 <DEFINE PUTREST-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) T1 T2)
492 #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
493 <COND (<==? <NODE-SUBR .NOD> ,REST> <REST-ANA .NOD .RTYP>)
494 (<SEGFLUSH .NOD .RTYP>
495 <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
496 <TYPE-OK? '<PRIMTYPE LIST> .RTYP>)
498 <ARGCHK <LENGTH .K> 2 PUTREST>
499 <SET T1 <EANA <1 .K> '<PRIMTYPE LIST> PUTREST>>
500 <SET T2 <EANA <2 .K> '<PRIMTYPE LIST> PUTREST>>
501 <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
502 <MESSAGE ERROR " ATTEMPT TO MUNG QUOTED OBJECT " .NOD>)>
503 <PUT .NOD ,NODE-TYPE ,PUTR-CODE>
504 <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
505 <TYPE-OK? .T1 .RTYP>)>>
507 <PUT ,PUTREST ANALYSIS ,PUTREST-ANA>
509 <DEFINE MEMQ-ANA (N R "AUX" (K <KIDS .N>) TYP VTYP STYP ETY)
510 #DECL ((N) NODE (K) <LIST [REST NODE]>)
514 <ARGCHK <LENGTH .K> 2 MEMQ>
515 <SET VTYP <EANA <1 .K> ANY MEMQ>>
516 <SET TYP <EANA <2 .K> STRUCTURED MEMQ>>
517 <COND (<NOT <TYPE-OK? .VTYP <SET ETY <GET-ELE-TYPE .TYP ALL>>>>
518 <MESSAGE WARNING "MEMQ NEVER TRUE " .N>)>
519 <COND (<AND <SET STYP <STRUCTYP .TYP>> <N==? .STYP TEMPLATE>>
520 <PUT .N ,NODE-TYPE ,MEMQ-CODE>)
522 <COND (.VERBOSE <ADDVMESS .N ("Not open compiled because type is: "
524 <PUT .N ,NODE-TYPE ,ISUBR-CODE>)>
525 <TYPE-OK? <TYPE-MERGE FALSE
526 <COND (<AND .ETY <N==? .ETY ANY>>
527 <FORM <COND (.STYP) (STRUCTURED)>
533 <PUT ,MEMQ ANALYSIS ,MEMQ-ANA>