4 <ENTRY ANA EANA SET-CURRENT-TYPE TYPE-NTH-REST WHO TMPS GET-TMP TRUTH UNTRUTH SEGFLUSH
5 KILL-REM BUILD-TYPE-LIST ANALYSIS GET-CURRENT-TYPE ADD-TYPE-LIST PUT-FLUSH WHON
6 SAVE-SURVIVORS SEQ-AN ARGCHK ASSUM-OK? FREST-L-D-STATE HTMPS ORUPC APPLTYP
7 MSAVE-L-D-STATE SHTMPS RESET-VARS STMPS ASSERT-TYPES SAVE-L-D-STATE
8 MUNG-L-D-STATE NORM-BAN SUBR-C-AN ENTROPY NAUX-BAN TUP-BAN ARGS-BAN
9 SPEC-FLUSH LIFE MANIFESTQ>
11 <USE "CHKDCL" "SUBRTY" "COMPDEC" "STRANA" "CARANA" "BITANA" "NOTANA" "ADVMESS" "MAPANA">
13 " This is the main file associated with the type analysis phase of
14 the compilation. It is called by calling FUNC-ANA with the main data structure
15 pointer. ANA is the FUNCTION that dispatches to the various special handlers
16 and the SUBR call analyzer further dispatches for specific functions."
18 " Many analyzers for specific SUBRs appear in their own files
19 (CARITH, STRUCT etc.). Currently no special hacks are done for TYPE?, EMPTY? etc.
20 in COND, ANDS and ORS."
22 " All analysis functions are called with 2 args, a NODE and a desired
23 type specification. These args are usually called NOD and RTYP or
26 " ANA is the main analysis dispatcher (see ANALYZERS at the end of
27 this file for its dispatch table."
29 <GDECL (TEMPLATES SUBRS) UVECTOR>
31 <DEFINE ANA (NOD RTYP "AUX" (P <PARENT .NOD>) TT TEM)
32 #DECL ((NOD) NODE (P) ANY (TEM TT) <OR FALSE LIST>)
33 <COND (<G=? <LENGTH .NOD> <INDEX ,SIDE-EFFECTS>>
34 <PUT .NOD ,SIDE-EFFECTS <>>)>
37 <APPLY <NTH ,ANALYZERS <NODE-TYPE .NOD>> .NOD .RTYP>>
38 <AND <N==? <NODE-TYPE .NOD> ,QUOTE-CODE>
39 <SET TEM <SIDE-EFFECTS .NOD>>
43 <COND (<EMPTY? .TEM> <SIDE-EFFECTS .P>)
44 (<EMPTY? <SET TT <SIDE-EFFECTS .P>>> .TEM)
45 (<OR <AND <TYPE? .TEM LIST>
53 <PUTREST <REST .TEM <- <LENGTH .TEM> 1>> .TT>
57 <DEFINE ARGCHK (GIV REQ NAME "AUX" (HI .REQ) (LO .REQ))
58 #DECL ((GIV) FIX (REQ HI LO) <OR <LIST FIX FIX> FIX>)
59 <COND (<TYPE? .REQ LIST>
63 <MESSAGE ERROR "TOO FEW ARGS TO " .NAME>)
65 <MESSAGE ERROR "TOO MANY ARGS TO " .NAME>)> T>
67 <DEFINE EANA (NOD RTYP NAME)
70 <MESSAGE ERROR "BAD ARGUMENT TO " .NAME .NOD>>>
72 " FUNC-ANA main entry to analysis phase. Analyzes bindings then body."
74 <DEFINE FUNC-ANA ANA-ACT (N R
76 <COND (<ASSIGNED? ANALY-OK> .ANALY-OK)
77 (ELSE T)>) (OV .VERBOSE))
78 #DECL ((ANA-ACT) <SPECIAL ACTIVATION> (ANALY-OK) <SPECIAL ANY>)
79 <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
82 <DEFINE FUNC-AN1 (FCN RTYP
83 "AUX" (VARTBL <SYMTAB .FCN>) (TMPS 0) (HTMPS 0) (TRUTH ())
84 (UNTRUTH ()) (WHO ()) (WHON <>) (PRED <>) TEM (LIFE ())
85 (USE-COUNT 0) (BACKTRACK 0))
86 #DECL ((FCN) <SPECIAL NODE> (VARTBL) <SPECIAL SYMTAB>
87 (TMPS BACKTRACK USE-COUNT HTMPS) <SPECIAL FIX>
88 (LIFE TRUTH UNTRUTH) <SPECIAL LIST>
89 (WHO PRED WHON) <SPECIAL ANY>)
91 <BIND-AN <BINDING-STRUCTURE .FCN>>
92 <OR <SET RTYP <TYPE-OK? .RTYP <INIT-DECL-TYPE .FCN>>>
93 <MESSAGE ERROR "FUNCTION RETURNS WRONG TYPE " <NODE-NAME .FCN>>>
94 <PROG ((ACT? <ACTIV? <BINDING-STRUCTURE .FCN> T>) (OV .VERBOSE))
95 <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
97 <PUT .FCN ,LIVE-VARS ()>
99 <PUT .FCN ,ASSUM <BUILD-TYPE-LIST .VARTBL>>
100 <PUT .FCN ,ACCUM-TYPE <COND (.ACT? .RTYP) (ELSE NO-RETURN)>>
101 <SET TEM <SEQ-AN <KIDS .FCN> <INIT-DECL-TYPE .FCN>>>
102 <COND (.ACT? <SPEC-FLUSH> <PUT-FLUSH ALL>)>
103 <OR <NOT <AGND .FCN>>
104 <ASSUM-OK? <ASSUM .FCN> <AGND .FCN>>
107 <PUT .FCN ,DEAD-VARS ()>
109 <MESSAGE ERROR " RETURNED VALUE VIOLATES VALUE DECL OF " .RTYP>>
110 <PUT .FCN ,RESULT-TYPE <TYPE-MERGE <ACCUM-TYPE .FCN> .TEM>>
111 <PUT <RSUBR-DECLS .FCN> 2 <TASTEFUL-DECL <RESULT-TYPE .FCN>>>
114 " BIND-AN analyze binding structure for PROGs, FUNCTIONs etc."
116 <DEFINE BIND-AN (BNDS "AUX" COD)
117 #DECL ((BNDS) <LIST [REST SYMTAB]> (COD) FIX)
120 <AND <EMPTY? .BNDS> <RETURN>>
121 <PUT <SET SYM <1 .BNDS>> ,COMPOSIT-TYPE ANY>
122 <PUT .SYM ,CURRENT-TYPE <>>
123 <APPLY <NTH ,BANALS <SET COD <CODE-SYM .SYM>>> .SYM>
124 <SET BNDS <REST .BNDS>>>>
126 " ENTROPY ignore call and return."
128 <DEFINE ENTROPY (SYM) T>
130 <DEFINE TUP-BAN (SYM) #DECL ((SYM) SYMTAB)
131 <COND (<NOT .ANALY-OK>
132 <PUT .SYM ,COMPOSIT-TYPE <1 <DECL-SYM .SYM>>>
133 <PUT .SYM ,CURRENT-TYPE ANY>)
134 (<N==? <ISTYPE? <1 <DECL-SYM .SYM>>> TUPLE>
135 <PUT .SYM ,COMPOSIT-TYPE TUPLE>
136 <PUT .SYM ,CURRENT-TYPE TUPLE>)
138 <PUT .SYM ,CURRENT-TYPE <1 <DECL-SYM .SYM>>>
139 <PUT .SYM ,COMPOSIT-TYPE <1 <DECL-SYM .SYM>>>)>>
141 " Analyze AUX and OPTIONAL intializations."
143 <DEFINE NORM-BAN (SYM "AUX" (VARTBL <NEXT-SYM .SYM>) TEM COD)
144 #DECL ((VARTBL) <SPECIAL SYMTAB> (SYM) SYMTAB (COD) FIX)
145 <OR <SET TEM <ANA <INIT-SYM .SYM> <1 <DECL-SYM .SYM>>>>
146 <MESSAGE ERROR "BAD AUX/OPT INIT " <NAME-SYM .SYM>
149 <RESULT-TYPE <INIT-SYM .SYM>>
150 <1 <DECL-SYM .SYM>>>>
151 <COND (<AND .ANALY-OK
152 <OR <G? <SET COD <CODE-SYM .SYM>> 9>
154 <COND (<NOT <SAME-DECL? .TEM <1 <DECL-SYM .SYM>>>>
155 <PUT .SYM ,CURRENT-TYPE .TEM>)>
156 <PUT .SYM ,COMPOSIT-TYPE .TEM>)
158 <PUT .SYM ,COMPOSIT-TYPE <1 <DECL-SYM .SYM>>>
159 <PUT .SYM ,CURRENT-TYPE <1 <DECL-SYM .SYM>>>)>>
161 " ARGS-BAN analyze ARGS decl (change to OPTIONAL in some cases)."
163 <DEFINE ARGS-BAN (SYM)
165 <PUT .SYM ,INIT-SYM <NODE1 ,QUOTE-CODE () LIST () ()>>
166 <PUT .SYM ,CODE-SYM 7>
167 <COND (.ANALY-OK <PUT .SYM ,COMPOSIT-TYPE LIST>)
168 (ELSE <PUT .SYM ,COMPOSIT-TYPE <1 <DECL-SYM .SYM>>>)>
169 <COND (<AND .ANALY-OK <NOT <SAME-DECL? LIST <1 <DECL-SYM .SYM>>>>>
170 <PUT .SYM ,CURRENT-TYPE LIST>)
171 (<NOT .ANALY-OK> <PUT .SYM ,CURRENT-TYPE ANY>)>>
173 <DEFINE NAUX-BAN (SYM)
175 <PUT .SYM ,COMPOSIT-TYPE
176 <COND (.ANALY-OK NO-RETURN) (ELSE <1 <DECL-SYM .SYM>>)>>
177 <PUT .SYM ,CURRENT-TYPE <COND (.ANALY-OK NO-RETURN)(ELSE ANY)>>>
179 " VECTOR of binding analyzers."
196 " SEQ-AN analyze a sequence of NODES discarding values until the last."
198 <DEFINE SEQ-AN (L FTYP "OPTIONAL" (INP <>))
199 #DECL ((L) <LIST [REST NODE]> (FTYP) ANY)
200 <COND (<EMPTY? .L> <MESSAGE INCONSISTENCY "EMPTY KIDS LIST ">)
204 <==? <NODE-TYPE <1 .L>> ,QUOTE-CODE>
205 <==? <RESULT-TYPE <1 .L>> ATOM>
206 <RESET-VARS .VARTBL>>
209 <COND (<EMPTY? <SET L <REST .L>>> .FTYP)
212 <COND (<==? .TT NO-RETURN>
213 <COND (<AND .VERBOSE <NOT <EMPTY? .L>>>
214 <ADDVMESS <PARENT .N>
215 ("This object ends a sequence of forms"
216 .N " because it never returns")>)>
218 <AND <EMPTY? .L> <RETURN .TT>>>)>>
220 " ANALYZE ASSIGNED? usage."
222 <DEFINE ASSIGNED?-ANA (NOD RTYP "AUX" (TEM <KIDS .NOD>) TT T1 T2)
223 #DECL ((TT NOD) NODE (T1) SYMTAB (TEM) <LIST [REST NODE]>)
224 <COND (<EMPTY? .TEM> <MESSAGE ERROR "NO ARGS ASSIGNED? " .NOD>)
225 (<SEGFLUSH .NOD .RTYP>)
227 <EANA <SET TT <1 .TEM>> ATOM ASSIGNED?>
228 <COND (<AND <EMPTY? <REST .TEM>>
229 <==? <NODE-TYPE .TT> ,QUOTE-CODE>
230 <SET T2 <SRCH-SYM <NODE-NAME .TT>>>
231 <NOT <==? <CODE-SYM <SET T1 .T2>> -1>>>
232 <PUT .NOD ,NODE-TYPE ,ASSIGNED?-CODE>
233 <PUT .NOD ,NODE-NAME .T1>
235 <PUT .T1 ,USED-AT-ALL T>
237 (<==? <LENGTH .TEM> 2>
238 <EANA <2 .TEM> '<OR <PRIMTYPE FRAME> PROCESS> ASSIGNED?>)
239 (<EMPTY? <REST .TEM>>
240 <COND (<AND .VERBOSE <==? <NODE-TYPE .TT> ,QUOTE-CODE>>
242 ("External reference to LVAL: "
244 <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)
245 (ELSE <MESSAGE ERROR "TOO MANY ARGS TO ASSIGNED?" .NOD>)>)>
246 <TYPE-OK? '<OR ATOM FALSE> .RTYP>>
248 <PUT ,ASSIGNED? ANALYSIS ,ASSIGNED?-ANA>
250 " ANALYZE LVAL usage. Become either direct reference or PUSHJ"
252 <DEFINE LVAL-ANA (NOD RTYP "AUX" TEM ITYP (TT <>) T1 T2 T3)
253 #DECL ((NOD) NODE (TEM) <LIST [REST NODE]> (T1) SYMTAB (WHO) LIST
256 (<EMPTY? <SET TEM <KIDS .NOD>>> <MESSAGE ERROR "NO ARGS TO LVAL " .NOD>)
257 (<SEGFLUSH .NOD .RTYP>)
258 (<AND <OR <AND <TYPE? <NODE-NAME .NOD> SYMTAB> <SET TT <NODE-NAME .NOD>>>
259 <AND <EANA <1 .TEM> ATOM LVAL>
261 <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>
262 <==? <RESULT-TYPE <1 .TEM>> ATOM>
263 <SET TT <SRCH-SYM <NODE-NAME <1 .TEM>>>>>>
264 <COND (<==? .WHON <PARENT .NOD>> <SET WHO ((<> .TT) !.WHO)>) (ELSE T)>
266 <SET ITYP <GET-CURRENT-TYPE .TT>>
268 <COND (<AND <==? .PRED <PARENT .NOD>>
269 <SET T2 <TYPE-OK? .ITYP FALSE>>
270 <SET T3 <TYPE-OK? .ITYP '<NOT FALSE>>>>
271 <SET TRUTH <ADD-TYPE-LIST .TT .T3 .TRUTH <>>>
272 <SET UNTRUTH <ADD-TYPE-LIST .TT .T2 .UNTRUTH <>>>)
274 <NOT <==? <CODE-SYM <SET T1 .TT>> -1>>>
275 <PUT .NOD ,NODE-TYPE ,LVAL-CODE>
276 <COND (<==? <USAGE-SYM .T1> 0>
277 <PUT .T1 ,USAGE-SYM <SET USE-COUNT <+ .USE-COUNT 1>>>)>
279 <PUT .T1 ,RET-AGAIN-ONLY <>>
280 <PUT .T1 ,USED-AT-ALL T>
281 <PUT .NOD ,NODE-NAME .T1>
282 <SET ITYP <TYPE-OK? .ITYP .RTYP>>
283 <AND .ITYP <SET-CURRENT-TYPE .T1 .ITYP>>
285 (<EMPTY? <REST .TEM>>
287 (<AND .VERBOSE <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>>
289 ("External variable being referenced: " <NODE-NAME <1 .TEM>>)>)>
290 <PUT .NOD ,NODE-TYPE ,FLVAL-CODE>
291 <AND .TT <PUT .NOD ,NODE-NAME <SET T1 .TT>>>
292 <COND (.TT <TYPE-OK? <1 <DECL-SYM .T1>> .RTYP>)
295 (<AND <==? <LENGTH .TEM> 2>
296 <EANA <2 .TEM> '<OR <PRIMTYPE FRAME> PROCESS> LVAL>>
298 (ELSE <MESSAGE ERROR "BAD CALL TO LVAL " .NOD>)>>
300 <PUT ,LVAL ANALYSIS ,LVAL-ANA>
302 " SET-ANA analyze uses of SET."
304 <DEFINE SET-ANA (NOD RTYP
305 "AUX" (TEM <KIDS .NOD>) (LN <LENGTH .TEM>) T1 T2 T11
306 (WHON .WHON) (PRED .PRED) OTYP T3 XX)
307 #DECL ((NOD) NODE (TEM) <LIST [REST NODE]> (LN) FIX (T1) SYMTAB
308 (WHON PRED) <SPECIAL ANY> (WHO) LIST)
309 <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
311 (<SEGFLUSH .NOD .RTYP>)
312 (<L? .LN 2> <MESSAGE ERROR "TOO FEW ARGS TO SET " .NOD>)
313 (<AND <OR <AND <TYPE? <NODE-NAME .NOD> SYMTAB> <SET T11 <NODE-NAME .NOD>>>
314 <AND <EANA <1 .TEM> ATOM SET>
316 <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>
317 <==? <RESULT-TYPE <1 .TEM>> ATOM>
318 <SET T11 <SRCH-SYM <NODE-NAME <1 .TEM>>>>>>
319 <COND (<==? .WHON <PARENT .NOD>>
321 <SET WHO ((T .T11) !.WHO)>)
323 <COND (<==? .PRED <PARENT .NOD>> <SET PRED .NOD>) (ELSE T)>
324 <OR <SET T2 <ANA <2 .TEM> <1 <DECL-SYM <SET T1 .T11>>>>>
325 <MESSAGE ERROR "DECL VIOLATION " <NAME-SYM .T1> .NOD>>>
326 <PUT .T1 ,PURE-SYM <>>
327 <SET XX <1 <DECL-SYM .T1>>>
328 <SET OTYP <OR <CURRENT-TYPE .T1> ANY>>
329 <COND (<AND <==? <CODE-SYM .T1> -1> .VERBOSE>
330 <ADDVMESS .NOD ("External variable being SET: " <NAME-SYM .T1>)>)>
331 <COND (<SET OTYP <TYPESAME .OTYP .T2>> <PUT .NOD ,TYPE-INFO (.OTYP <>)>)
332 (ELSE <PUT .NOD ,TYPE-INFO (<> <>)>)>
335 <COND (<==? <CODE-SYM .T1> -1> ,FSET-CODE) (ELSE ,SET-CODE)>>
336 <PUT .NOD ,NODE-NAME .T1>
338 <SET-CURRENT-TYPE .T1 .T2>
339 <PUT .T1 ,USED-AT-ALL T>
340 <COND (<AND <==? .PRED .NOD>
341 <SET OTYP <TYPE-OK? .T2 '<NOT FALSE>>>
342 <SET T3 <TYPE-OK? .T2 FALSE>>>
343 <SET TRUTH <ADD-TYPE-LIST .T1 .OTYP .TRUTH T>>
344 <SET UNTRUTH <ADD-TYPE-LIST .T1 .T3 .UNTRUTH T>>)>
345 <TYPE-OK? .T2 .RTYP>)
347 <SET T11 <ANA <2 .TEM> ANY>>
349 <COND (<AND .VERBOSE <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>>
351 ("External variable being SET: "
352 <NODE-NAME <1 .TEM>>)>)>
353 <PUT .NOD ,NODE-TYPE ,FSET-CODE>)
354 (ELSE <EANA <3 .TEM> '<OR <PRIMTYPE FRAME> PROCESS> SET>)>
355 <TYPE-OK? .T11 .RTYP>)
356 (ELSE <MESSAGE ERROR "BAD CALL TO SET " <NODE-NAME <1 .TEM>> .NOD>)>>
358 <PUT ,SET ANALYSIS ,SET-ANA>
360 <DEFINE MUNG-L-D-STATE (V) #DECL ((V) <OR VECTOR SYMTAB>)
361 <REPEAT () <COND (<TYPE? .V VECTOR> <RETURN>)>
362 <PUT .V ,DEATH-LIST ()>
363 <SET V <NEXT-SYM .V>>>>
365 <DEFINE MRESTORE-L-D-STATE (L1 L2 V)
366 <RESTORE-L-D-STATE .L1 .V>
367 <RESTORE-L-D-STATE .L2 .V T>>
369 <DEFINE FREST-L-D-STATE (L)
373 #DECL ((LL) <LIST SYMTAB <LIST [REST NODE]>>)
374 <COND (<NOT <2 <TYPE-INFO <1 <2 .LL>>>>>
375 <PUT <1 .LL> ,DEATH-LIST <2 .LL>>)>>
378 <DEFINE RESTORE-L-D-STATE (L V "OPTIONAL" (FLG <>))
379 #DECL ((L) <LIST [REST <LIST SYMTAB LIST>]> (V) <OR SYMTAB VECTOR>)
382 #DECL ((DL) <LIST [REST NODE]>)
383 <COND (<TYPE? .V VECTOR> <RETURN>)>
384 <COND (<AND <NOT <EMPTY? <SET DL <DEATH-LIST .V>>>>
385 <NOT <2 <TYPE-INFO <1 .DL>>>>>
386 <PUT .V ,DEATH-LIST ()>)>
387 <SET V <NEXT-SYM .V>>>>
389 #DECL ((DL) <LIST NODE> (S) SYMTAB)
390 <COND (<EMPTY? .L> <RETURN>)>
394 <COND (<==? .S .V> <RETURN>) (<TYPE? .V VECTOR> <RETURN>)>
400 <COND (<==? <NODE-TYPE .N> ,SET-CODE>
404 <SET V <NEXT-SYM .V>>>>
405 <COND (<NOT <2 <TYPE-INFO <1 <SET DL <2 <1 .L>>>>>>>
408 <COND (.FLG <LMERGE <DEATH-LIST .S> .DL>) (ELSE .DL)>>)>
411 <DEFINE SAVE-L-D-STATE (V)
412 #DECL ((V) <OR VECTOR SYMTAB>)
413 <REPEAT ((L (())) (LP .L) DL)
414 #DECL ((L LP) LIST (DL) <LIST [REST NODE]>)
415 <COND (<TYPE? .V VECTOR> <RETURN <REST .L>>)>
416 <COND (<AND <NOT <EMPTY? <SET DL <DEATH-LIST .V>>>>
417 <NOT <2 <CHTYPE <TYPE-INFO <1 .DL>> LIST>>>>
418 <SET LP <REST <PUTREST .LP ((.V .DL))>>>)>
419 <SET V <NEXT-SYM .V>>>>
421 <DEFINE MSAVE-L-D-STATE (L V)
422 #DECL ((V) <OR VECTOR SYMTAB> (L) LIST)
423 <REPEAT ((L (() !.L)) (LR .L) (LP <REST .L>) DL S TEM)
424 #DECL ((L LP LR TEM) LIST (S) SYMTAB (DL) <LIST [REST NODE]>)
426 <PUTREST .L <SAVE-L-D-STATE .V>>
428 (<TYPE? .V VECTOR> <RETURN <REST .LR>>)
429 (<AND <NOT <EMPTY? <SET DL <DEATH-LIST .V>>>>
430 <NOT <2 <TYPE-INFO <1 .DL>>>>>
431 <COND (<==? <SET S <1 <1 .LP>>> .V>
432 <SET TEM <LMERGE <2 <1 .LP>> .DL>>
434 <PUTREST .L <SET LP <REST .LP>>>)
437 <SET LP <REST <SET L .LP>>>)>)
439 <PUTREST .L <SET L ((.V .DL))>>
441 (<==? .V <1 <1 .LP>>> <SET LP <REST <SET L .LP>>>)>
442 <SET V <NEXT-SYM .V>>>>
444 <DEFINE LMERGE (L1 L2)
445 #DECL ((L1 L2) <LIST [REST NODE]>)
449 <COND (<OR <2 <TYPE-INFO .N>>
450 <AND <==? <NODE-TYPE .N> ,SET-CODE>
451 <NOT <MEMQ .N .L2>>>>
458 <COND (<OR <2 <TYPE-INFO .N>>
459 <==? <NODE-TYPE .N> ,SET-CODE>
464 <COND (<EMPTY? .L1> .L2)
465 (ELSE <PUTREST <REST .L1 <- <LENGTH .L1> 1>> .L2> .L1)>>
467 <DEFINE MAKE-DEAD (N SYM) #DECL ((N) NODE (SYM) SYMTAB)
468 <PUT .SYM ,DEATH-LIST (.N)>>
470 <DEFINE KILL-REM (L V)
471 #DECL ((L) <LIST [REST SYMTAB]> (V) <OR SYMTAB VECTOR>)
474 <COND (<TYPE? .V VECTOR> <RETURN .L1>)>
475 <COND (<AND <NOT <SPEC-SYM .V>>
476 <N==? <CODE-SYM .V> -1>
479 <SET V <NEXT-SYM .V>>>>
481 <DEFINE SAVE-SURVIVORS (LS LI "OPTIONAL" (FLG <>))
482 #DECL ((LS) <LIST [REST <LIST SYMTAB LIST>]> (LI) <LIST [REST SYMTAB]>)
485 <COND (<MEMQ <1 .LL> .LI>
489 <PUT <TYPE-INFO .N> 2 T>>
491 (.FLG <PUT <1 .LL> ,DEATH-LIST <2 .LL>>)>>
494 <DEFINE REVIVE (NOD SYM "AUX" (L <DEATH-LIST .SYM>))
495 #DECL ((L) <LIST [REST NODE]> (SYM) SYMTAB (NOD) NODE)
496 <COND (<AND <NOT <SPEC-SYM .SYM>> <N==? <CODE-SYM .SYM> -1>>
497 <COND (<EMPTY? .L> <SET LIFE (.SYM !.LIFE)>)
499 <MAPF <> <FUNCTION (N) #DECL ((N) NODE) <PUT <TYPE-INFO .N> 2 T>>
502 <PUT .SYM ,DEATH-LIST (.NOD)>
503 <PUT .NOD ,TYPE-INFO (<> <>)>)>>
505 " Ananlyze a FORM that could really be an NTH."
507 <DEFINE FORM-F-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (OBJ <NODE-NAME .NOD>) TYP)
508 #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
509 <COND (<==? <ISTYPE? <SET TYP <ANA <1 .K> APPLICABLE>>> FIX>
510 <PUT .NOD ,KIDS (<2 .K> <1 .K> !<REST .K 2>)>
511 <COND (<==? <LENGTH .K> 2>
512 <SET RTYP <NTH-REST-ANA .NOD .RTYP ,NTH-CODE .TYP>>)
514 <SET RTYP <PUT-ANA .NOD .RTYP ,PUT-CODE .TYP>>)>
515 <PUT .NOD ,NODE-SUBR <NODE-TYPE .NOD>>
517 <PUT .NOD ,NODE-NAME .OBJ>
518 <PUT .NOD ,NODE-TYPE ,FORM-F-CODE>
521 <SPECIALIZE <NODE-NAME .NOD>>
524 <PUT .NOD ,SIDE-EFFECTS (ALL)>
525 <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>)>>
527 " Further analyze a FORM."
529 <DEFINE FORM-AN (NOD RTYP)
531 <APPLY <OR <GET <NODE-SUBR .NOD> ANALYSIS>
532 <GET <TYPE <NODE-SUBR .NOD>> TANALYSIS>
537 <PUT .N ,SIDE-EFFECTS (ALL)>
538 <TYPE-OK? <RESULT-TYPE .N> .R>>>
542 "Determine if an ATOM is mainfest."
544 <DEFINE MANIFESTQ (ATM)
546 <AND <MANIFEST? .ATM>
548 <NOT <TYPE? ,.ATM SUBR>>
549 <NOT <TYPE? ,.ATM RSUBR>>>>
551 " Search for a decl associated with a local value."
553 <DEFINE SRCH-SYM (ATM "AUX" (TB .VARTBL))
554 #DECL ((ATM) ATOM (TB) <PRIMTYPE VECTOR>)
556 <AND <EMPTY? .TB> <RETURN <>>>
557 <AND <==? .ATM <NAME-SYM .TB>> <RETURN .TB>>
558 <SET TB <NEXT-SYM .TB>>>>
560 " Here to flush decls of specials for an external function call."
562 <DEFINE SPEC-FLUSH () <FLUSHER <>>>
564 " Here to flush decls when a PUT, PUTREST or external call happens."
566 <DEFINE PUT-FLUSH (TYP) <FLUSHER .TYP>>
568 <DEFINE FLUSHER (FLSFLG "AUX" (V .VARTBL))
569 #DECL ((SYM) SYMTAB (V) <OR SYMTAB VECTOR>)
575 (<AND <CURRENT-TYPE <SET SYM .V>>
576 <OR <AND <SPEC-SYM .SYM> <NOT .FLSFLG>>
578 <N==? <CURRENT-TYPE .V> NO-RETURN>
579 <TYPE-OK? <CURRENT-TYPE .V> STRUCTURED>
580 <OR <==? .FLSFLG ALL>
581 <NOT <SET TEM <STRUCTYP <CURRENT-TYPE .V>>>>
582 <==? .TEM .FLSFLG>>>>>
584 .SYM <FLUSH-FIX-TYPE .SYM <CURRENT-TYPE .SYM> .FLSFLG>>)>
585 <COND (<==? <USAGE-SYM .SYM> 0> <PUT .SYM ,USAGE-SYM <>>)>
586 <COND (<EMPTY? <SET V <NEXT-SYM .V>>> <RETURN>)>>)
590 <COND (<==? <USAGE-SYM <SET SYM .V>> 0> <PUT .SYM ,USAGE-SYM <>>)>
591 <COND (<EMPTY? <SET V <NEXT-SYM .V>>> <RETURN>)>>)>>
593 <DEFINE FLUSH-FIX-TYPE (SYM TY FLG "AUX" TEM)
596 <SET TEM <TOP-TYPE <TYPE-OK? .TY STRUCTURED>>>
597 <TYPE-OK? <COND (<SET TY <TYPE-OK? .TY '<NOT STRUCTURED>>>
598 <TYPE-MERGE .TEM .TY>)
600 <1 <DECL-SYM .SYM>>>>
601 <1 <DECL-SYM .SYM>>>>
604 " Punt forms with segments in them."
606 <DEFINE SEGFLUSH (NOD RTYP)
607 #DECL ((NOD) NODE (L) <LIST [REST NODE]>)
608 <COND (<REPEAT ((L <KIDS .NOD>))
609 <AND <EMPTY? .L> <RETURN <>>>
610 <AND <==? <NODE-TYPE <1 .L>> ,SEGMENT-CODE> <RETURN T>>
614 ("Not open compiled due to SEGMENT.")>)>
615 <SUBR-C-AN .NOD .RTYP>)>>
617 " STACKFORM analyzer."
619 <DEFINE STACKFORM-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) TEM STFTYP TT)
620 #DECL ((NOD TT) NODE (K) <LIST [REST NODE]>)
621 <MESSAGE WARNING "STACKFORM IS HAZARDOUS TO YOUR CODE!">
622 <PUT .NOD ,NODE-TYPE ,STACKFORM-CODE>
623 <ARGCHK <LENGTH .K> 3 STACKFORM>
624 <ANA <SET TT <1 .K>> ANY>
625 <SET STFTYP <APPLTYP .TT>>
627 <SET TEM <ANA <3 .K> ANY>>
628 <OR <TYPE-OK? .TEM FALSE>
629 <MESSAGE WARNING " STACKFORM CAN'T STOP " .NOD>>
630 <PUT .NOD ,SIDE-EFFECTS (ALL)>
633 <TYPE-OK? .STFTYP .RTYP>>
635 <PUT ,STACKFORM ANALYSIS ,STACKFORM-ANA>
637 " Determine if the arg to STACKFORM is a SUBR."
639 <DEFINE APPLTYP (NOD "AUX" (NT <NODE-TYPE .NOD>) ATM TT)
640 #DECL ((ATM) ATOM (NOD TT) NODE (NT) FIX)
641 <COND (<==? .NT ,GVAL-CODE> ;"<STACKFORM ,FOO ..."
642 <COND (<AND <==? <NODE-TYPE <SET TT <1 <KIDS .NOD>>>>
644 <GASSIGNED? <SET ATM <NODE-NAME .TT>>>
648 (ELSE ANY) ;"MAY TRY OTHERS LATER ">>
650 " Return type returned by a SUBR."
652 <DEFINE SUBR-TYPE (SUB "AUX" TMP)
654 <SET TMP <2 <GET-TMP .SUB>>>
655 <COND (<TYPE? .TMP ATOM FORM> .TMP) (ELSE ANY)>>
657 " Access the SUBR data base for return type."
659 <DEFINE GET-TMP (SUB "AUX" (LS <MEMQ .SUB ,SUBRS>))
660 #DECL ((VALUE) <LIST ANY ANY>)
661 <COND (.LS <NTH ,TEMPLATES <LENGTH .LS>>)
666 <DEFINE GVAL-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM TT TEM1)
667 #DECL ((NOD TEM) NODE (TT) <VECTOR VECTOR ATOM ANY> (LN) FIX)
668 <COND (<SEGFLUSH .NOD .RTYP>)
671 <PUT .NOD ,NODE-TYPE ,FGVAL-CODE>
672 <EANA <1 .K> ATOM GVAL>
673 <COND (<AND <==? <NODE-TYPE <SET TEM <1 .K>>> ,QUOTE-CODE>
674 <==? <RESULT-TYPE .TEM> ATOM>>
675 <PUT .NOD ,NODE-TYPE ,GVAL-CODE>
676 <COND (<MANIFEST? <SET TEM1 <NODE-NAME .TEM>>>
677 <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
678 <PUT .NOD ,NODE-NAME ,.TEM1>
680 <TYPE-OK? <GEN-DECL ,.TEM1> .RTYP>)
681 (<AND <GBOUND? .TEM1> <SET TEM1 <GET-DECL <GLOC .TEM1>>>>
682 <TYPE-OK? .TEM .RTYP>)
683 (ELSE <TYPE-OK? ANY .RTYP>)>)
684 (ELSE <TYPE-OK? ANY .RTYP>)>)>>
686 <PUT ,GVAL ANALYSIS ,GVAL-ANA>
688 " Analyze SETG usage."
690 <DEFINE SETG-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM TT T1 TTT)
691 #DECL ((NOD TEM) NODE (K) <LIST [REST NODE]> (LN) FIX (TT) VECTOR)
692 <COND (<SEGFLUSH .NOD .RTYP>)
695 <PUT .NOD ,NODE-TYPE ,FSETG-CODE>
696 <EANA <SET TEM <1 .K>> ATOM SETG>
697 <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
698 <COND (<==? <NODE-TYPE .TEM> ,QUOTE-CODE>
699 <AND <MANIFEST? <SET TTT <NODE-NAME .TEM>>>
701 "ATTEMPT TO SETG MANIFEST VARIABLE "
703 <PUT .NOD ,NODE-TYPE ,SETG-CODE>
704 <COND (<AND <GBOUND? .TTT>
705 <SET T1 <GET-DECL <GLOC .TTT>>>>
708 " GLOBAL DECL VIOLATION "
710 <TYPE-OK? .T1 .RTYP>)
712 <SET TTT <ANA <2 .K> ANY>>
713 <TYPE-OK? .TTT .RTYP>)>)
715 <SET TTT <ANA <2 .K> ANY>>
716 <TYPE-OK? .TTT .RTYP>)>)>>>
718 <PUT ,SETG ANALYSIS ,SETG-ANA>
720 <DEFINE BUILD-TYPE-LIST (V)
721 #DECL ((V) <OR VECTOR SYMTAB> (VALUE) LIST)
723 <REPEAT ((L (())) (LP .L) TEM)
725 <COND (<EMPTY? .V> <RETURN <REST .L>>)
726 (<N==? <CODE-SYM .V> -1>
727 <SET TEM <GET-CURRENT-TYPE .V>>
728 <SET LP <REST <PUTREST .LP ((.V .TEM T))>>>)>
729 <SET V <NEXT-SYM .V>>>) (ELSE ())>>
731 <DEFINE RESET-VARS (V "OPTIONAL" (VL '[]) (FLG <>))
732 #DECL ((V VL) <OR SYMTAB VECTOR>)
734 <COND (<==? .V .VL> <SET FLG T>)>
735 <COND (<EMPTY? .V> <RETURN>)
737 <PUT .V ,CURRENT-TYPE <>>
738 <PUT .V ,COMPOSIT-TYPE ANY>)>
739 <PUT .V ,USAGE-SYM 0>
740 <PUT .V ,DEATH-LIST ()>
741 <SET V <NEXT-SYM .V>>>>
743 <DEFINE GET-CURRENT-TYPE (SYM)
745 <OR <AND .ANALY-OK <CURRENT-TYPE .SYM>> <1 <DECL-SYM .SYM>>>>
747 <DEFINE SET-CURRENT-TYPE (SYM ITYP "AUX" (OTYP <1 <DECL-SYM .SYM>>))
749 <COND (<AND .ANALY-OK
750 <N==? <CODE-SYM .SYM> -1>
751 <NOT <SAME-DECL? <TYPE-AND .ITYP .OTYP> .OTYP>>>
752 <PUT .SYM ,CURRENT-TYPE .ITYP>
755 <TYPE-MERGE .ITYP <COMPOSIT-TYPE .SYM>>>)
757 <PUT .SYM ,CURRENT-TYPE <>>
758 <PUT .SYM ,COMPOSIT-TYPE .OTYP>)>>
761 #DECL ((V) <OR VECTOR SYMTAB> (L) <LIST [REST <LIST SYMTAB ANY ANY>]>)
763 <COND (<EMPTY? .V> <RETURN>)>
764 <COND (<CURRENT-TYPE .V>
765 <SET L <ADD-TYPE-LIST .V <CURRENT-TYPE .V> .L T>>)>
766 <SET V <NEXT-SYM .V>>>
769 <DEFINE ANDUP (FROM TO)
770 #DECL ((TO FROM) <LIST [REST <LIST SYMTAB ANY ANY>]>)
772 <FUNCTION (L) <SET TO <ADD-TYPE-LIST <1 .L> <2 .L> .TO T>>>
776 <DEFINE ORUPC (V L "AUX" WIN)
777 #DECL ((V) <OR VECTOR SYMTAB> (L) <LIST [REST <LIST SYMTAB ANY ANY>]>)
781 <COND (<TYPE? .V VECTOR> <RETURN>)>
784 <FUNCTION (LL) #DECL ((LL) <LIST SYMTAB <OR ATOM FORM SEGMENT> ANY>)
785 <COND (<==? <1 .LL> .V>
786 <PUT .LL 2 <TYPE-MERGE <2 .LL> <GET-CURRENT-TYPE .V>>>
788 <MAPLEAVE <SET WIN T>>)>>
790 <COND (<AND <NOT .WIN>
792 <SET L ((.V <1 <DECL-SYM .V>> T) !.L)>)>
793 <SET V <NEXT-SYM .V>>>)>
796 <DEFINE ORUP (FROM TO "AUX" NDECL)
797 #DECL ((TO FROM) <LIST [REST <LIST SYMTAB <OR ATOM FORM SEGMENT> <OR ATOM FALSE>>]>
798 (NDECL) <OR ATOM FORM SEGMENT>)
800 <FUNCTION (L "AUX" (SYM <1 .L>) (WIN <>))
803 <COND (<==? <1 .LL> .SYM>
804 <SET NDECL <TYPE-MERGE <2 .LL> <2 .L>>>
807 <MAPLEAVE <SET WIN T>>)>>
812 <TYPE-MERGE <GET-CURRENT-TYPE .SYM> <2 .L>>
818 <DEFINE ASSERT-TYPES (L)
819 #DECL ((L) <LIST [REST <LIST SYMTAB ANY ANY>]>)
821 <FUNCTION (LL) <SET-CURRENT-TYPE <1 .LL> <2 .LL>>>
824 <DEFINE ADD-TYPE-LIST (SYM NDECL INF MUNG
825 "OPTIONAL" (NTH-REST ())
826 "AUX" (WIN <>) (OD <GET-CURRENT-TYPE .SYM>))
827 #DECL ((SYM) SYMTAB (INF) LIST (NTH-REST) <LIST [REST ATOM FIX]>
828 (NDECL) <OR ATOM FALSE FORM SEGMENT> (MUNG) <OR ATOM FALSE>)
830 <SET NDECL <TYPE-NTH-REST .NDECL .NTH-REST>>
833 #DECL ((L) <LIST SYMTAB ANY>)
834 <COND (<==? <1 .L> .SYM>
836 <COND (.MUNG <TYPE-AND .NDECL .OD>)
837 (ELSE <TYPE-AND .NDECL <2 .L>>)>>
840 <MAPLEAVE <SET WIN T>>)>>
843 <SET NDECL <TYPE-AND .NDECL .OD>>
844 <SET INF ((.SYM .NDECL .MUNG) !.INF)>)>)>
847 <DEFINE TYPE-NTH-REST (NDECL NTH-REST) #DECL ((NTH-REST) <LIST [REST ATOM FIX]>)
848 <REPEAT ((FIRST T) (NUM 0))
850 <COND (<EMPTY? .NTH-REST> <RETURN .NDECL>)>
851 <COND (<==? <1 .NTH-REST> NTH>
855 <+ .NUM <2 .NTH-REST> -1>>>
862 (.FIRST <SET NDECL <REST-DECL .NDECL <2 .NTH-REST>>>)
863 (ELSE <SET NUM <+ .NUM <2 .NTH-REST>>>)>
864 <SET NTH-REST <REST .NTH-REST 2>>>>
866 " AND/OR analyzer. Called from AND-ANA and OR-ANA."
868 <DEFINE BOOL-AN (NOD RTYP ORER
869 "AUX" (L <KIDS .NOD>) FTYP FTY
871 <COND (<TYPE-OK? .RTYP FALSE> .RTYP)
872 (ELSE <FORM OR .RTYP FALSE>)>)
873 (FLG <==? .PRED <PARENT .NOD>>) (SINF ()) STR SUNT
874 (FIRST T) FNOK NFNOK PASS)
875 #DECL ((NOD) NODE (L) <LIST [REST NODE]> (ORER RTYP) ANY (FTYP) FORM
876 (STR SINF SUNT) LIST)
877 <PROG ((TRUTH ()) (UNTRUTH ()) (PRED .NOD) L-D)
878 #DECL ((TRUTH UNTRUTH) <SPECIAL LIST> (PRED) <SPECIAL ANY> (L-D) LIST)
880 (<EMPTY? .L> <SET FTYP <TYPE-OK? FALSE .RTYP>>)
885 "AUX" (LAST <EMPTY? <REST .N>>) TY)
886 #DECL ((N) <LIST NODE>)
887 <COND (<AND .LAST <NOT .FLG>> <SET PRED <>>)>
888 <SET TY <ANA <1 .N> <COND (.LAST .RTYP) (.ORER .RTY) (ELSE ANY)>>>
890 <OR <==? .TY NO-RETURN> <NOT <TYPE-OK? .TY FALSE>>>>
891 <SET NFNOK <==? FALSE <ISTYPE? .TY>>>
892 <SET PASS <COND (.ORER .NFNOK) (ELSE .FNOK)>>
895 <MESSAGE WARNING " OR/AND MAY RETURN WRONG TYPE " <1 .N>>)>
896 <COND (<COND (.ORER .FNOK) (ELSE .NFNOK)>
897 ;"This must end the AND/OR"
898 <COND (<AND .VERBOSE <NOT .LAST>>
900 ("This object prematurely ends AND/OR: "
901 <1 .N> " its type is: " .TY)>)>
903 <COND (<AND <N==? .TY NO-RETURN> <OR .LAST <NOT .PASS>>>
905 <SET L-D <SAVE-L-D-STATE .VARTBL>>
907 <ANDUP <COND (.ORER .TRUTH) (ELSE .UNTRUTH)>
908 <BUILD-TYPE-LIST .VARTBL>>>)
910 <SET L-D <MSAVE-L-D-STATE .L-D .VARTBL>>
912 <ORUP <COND (.ORER .TRUTH) (ELSE .UNTRUTH)>
913 <ORUPC .VARTBL .SINF>>>)>
915 <ASSERT-TYPES <COND (.ORER .UNTRUTH) (ELSE .TRUTH)>>
916 <SET TRUTH <SET UNTRUTH ()>>
917 <OR .FIRST <RESTORE-L-D-STATE .L-D .VARTBL>>
918 <COND (<==? .TY NO-RETURN>
921 "UNREACHABLE AND/OR CLAUSE "
930 (ELSE <BUILD-TYPE-LIST .VARTBL>)>>
932 <COND (.ORER <BUILD-TYPE-LIST .VARTBL>)
934 <ASSERT-TYPES <ORUPC .VARTBL .SINF>>
936 (<AND .ORER .NFNOK> <MAPRET>)
941 <COND (<AND .FNOK .ORER> <SET FTY <TYPE-OK? .FTY '<NOT FALSE>>>)>)>>
942 <COND (.FLG <SET TRUTH .STR> <SET UNTRUTH .SUNT>)>
945 <DEFINE AND-ANA (NOD RTYP)
947 <PUT .NOD ,NODE-TYPE ,AND-CODE>
948 <BOOL-AN .NOD .RTYP <>>>
950 <PUT ,AND ANALYSIS ,AND-ANA>
952 <DEFINE OR-ANA (NOD RTYP)
954 <PUT .NOD ,NODE-TYPE ,OR-CODE>
955 <BOOL-AN .NOD .RTYP T>>
957 <PUT ,OR ANALYSIS ,OR-ANA>
961 <DEFINE CASE-ANA (N R) <COND-CASE .N .R T>>
963 <DEFINE COND-ANA (N R) <COND-CASE .N .R <>>>
965 <DEFINE COND-CASE (NOD RTYP CASE?
966 "AUX" (L <KIDS .NOD>) (FIRST T) (LAST <>) TT FNOK NFNOK STR
967 SUNT (FIRST1 T) PRAT (DFLG <>) TST-TYP SVWHO)
968 #DECL ((NOD) NODE (L) <LIST [REST NODE]> (RTYP) ANY)
969 <PROG ((TRUTH ()) (UNTRUTH ()) (TINF1 ()) (TINF ()) L-D L-D1)
970 #DECL ((TRUTH UNTRUTH) <SPECIAL LIST> (TINF1 TINF L-D L-D1) LIST)
972 (<EMPTY? .L> <TYPE-OK? FALSE .RTYP>)
975 <SET PRAT <NODE-NAME <1 <KIDS <1 .L>>>>>
976 <PROG ((WHON .NOD) (WHO ()))
977 #DECL ((WHO) <SPECIAL LIST> (WHON) <SPECIAL NODE>)
978 <SET TST-TYP <EANA <2 .L> ANY CASE>>
980 <SET L <REST .L 2>>)>
983 <FUNCTION (BRN "AUX" (BR <1 .BRN>) (PRED .BR) (EC T))
984 #DECL ((BRN) <LIST NODE> (BR) NODE (PRED) <SPECIAL
986 <COND (<AND .CASE? <==? <NODE-TYPE .BR> ,QUOTE-CODE> <SET DFLG T>>
988 <OR <PREDIC .BR> <MESSAGE ERROR "EMPTY COND CLAUSE " .BR>>
989 <SET UNTRUTH <SET TRUTH ()>>
990 <SET LAST <EMPTY? <REST .BRN>>>
992 <COND (<NOT <EMPTY? <CLAUSES .BR>>> <SET EC <>> ANY)
994 (ELSE <TYPE-MERGE .RTYP FALSE>)>>
997 <SPEC-ANA <NODE-NAME <CHTYPE <PREDIC .BR> NODE>>
1004 (ELSE <ANA <PREDIC .BR> .TT>)>>
1005 <SET DFLG <SET PRED <>>>
1006 <SET FNOK <OR <==? .TT NO-RETURN> <NOT <TYPE-OK? .TT FALSE>>>>
1007 <SET NFNOK <==? <ISTYPE? .TT> FALSE>>
1014 ("Cond predicate always FALSE: "
1016 !<COND (<EMPTY? <CLAUSES .BR>> ())
1017 (ELSE (" and non-reachable code in clause."))>)>)>
1019 (<AND .FNOK <NOT .LAST>>
1022 ("Cond ended prematurely because predicate always true: "
1026 <COND (<NOT <OR .FNOK <AND <NOT .LAST> .NFNOK>>>
1027 <SET L-D <SAVE-L-D-STATE .VARTBL>>
1029 <SET TINF <ANDUP .UNTRUTH <BUILD-TYPE-LIST .VARTBL>>>)
1031 <SET TINF <ANDUP .UNTRUTH <ORUPC .VARTBL .TINF>>>)>
1032 <ASSERT-TYPES .TRUTH>
1035 <OR .EC <SET TT <SEQ-AN <CLAUSES .BR> .RTYP>>>
1036 <COND (<N==? .TT NO-RETURN>
1038 <SET TINF1 <BUILD-TYPE-LIST .VARTBL>>
1039 <SET L-D1 <SAVE-L-D-STATE .VARTBL>>)
1041 <SET TINF1 <ORUPC .VARTBL .TINF1>>
1042 <SET L-D1 <MSAVE-L-D-STATE .L-D1 .VARTBL>>)>
1044 <OR .FIRST <RESTORE-L-D-STATE .L-D .VARTBL>>
1046 <AND <NOT .FNOK> <SET TT <TYPE-MERGE .TT FALSE>>>)
1047 (.EC <SET TT <TYPE-OK? .TT '<NOT FALSE>>>)>)
1048 (.NFNOK <SET TT FALSE>)>
1049 <COND (<OR .LAST .FNOK>
1051 <ASSERT-TYPES .TINF1>
1052 <OR .FIRST1 <RESTORE-L-D-STATE .L-D1 .VARTBL>>)
1055 <ASSERT-TYPES .TINF>
1056 <OR .FIRST <RESTORE-L-D-STATE .L-D .VARTBL>>)
1058 <ASSERT-TYPES <ORUP .TINF .TINF1>>
1059 <MRESTORE-L-D-STATE .L-D1 .L-D .VARTBL>)>)>
1061 (ELSE <ASSERT-TYPES .TINF> .TT)>>
1066 <DEFINE SPEC-ANA (CONST PRED-NAME OTYPE RTYP DFLG NOD WHO "AUX" TEM PAT)
1069 <COND (<TYPE? .CONST LIST>
1070 <COND (<==? .PRED-NAME ==?> <GEN-DECL <1 .CONST>>)
1071 (<==? .PRED-NAME TYPE?> <TYPE-MERGE !.CONST>)
1074 <FUNCTION (X) <FORM PRIMTYPE .X>>
1077 <COND (<==? .PRED-NAME ==?> <GEN-DECL .CONST>)
1078 (<==? .PRED-NAME TYPE?> .CONST)
1079 (ELSE <FORM PRIMTYPE .CONST>)>)>>
1081 <PUT .NOD ,RESULT-TYPE <SET TEM <TYPE-OK? ATOM .RTYP>>>
1084 <COND (<AND <N==? .PRED-NAME ==?>
1086 <NOT <TYPE-OK? <FORM NOT .PAT> .OTYPE>>>
1088 (<TYPE-OK? .OTYPE .PAT> <SET TEM '<OR FALSE ATOM>>)
1089 (ELSE <SET TEM FALSE>)>
1091 <FUNCTION (L "AUX" (FLG <1 .L>) (SYM <2 .L>))
1092 #DECL ((L) <LIST <OR ATOM FALSE> SYMTAB>
1109 <PUT .NOD ,RESULT-TYPE <SET TEM <TYPE-OK? .TEM .RTYP>>>
1112 " PROG/REPEAT analyzer. Hacks bindings and sets up info for GO/RETURN/AGAIN
1115 <DEFINE PRG-REP-ANA (PPNOD PRTYP
1116 "AUX" (OV .VARTBL) (VARTBL <SYMTAB .PPNOD>) TT L-D
1117 (OPN <AND <ASSIGNED? PNOD> .PNOD>) PNOD)
1118 #DECL ((PNOD) <SPECIAL NODE> (VARTBL) <SPECIAL SYMTAB> (OV) SYMTAB (L-D) LIST
1120 <COND (<N==? <NODE-SUBR .PPNOD> ,BIND> <SET PNOD .PPNOD>)
1121 (.OPN <SET PNOD .OPN>)>
1122 <PROG ((TMPS 0) (HTMPS 0) (ACT? <ACTIV? <BINDING-STRUCTURE .PPNOD> T>))
1123 #DECL ((TMPS HTMPS) <SPECIAL FIX>)
1124 <BIND-AN <BINDING-STRUCTURE .PPNOD>>
1125 <SET L-D <SAVE-L-D-STATE .VARTBL>>
1126 <RESET-VARS .VARTBL .OV T>
1127 <OR <SET PRTYP <TYPE-OK? .PRTYP <INIT-DECL-TYPE .PPNOD>>>
1128 <MESSAGE ERROR "PROG RETURNS WRONG TYPE ">>
1129 <PUT .PPNOD ,RESULT-TYPE .PRTYP>
1130 <PROG ((STMPS .TMPS) (SHTMPS .HTMPS) (LL .LIFE) (OV .VERBOSE))
1131 #DECL ((STMPS SHTMPS) FIX (LL LIFE) LIST)
1132 <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
1133 <MUNG-L-D-STATE .VARTBL>
1135 <PUT .PPNOD ,AGND <>>
1136 <PUT .PPNOD ,DEAD-VARS ()>
1137 <PUT .PPNOD ,VSPCD ()>
1138 <PUT .PPNOD ,LIVE-VARS ()>
1141 <PUT .PPNOD ,ASSUM <BUILD-TYPE-LIST .VARTBL>>
1142 <PUT .PPNOD ,ACCUM-TYPE NO-RETURN>
1144 <SEQ-AN <KIDS .PPNOD>
1145 <COND (<N==? <NODE-SUBR .PPNOD> ,REPEAT> .PRTYP)
1150 <OR <AND <N==? <NODE-SUBR .PPNOD> ,REPEAT> <NOT <AGND .PPNOD>>>
1153 <COND (<N==? <NODE-SUBR .PPNOD> ,REPEAT> <AGND .PPNOD>)
1155 <ORUPC .VARTBL <CHTYPE <AGND .PPNOD> LIST>>)
1156 (ELSE <BUILD-TYPE-LIST .VARTBL>)>>
1158 <COND (<==? <NODE-SUBR .PPNOD> ,REPEAT>
1159 <COND (<AGND .PPNOD>
1162 <MSAVE-L-D-STATE <LIVE-VARS .PPNOD> .VARTBL>>)
1163 (ELSE <PUT .PPNOD ,LIVE-VARS <SAVE-L-D-STATE .VARTBL>>)>)>
1164 <SAVE-SURVIVORS .L-D .LIFE T>
1165 <SAVE-SURVIVORS <LIVE-VARS .PPNOD> .LIFE>
1167 <MESSAGE " ERROR PROG VALUE VIOLATES VALUE DECL OF "
1170 <COND (<NOT <OR <==? .TT NO-RETURN> <==? <NODE-SUBR .PPNOD> ,REPEAT>>>
1173 <MSAVE-L-D-STATE <DEAD-VARS .PPNOD> .VARTBL>>
1174 <COND (<N==? <ACCUM-TYPE .PPNOD> NO-RETURN>
1175 <ASSERT-TYPES <ORUPC .VARTBL <VSPCD .PPNOD>>>)>)
1176 (<N==? <ACCUM-TYPE .PPNOD> NO-RETURN>
1177 <ASSERT-TYPES <VSPCD .PPNOD>>)>
1178 <FREST-L-D-STATE <DEAD-VARS .PPNOD>>
1179 <SET LIFE <KILL-REM .LIFE .OV>>
1182 <COND (.ACT? <PUT .PPNOD ,SIDE-EFFECTS (ALL)> .PRTYP)
1183 (<==? <NODE-SUBR .PPNOD> ,REPEAT> <ACCUM-TYPE .PPNOD>)
1184 (ELSE <TYPE-MERGE .TT <ACCUM-TYPE .PPNOD>>)>>>
1185 <ACCUM-TYPE .PPNOD>>
1187 " Determine if assumptions made for this loop are still valid."
1189 <DEFINE ASSUM-OK? (AS TY "AUX" (OK? T))
1190 #DECL ((TY AS) <LIST [REST <LIST SYMTAB ANY ANY>]>)
1194 <FUNCTION (L "AUX" (SYM <1 .L>) (TT <>))
1195 #DECL ((L) <LIST SYMTAB <OR ATOM FORM SEGMENT>>)
1200 <COND (<AND <SET TT <==? <1 .LL> .SYM>>
1201 <N=? <2 .L> <2 .LL>>
1202 <OR <==? <2 .L> NO-RETURN>
1203 <TYPE-OK? <2 .LL> <NOTIFY <2 .L>>>>>
1204 <COND (.OK? <SET BACKTRACK <+ .BACKTRACK 1>>)>
1206 <AND <GASSIGNED? DEBUGSW>
1208 <PRIN1 <NAME-SYM .SYM>>
1209 <PRINC " NOT OK current type: ">
1211 <PRINC " assumed type: ">
1215 <PUT .L 2 <TYPE-MERGE <2 .LL> <2 .L>>>
1219 <COND (<NOT .OK?> <ASSERT-TYPES .AS>)>)>
1223 <COND (<AND <TYPE? .D FORM> <==? <LENGTH .D> 2> <==? <1 .D> NOT>>
1225 (ELSE <FORM NOT .D>)>>
1227 " Analyze RETURN from a PROG/REPEAT. Check with PROGs final type."
1229 <DEFINE RETURN-ANA (NOD RTYP "AUX" (TT <KIDS .NOD>) N (LN <LENGTH .TT>) TEM)
1230 #DECL ((NOD) NODE (TT) <LIST [REST NODE]> (LN) FIX (N) <OR NODE FALSE>)
1232 <MESSAGE ERROR "TOO MANY ARGS TO RETURN " .NOD>)
1233 (<OR <AND <==? .LN 2> <SET N <ACT-CHECK <2 .TT>>>>
1234 <AND <L=? .LN 1> <SET N <PROGCHK RETURN>>>>
1235 <SET N <CHTYPE .N NODE>>
1239 <SET TT (<NODE1 ,QUOTE-CODE .NOD ATOM T ()>)>>>
1240 <SET TEM <EANA <1 .TT> <INIT-DECL-TYPE .N> RETURN>>
1241 <COND (<==? <ACCUM-TYPE .N> NO-RETURN>
1242 <PUT .N ,VSPCD <BUILD-TYPE-LIST <SYMTAB .N>>>
1243 <PUT .N ,DEAD-VARS <SAVE-L-D-STATE .VARTBL>>)
1245 <PUT .N ,VSPCD <ORUPC <SYMTAB .N> <VSPCD .N>>>
1248 <MSAVE-L-D-STATE <DEAD-VARS .N> .VARTBL>>)>
1249 <PUT .N ,ACCUM-TYPE <TYPE-MERGE .TEM <ACCUM-TYPE .N>>>
1250 <PUT .NOD ,NODE-TYPE ,RETURN-CODE>
1252 (ELSE <SUBR-C-AN .NOD ANY>)>>
1254 <PUT ,RETURN ANALYSIS ,RETURN-ANA>
1256 <DEFINE ACT-CHECK (N "AUX" SYM RAO N1)
1257 #DECL ((N N1) NODE (SYM) <OR SYMTAB FALSE> (RAO VALUE) <OR FALSE NODE>)
1258 <COND (<OR <AND <==? <NODE-TYPE .N> ,LVAL-CODE>
1259 <TYPE? <NODE-NAME .N> SYMTAB>
1260 <PURE-SYM <SET SYM <NODE-NAME .N>>>
1261 <==? <CODE-SYM .SYM> 1>>
1262 <AND <==? <NODE-TYPE .N> ,SUBR-CODE>
1263 <==? <NODE-SUBR .N> ,LVAL>
1264 <==? <LENGTH <KIDS .N>> 1>
1265 <==? <NODE-TYPE <SET N1 <1 <KIDS .N>>>> ,QUOTE-CODE>
1266 <TYPE? <NODE-NAME .N1> ATOM>
1267 <SET SYM <SRCH-SYM <NODE-NAME .N1>>>
1269 <==? <CODE-SYM .SYM> 1>>>
1270 <SET RAO <RET-AGAIN-ONLY <CHTYPE .SYM SYMTAB>>>
1271 <EANA .N ACTIVATION AGAIN-RETURN>
1272 <PUT <CHTYPE .SYM SYMTAB> ,RET-AGAIN-ONLY .RAO>
1277 <DEFINE AGAIN-ANA (NOD RTYP "AUX" (TEM <KIDS .NOD>) N)
1278 #DECL ((NOD) NODE (TEM) <LIST [REST NODE]> (N) <OR FALSE NODE>)
1279 <COND (<OR <AND <EMPTY? .TEM> <SET N <PROGCHK AGAIN>>>
1280 <AND <EMPTY? <REST .TEM>> <SET N <ACT-CHECK <1 .TEM>>>>>
1281 <PUT .NOD ,NODE-TYPE ,AGAIN-CODE>
1282 <SET N <CHTYPE .N NODE>>
1285 <MSAVE-L-D-STATE <LIVE-VARS .N> .VARTBL>>)
1286 (ELSE <PUT .N ,LIVE-VARS <SAVE-L-D-STATE .VARTBL>>)>
1289 <COND (<NOT <AGND .N>> <BUILD-TYPE-LIST <SYMTAB .N>>)
1290 (ELSE <ORUPC <SYMTAB .N> <AGND .N>>)>>
1292 (<EMPTY? <REST .TEM>>
1293 <OR <ANA <1 .TEM> ACTIVATION>
1294 <MESSAGE ERROR "WRONG TYPE FOR AGAIN " .NOD>>
1296 (ELSE <MESSAGE ERROR "TOO MANY ARGS TO AGAIN " .NOD>)>>
1298 <PUT ,AGAIN ANALYSIS ,AGAIN-ANA>
1300 " Analyze losing GOs."
1302 <DEFINE GO-ANA (NOD RTYP "AUX" (TEM <KIDS .NOD>) N RT)
1303 #DECL ((NOD N) NODE (TEM) <LIST [REST NODE]>)
1304 <MESSAGE WARGINING "GO/TAG NOT REALLY SUPPORTED.">
1305 <COND (<1? <LENGTH .TEM>>
1306 <SET RT <EANA <SET N <1 .TEM>> '<OR TAG ATOM> GO>>
1307 <COND (<OR <AND <==? <NODE-TYPE .N> ,QUOTE-CODE>
1311 <AND <==? .RT ATOM> .ANALY-OK
1312 <PROG () <SET ANALY-OK <>> <AGAIN .ANA-ACT>>>
1313 <PUT .NOD ,NODE-TYPE ,GO-CODE> NO-RETURN)
1314 (ELSE <MESSAGE ERROR "BAD ARG TO GO " .NOD>)>)
1315 (ELSE <MESSAGE ERROR "WRONG NO. OF ARGS TO GO " .NOD>)>>
1317 <PUT ,GO ANALYSIS ,GO-ANA>
1319 <DEFINE TAG-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) N)
1320 #DECL ((PNOD N NOD) NODE (K) <LIST [REST NODE]>)
1321 <MESSAGE WARGINING "GO/TAG NOT REALLY SUPPORTED.">
1322 <COND (<1? <LENGTH .K>>
1324 <AND .ANALY-OK <PROG () <SET ANALY-OK <>> <AGAIN .ANA-ACT>>>
1325 <PUT .PNOD ,ACTIVATED T>
1326 <EANA <SET N <1 .K>> ATOM TAG>
1327 <COND (<AND <==? <NODE-TYPE .N> ,QUOTE-CODE>
1328 <==? <RESULT-TYPE .N> ATOM>>
1329 <PUT .NOD ,NODE-TYPE ,TAG-CODE> TAG)
1330 (ELSE <MESSAGE ERROR "BAD ARG TO TAG " .NOD>)>)>>
1332 <PUT ,TAG ANALYSIS ,TAG-ANA>
1334 " If not in PROG/REPEAT complain about NAME."
1336 <DEFINE PROGCHK (NAME)
1337 <OR <ASSIGNED? PNOD>
1338 <MESSAGE ERROR "NOT IN PROG/REPEAT " .NAME>>
1341 " Dispatch to special handlers for SUBRs. Or use standard."
1343 <DEFINE SUBR-ANA (NOD RTYP)
1345 <APPLY <GET <NODE-SUBR .NOD> ANALYSIS ',SUBR-C-AN>
1349 " Hairy SUBR call analyzer. Also looks for internal calls."
1351 <DEFINE SUBR-C-AN (NOD RTYP
1352 "AUX" (ARGS 0) (TYP ANY)
1353 (TMPL <GET-TMP <NODE-SUBR .NOD>>) (NRGS1 <1 .TMPL>)
1355 <COND (<AND <G? <LENGTH .TMPL> 4>
1356 <NOT <==? <4 .TMPL> STACK>>>
1358 #DECL ((NOD) <SPECIAL NODE> (ARGS) <SPECIAL FIX>
1359 (TYP NRGS1 ARGACS) <SPECIAL ANY> (TMPL) <SPECIAL LIST>)
1361 <FUNCTION ("TUPLE" T "AUX" NARGS (TL <LENGTH .TMPL>) TEM (NARGS1 .NRGS1) (N .NOD)
1362 (TPL .TMPL) (RGS .ARGS))
1363 #DECL ((T) TUPLE (ARGS RGS TL) FIX
1364 (TMPL TPL) <LIST ANY ANY [REST LIST ANY ANY ANY]> (N NOD) NODE
1365 (NARGS) <LIST FIX FIX>)
1371 <COND (<TYPE? .TYP ATOM FORM>) (ELSE <SET TYP ANY>)>
1372 <COND (<AND <G? .TL 2> <NOT .ARGACS>>
1373 <PUT .N ,NODE-TYPE ,ISUBR-CODE>)>)
1376 (<TYPE? .NARGS1 FIX>
1377 <ARGCHK .RGS .NARGS1 <NODE-NAME .N>>)
1378 (<TYPE? .NARGS1 LIST>
1379 <AND <G? .RGS <2 <SET NARGS .NARGS1>>>
1380 <MESSAGE ERROR " TOO MANY ARGS TO " <NODE-NAME .N> .N>>
1381 <AND <L? .RGS <1 .NARGS>>
1382 <MESSAGE ERROR " TOO FEW ARGS TO " <NODE-NAME .N> .N>>
1384 <G? .RGS <+ <1 .NARGS> <LENGTH <3 .TPL>>>>
1385 <SET TL 0>> ;"Dont handle funny calls to things like LLOC."
1386 <COND (<AND <L? .RGS <2 .NARGS>> <G? .TL 2>>
1387 ;"For funny cases like LLOC."
1396 <REST <3 .TPL> <- .RGS <1 .NARGS>>>>>
1397 <SET RGS <2 .NARGS>>
1398 <COND (<EMPTY? <KIDS .N>> <PUT .N ,KIDS .TEM>)
1400 <PUTREST <REST <KIDS .N> <- <LENGTH <KIDS .N>> 1>>
1402 <COND (<TYPE? .TYP ATOM FORM>)
1403 (ELSE <SET TYP <APPLY .TYP !.T>>)>
1404 <COND (<G? .TL 2> ;"Short call exists?."
1405 <OR <==? <4 .TPL> STACK> <SET RGS 0>>
1406 <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
1408 <FUNCTION (N "AUX" TYP)
1409 #DECL ((N NOD) NODE (ARGS) FIX (ARGACS) <PRIMTYPE LIST>)
1410 <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE>
1411 <EANA <1 <KIDS .N>> STRUCTURED SEGMENT>
1415 <SET ARGS <+ .ARGS 1>>
1416 <SET TYP <ANA .N ANY>>
1417 <COND (<AND <NOT <SEGS .NOD>> .ARGACS <NOT <EMPTY? .ARGACS>>>
1418 <SET ARGACS <REST .ARGACS>>)>
1421 <PUT .NOD ,SIDE-EFFECTS (ALL)>
1422 <PUT .NOD ,STACKS <* .ARGS 2>>
1423 <TYPE-OK? .TYP .RTYP>>
1425 <DEFINE SEGMENT-ANA (NOD RTYP) <MESSAGE ERROR "ILLEGAL SEGMENT " .NOD>>
1427 " Analyze VECTOR, UVECTOR and LIST builders."
1429 <DEFINE COPY-AN (NOD RTYP
1430 "AUX" (ARGS 0) (RT <ISTYPE? <RESULT-TYPE .NOD>>) (K <KIDS .NOD>) N
1431 (LWIN <==? .RT LIST>) NN COD)
1432 #DECL ((NOD N) NODE (ARGS) FIX (K) <LIST [REST NODE]>)
1435 <REPEAT (DC STY PTY TEM TT (SG <>) (FRM <FORM .RT>)
1436 (FRME <CHTYPE .FRM LIST>) (GOTDC <>))
1437 #DECL ((FRM) FORM (FRME) <LIST ANY>)
1439 <COND (<==? .RT LIST>
1441 <COND (<EMPTY? <REST .FRM>> <1 .FRM>)
1443 <COND (.DC <PUTREST .FRME ([REST .DC])>)
1444 (.STY <PUTREST .FRME ([REST .STY])>)
1445 (.PTY <PUTREST .FRME ([REST <FORM PRIMTYPE .PTY>])>)>
1446 <RETURN <SET RT .FRM>>)
1447 (<OR <==? <SET COD <NODE-TYPE <SET N <1 .K>>>> ,SEGMENT-CODE>
1448 <==? .COD ,SEG-CODE>>
1450 <GET-ELE-TYPE <EANA <1 <KIDS .N>> STRUCTURED SEGMENT>
1453 <COND (<NOT .SG> <SET GOTDC <>>)>
1456 <MEMQ <STRUCTYP <RESULT-TYPE <1 <KIDS .N>>>>
1457 '![LIST VECTOR UVECTOR TUPLE!]>>)
1458 (ELSE <SET LWIN <>>)>)
1459 (ELSE <SET ARGS <+ .ARGS 2>> <SET TEM <ANA .N ANY>>)>
1463 <COND (<SET STY <ISTYPE? <SET DC .TEM>>>
1465 (<OR <NOT .DC> <N==? .DC .TEM>>
1467 <COND (<OR <N==? <SET TT <ISTYPE? .TEM>> .STY> <NOT .STY>>
1470 <==? .PTY <AND .TT <TYPEPRIM .TT>>>>)
1471 (ELSE <SET PTY <>>)>)>)>
1472 <COND (<NOT .SG> <SET FRME <REST <PUTREST .FRME (.TEM)>>>)>
1473 <SET K <REST .K>>>)>
1474 <PUT .NOD ,RESULT-TYPE .RT>
1475 <PUT .NOD ,STACKS .ARGS>
1477 (<AND <GASSIGNED? COPY-LIST-CODE> .LWIN>
1481 <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE>
1482 <PUT .N ,NODE-TYPE ,SEG-CODE>)>>
1484 <COND (<AND <==? <LENGTH <SET K <KIDS .NOD>>> 1>
1485 <==? <NODE-TYPE <1 .K>> ,SEG-CODE>
1486 <==? <STRUCTYP <RESULT-TYPE <SET NN <1 <KIDS <1 .K>>>>>> LIST>>
1487 <COND (<NOT <EMPTY? <PARENT .NOD>>>
1489 <FUNCTION (L "AUX" (N <1 .L>))
1490 #DECL ((N) NODE (L) <LIST [REST NODE]>)
1491 <COND (<==? .NOD .N>
1494 <KIDS <CHTYPE <PARENT .NOD> NODE>>>)>
1495 <PUT .NN ,PARENT <CHTYPE <PARENT .NOD> NODE>>
1496 <SET RT <RESULT-TYPE .NN>>)
1497 (ELSE <PUT .NOD ,NODE-TYPE ,COPY-LIST-CODE>)>)
1502 <COND (<==? <NODE-TYPE .N> ,SEG-CODE>
1503 <PUT .N ,NODE-TYPE ,SEGMENT-CODE>)>>
1505 <PUT .NOD ,NODE-TYPE ,COPY-CODE>)>
1506 <TYPE-OK? .RT .RTYP>>
1508 " Analyze quoted objects, for structures hack type specs."
1510 <DEFINE QUOTE-ANA (NOD RTYP)
1512 <TYPE-OK? <GEN-DECL <NODE-NAME .NOD>> .RTYP>>
1514 <DEFINE QUOTE-ANA2 (NOD RTYP)
1516 <COND (<1? <LENGTH <KIDS .NOD>>>
1517 <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
1518 <PUT .NOD ,NODE-NAME <1 <KIDS .NOD>>>
1520 <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>)
1521 (ELSE <MESSAGE ERROR "BAD CALL TO QUOTE ">)>>
1523 <PUT ,QUOTE ANALYSIS ,QUOTE-ANA2>
1525 <DEFINE IRSUBR-ANA (NOD RTYP)
1526 <RSUBRC-ANA .NOD .RTYP <>>>
1528 " Analyze a call to an RSUBR."
1530 <DEFINE RSUBR-ANA (NOD RTYP "AUX" ACST RN)
1531 #DECL ((NOD RN FCN) NODE)
1532 <COND (<AND <TYPE? <NODE-SUBR .NOD> FUNCTION>
1533 <SET ACST <ACS <SET RN <GET <NODE-NAME .NOD> .IND>>>>
1534 <OR <ASSIGNED? GROUP-NAME> <==? .FCN .RN>>>
1535 <RSUBRC-ANA .NOD .RTYP .ACST>)
1536 (ELSE <RSUBRC-ANA .NOD .RTYP <>>)>>
1538 <DEFINE RSUBRC-ANA (NOD RTYP ACST "AUX" (ARGS 0))
1539 #DECL ((NOD N) NODE (ACST) <PRIMTYPE LIST> (ARGS) FIX)
1540 <AND <=? .ACST '(STACK)> <SET ACST <>>>
1543 #DECL ((ARG NOD) NODE)
1544 <COND (<==? <NODE-TYPE .ARG> ,SEGMENT-CODE>
1545 <EANA <1 <KIDS .ARG>> .RT SEGMENT>
1548 <EANA .ARG .RT <NODE-NAME .NOD>>
1549 <COND (<AND <NOT <SEGS .NOD>> .ACST>
1550 <SET ACST <REST .ACST>>)>
1551 <SET ARGS <+ .ARGS 1>>)>>
1552 <KIDS .NOD> <TYPE-INFO .NOD>>
1555 <OR .ACST <PUT .NOD ,STACKS <* .ARGS 2>>>
1556 <PUT .NOD ,SIDE-EFFECTS (ALL)>
1557 <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>>
1559 " Analyze CHTYPE, in some cases do it at compile time."
1561 <DEFINE CHTYPE-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) NTN NT OBN OB)
1562 #DECL ((NOD OBN NTN) NODE (K) <LIST [REST NODE]> (NT) ATOM)
1563 <COND (<SEGFLUSH .NOD .RTYP>)
1565 <ARGCHK <LENGTH .K> 2 CHTYPE>
1566 <SET OB <ANA <SET OBN <1 .K>> ANY>>
1567 <EANA <SET NTN <2 .K>> ATOM CHTYPE>
1568 <COND (<==? <NODE-TYPE .NTN> ,QUOTE-CODE>
1569 <OR <MEMQ <SET NT <NODE-NAME .NTN>> <ALLTYPES>>
1570 <MESSAGE ERROR " 2D ARG CHTYPE NOT A TYPE " .NT .NOD>>
1571 <OR <TYPE-OK? .OB <FORM PRIMTYPE <TYPEPRIM .NT>>>
1573 " PRIMTYPES DIFFER CHTYPE"
1576 <COND (<==? <NODE-TYPE .OBN> ,QUOTE-CODE>
1577 <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
1581 <CHTYPE <NODE-NAME .OBN> .NT>>)
1582 (ELSE <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>)>
1583 <PUT .NOD ,RESULT-TYPE .NT>
1584 <TYPE-OK? .NT .RTYP>)
1588 ("Can't open compile CHTYPE.")>)>
1589 <TYPE-OK? ANY .RTYP>)>)>>
1591 <PUT ,CHTYPE ANALYSIS ,CHTYPE-ANA>
1593 " Analyze use of ASCII sometimes do at compile time."
1595 <DEFINE ASCII-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) ITM TYP TEM)
1596 #DECL ((NOD ITM) NODE (K) <LIST [REST NODE]>)
1597 <COND (<SEGFLUSH .NOD .RTYP>)
1599 <ARGCHK <LENGTH .K> 1 ASCII>
1600 <SET TYP <EANA <SET ITM <1 .K>> '<OR FIX CHARACTER> ASCII>>
1601 <COND (<==? <NODE-TYPE .ITM> ,QUOTE-CODE>
1602 <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
1603 <PUT .NOD ,NODE-NAME <SET TEM <ASCII <NODE-NAME .ITM>>>>
1604 <PUT .NOD ,RESULT-TYPE <TYPE .TEM>>
1605 <PUT .NOD ,KIDS ()>)
1606 (<==? <ISTYPE? .TYP> FIX>
1607 <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>
1608 <PUT .NOD ,RESULT-TYPE CHARACTER>)
1609 (<==? .TYP CHARACTER>
1610 <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>
1611 <PUT .NOD ,RESULT-TYPE FIX>)
1613 <PUT .NOD ,RESULT-TYPE '<OR FIX CHARACTER>>)>
1614 <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>)>>
1616 <PUT ,ASCII ANALYSIS ,ASCII-ANA>
1618 <DEFINE UNWIND-ANA (NOD RTYP"AUX" (K <KIDS .NOD>) ITYP)
1619 #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
1620 <SET ITYP <EANA <1 .K> ANY UNWIND>>
1621 <EANA <2 .K> ANY UNWIND>
1622 <TYPE-OK? .ITYP .RTYP>>
1624 " Analyze ISTRING/ILIST/IVECTOR/IUVECTOR in cases of known and unknown last arg."
1626 <DEFINE ISTRUC-ANA (N R "AUX" (K <KIDS .N>) FM NUM TY (NEL REST) SIZ)
1627 #DECL ((N FM NUM) NODE)
1628 <COND (<==? <NODE-SUBR .N> ,IBYTES>
1629 <EANA <1 .K> FIX <NODE-NAME .N>>
1630 <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
1631 <SET SIZ <NODE-NAME <1 .K>>>)>
1633 <EANA <SET NUM <1 .K>> FIX <NODE-NAME .N>>
1635 <EANA <SET FM <2 .K>>
1636 <COND (<==? <NODE-NAME .FM> ISTRING> CHARACTER)
1637 (<==? <NODE-NAME .FM> IBYTES> FIX)
1640 <COND (<TYPE-OK? .TY '<OR FORM LIST VECTOR UVECTOR>>
1641 <MESSAGE WARNING "UNCERTAIN USE OF " <NODE-NAME .N> .N>
1644 (ELSE <PUT .N ,NODE-TYPE ,ISTRUC2-CODE>)>
1645 <COND (<==? <NODE-TYPE .NUM> ,QUOTE-CODE> <SET NEL <NODE-NAME .NUM>>)>
1646 <AND <TYPE-OK? .TY FORM> <SET TY ANY>>
1647 <TYPE-OK? <COND (<==? <NODE-SUBR .N> ,IBYTES>
1648 <COND (<ASSIGNED? SIZ>
1649 <COND (<TYPE? .NEL FIX> <FORM BYTES .SIZ .NEL>)
1650 (ELSE <FORM BYTES .SIZ>)>)
1653 <FORM <ISTYPE? <RESULT-TYPE .N>>
1655 !<COND (<==? .TY ANY> ())
1656 (ELSE ([REST .TY]))>>)>
1659 <DEFINE ISTRUC2-ANA (N R "AUX" (K <KIDS .N>) GD NUM TY (NEL REST) SIZ)
1660 #DECL ((N NUM GD) NODE)
1661 <COND (<==? <NODE-SUBR .N> ,IBYTES>
1662 <EANA <1 .K> FIX <NODE-NAME .N>>
1663 <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
1664 <SET SIZ <NODE-NAME <1 .K>>>)>
1666 <EANA <SET NUM <1 .K>> FIX <NODE-NAME .N>>
1668 <EANA <SET GD <2 .K>>
1669 <COND (<==? <NODE-SUBR .N> ,ISTRING> CHARACTER)
1670 (<==? <NODE-SUBR .N> ,IBYTES> FIX)
1673 <COND (<==? <NODE-TYPE .NUM> ,QUOTE-CODE> <SET NEL <NODE-NAME .NUM>>)>
1674 <TYPE-OK? <COND (<==? <NODE-SUBR .N> ,IBYTES>
1675 <COND (<ASSIGNED? SIZ>
1676 <COND (<TYPE? .NEL FIX> <FORM BYTES .SIZ .NEL>)
1677 (ELSE <FORM BYTES .SIZ>)>)
1680 <FORM <ISTYPE? <RESULT-TYPE .N>>
1682 !<COND (<==? .TY ANY> ())
1683 (ELSE ([REST .TY]))>>)>
1686 " Analyze READ type SUBRS in two cases (print uncertain usage message maybe?)"
1688 <DEFINE READ-ANA (N R)
1691 <FUNCTION (NN "AUX" TY)
1693 <COND (<==? <NODE-TYPE .NN> ,EOF-CODE>
1694 <SPEC-FLUSH> <PUT-FLUSH ALL>
1695 <SET TY <EANAQ <1 <KIDS .NN>> ANY <NODE-NAME .N> .N>>
1696 <COND (<TYPE-OK? .TY
1697 '<OR FORM LIST VECTOR UVECTOR>>
1699 " UNCERTAIN USE OF "
1701 (ELSE <PUT .N ,NODE-TYPE ,READ-EOF2-CODE>)>)
1702 (ELSE <EANA .NN ANY <NODE-NAME .N>>)>>
1704 <SPEC-FLUSH><PUT-FLUSH ALL>
1707 <DEFINE READ2-ANA (N R)
1712 <COND (<==? <NODE-TYPE .NN> ,EOF-CODE>
1713 <EANAQ <1 <KIDS .NN>> ANY <NODE-NAME .N> .N>)
1714 (ELSE <EANA .NN ANY <NODE-NAME .N>>)>>
1716 <SPEC-FLUSH><PUT-FLUSH ALL>
1719 <DEFINE GET-ANA (N R "AUX" TY (K <KIDS .N>) (NAM <NODE-NAME .N>))
1720 #DECL ((N) NODE (K) <LIST NODE NODE NODE>)
1721 <EANA <1 .K> ANY .NAM>
1722 <EANA <2 .K> ANY .NAM>
1723 <SET TY <EANAQ <3 .K> ANY .NAM .N>>
1724 <COND (<TYPE-OK? .TY '<OR LIST VECTOR UVECTOR FORM>>
1725 <MESSAGE WARNING "UNCERTAIN USE OF " .NAM .N>
1726 <SPEC-FLUSH> <PUT-FLUSH ALL>)
1727 (ELSE <PUT .N ,NODE-TYPE ,GET2-CODE>)>
1730 <DEFINE GET2-ANA (N R "AUX" (K <KIDS .N>) (NAM <NODE-NAME .N>) (LN <LENGTH .K>))
1731 #DECL ((N) NODE (K) <LIST NODE NODE [REST NODE]> (LN) FIX)
1732 <EANA <1 .K> ANY .NAM>
1733 <EANA <2 .K> ANY .NAM>
1734 <COND (<==? .LN 3> <EANAQ <3 .K> ANY .NAM .N>)>
1737 <DEFINE EANAQ (N R NAM INOD "AUX" SPCD)
1738 #DECL ((N) NODE (SPCD) LIST)
1739 <SET SPCD <BUILD-TYPE-LIST .VARTBL>>
1740 <SET R <EANA .N .R .NAM>>
1741 <ASSERT-TYPES <ORUPC .VARTBL .SPCD>>
1745 #DECL ((TMPS HTMPS) FIX)
1747 <AND <G? <SET TMPS <+ .TMPS 2>> .HTMPS> <SET HTMPS .TMPS>>)
1748 (ELSE <SETG REGS <- ,REGS 1>>)>>
1750 <DEFINE UNUSE-REG ()
1752 <COND (<==? ,REGS 5> <SET TMPS <- .TMPS 2>>)
1753 (ELSE <SETG REGS <+ ,REGS 1>>)>>
1756 #DECL ((TMPS HTMPS) FIX)
1757 <AND <G? <SET TMPS <+ .TMPS <* <- 5 ,REGS> 2>>> .HTMPS>
1761 <DEFINE ACTIV? (BST NOACT)
1762 #DECL ((BST) <LIST [REST SYMTAB]>)
1764 <AND <EMPTY? .BST> <RETURN <>>>
1765 <AND <==? <CODE-SYM <1 .BST>> 1>
1767 <NOT <RET-AGAIN-ONLY <1 .BST>>>
1768 <SPEC-SYM <1 .BST>>>
1770 <SET BST <REST .BST>>>>
1772 <DEFINE SAME-DECL? (D1 D2) <OR <=? .D1 .D2> <NOT <TYPE-OK? .D2 <NOTIFY .D1>>>>>
1774 <DEFINE SPECIALIZE (OBJ "AUX" T1 T2 SYM OB)
1775 #DECL ((T1) FIX (OB) FORM (T2) <OR FALSE SYMTAB>)
1776 <COND (<AND <TYPE? .OBJ FORM SEGMENT>
1777 <SET OB <CHTYPE .OBJ FORM>>
1778 <OR <AND <==? <SET T1 <LENGTH .OB>> 2>
1780 <TYPE? <SET SYM <2 .OB>> ATOM>>
1783 <TYPE? <SET SYM <2 .OB>> ATOM>>>
1784 <SET T2 <SRCH-SYM .SYM>>>
1785 <COND (<NOT <SPEC-SYM .T2>>
1786 <MESSAGE NOTE " REDCLARED SPECIAL " .SYM>
1787 <PUT .T2 ,SPEC-SYM T>)>)>
1788 <COND (<MEMQ <PRIMTYPE .OBJ> '![FORM LIST UVECTOR VECTOR!]>
1789 <MAPF <> ,SPECIALIZE .OBJ>)>>
1791 <COND (<GASSIGNED? ARITH-ANA>
1794 (,QUOTE-CODE ,QUOTE-ANA)
1795 (,FUNCTION-CODE ,FUNC-ANA)
1796 (,SEGMENT-CODE ,SEGMENT-ANA)
1797 (,FORM-CODE ,FORM-AN)
1798 (,PROG-CODE ,PRG-REP-ANA)
1799 (,SUBR-CODE ,SUBR-ANA)
1800 (,COND-CODE ,COND-ANA)
1801 (,COPY-CODE ,COPY-AN)
1802 (,RSUBR-CODE ,RSUBR-ANA)
1803 (,ISTRUC-CODE ,ISTRUC-ANA)
1804 (,ISTRUC2-CODE ,ISTRUC2-ANA)
1805 (,READ-EOF-CODE ,READ-ANA)
1806 (,READ-EOF2-CODE ,READ2-ANA)
1807 (,GET-CODE ,GET-ANA)
1808 (,GET2-CODE ,GET2-ANA)
1809 (,MAP-CODE ,MAPPER-AN)
1810 (,MARGS-CODE ,MARGS-ANA)
1811 (,ARITH-CODE ,ARITH-ANA)
1812 (,TEST-CODE ,ARITHP-ANA)
1813 (,0-TST-CODE ,ARITHP-ANA)
1814 (,1?-CODE ,ARITHP-ANA)
1815 (,MIN-MAX-CODE ,ARITH-ANA)
1816 (,ABS-CODE ,ABS-ANA)
1817 (,FIX-CODE ,FIX-ANA)
1818 (,FLOAT-CODE ,FLOAT-ANA)
1819 (,MOD-CODE ,MOD-ANA)
1820 (,LNTH-CODE ,LENGTH-ANA)
1821 (,MT-CODE ,EMPTY?-ANA)
1822 (,NTH-CODE ,NTH-ANA)
1823 (,REST-CODE ,REST-ANA)
1824 (,PUT-CODE ,PUT-ANA)
1825 (,PUTR-CODE ,PUTREST-ANA)
1826 (,UNWIND-CODE ,UNWIND-ANA)
1827 (,FORM-F-CODE ,FORM-F-ANA)
1828 (,IRSUBR-CODE ,IRSUBR-ANA)
1829 (,ROT-CODE ,ROT-ANA)
1830 (,LSH-CODE ,LSH-ANA)
1831 (,BIT-TEST-CODE ,BIT-TEST-ANA)
1832 (,CASE-CODE ,CASE-ANA)
1833 (,COPY-LIST-CODE ,COPY-AN)>>)>