17 <USE "SYMANA" "CHKDCL" "COMPDEC" "ADVMESS">
19 "Structure hackers for the compiler (analyzers)"
21 <DEFINE LNTH-MT-ANA (NOD RTYP COD
22 "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM (WHO ())
25 <AND <OR <AND <==? .COD ,LNTH-CODE>
27 <ANCEST .GLN <PARENT .NOD>>>
28 <AND <==? .PRED <PARENT .NOD>>
31 #DECL ((NOD) NODE (LN COD) FIX (K) <LIST [REST NODE]> (WHO) <SPECIAL LIST>
32 (WHON) <SPECIAL <OR NODE FALSE>>)
34 (<SEGFLUSH .NOD .RTYP>)
36 <ARGCHK .LN 1 <NODE-NAME .NOD> .NOD>
37 <SET TEM <STRUCTYP <EANA <1 .K> STRUCTURED <NODE-NAME .NOD>>>>
39 (<OR .TEM <==? .COD ,MT-CODE>>
40 <PUT .NOD ,NODE-TYPE .COD>
45 ("Not open compiled because type is: "
46 <RESULT-TYPE <1 .K>>)>)>
47 <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>)>
48 <COND (<==? .COD ,MT-CODE>
50 <FUNCTION (L "AUX" (SYM <2 .L>) (FLG <1 .L>))
51 #DECL ((L) <LIST <OR FALSE ATOM> SYMTAB> (SYM) SYMTAB)
54 '<STRUCTURED [REST <NOT ANY>]>
66 (ELSE <SET GLE .WHO>)>
67 <TYPE-OK? <COND (<==? <NODE-SUBR .NOD> ,LENGTH> <FORM FIX (0 ,PLUSINF)>)
71 <DEFINE ANCEST (N1 N2)
74 <COND (<==? .N1 .N2> <RETURN>)>
75 <OR <==? <NODE-TYPE .N2> ,SET-CODE> <RETURN <>>>
76 <COND (<TYPE? <PARENT .N2> NODE> <SET N2 <PARENT .N2>>)
79 <DEFINE LENGTH-ANA (N R) <LNTH-MT-ANA .N .R ,LNTH-CODE>>
81 <DEFINE EMPTY?-ANA (N R) <LNTH-MT-ANA .N .R ,MT-CODE>>
83 <COND (<GASSIGNED? LENGTH-ANA>
84 <PUTPROP ,EMPTY? ANALYSIS ,EMPTY?-ANA>
85 <PUTPROP ,LENGTH ANALYSIS ,LENGTH-ANA>)>
87 <DEFINE LENGTH?-ANA (NOD RTYP
88 "AUX" (K <KIDS .NOD>) TEM (WHO ())
89 (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>))
90 #DECL ((NOD) NODE (K) <LIST [REST NODE]> (WHON) <SPECIAL ANY>
93 (<SEGFLUSH .NOD .RTYP>)
95 <ARGCHK <LENGTH .K> 2 LENGTH? .NOD>
96 <SET TEM <EANA <1 .K> STRUCTURED LENGTH?>>
98 <EANA <2 .K> FIX LENGTH?>
99 <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> ;"Constant 2d arg?"
101 <FUNCTION (L "AUX" (SYM <2 .L>) (FLG <1 .L>))
102 #DECL ((L) <LIST ANY SYMTAB> (SYM) SYMTAB)
106 <FORM STRUCTURED [<NODE-NAME <2 .K>> ANY]>
111 <COND (<SET TEM <STRUCTYP .TEM>> <PUT .NOD ,NODE-TYPE ,LENGTH?-CODE>)
115 ("Not open compiled because type is: "
116 <RESULT-TYPE <1 .K>>)>)>
117 <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
121 <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
127 <COND (<GASSIGNED? LENGTH?-ANA> <PUTPROP ,LENGTH? ANALYSIS ,LENGTH?-ANA>)>
129 <DEFINE MONAD-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM)
130 #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
131 <COND (<SEGFLUSH .NOD .RTYP>
132 <TYPE-OK? .RTYP BOOLEAN>)
134 <ARGCHK .LN 1 MONAD? .NOD>
135 <SET TEM <EANA <1 .K> STRUCTURED <NODE-NAME .NOD>>>
136 <PUT .NOD ,NODE-TYPE ,MONAD-CODE>
137 <TYPE-OK? .RTYP BOOLEAN>)>>
139 <COND (<GASSIGNED? MONAD-ANA> <PUTPROP ,MONAD? ANALYSIS ,MONAD-ANA>)>
141 <DEFINE NTH-REST-ANA (NOD RTYP COD
143 "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TS VAL TPS
144 (RV <OR .TF <==? <NODE-NAME .NOD> INTH>>)
146 (NM <COND (.RV NTH) (ELSE <NODE-NAME .NOD>)>) XX
147 (OWHON <AND <==? .WHON <PARENT .NOD>> .NOD>) NUMB)
148 #DECL ((COD NUMB LN) FIX (NOD WHON PRED) NODE (K) <LIST [REST NODE]>
151 <PROG ((WHO ()) (WHON <>))
152 #DECL ((WHON) <SPECIAL ANY> (WHO) <SPECIAL LIST>)
154 (<SEGFLUSH .NOD .RTYP>)
159 <SET K (<1 .K> <NODE1 ,QUOTE-CODE .NOD FIX 1 ()>)>>)
160 (ELSE <ARGCHK .LN 2 <NODE-NAME .NOD> .NOD>)>
162 <OR .TF <SET TF <EANA <2 .K> '<OR FIX OFFSET> .NM>>>
164 <SET TS <EANA <1 .K> STRUCTURED .NM>>)
167 <SET TS <EANA <1 .K> STRUCTURED .NM>>
169 <OR .TF <SET TF <EANA <2 .K> '<OR FIX OFFSET> .NM>>>)>
170 <COND (<AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
171 <SET AMT <NODE-NAME <2 .K>>>
172 <==? <ISTYPE? .TF> OFFSET>>
173 <SET TS <TYPE-AND .TS <GET-DECL .AMT>>>
174 <SET AMT <INDEX .AMT>>
175 <PUT <1 .K> ,RESULT-TYPE .TS>)>
176 <COND (<ASSIGNED? AMT>
177 <COND (<==? .COD ,NTH-CODE>
179 <SET TS <TYPE-AND .TS <FORM STRUCTURED .RTYP>>>)
181 <SET TS <TYPE-AND .TS <FORM STRUCTURED
184 (<SET PT <STRUCTYP .RTYP>>
186 <SET TS <TYPE-AND .TS <FORM PRIMTYPE .PT>>>)
188 <SET TS <TYPE-AND .TS <FORM <FORM PRIMTYPE .PT>
191 <SET TS <TYPE-AND .TS <FORM STRUCTURED [.AMT ANY]>>>)>)
192 (<==? .COD ,NTH-CODE>
193 <SET TS <TYPE-AND .TS <FORM STRUCTURED ANY>>>)
194 (<SET PT <STRUCTYP .RTYP>>
195 <SET TS <TYPE-AND .TS <FORM PRIMTYPE .PT>>>)>
196 <PUT <1 .K> ,RESULT-TYPE .TS>
197 <SET TPS <STRUCTYP .TS>>
198 <COND (<AND .TPS <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
201 (<OR <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
202 <==? <NODE-NAME <2 .K>> 1>>
204 <OR <==? <ISTYPE? .TF> FIX>
205 <AND <==? <ISTYPE? .TF> OFFSET>
206 <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
207 <AND <TYPE-OK? .TF FIX>
208 <N==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>>>>
209 <PUT .NOD ,NODE-TYPE .COD>)
211 <AND <==? .COD ,NTH-CODE> <PUT .NOD ,NODE-NAME NTH>>
213 <ADDVMESS .NOD ("Not open compiled because type is: " .TS)>)>
214 <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
218 <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
220 <COND (<==? <ISTYPE? .TF> OFFSET>
221 <INDEX <NODE-NAME <2 .K>>>)
222 (ELSE <NODE-NAME <2 .K>>)>>)
224 <==? <NODE-SUBR .NOD> ,REST>>
227 <FUNCTION (L "AUX" (SYM <2 .L>) (FL <1 .L>) T1 T2)
228 #DECL ((L) <LIST ANY SYMTAB [REST ATOM FIX]> (SYM) SYMTAB)
229 <SET XX (.NM .NUMB !<REST .L 2>)>
232 <TYPE-AND <GET-CURRENT-TYPE .SYM> <TYPE-NTH-REST .VAL .XX>>>
233 <COND (.OWHON <SET WHO ((.FL .SYM !.XX) !.WHO)>)>
234 <COND (<AND <==? .PRED <PARENT .NOD>>
235 <SET T1 <TYPE-OK? .VAL FALSE>>
236 <SET T2 <TYPE-OK? .VAL '<NOT FALSE>>>>
237 <SET TRUTH <ADD-TYPE-LIST .SYM .T2 .TRUTH .FL .XX>>
239 <ADD-TYPE-LIST .SYM .T1 .UNTRUTH .FL .XX>>)>>
241 <COND (<AND <==? .TPS LIST>
242 <OR <==? <NODE-TYPE <1 .K>> ,LVAL-CODE>
243 <==? <NODE-TYPE <1 .K>> ,SET-CODE>>
244 <LOOK-FOR .NOD <1 .K> <2 .K> <==? <NODE-SUBR .NOD> ,REST>>>
245 <PUT .NOD ,NODE-TYPE ,ALL-REST-CODE>)
246 (<AND <==? .TPS LIST>
247 <==? .COD ,REST-CODE>
248 <GASSIGNED? PUT-SAME-CODE>
249 <==? <NODE-TYPE <1 .K>> ,PUTR-CODE>
250 <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
252 <PUT .NOD ,NODE-TYPE ,PUTR-CODE>)>
255 <DEFINE LOOK-FOR (MN N1 N RFLG "AUX" TT K (S ()) (SS (() () ())))
256 #DECL ((S) <LIST [REST NODE]> (N MN N1) NODE (TT) <OR FALSE NODE>
257 (K) <LIST [REST NODE]>)
259 <COND (<==? <NODE-TYPE .N1> ,LVAL-CODE>
262 (<==? <NODE-TYPE .N1> ,SET-CODE>
264 <SET N1 <2 <KIDS .N1>>>)
267 <SET TT <SET-SEARCH .N ,ARITH-CODE .S .SS>>
268 <==? <NODE-SUBR <SET N .TT>> ,->
269 <==? <LENGTH <SET K <KIDS .N>>> 2>
270 <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
271 <==? <NODE-NAME <2 .K>> 1>
274 <SET TT <SET-SEARCH .N ,LNTH-CODE .S <REST .SS>>>
275 <SET TT <SET-SEARCH <1 <KIDS .TT>> ,LVAL-CODE .S <REST .SS 2>>>
276 <SMEMQ <NODE-NAME .TT> .S>
277 <PUT .MN ,TYPE-INFO .SS>>>
279 <DEFINE SET-SEARCH (N C S SS "AUX" (L ()))
280 #DECL ((N) NODE (C) FIX (S) <LIST [REST NODE]> (L SS) LIST)
282 <COND (<==? .C <NODE-TYPE .N>> <PUT .SS 1 .L> <RETURN .N>)>
283 <COND (<OR <N==? <NODE-TYPE .N> ,SET-CODE>
284 <SMEMQ <NODE-NAME .N> .S>>
287 <SET N <2 <KIDS .N>>>>>
289 <DEFINE SMEMQ (SYM L)
290 #DECL ((SYM) SYMTAB (L) LIST)
292 <FUNCTION (LL "AUX" (N <1 .LL>))
294 <COND (<==? <NODE-NAME .N> .SYM> <MAPLEAVE .LL>)>>
297 <DEFINE NTH-ANA (N R) <NTH-REST-ANA .N .R ,NTH-CODE>>
299 <DEFINE REST-ANA (N R) <NTH-REST-ANA .N .R ,REST-CODE>>
301 <COND (<GASSIGNED? NTH-ANA>
302 <PUTPROP ,NTH ANALYSIS ,NTH-ANA>
303 <PUTPROP ,REST ANALYSIS ,REST-ANA>)>
305 <DEFINE PUT-ANA (NOD RTYP
307 "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) (TS ANY) TV (TPS <>)
308 VAL (SVWHO ()) WHICH NS TVO TEM (P ()) TFF NUMB
309 (RV <OR .TF <==? <NODE-NAME .NOD> IPUT>>) AMT
310 (NM <COND (.RV PUT) (ELSE <NODE-NAME .NOD>)>))
311 #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN NUMB) FIX (WHO P SVWHO) LIST)
313 <PROG ((WHO ()) (WHON <>))
314 #DECL ((WHO) <SPECIAL LIST> (WHON) <SPECIAL <OR FALSE NODE>>)
316 (<SEGFLUSH .NOD .RTYP>)
318 <ARGCHK .LN 3 <NODE-NAME .NOD> .NOD>
321 <OR .TF <SET TF <SET TFF <EANA <2 .K> '<OR FIX OFFSET> PUT>>>>
323 <SET TS <ANA <1 .K> STRUCTURED>>
327 <SET TS <ANA <1 .K> STRUCTURED>>
329 <OR .TF <SET TFF <SET TF <EANA <2 .K> '<OR FIX OFFSET> PUT>>>>)>
330 <SET TV <ANA <3 .K> ANY>>
331 <COND (<AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
332 <SET AMT <NODE-NAME <2 .K>>>
333 <==? <ISTYPE? .TF> OFFSET>>
334 <SET TS <TYPE-AND .TS <GET-DECL <NODE-NAME <2 .K>>>>>
335 <SET AMT <INDEX .AMT>>
336 <PUT <1 .K> ,RESULT-TYPE .TS>)>
337 <OR <AND <OR <==? <ISTYPE? .TF> FIX>
338 <AND <==? <ISTYPE? .TF> OFFSET>
339 <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>>
340 <==? <NODE-SUBR .NOD> ,PUT>>
343 <COND (<AND .TF .TS <ASSIGNED? AMT>>
346 !<COND (<1? .WHICH> (ANY))
347 (ELSE ([<- .WHICH 1> ANY] ANY))>>)
348 (ELSE <SET WHICH ALL> '<STRUCTURED ANY>)>>
349 <SET TS <TYPE-AND .TS .NS>>
351 (<AND <N==? .WHICH ALL> <N==? .TV ANY>>
354 <NOT <TYPE? .TS FORM SEGMENT>>
358 <FUNCTION (X!-INITIAL)
360 (<AND <TYPE? .X!-INITIAL FORM>
361 <==? <REST .X!-INITIAL
362 <- <LENGTH .X!-INITIAL> 1>>
363 <REST .NS <- <LENGTH .NS> 1>>>>
368 <N==? <REST .NS <- <LENGTH .NS> 1>>
369 <REST .TS <- <LENGTH .TS> 1>>>)>>
370 <PUT .NS <LENGTH .NS> .TV>)
371 (ELSE <PUT <SET NS <FORM !.NS>> <LENGTH .NS> .TV>)>)>
373 (<AND .TS .TF <NOT <EMPTY? .WHO>>>
376 <FUNCTION (L "AUX" (S <2 .L>) (ND <DECL-SYM .S>))
377 #DECL ((L) <LIST ANY SYMTAB> (S) SYMTAB)
378 <SET ND <DECL-DOWN .ND !<REST .L 2!>>>
379 <COND (<NOT <SET ND <TYPE-AND .ND .NS>>>
380 <COMPILE-ERROR "Bad argument to PUT " .NOD>)>
383 <TOP-TYPE <DECL-DOWN <GET-CURRENT-TYPE .S> !<REST .L 2!>>>
386 <SET TV <TYPE-AND .TV <GET-ELE-TYPE .NS .WHICH>>>)
387 (<NOT <EMPTY? .WHO>> <SET TV ANY>)>
389 <PUT <1 .K> ,RESULT-TYPE <SET TS <TYPE-AND <TOP-TYPE .NS> .TS>>>>
391 <SET TVO <GET-ELE-TYPE .TS .WHICH>>
392 <SET TS <GET-ELE-TYPE .TS .WHICH <> .TV>>)>
393 <COND (<AND .TS .TF <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
396 <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD!>)>)>
400 <SET TPS <STRUCTYP .TS>>
401 <OR <==? <ISTYPE? .TF> FIX> <==? <ISTYPE? .TF> OFFSET>>>
402 <PUT .NOD ,NODE-TYPE ,PUT-CODE>
403 <COND (<AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
404 <NOT ,INTERPRETER-IMPLEMENTOR?>>
405 <COMPILE-ERROR "Attempt to PUT in quoted object " .NOD>)>)
407 <COND (<AND .VERBOSE <==? <NODE-SUBR .NOD> ,PUT>>
408 <ADDVMESS .NOD ("Not open compiled because type is: " .TS)>)>
409 <PUT .NOD ,NODE-TYPE ,IPUT-CODE>
410 <PUT .NOD ,NODE-NAME PUT>)>)>
411 <PUT-FLUSH <OR .TPS ALL>>
412 <TYPE-OK? <COND (.TS .TS) (ELSE ANY)> .RTYP>>>
414 (<==? <NODE-TYPE .NOD> ,PUT-CODE>
416 <FUNCTION (L "AUX" (SYM <2 .L>))
417 #DECL ((L) <LIST ANY SYMTAB [REST ATOM FIX]> (SYM) SYMTAB)
420 <PUT-TYPE-HACK <GET-CURRENT-TYPE .SYM>
426 <COND (<AND <==? <NODE-TYPE .NOD> ,PUT-CODE>
427 <GASSIGNED? PUT-SAME-CODE>
428 <MEMQ .TPS '[LIST VECTOR UVECTOR TUPLE STRING BYTES]>
431 <COND (<AND <G=? <LENGTH .N>
432 <INDEX ,SIDE-EFFECTS>>
437 <MEMQ <NODE-TYPE <3 .K>> ,HACK-NODES>
438 <==? <ISTYPE? <RESULT-TYPE <3 .K>>> FIX>
439 <NOT <EMPTY? <SET TEM <KIDS <3 .K>>>>>
440 <NOT <OR <==? <NODE-SUBR <3 .K>> ,/>
441 <AND <==? <NODE-SUBR <3 .K>> ,->
442 <NOT <AND <==? <LENGTH .TEM> 2>
443 <==? <NODE-NAME <2 .TEM>> 1>>>>>>
445 <FUNCTION (L "AUX" (N <1 .L>))
446 <COND (<AND <==? <NODE-TYPE .N> ,NTH-CODE>
447 <SAME-OBJ <1 .K> <1 <KIDS .N>>>
448 <SAME-OBJ <2 .K> <2 <KIDS .N>>>>
449 <COND (<NOT <EMPTY? .P>>
450 <PUTREST .P <REST .L>>
451 <SET TEM (.N !.TEM)>)>
456 <PUT <3 .K> ,KIDS .TEM>
457 <PUT .NOD ,NODE-TYPE ,PUT-SAME-CODE>)>
460 <DEFINE PUT-TYPE-HACK (TY TS L WHICH EX)
461 #DECL ((L) <LIST [REST FIX ATOM]>)
464 (<AND <EMPTY? <REST .L 2>> <==? <2 .L> REST>>
468 <PUT-TYPE-HACK <GET-ELE-TYPE .TS .WHICH>
473 (<==? <2 .L> REST> <PUT-TYPE-HACK .TY .TS <REST .L 2> .WHICH <1 .L>>)
479 <PUT-TYPE-HACK <GET-ELE-TYPE .TY <+ <1 .L> .EX>>
486 #DECL ((VALUE L) LIST)
487 <COND (<EMPTY? .L> .L) (ELSE (!<LPR <REST .L>> <1 .L>))>>
489 <SETG HACK-NODES [,ABS-CODE ,ARITH-CODE]>
491 <COND (<GASSIGNED? PUT-ANA> <PUTPROP ,PUT ANALYSIS ,PUT-ANA>)>
493 <DEFINE SAME-OBJ (N1 N2)
495 <COND (<==? <NODE-TYPE .N1> <NODE-TYPE .N2>>
496 <COND (<MEMQ <NODE-TYPE .N1> ,SNODES>
497 <==? <NODE-NAME .N1> <NODE-NAME .N2>>)
501 <COND (<SAME-OBJ .N3 .N4>)
502 (ELSE <MAPLEAVE <>>)>>
506 <DEFINE DECL-DOWN ("TUPLE" TUP "AUX" (ND <1 .TUP>) (LN <- <LENGTH .TUP> 1>))
507 #DECL ((TUP) TUPLE (LN) FIX)
509 <COND (<L? .LN 2> <RETURN .ND>)
514 <==? <NTH .TUP .LN> REST>>>)>
517 <DEFINE DECL-UP (NX L)
519 <REPEAT ((FIRST T) (NUM 0))
520 #DECL ((NUM) FIX (L) LIST)
521 <COND (<EMPTY? .L> <RETURN .NX>)>
522 <COND (<==? <1 .L> NTH>
525 !<COND (<0? <SET NUM <+ .NUM <2 .L> -1>>> ())
531 (.FIRST <SET NX <REST-DECL .NX <2 .L>>>)
532 (ELSE <SET NUM <+ .NUM <2 .L>>>)>
533 <SET L <REST .L 2>>>>
535 <DEFINE PUTREST-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) T1 T2)
536 #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
537 <COND (<==? <NODE-SUBR .NOD> ,REST> <REST-ANA .NOD .RTYP>)
538 (<SEGFLUSH .NOD .RTYP>
539 <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
540 <TYPE-OK? '<PRIMTYPE LIST> .RTYP>)
542 <ARGCHK <LENGTH .K> 2 PUTREST .NOD>
543 <SET T1 <EANA <1 .K> '<PRIMTYPE LIST> PUTREST>>
544 <SET T2 <EANA <2 .K> '<PRIMTYPE LIST> PUTREST>>
545 <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
546 <COMPILE-ERROR "Attempt to PUTREST in quoted object "
548 <PUT .NOD ,NODE-TYPE ,PUTR-CODE>
549 <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
550 <TYPE-OK? .T1 .RTYP>)>>
552 <COND (<GASSIGNED? PUTREST-ANA> <PUTPROP ,PUTREST ANALYSIS ,PUTREST-ANA>)>
554 <DEFINE MEMQ-ANA (N R "AUX" (K <KIDS .N>) TYP VTYP STYP ETY)
555 #DECL ((N) NODE (K) <LIST [REST NODE]>)
559 <ARGCHK <LENGTH .K> 2 MEMQ .N>
560 <SET VTYP <EANA <1 .K> ANY MEMQ>>
561 <SET TYP <EANA <2 .K> STRUCTURED MEMQ>>
562 <COND (<NOT <TYPE-OK? .VTYP <SET ETY <GET-ELE-TYPE .TYP ALL>>>>
563 <COMPILE-WARNING "MEMQ never true " .N>)>
564 <COND (<AND <SET STYP <STRUCTYP .TYP>> <N==? .STYP TEMPLATE>>
565 <PUT .N ,NODE-TYPE ,MEMQ-CODE>)
569 ("Not efficiently open compiled because type is: " .TYP)>)>
570 <PUT .N ,NODE-TYPE ,MEMQ-CODE>)>
571 <TYPE-OK? <TYPE-MERGE BOOL-FALSE
572 <COND (<AND .ETY <N==? .ETY ANY>>
573 <FORM <COND (.STYP) (STRUCTURED)>
576 (.STYP <FORM .STYP ANY>)
577 ('<STRUCTURED ANY>)>>
580 <DEFINE TOP-ANA (N R "AUX" (K <KIDS .N>))
581 #DECL ((N) NODE (K) <LIST [REST NODE]>)
582 <COND (<SEGFLUSH .N .R>)
584 <ARGCHK <LENGTH .K> 1 TOP .N>
585 <SET TYP <EANA <1 .K> STRUCTURED TOP>>
586 <COND (<AND <SET TYP <STRUCTYP .TYP>> <==? .TYP LIST>>
587 <COMPIL-ERROR "Cant TOP a list: " .N>)>
588 <PUT .N ,NODE-TYPE ,TOP-CODE>
589 <TYPE-OK? <COND (.TYP) (ELSE STRUCTURED)> .R>)>>
591 <DEFINE BACK-ANA (N R "AUX" (K <KIDS .N>))
592 #DECL ((N) NODE (K) <LIST [REST NODE]>)
593 <COND (<SEGFLUSH .N .R>)
595 <ARGCHK <LENGTH .K> '(1 2) BACK .N>
596 <SET TYP <EANA <1 .K> STRUCTURED TOP>>
597 <COND (<AND <SET TYP <STRUCTYP .TYP>> <==? .TYP LIST>>
598 <COMPIL-ERROR "Cant BACK a list: " .N>)>
599 <COND (<NOT <EMPTY? <REST .K>>> <EANA <2 .K> FIX BACK>)>
600 <PUT .N ,NODE-TYPE ,BACK-CODE>
601 <TYPE-OK? <COND (.TYP) (ELSE STRUCTURED)> .R>)>>
603 <COND (<GASSIGNED? BACK-ANA> <PUTPROP ,BACK ANALYSIS ,BACK-ANA>)>
605 <COND (<GASSIGNED? TOP-ANA> <PUTPROP ,TOP ANALYSIS ,TOP-ANA>)>
607 <COND (<GASSIGNED? MEMQ-ANA> <PUTPROP ,MEMQ ANALYSIS ,MEMQ-ANA>)>