57 " This is the main file associated with the type analysis phase of
58 the compilation. It is called by calling FUNC-ANA with the main data structure
59 pointer. ANA is the FUNCTION that dispatches to the various special handlers
60 and the SUBR call analyzer further dispatches for specific functions."
62 " Many analyzers for specific SUBRs appear in their own files
63 (CARITH, STRUCT etc.). Currently no special hacks are done for TYPE?, EMPTY?
64 etc. in COND, ANDS and ORS."
66 " All analysis functions are called with 2 args, a NODE and a desired
67 type specification. These args are usually called NOD and RTYP or
70 " ANA is the main analysis dispatcher (see ANALYZERS at the end of
71 this file for its dispatch table."
73 <GDECL (TEMPLATES SUBRS) VECTOR>
75 <DEFINE ANA (NOD RTYP "AUX" (P <PARENT .NOD>))
76 #DECL ((NOD) NODE (P) ANY (TEM TT) <OR FALSE LIST>)
77 <COND (<G=? <LENGTH .NOD> <INDEX ,SIDE-EFFECTS>>
78 <PUT .NOD ,SIDE-EFFECTS <>>)>
79 <PUT .NOD ,RESULT-TYPE <ANALYSIS-DISPATCHER .NOD .RTYP>>
80 <UPDATE-SIDE-EFFECTS .NOD .P>
83 <DEFINE UPDATE-SIDE-EFFECTS (NOD P "AUX" TEM TT)
84 #DECL ((NOD) NODE (TEM TT) <OR FALSE LIST>)
86 (<AND <N==? <NODE-TYPE .NOD> ,QUOTE-CODE>
87 <SET TEM <SIDE-EFFECTS .NOD>>
89 <COND (<NOT <TYPE? .P NODE>> <RETURN <>>)>
90 <COND (<G=? <LENGTH .P> <CHTYPE <INDEX ,SIDE-EFFECTS> FIX>>
96 <COND (<EMPTY? .TEM> <SIDE-EFFECTS .P>)
97 (<EMPTY? <SET TT <SIDE-EFFECTS .P>>> .TEM)
98 (<AND <MEMQ ALL .TEM> <MEMQ ALL .TT>>
99 <COND (<G? <LENGTH .TEM> <LENGTH .TT>>
103 <COND (<AND <N==? .IT ALL>
104 <NOT <MEMQ .IT .TEM>>> .IT)
107 <COND (<EMPTY? .TT> .TEM)
109 <PUTREST <REST .TT <- <LENGTH .TT> 1>> .TEM>
115 <COND (<AND <N==? .IT ALL>
116 <NOT <MEMQ .IT .TT>>> .IT)
119 <COND (<EMPTY? .TEM> .TT)
121 <PUTREST <REST .TEM <- <LENGTH .TEM> 1>> .TT>
123 (<G? <LENGTH .TT> <LENGTH .TEM>> (!.TEM !.TT))
124 (ELSE (!.TT !.TEM))>>)>>
126 <DEFINE ARGCHK (GIV REQ NAME NOD "AUX" (HI .REQ) (LO .REQ))
127 #DECL ((GIV) FIX (REQ HI LO) <OR <LIST FIX FIX> FIX> (NOD) NODE)
128 <COND (<TYPE? .REQ LIST> <SET HI <2 .REQ>> <SET LO <1 .REQ>>)>
130 <COMPILE-ERROR "Too many arguments to: " .NAME .NOD>)
132 <COMPILE-ERROR "Too many arguments to: " .NAME .NOD>)>
135 <DEFINE EANA (NOD RTYP NAME)
137 <COND (<ANA .NOD .RTYP>)
138 (ELSE <COMPILE-ERROR "Argument wrong type to: " .NAME .NOD>)>>
140 " FUNC-ANA main entry to analysis phase. Analyzes bindings then body."
142 <DEFINE FUNC-ANA ANA-ACT (N R
144 <COND (<ASSIGNED? ANALY-OK> .ANALY-OK)
145 (ELSE T)>) (OV .VERBOSE))
146 #DECL ((ANA-ACT) <SPECIAL ANY> (ANALY-OK) <SPECIAL ANY>)
147 <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
150 <DEFINE FUNC-AN1 (FCN RTYP
151 "AUX" (VARTBL <SYMTAB .FCN>) (TMPS 0) (HTMPS 0) (TRUTH ())
152 (UNTRUTH ()) (WHO ()) (WHON <>) (PRED <>) TEM (LIFE ())
153 (USE-COUNT 0) (BACKTRACK 0) NRTYP)
154 #DECL ((FCN) <SPECIAL NODE> (VARTBL) <SPECIAL SYMTAB>
155 (TMPS BACKTRACK USE-COUNT HTMPS) <SPECIAL FIX>
156 (LIFE TRUTH UNTRUTH) <SPECIAL LIST> (WHO PRED WHON) <SPECIAL ANY>)
158 <BIND-AN <BINDING-STRUCTURE .FCN>>
159 <COND (<NOT <SET NRTYP <TYPE-OK? .RTYP <INIT-DECL-TYPE .FCN>>>>
160 <COMPILE-ERROR "Function returns wrong type: "
162 ". Declared type is "
163 <INIT-DECL-TYPE .FCN>
164 ", required type is "
166 <PROG ((ACT? <ACTIV? <BINDING-STRUCTURE .FCN> T>) (OV .VERBOSE))
167 <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
169 <PUT .FCN ,LIVE-VARS ()>
171 <PUT .FCN ,ASSUM <BUILD-TYPE-LIST .VARTBL>>
172 <PUT .FCN ,ACCUM-TYPE <COND (.ACT? .RTYP) (ELSE NO-RETURN)>>
173 <SET TEM <SEQ-AN <KIDS .FCN> <INIT-DECL-TYPE .FCN>>>
174 <COND (.ACT? <SPEC-FLUSH> <PUT-FLUSH ALL>)>
176 (<OR <AND <OR <AGND .FCN> .ACT?>
177 <NOT <ASSUM-OK? <ASSUM .FCN>
179 <BUILD-TYPE-LIST .VARTBL>>>>>
181 <SET ACT? <ACTIV? <BINDING-STRUCTURE .FCN> T>>
182 <ASSERT-TYPES <ASSUM .FCN>>>>
185 <PUT .FCN ,DEAD-VARS ()>
187 <COMPILE-ERROR "Returned value violates decl of: " .NRTYP>)>
188 <PUT .FCN ,RESULT-TYPE <TYPE-MERGE <ACCUM-TYPE .FCN> .TEM>>
189 <PUT <RSUBR-DECLS .FCN> 2 <TASTEFUL-DECL <RESULT-TYPE .FCN>>>
192 " BIND-AN analyze binding structure for PROGs, FUNCTIONs etc."
194 <DEFINE BIND-AN (BNDS "AUX" COD)
195 #DECL ((BNDS) <LIST [REST SYMTAB]> (COD) FIX)
198 <COND (<EMPTY? .BNDS> <RETURN>)>
199 <PUT <SET SYM <1 .BNDS>> ,COMPOSIT-TYPE ANY>
200 <PUT .SYM ,CURRENT-TYPE <>>
202 <SET BNDS <REST .BNDS>>>>
204 " ENTROPY ignore call and return."
206 <DEFINE ENTROPY (SYM) T>
208 <DEFINE TUP-BAN (SYM)
210 <COND (<NOT .ANALY-OK>
211 <PUT .SYM ,COMPOSIT-TYPE <DECL-SYM .SYM>>
212 <PUT .SYM ,CURRENT-TYPE ANY>)
213 (<N==? <ISTYPE? <DECL-SYM .SYM>> TUPLE>
214 <PUT .SYM ,COMPOSIT-TYPE TUPLE>
215 <PUT .SYM ,CURRENT-TYPE TUPLE>)
217 <PUT .SYM ,CURRENT-TYPE <DECL-SYM .SYM>>
218 <PUT .SYM ,COMPOSIT-TYPE <DECL-SYM .SYM>>)>>
220 " Analyze AUX and OPTIONAL intializations."
222 <DEFINE NORM-BAN (SYM
223 "AUX" (VARTBL <NEXT-SYM .SYM>) TEM COD (N <INIT-SYM .SYM>))
224 #DECL ((VARTBL) <SPECIAL SYMTAB> (SYM) SYMTAB (COD) FIX (N) NODE)
225 <COND (<NOT <SET TEM <ANA .N <DECL-SYM .SYM>>>>
226 <COMPILE-ERROR "AUX/OPT init for: "
234 <COND (<AND .ANALY-OK
235 <OR <G? <SET COD <CODE-SYM .SYM>> ,ARGL-OPT>
236 <L? .COD ,ARGL-QIOPT>>>
237 <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE>
238 <COND (<==? <NODE-NAME .N> <>> <SET TEM BOOL-FALSE>)
239 (<==? <NODE-NAME .N> T> <SET TEM BOOL-TRUE>)>)>
240 <PUT .SYM ,CURRENT-TYPE .TEM>
241 <PUT .SYM ,COMPOSIT-TYPE .TEM>)
243 <PUT .SYM ,COMPOSIT-TYPE <DECL-SYM .SYM>>
244 <PUT .SYM ,CURRENT-TYPE <DECL-SYM .SYM>>)>>
246 " ARGS-BAN analyze ARGS decl (change to OPTIONAL in some cases)."
248 <DEFINE ARGS-BAN (SYM)
250 <PUT .SYM ,INIT-SYM <NODE1 ,QUOTE-CODE () LIST () ()>>
251 <PUT .SYM ,CODE-SYM ,ARGL-IOPT>
252 <COND (.ANALY-OK <PUT .SYM ,COMPOSIT-TYPE LIST>)
253 (ELSE <PUT .SYM ,COMPOSIT-TYPE <DECL-SYM .SYM>>)>
255 <PUT .SYM ,CURRENT-TYPE <TYPE-AND LIST <DECL-SYM .SYM>>>)
256 (<NOT .ANALY-OK> <PUT .SYM ,CURRENT-TYPE ANY>)>>
258 <DEFINE NAUX-BAN (SYM)
262 <COND (.ANALY-OK NO-RETURN) (ELSE <DECL-SYM .SYM>)>>
263 <PUT .SYM ,CURRENT-TYPE <COND (.ANALY-OK NO-RETURN) (ELSE ANY)>>>
265 "BIND-DISPATCH go to various binding analyzers analyzers."
267 <DEFINE BIND-DISPATCH (SYM "AUX" (COD <CODE-SYM .SYM>))
270 (,ARGL-ACT <ENTROPY .SYM>)
271 (,ARGL-IAUX <NORM-BAN .SYM>)
272 (,ARGL-AUX <NAUX-BAN .SYM>)
273 (,ARGL-TUPLE <TUP-BAN .SYM>)
274 (,ARGL-ARGS <ARGS-BAN .SYM>)
275 (,ARGL-QIOPT <NORM-BAN .SYM>)
276 (,ARGL-IOPT <NORM-BAN .SYM>)
277 (,ARGL-QOPT <ENTROPY .SYM>)
278 (,ARGL-OPT <ENTROPY .SYM>)
279 (,ARGL-CALL <ENTROPY .SYM>)
280 (,ARGL-BIND <ENTROPY .SYM>)
281 (,ARGL-QUOTE <ENTROPY .SYM>)
282 (,ARGL-ARG <ENTROPY .SYM>)>>
284 " SEQ-AN analyze a sequence of NODES discarding values until the last."
286 <DEFINE SEQ-AN (L FTYP "OPTIONAL" (DO-PRED <>) "AUX" (SOA <>) VAL)
287 #DECL ((L) <LIST [REST NODE]>)
289 (<EMPTY? .L> <COMPILE-LOSSAGE "Empty KIDS list in SEQ-AN">)
292 <REPEAT (TT N X Y TMP (RES NO-RETURN) (SPCD <>) ENDIF-FLAG
294 #DECL ((X) NODE (Y) <LIST [REST NODE]> (RET-OR-AGAIN) <SPECIAL ANY>)
298 (<OR <AND <EMPTY? <SET L <REST .L>>> <NOT <IFSYS-ENDIF? .N "ENDIF">>>
299 <AND <NOT <EMPTY? .L>>
300 <IFSYS-ENDIF? <1 .L> "ENDIF">
302 <COND (<AND .DO-PRED <EMPTY? .L>>
303 <PROG ((PRED <PARENT .N>)) #DECL ((PRED) <SPECIAL ANY>)
304 <SET TT <ANA .N .FTYP>>>)
306 <SET TT <ANA .N .FTYP>>)>
307 <COND (<AND .ENDIF-FLAG .SPCD>
308 <ASSERT-TYPES <ORUPC .VARTBL .SPCD>>
310 <SET RES <TYPE-MERGE .TT .RES>>)
311 (<IFSYS-ENDIF? .N "IFSYS">
312 <SET TT <ANA .N ANY>>
313 <SET SPCD <BUILD-TYPE-LIST .VARTBL>>)
315 <SET TT <ANA .N ANY>>
317 (<OR <L? <LENGTH .N> <CHTYPE <INDEX ,SIDE-EFFECTS> FIX>>
318 <NOT <SIDE-EFFECTS .N>>>
322 (<AND .VERBOSE <NOT <EMPTY? .L>>>
325 ("This object has no side-effects and its value is ignored"
327 (ELSE <PUTPROP .N DONT-FLUSH-ME T>)>)>)>
328 <COND (<NOT .TT> <SET SOA .RET-OR-AGAIN> <RETURN <>>)>
331 <COND (<AND .VERBOSE <NOT <EMPTY? .L>>>
332 <ADDVMESS <PARENT .N>
333 ("This object ends a sequence of forms"
335 " because it never returns")>)>
336 <SET SOA .RET-OR-AGAIN>
338 <COND (<EMPTY? .L> <SET SOA .RET-OR-AGAIN> <RETURN .RES>)>>>
339 <COND (.SOA <SET RET-OR-AGAIN T>)>
342 <DEFINE IFSYS-ENDIF? (N STR "AUX" Y NM)
343 #DECL ((N) NODE (Y) <LIST [REST NODE]>)
344 <AND <==? <NODE-TYPE .N> ,CALL-CODE>
345 <G? <LENGTH <SET Y <KIDS .N>>> 1>
346 <TYPE? <SET NM <NODE-NAME <1 .Y>>> ATOM>
347 <=? <SPNAME .NM> .STR>>>
349 " ANALYZE ASSIGNED? usage."
351 <DEFINE ASSIGNED?-ANA (NOD RTYP
352 "AUX" (TEM <KIDS .NOD>) TT T1 T2 (TY '<OR ATOM
354 #DECL ((TT NOD) NODE (T1) SYMTAB (TEM) <LIST [REST NODE]>)
356 (<EMPTY? .TEM> <COMPILE-ERROR "No arguments ASSIGNED?: " .NOD>)
357 (<SEGFLUSH .NOD .RTYP>)
359 <EANA <SET TT <1 .TEM>> ATOM ASSIGNED?>
360 <COND (<AND <EMPTY? <REST .TEM>>
361 <==? <NODE-TYPE .TT> ,QUOTE-CODE>
362 <SET T2 <SRCH-SYM <NODE-NAME .TT>>>
363 <NOT <==? <CODE-SYM <SET T1 .T2>> -1>>>
364 <PUT .NOD ,NODE-TYPE ,ASSIGNED?-CODE>
365 <PUT .NOD ,NODE-NAME .T1>
367 <PUT .T1 ,USED-AT-ALL T>
368 <PUT .T1 ,USAGE-SYM <+ <USAGE-SYM .T1> 1>>
371 <COND (<==? <GET-CURRENT-TYPE .T1> NO-RETURN> BOOL-FALSE)
373 (<==? <LENGTH .TEM> 2>
374 <EANA <2 .TEM> '<OR <PRIMTYPE FRAME> PROCESS> ASSIGNED?>)
375 (<EMPTY? <REST .TEM>>
376 <COND (<AND .VERBOSE <==? <NODE-TYPE .TT> ,QUOTE-CODE>>
378 ("External reference to LVAL: "
380 <PUT .NOD ,NODE-TYPE ,ASSIGNED?-CODE>
382 (ELSE <COMPILE-ERROR "Too many args to ASSIGNED?: " .NOD>)>)>
383 <TYPE-OK? .TY .RTYP>>
385 <COND (<GASSIGNED? ASSIGNED?-ANA>
386 <PUTPROP ,ASSIGNED? ANALYSIS ,ASSIGNED?-ANA>)>
388 " ANALYZE LVAL usage. Become either direct reference or PUSHJ"
390 <DEFINE LVAL-ANA (NOD RTYP
391 "AUX" TEM ITYP (TT <>) T1 T2 T3 (P <PARENT .NOD>) NT)
392 #DECL ((NOD) NODE (TEM) <LIST [REST NODE]> (T1) SYMTAB (WHO) LIST)
393 <COND (<EMPTY? <SET TEM <KIDS .NOD>>>
394 <COMPILE-ERROR "No arguments LVAL: " .NOD>)
395 (<SEGFLUSH .NOD .RTYP>)
396 (<AND <OR <AND <TYPE? <NODE-NAME .NOD> SYMTAB>
397 <SET TT <NODE-NAME .NOD>>>
398 <AND <EANA <1 .TEM> ATOM LVAL>
400 <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>
401 <==? <RESULT-TYPE <1 .TEM>> ATOM>
402 <SET TT <SRCH-SYM <NODE-NAME <1 .TEM>>>>>>
403 <COND (<==? .WHON .P> <SET WHO ((<> .TT) !.WHO)>) (ELSE T)>
405 <SET ITYP <GET-CURRENT-TYPE .TT>>
407 <COND (<AND <==? .PRED .P>
408 <SET T2 <TYPE-OK? .ITYP FALSE>>
409 <SET T3 <TYPE-OK? .ITYP '<NOT FALSE>>>>
410 <SET TRUTH <ADD-TYPE-LIST .TT .T3 .TRUTH <>>>
411 <SET UNTRUTH <ADD-TYPE-LIST .TT .T2 .UNTRUTH <>>>)
412 (<AND <N==? .PRED .P>
413 <OR <NOT <TYPE? .P NODE>>
414 <AND <N==? <SET NT <NODE-TYPE .P>> ,SET-CODE>
416 <OR <N==? .NT ,SUBR-CODE>
417 <AND <N==? <NODE-SUBR .P> ,SET>
418 <N==? <NODE-SUBR .P> ,NOT>>>>>
419 <MEMQ .ITYP '[BOOL-TRUE BOOL-FALSE BOOLEAN]>>
420 <SET-CURRENT-TYPE .TT <SET ITYP <GET-DECL .ITYP>>>
423 <NOT <==? <CODE-SYM <SET T1 .TT>> -1>>>
424 <PUT .NOD ,NODE-TYPE ,LVAL-CODE>
426 <PUT .T1 ,RET-AGAIN-ONLY <>>
427 <PUT .T1 ,USED-AT-ALL T>
428 <PUT .T1 ,USAGE-SYM <+ <USAGE-SYM .T1> 1>>
429 <PUT .NOD ,NODE-NAME .T1>
430 <SET ITYP <TYPE-OK? .ITYP .RTYP>>
431 <COND (.ITYP <SET-CURRENT-TYPE .T1 .ITYP>)>
433 (<EMPTY? <REST .TEM>>
434 <COND (<AND .VERBOSE <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>>
436 ("External variable being referenced: "
437 <NODE-NAME <1 .TEM>>)>)>
438 <PUT .NOD ,NODE-TYPE ,FLVAL-CODE>
439 <AND .TT <PUT .NOD ,NODE-NAME <SET T1 .TT>>>
440 <COND (.TT <TYPE-OK? <DECL-SYM .T1> .RTYP>) (ELSE .RTYP)>)
441 (<AND <==? <LENGTH .TEM> 2>
442 <EANA <2 .TEM> '<OR <PRIMTYPE FRAME> PROCESS> LVAL>>
444 (ELSE <COMPILE-ERROR "Too many args to LVAL: " .NOD>)>>
446 <COND (<GASSIGNED? LVAL-ANA> <PUTPROP ,LVAL ANALYSIS ,LVAL-ANA>)>
448 " SET-ANA analyze uses of SET."
450 <DEFINE SET-ANA (NOD RTYP
451 "AUX" (TEM <KIDS .NOD>) (LN <LENGTH .TEM>) T1 (T2 ATOM) T11
452 (NM <2 <CHTYPE <NODE-SUBR .NOD> MSUBR>>) (WHON .WHON)
453 (PRED .PRED) OTYP T3 XX N)
454 #DECL ((N NOD) NODE (TEM) <LIST [REST NODE]> (LN) FIX (T1) SYMTAB
455 (WHON PRED) <SPECIAL ANY> (WHO) LIST)
456 <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
458 (<SEGFLUSH .NOD .RTYP>)
459 (<OR <AND <==? .NM SET> <L? .LN 2>>
460 <AND <==? .NM UNASSIGN> <==? .LN 0>>>
461 <COMPILE-ERROR "Too few arguments to: " .NOD>)
462 (<AND <OR <AND <TYPE? <NODE-NAME .NOD> SYMTAB> <SET T11 <NODE-NAME .NOD>>>
463 <AND <EANA <1 .TEM> ATOM .NM>
464 <OR <AND <==? .NM SET> <==? .LN 2>>
465 <AND <==? .NM UNASSIGN> <==? .LN 1>>>
466 <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>
467 <SET T11 <SRCH-SYM <NODE-NAME <1 .TEM>>>>>>
468 <COND (<==? .WHON <PARENT .NOD>>
470 <SET WHO ((T .T11) !.WHO)>)
472 <COND (<==? .PRED <PARENT .NOD>> <SET PRED .NOD>) (ELSE T)>
474 <COND (<AND <==? .NM SET>
475 <NOT <SET T2 <ANA <SET N <2 .TEM>>
477 <COMPILE-ERROR "Decl violation: " <NAME-SYM .T1> .NOD>)
479 <PUT .T1 ,PURE-SYM <>>
480 <SET XX <DECL-SYM .T1>>
481 <PUT .T1 ,USAGE-SYM <+ <USAGE-SYM .T1> 1>>
482 <SET OTYP <OR <CURRENT-TYPE .T1> ANY>>
483 <COND (<AND <==? <CODE-SYM .T1> -1> .VERBOSE>
484 <ADDVMESS .NOD ("External variable being SET (or UNASSIGNed): "
486 <COND (<==? .NM SET> <SET T2 <OR <TYPE-AND .T2 .RTYP> .T2>>)>
487 <COND (<N==? .NM SET>
488 <TYPE-INFO .NOD (<> <>)>)
489 (<SET OTYP <TYPESAME .OTYP .T2>> <PUT .NOD ,TYPE-INFO (.OTYP <>)>)
490 (ELSE <PUT .NOD ,TYPE-INFO (<> <>)>)>
493 <COND (<==? <CODE-SYM .T1> -1> ,FSET-CODE) (ELSE ,SET-CODE)>>
494 <PUT .NOD ,NODE-NAME .T1>
496 <COND (<AND <==? .NM SET> <==? <NODE-TYPE .N> ,QUOTE-CODE>>
497 <COND (<==? <NODE-NAME .N> <>> <SET T2 BOOL-FALSE>)
498 (<==? <NODE-NAME .N> T> <SET T2 BOOL-TRUE>)>)>
499 <SET-CURRENT-TYPE .T1 <COND (<==? .NM SET> .T2)(ELSE NO-RETURN)>>
500 <PUT .T1 ,USED-AT-ALL T>
502 <COND (<AND <==? .PRED .NOD>
503 <SET OTYP <TYPE-OK? .T2 '<NOT FALSE>>>
504 <SET T3 <TYPE-OK? .T2 FALSE>>>
505 <SET TRUTH <ADD-TYPE-LIST .T1 .OTYP .TRUTH T>>
506 <SET UNTRUTH <ADD-TYPE-LIST .T1 .T3 .UNTRUTH T>>)>
507 <TYPE-OK? .T2 .RTYP>)
509 <TYPE-OK? .T2 .RTYP>)>)
510 (<AND <==? .NM SET> <L? .LN 4>>
511 <SET T11 <ANA <2 .TEM> ANY>>
513 <COND (<AND .VERBOSE <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>>
515 ("External variable being SET: "
516 <NODE-NAME <1 .TEM>>)>)>
517 <PUT .NOD ,NODE-TYPE ,FSET-CODE>)
518 (ELSE <EANA <3 .TEM> '<OR <PRIMTYPE FRAME> PROCESS> SET>)>
519 <TYPE-OK? .T11 .RTYP>)
520 (<AND <==? .NM UNASSIGN> <L? .LN 3>>
522 <COND (<AND .VERBOSE <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>>
524 ("External variable being UNASSIGNed: "
525 <NODE-NAME <1 .TEM>>)>)>
526 <PUT .NOD ,NODE-TYPE ,FSET-CODE>)
527 (ELSE <EANA <2 .TEM> '<OR <PRIMTYPE FRAME> PROCESS> SET>)>)
528 (ELSE <COMPILE-ERROR "Too many args to SET: " .NOD>)>>
530 <DEFINE MULTI-SET-ANA (NOD RTYP
531 "AUX" (K <KIDS .NOD>) (LN 0) (WHON .WHON) (PRED .PRED)
532 (SEG? <>) (N <1 .K>) (L-OF-A <NODE-NAME .N>)
533 L-OF-SY TY TY1 TTY FTY)
534 #DECL ((N NOD) NODE (TEM) <LIST [REST NODE]> (LN) FIX (T1) SYMTAB
535 (WHON PRED) <SPECIAL ANY> (WHO) LIST (L-OF-A L-OF-SY) LIST)
536 <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
540 "AUX" (ATM:<OR ADECL ATOM LIST SYMTAB> <1 .AL>) (N:NODE <1 .NL>)
541 (NT:FIX <NODE-TYPE .N>) SY)
543 (<OR <==? .NT ,SEGMENT-CODE> <==? .NT ,SEG-CODE>>
544 <MAPSTOP !<MULTI-SET-SEG .NOD .AL .NL>>)
546 <COND (<AND <EMPTY? <REST .AL>> <NOT <EMPTY? <REST .NL>>>>
547 <COMPILE-ERROR "Too many values for vars: " .NOD>)
548 (<AND <NOT <EMPTY? <REST .AL>>> <EMPTY? <REST .NL>>>
549 <COMPILE-ERROR "Too few values for vars: " .NOD>)>
551 <COND (<TYPE? .ATM ATOM>
552 <COND (<SET SY <SRCH-SYM .ATM>> <SET ATM .SY>)>)
554 <COND (<SET SY <SRCH-SYM <1 .ATM>>>
559 <SET ATM <1 .ATM>>)>)
563 <COND (<TYPE? .ATM SYMTAB>
564 <COND (<AND <==? .WHON <PARENT .NOD>>
567 <SET WHO ((T .ATM) !.WHO)>)>
568 <COND (<AND <==? .PRED <PARENT .NOD>>
571 <COND (<OR <NOT <SET TY <TYPE-OK? .TY1 <DECL-SYM .ATM>>>>
572 <NOT <SET TY <ANA .N .TY>>>>
573 <COMPILE-ERROR "Decl violation: "
576 <PUT .ATM ,PURE-SYM <>>
577 <PUT .ATM ,USAGE-SYM <+ <USAGE-SYM .ATM> 1>>
578 <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE>
579 <COND (<==? <NODE-NAME .N> <>>
581 (<==? <NODE-NAME .N> T>
582 <SET TY BOOL-TRUE>)>)>
583 <SET-CURRENT-TYPE .ATM .TY>
584 <PUT .ATM ,USED-AT-ALL T>
585 <COND (<AND <==? .PRED .NOD>
586 <SET TTY <TYPE-OK? .TY '<NOT FALSE>>>
587 <SET FTY <TYPE-OK? .TY FALSE>>>
588 <SET TRUTH <ADD-TYPE-LIST .ATM .TTY .TRUTH T>>
590 <ADD-TYPE-LIST .ATM .FTY .UNTRUTH T>>)>)
591 (ELSE <SET TY <ANA .N .TY1>>)>
593 <OR <AND <TYPE? .ATM SYMTAB>
594 <==? <CODE-SYM .ATM> -1>
595 <SET ATM <NAME-SYM .ATM>>>
597 <ADDVMESS .NOD ("External variable being SET: " .ATM)>)>
601 <PUT .NOD ,NODE-NAME .L-OF-SY>
602 <PUT .NOD ,NODE-TYPE ,MULTI-SET-CODE>
603 <TYPE-OK? <2 <NTH .L-OF-SY <LENGTH .L-OF-SY>>> .RTYP>>
605 <DEFINE MULTI-SET-SEG (NOD:NODE AL:LIST NL:<LIST [REST NODE]>
606 "AUX" (MIN-LN:FIX 0) (MAX-LN:FIX 0)
607 (LN:FIX <LENGTH .AL>) (COMPOSIT-DECL NO-RETURN)
608 (COMPOSIT-TYPE NO-RETURN) L-OF-SY:LIST)
611 <FUNCTION (ATM:<OR ADECL ATOM LIST SYMTAB> "AUX" SY (TY ANY))
612 <COND (<TYPE? .ATM ATOM>
613 <COND (<SET SY <SRCH-SYM .ATM>> <SET ATM .SY>)>)
615 <COND (<SET SY <SRCH-SYM <1 .ATM>>>
620 <SET ATM <1 .ATM>>)>)
624 <COND (<TYPE? .ATM SYMTAB>
625 <COND (<NOT <SET TY <TYPE-AND <DECL-SYM .ATM> .TY>>>
626 <COMPILE-ERROR "ADECL and DECL mismatch: "
630 <TYPE-MERGE .COMPOSIT-DECL .TY>>
631 <PUT .ATM ,PURE-SYM <>>
632 <PUT .ATM ,USAGE-SYM <+ <USAGE-SYM .ATM> 1>>
633 <PUT .ATM ,USED-AT-ALL T>)>
637 <FUNCTION (N:NODE "AUX" (NT:FIX <NODE-TYPE .N>) TY ET)
639 (<OR <==? .NT ,SEG-CODE> <==? .NT ,SEGMENT-CODE>>
640 <SET TY <EANA <SET N <1 <KIDS .N>>> '<OR MULTI STRUCTURED> MULTI-SET>>
641 <COND (<N==? .COMPOSIT-DECL ANY>
643 <TYPE-OK? <GET-ELE-TYPE .TY ALL>
645 <COMPILE-ERROR "Decl violation: " .NOD>)>)
646 (ELSE <SET ET <GET-ELE-TYPE .TY ALL>>)>
647 <SET COMPOSIT-TYPE <TYPE-MERGE .ET .COMPOSIT-TYPE>>
648 <SET MAX-LN <MAX <+ .MAX-LN <MAXL .TY>> ,MAX-LENGTH>>
649 <SET MIN-LN <+ .MIN-LN <MINL .TY>>>)
652 <TYPE-MERGE <EANA .N .COMPOSIT-DECL MULTI-SET> .COMPOSIT-TYPE>>
653 <SET MAX-LN <MAX <+ .MAX-LN 1> ,MAX-LENGTH>>
654 <SET MIN-LN <+ .MIN-LN 1>>)>>
658 <COND (<TYPE? <SET SY <1 .SY>> SYMTAB>
660 .SY <TYPE-AND .COMPOSIT-TYPE <DECL-SYM .SY>>>)>>
662 <COND (<G? .MIN-LN .LN> <COMPILE-ERROR "Too many values: " .NOD>)
663 (<L? .MAX-LN .LN> <COMPILE-ERROR "Too few values: " .NOD>)>
666 <COND (<GASSIGNED? SET-ANA>
667 <PUTPROP ,SET ANALYSIS ,SET-ANA>
668 <PUTPROP ,UNASSIGN ANALYSIS ,SET-ANA>)>
670 <DEFINE MUNG-L-D-STATE (V)
671 #DECL ((V) <OR VECTOR SYMTAB>)
673 <COND (<TYPE? .V VECTOR> <RETURN>)>
674 <PUT .V ,DEATH-LIST ()>
675 <SET V <NEXT-SYM .V>>>>
677 <DEFINE MRESTORE-L-D-STATE (L1 L2 V)
678 <RESTORE-L-D-STATE .L1 .V>
679 <RESTORE-L-D-STATE .L2 .V T>>
681 <DEFINE FREST-L-D-STATE (L)
685 #DECL ((LL) <LIST SYMTAB <LIST [REST NODE]>>)
686 <COND (<NOT <2 <TYPE-INFO <1 <2 .LL>>>>>
687 <PUT <1 .LL> ,DEATH-LIST <2 .LL>>)>>
690 <DEFINE RESTORE-L-D-STATE (L V "OPTIONAL" (FLG <>))
691 #DECL ((L) <LIST [REST <LIST SYMTAB LIST>]> (V) <OR SYMTAB VECTOR>)
694 #DECL ((DL) <LIST [REST NODE]>)
695 <COND (<TYPE? .V VECTOR> <RETURN>)>
696 <COND (<AND <NOT <EMPTY? <SET DL <DEATH-LIST .V>>>>
697 <NOT <2 <TYPE-INFO <1 .DL>>>>>
698 <PUT .V ,DEATH-LIST ()>)>
699 <SET V <NEXT-SYM .V>>>)>
701 #DECL ((DL) <LIST NODE> (S) SYMTAB)
702 <COND (<EMPTY? .L> <RETURN>)>
706 <COND (<==? .S .V> <RETURN>) (<TYPE? .V VECTOR> <RETURN>)>
712 <COND (<==? <NODE-TYPE .N> ,SET-CODE>
716 <SET V <NEXT-SYM .V>>>>
717 <COND (<NOT <2 <TYPE-INFO <1 <SET DL <2 <1 .L>>>>>>>
720 <COND (.FLG <LMERGE <DEATH-LIST .S> .DL>) (ELSE .DL)>>)>
723 <DEFINE SAVE-L-D-STATE (V)
724 #DECL ((V) <OR VECTOR SYMTAB>)
725 <REPEAT ((L (())) (LP .L) DL)
726 #DECL ((L LP) LIST (DL) <LIST [REST NODE]>)
727 <COND (<TYPE? .V VECTOR> <RETURN <REST .L>>)>
728 <COND (<AND <NOT <EMPTY? <SET DL <DEATH-LIST .V>>>>
729 <NOT <2 <CHTYPE <TYPE-INFO <1 .DL>> LIST>>>>
730 <SET LP <REST <PUTREST .LP ((.V .DL))>>>)>
731 <SET V <NEXT-SYM .V>>>>
733 <DEFINE MSAVE-L-D-STATE (L V)
734 #DECL ((V) <OR VECTOR SYMTAB> (L) LIST)
735 <REPEAT ((L (() !.L)) (LR .L) (LP <REST .L>) DL S TEM)
736 #DECL ((L LP LR TEM) LIST (S) SYMTAB (DL) <LIST [REST NODE]>)
738 <PUTREST .L <SAVE-L-D-STATE .V>>
740 (<TYPE? .V VECTOR> <RETURN <REST .LR>>)
741 (<AND <NOT <EMPTY? <SET DL <DEATH-LIST .V>>>>
742 <NOT <2 <TYPE-INFO <1 .DL>>>>>
743 <COND (<==? <SET S <1 <1 .LP>>> .V>
744 <SET TEM <LMERGE <2 <1 .LP>> .DL>>
746 <PUTREST .L <SET LP <REST .LP>>>)
749 <SET LP <REST <SET L .LP>>>)>)
751 <PUTREST .L <SET L ((.V .DL))>>
753 (<==? .V <1 <1 .LP>>> <SET LP <REST <SET L .LP>>>)>
754 <SET V <NEXT-SYM .V>>>>
756 <DEFINE LMERGE (L1 L2)
757 #DECL ((L1 L2) <LIST [REST NODE]>)
761 <COND (<OR <2 <TYPE-INFO .N>>
762 <AND <==? <NODE-TYPE .N> ,SET-CODE>
763 <NOT <MEMQ .N .L2>>>>
770 <COND (<OR <2 <TYPE-INFO .N>>
771 <==? <NODE-TYPE .N> ,SET-CODE>
776 <COND (<EMPTY? .L1> .L2)
777 (ELSE <PUTREST <REST .L1 <- <LENGTH .L1> 1>> .L2> .L1)>>
779 <DEFINE MAKE-DEAD (N SYM)
780 #DECL ((N) NODE (SYM) SYMTAB)
781 <PUT .SYM ,DEATH-LIST (.N)>>
783 <DEFINE KILL-REM (L V)
784 #DECL ((L) <LIST [REST SYMTAB]> (V) <OR SYMTAB VECTOR>)
787 <COND (<TYPE? .V VECTOR> <RETURN .L1>)>
788 <COND (<AND <NOT <SPEC-SYM .V>>
789 <N==? <CODE-SYM .V> -1>
792 <SET V <NEXT-SYM .V>>>>
794 <DEFINE SAVE-SURVIVORS (LS LI "OPTIONAL" (FLG <>))
795 #DECL ((LS) <LIST [REST <LIST SYMTAB LIST>]> (LI) <LIST [REST
799 <COND (<MEMQ <1 .LL> .LI>
803 <PUT <TYPE-INFO .N> 2 T>>
805 (.FLG <PUT <1 .LL> ,DEATH-LIST <2 .LL>>)>>
808 <DEFINE REVIVE (NOD SYM "AUX" (L <DEATH-LIST .SYM>))
809 #DECL ((L) <LIST [REST NODE]> (SYM) SYMTAB (NOD) NODE)
810 <COND (<AND <NOT <SPEC-SYM .SYM>> <N==? <CODE-SYM .SYM> -1>>
811 <COND (<EMPTY? .L> <SET LIFE (.SYM !.LIFE)>)
816 <PUT <TYPE-INFO .N> 2 T>>
818 <PUT .SYM ,DEATH-LIST (.NOD)>
819 <PUT .NOD ,TYPE-INFO (<> <>)>)>>
821 " Ananlyze a FORM that could really be an NTH."
823 <DEFINE FORM-F-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (OBJ <NODE-NAME .NOD>) TYP)
824 #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
825 <COND (<==? <ISTYPE? <SET TYP <ANA <1 .K> APPLICABLE>>> FIX>
826 <PUT .NOD ,KIDS (<2 .K> <1 .K> !<REST .K 2>)>
827 <COND (<==? <LENGTH .K> 2>
828 <SET RTYP <NTH-REST-ANA .NOD .RTYP ,NTH-CODE .TYP>>)
829 (ELSE <SET RTYP <PUT-ANA .NOD .RTYP ,PUT-CODE>>)>
830 <PUT .NOD ,NODE-SUBR <NODE-TYPE .NOD>>
832 <PUT .NOD ,NODE-NAME .OBJ>
833 <PUT .NOD ,NODE-TYPE ,FORM-F-CODE>
836 <SPECIALIZE <NODE-NAME .NOD>>
839 <PUT .NOD ,SIDE-EFFECTS (ALL)>
840 <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>)>>
842 " Further analyze a FORM."
844 <DEFINE FORM-AN (NOD RTYP)
846 <APPLY <OR <GETPROP <NODE-SUBR .NOD> ANALYSIS>
847 <GETPROP <TYPE <NODE-SUBR .NOD>> TANALYSIS>
852 <PUT .N ,SIDE-EFFECTS (ALL)>
853 <TYPE-OK? <RESULT-TYPE .N> .R>>>
857 "Determine if an ATOM is mainfest."
859 <DEFINE MANIFESTQ (ATM)
861 <AND <MANIFEST? .ATM> <GASSIGNED? .ATM> <NOT <TYPE? ,.ATM MSUBR>>>>
863 " Search for a decl associated with a local value."
865 <DEFINE SRCH-SYM (ATM "AUX" (TB .VARTBL))
866 #DECL ((ATM) ATOM (TB) <PRIMTYPE VECTOR>)
868 <COND (<EMPTY? .TB> <RETURN <>>)>
869 <COND (<==? .ATM <NAME-SYM .TB>> <RETURN .TB>)>
870 <SET TB <NEXT-SYM .TB>>>>
872 " Here to flush decls of specials for an external function call."
874 <DEFINE SPEC-FLUSH () <FLUSHER <>>>
876 " Here to flush decls when a PUT, PUTREST or external call happens."
878 <DEFINE PUT-FLUSH (TYP) <FLUSHER .TYP>>
880 <DEFINE FLUSHER (FLSFLG "AUX" (V .VARTBL))
881 #DECL ((SYM) SYMTAB (V) <OR SYMTAB VECTOR>)
887 (<AND <SET CT <CURRENT-TYPE <SET SYM .V>>>
888 <OR <AND <SPEC-SYM .SYM> <NOT .FLSFLG>>
891 <N==? .CT BOOL-FALSE>
894 <TYPE-OK? <CURRENT-TYPE .V> '<STRUCTURED ANY>>
895 <OR <==? .FLSFLG ALL>
896 <NOT <SET TEM <STRUCTYP <CURRENT-TYPE .V>>>>
897 <==? .TEM .FLSFLG>>>>>
899 .SYM <FLUSH-FIX-TYPE .SYM <CURRENT-TYPE .SYM> .FLSFLG>>)>
900 <COND (<EMPTY? <SET V <NEXT-SYM .V>>> <RETURN>)>>)
904 <COND (<EMPTY? <SET V <NEXT-SYM .V>>> <RETURN>)>>)>>
906 <DEFINE FLUSH-FIX-TYPE (SYM TY FLG "AUX" TEM)
909 <SET TEM <TOP-TYPE <TYPE-OK? .TY STRUCTURED>>>
910 <TYPE-OK? <COND (<SET TY <TYPE-OK? .TY '<NOT STRUCTURED>>>
911 <TYPE-MERGE .TEM .TY>)
916 " Punt forms with segments in them."
918 <DEFINE SEGFLUSH (NOD RTYP)
919 #DECL ((NOD) NODE (L) <LIST [REST NODE]>)
921 (<REPEAT ((L <KIDS .NOD>))
922 <AND <EMPTY? .L> <RETURN <>>>
923 <AND <==? <NODE-TYPE <1 .L>> ,SEGMENT-CODE> <RETURN T>>
926 <ADDVMESS .NOD ("Not open compiled due to SEGMENT.")>)>
927 <SUBR-C-AN .NOD .RTYP>)>>
929 " Determine if the arg to STACKFORM is a SUBR."
931 <DEFINE APPLTYP (NOD "AUX" (NT <NODE-TYPE .NOD>) ATM TT)
932 #DECL ((ATM) ATOM (NOD TT) NODE (NT) FIX)
933 <COND (<==? .NT ,GVAL-CODE>
934 <COND (<AND <==? <NODE-TYPE <SET TT <1 <KIDS .NOD>>>>
936 <GASSIGNED? <SET ATM <NODE-NAME .TT>>>
942 " Return type returned by a SUBR."
944 <DEFINE SUBR-TYPE (SUB "AUX" TMP)
946 <SET TMP <2 <GET-TMP .SUB>>>
947 <COND (<TYPE? .TMP ATOM FORM> .TMP) (ELSE ANY)>>
949 " Access the SUBR data base for return type."
951 <DEFINE GET-TMP (SUB "AUX" (LS <MEMQ .SUB ,SUBRS>))
952 #DECL ((VALUE) <LIST ANY ANY>)
953 <COND (.LS <NTH ,TEMPLATES <LENGTH .LS>>) (ELSE '(ANY ANY))>>
957 <DEFINE GVAL-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM TT TEM1)
958 #DECL ((NOD TEM) NODE (TT) <VECTOR VECTOR ATOM ANY> (LN) FIX)
960 (<SEGFLUSH .NOD .RTYP>)
962 <ARGCHK .LN 1 GVAL .NOD>
963 <PUT .NOD ,NODE-TYPE ,FGVAL-CODE>
964 <EANA <1 .K> ATOM GVAL>
965 <COND (<AND <==? <NODE-TYPE <SET TEM <1 .K>>> ,QUOTE-CODE>
966 <==? <RESULT-TYPE .TEM> ATOM>>
967 <PUT .NOD ,NODE-TYPE ,GVAL-CODE>
968 <COND (<MANIFEST? <SET TEM1 <NODE-NAME .TEM>>>
969 <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
970 <PUT .NOD ,NODE-NAME ,.TEM1>
972 <TYPE-OK? <GEN-DECL ,.TEM1> .RTYP>)
973 (<AND <GBOUND? .TEM1>
974 <COND (<GASSIGNED? GLOC>
975 <SET TEM1 <GET-DECL <GLOC .TEM1>>>)
976 (ELSE <SET TEM1 <GET-DECL <GBIND .TEM1>>>)>>
977 <TYPE-OK? .TEM1 .RTYP>)
978 (ELSE <TYPE-OK? ANY .RTYP>)>)
979 (ELSE <TYPE-OK? ANY .RTYP>)>)>>
981 <COND (<GASSIGNED? GVAL-ANA> <PUTPROP ,GVAL ANALYSIS ,GVAL-ANA>)>
983 <DEFINE GASSIGNED?-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>)
984 (NM <NODE-NAME .NOD>))
985 #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX)
986 <COND (<SEGFLUSH .NOD .RTYP>)
988 <ARGCHK .LN 1 .NM .NOD>
989 <PUT .NOD ,NODE-TYPE ,GASSIGNED?-CODE>
990 <EANA <1 .K> ATOM .NM>)>
991 <TYPE-OK? '<OR ATOM FALSE> .RTYP>>
993 <COND (<GASSIGNED? GASSIGNED?-ANA>
994 <PUTPROP ,GASSIGNED? ANALYSIS ,GASSIGNED?-ANA>)>
996 <COND (<AND <GASSIGNED? GBOUND?> <GASSIGNED? GASSIGNED?-ANA>>
997 <PUTPROP ,GBOUND? ANALYSIS ,GASSIGNED?-ANA>)>
999 " Analyze SETG usage."
1001 <DEFINE SETG-ANA (NOD RTYP
1002 "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM TT T1 TTT)
1003 #DECL ((NOD TEM) NODE (K) <LIST [REST NODE]> (LN) FIX (TT) VECTOR)
1005 (<SEGFLUSH .NOD .RTYP>)
1007 <ARGCHK .LN '(2 3) SETG .NOD>
1008 <PUT .NOD ,NODE-TYPE ,FSETG-CODE>
1009 <EANA <SET TEM <1 .K>> ATOM SETG>
1010 <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
1011 <COND (<==? <NODE-TYPE .TEM> ,QUOTE-CODE>
1012 <COND (<MANIFEST? <SET TTT <NODE-NAME .TEM>>>
1013 <COMPILE-WARNING "SETGing manifest GVAL? " .TTT .NOD>)>
1014 <PUT .NOD ,NODE-TYPE ,SETG-CODE>
1015 <COND (<AND <GBOUND? .TTT>
1016 <COND (<GASSIGNED? GLOC>
1017 <SET T1 <GET-DECL <GLOC .TTT>>>)
1018 (ELSE <SET T1 <GET-DECL <GBIND .TTT>>>)>>
1019 <COND (<NOT <ANA <2 .K> .T1>>
1020 <COMPILE-ERROR "GLOBAL declaration violation"
1023 <SET TTT <TYPE-OK? .T1 .RTYP>>)
1025 <SET TTT <ANA <2 .K> ANY>>
1026 <SET TTT <TYPE-OK? .TTT .RTYP>>)>)
1027 (ELSE <SET TTT <ANA <2 .K> ANY>> <SET TTT <TYPE-OK? .TTT .RTYP>>)>
1028 <COND (<==? .LN 3> <EANA <3 .K> ANY SETG>)>
1031 <COND (<GASSIGNED? SETG-ANA> <PUTPROP ,SETG ANALYSIS ,SETG-ANA>)>
1033 <DEFINE BUILD-TYPE-LIST (V "OPT" (ALL T))
1034 #DECL ((V) <OR VECTOR SYMTAB> (VALUE) LIST)
1036 <REPEAT ((L (())) (LP .L) TEM)
1038 <COND (<EMPTY? .V> <RETURN <REST .L>>)
1039 (<N==? <CODE-SYM .V> -1>
1040 <SET TEM <GET-CURRENT-TYPE .V>>
1041 <COND (<OR .ALL <N==? .TEM NO-RETURN>>
1042 <SET LP <REST <PUTREST .LP ((.V .TEM T))>>>)>)>
1043 <SET V <NEXT-SYM .V>>>)
1046 <DEFINE RESET-VARS (V "OPTIONAL" (VL '[]) (FLG <>))
1047 #DECL ((V VL) <OR SYMTAB VECTOR>)
1049 <COND (<==? .V .VL> <SET FLG T>)>
1050 <COND (<EMPTY? .V> <RETURN>)
1052 <PUT .V ,CURRENT-TYPE <>>
1053 <PUT .V ,COMPOSIT-TYPE ANY>)>
1054 <PUT .V ,DEATH-LIST ()>
1055 <SET V <NEXT-SYM .V>>>>
1057 <DEFINE GET-CURRENT-TYPE (SYM)
1058 #DECL ((SYM) SYMTAB)
1059 <COND (<AND .ANALY-OK <CURRENT-TYPE .SYM>>) (ELSE <DECL-SYM .SYM>)>>
1061 <DEFINE SET-CURRENT-TYPE (SYM ITYP "AUX" (OTYP <DECL-SYM .SYM>))
1062 #DECL ((SYM) SYMTAB)
1063 <COND (<AND .ANALY-OK <N==? <CODE-SYM .SYM> -1>>
1064 <PUT .SYM ,CURRENT-TYPE <TYPE-AND .ITYP .OTYP>>
1067 <TYPE-MERGE .ITYP <COMPOSIT-TYPE .SYM>>>)
1069 <PUT .SYM ,CURRENT-TYPE <>>
1070 <PUT .SYM ,COMPOSIT-TYPE .OTYP>)>>
1072 <DEFINE ANDUPC (V L)
1073 #DECL ((V) <OR VECTOR SYMTAB> (L) <LIST [REST <LIST SYMTAB ANY ANY>]>)
1075 <COND (<EMPTY? .V> <RETURN>)>
1076 <COND (<AND <SET TMP <CURRENT-TYPE .V>> <N==? .TMP NO-RETURN>>
1077 <SET L <ADD-TYPE-LIST .V <CURRENT-TYPE .V> .L T>>)>
1078 <SET V <NEXT-SYM .V>>>
1081 <DEFINE ANDUP (FROM TO)
1082 #DECL ((TO FROM) <LIST [REST <LIST SYMTAB ANY ANY>]>)
1084 <FUNCTION (L) <SET TO <ADD-TYPE-LIST <1 .L> <2 .L> .TO T>>>
1088 <DEFINE ORUPC (V L "AUX" WIN)
1089 #DECL ((V) <OR VECTOR SYMTAB> (L) <LIST [REST <LIST SYMTAB ANY ANY>]>)
1093 <COND (<TYPE? .V VECTOR> <RETURN>)>
1097 #DECL ((LL) <LIST SYMTAB <OR ATOM FORM SEGMENT> ANY>)
1098 <COND (<==? <1 .LL> .V>
1099 <PUT .LL 2 <TYPE-MERGE <2 .LL> <GET-CURRENT-TYPE .V>>>
1101 <MAPLEAVE <SET WIN T>>)>>
1103 <COND (<AND <NOT .WIN> <CURRENT-TYPE .V>>
1104 <SET L ((.V <DECL-SYM .V> T) !.L)>)>
1105 <SET V <NEXT-SYM .V>>>)>
1108 <DEFINE ORUP (FROM TO "AUX" NDECL (TOTUP <STACK <VECTOR !.TO>>))
1110 <LIST [REST <LIST SYMTAB <OR ATOM FORM SEGMENT> <OR ATOM FALSE>>]>
1111 (TOTUP) <<PRIMTYPE VECTOR>
1112 [REST <OR <LIST SYMTAB <OR ATOM FORM SEGMENT>
1116 <OR ATOM FORM SEGMENT>)
1118 <FUNCTION (L "AUX" (SYM <1 .L>) (WIN <>))
1120 <FUNCTION (TP "AUX" (LL <1 .TP>))
1121 <COND (<AND .LL <==? <1 .LL> .SYM>>
1122 <SET NDECL <TYPE-MERGE <2 .LL> <2 .L>>>
1126 <MAPLEAVE <SET WIN T>>)>>
1131 <TYPE-MERGE <GET-CURRENT-TYPE .SYM> <2 .L>>
1136 <FUNCTION (LL) #DECL ((LL) <OR FALSE LIST>)
1138 <PUT .LL 2 <TYPE-MERGE <GET-CURRENT-TYPE <1 .LL>>
1143 <DEFINE ASSERT-TYPES (L)
1144 #DECL ((L) <LIST [REST <LIST SYMTAB ANY ANY>]>)
1145 <MAPF <> <FUNCTION (LL) <SET-CURRENT-TYPE <1 .LL> <2 .LL>>> .L>>
1147 <DEFINE ADD-TYPE-LIST (SYM NDECL INF MUNG
1148 "OPTIONAL" (NTH-REST ())
1149 "AUX" (WIN <>) (OD <GET-CURRENT-TYPE .SYM>))
1150 #DECL ((SYM) SYMTAB (INF) LIST (NTH-REST) <LIST [REST ATOM FIX]>
1151 (NDECL) <OR ATOM FALSE FORM SEGMENT> (MUNG) <OR ATOM FALSE>)
1153 <SET NDECL <TYPE-NTH-REST .NDECL .NTH-REST>>
1156 #DECL ((L) <LIST SYMTAB ANY>)
1157 <COND (<==? <1 .L> .SYM>
1159 <COND (.MUNG <TYPE-AND .NDECL .OD>)
1160 (ELSE <TYPE-AND .NDECL <2 .L>>)>>
1163 <MAPLEAVE <SET WIN T>>)>>
1166 <SET NDECL <TYPE-AND .NDECL .OD>>
1167 <SET INF ((.SYM .NDECL .MUNG) !.INF)>)>)>
1170 <DEFINE TYPE-NTH-REST (NDECL NTH-REST)
1171 #DECL ((NTH-REST) <LIST [REST ATOM FIX]>)
1172 <REPEAT ((FIRST T) (NUM 0))
1174 <COND (<EMPTY? .NTH-REST> <RETURN .NDECL>)>
1175 <COND (<==? <1 .NTH-REST> NTH>
1178 !<COND (<0? <SET NUM
1179 <+ .NUM <2 .NTH-REST> -1>>>
1182 (ELSE ([.NUM ANY]))>
1186 (.FIRST <SET NDECL <REST-DECL .NDECL <2 .NTH-REST>>>)
1187 (ELSE <SET NUM <+ .NUM <2 .NTH-REST>>>)>
1188 <SET NTH-REST <REST .NTH-REST 2>>>>
1190 " AND/OR analyzer. Called from AND-ANA and OR-ANA."
1192 <DEFINE BOOL-AN (NOD RTYP ORER
1193 "AUX" (L <KIDS .NOD>) FTYP FTY
1195 <COND (<TYPE-OK? .RTYP FALSE> .RTYP)
1196 (ELSE <FORM OR .RTYP FALSE>)>)
1197 (FLG <==? .PRED <PARENT .NOD>>) (SINF ()) STR SUNT
1198 (FIRST T) FNOK NFNOK PASS)
1199 #DECL ((NOD) NODE (L) <LIST [REST NODE]> (ORER RTYP) ANY (FTYP) FORM
1200 (STR SINF SUNT) LIST)
1201 <PROG ((TRUTH ()) (UNTRUTH ()) (PRED .NOD) L-D)
1202 #DECL ((TRUTH UNTRUTH) <SPECIAL LIST> (PRED) <SPECIAL ANY> (L-D) LIST)
1204 (<EMPTY? .L> <SET FTYP <TYPE-OK? FALSE .RTYP>>)
1208 <FUNCTION (N "AUX" (LAST <EMPTY? <REST .N>>) TY)
1209 #DECL ((N) <LIST NODE>)
1210 <COND (<AND .LAST <NOT .FLG>> <SET PRED <>>)>
1211 <SET TY <ANA <1 .N> <COND (.LAST .RTYP) (.ORER .RTY) (ELSE ANY)>>>
1212 ; "FNOK seems to mean that this clause of the boolean can't
1213 return false; NFNOK means it always returns false"
1214 <SET FNOK <OR <==? .TY NO-RETURN> <NOT <TYPE-OK? .TY FALSE>>>>
1215 <SET NFNOK <==? FALSE <ISTYPE? .TY>>>
1216 ; "Therefore, PASS means this clause's result doesn't need to be
1217 tested, because we'll always go to the next clause."
1218 <SET PASS <COND (.ORER .NFNOK) (ELSE .FNOK)>>
1221 <COMPILE-WARNING "OR/AND clause returns wrong type: "
1224 (<COND (.ORER .FNOK) (ELSE .NFNOK)>
1225 ; "If OR, and FNOK, this will terminate the whole thing, etc..."
1227 (<AND .VERBOSE <NOT .LAST>>
1229 ("This object prematurely ends AND/OR: "
1231 !<COND (<==? .TY NO-RETURN> '(" it never returns "))
1232 (ELSE (" its type is: " .TY))>)>)>
1235 (<AND <N==? .TY NO-RETURN> <NOT .PASS>>
1236 ; "This clause actually returns an interesting condition..."
1238 <SET L-D <SAVE-L-D-STATE .VARTBL>>
1239 <SET STR <ANDUP <COPY-TYPE-LIST .TRUTH>
1240 <BUILD-TYPE-LIST .VARTBL <>>>>
1241 <SET SUNT <ANDUP <COPY-TYPE-LIST .UNTRUTH>
1242 <BUILD-TYPE-LIST .VARTBL <>>>>
1244 <ANDUP <COND (.ORER .TRUTH) (ELSE .UNTRUTH)>
1245 <BUILD-TYPE-LIST .VARTBL>>>)
1247 <SET L-D <MSAVE-L-D-STATE .L-D .VARTBL>>
1249 <SET SUNT <ANDUP .UNTRUTH <ANDUPC .VARTBL .SUNT>>>
1250 <SET STR <ORUP .STR .TRUTH>>)
1252 <SET SUNT <ORUP .SUNT .UNTRUTH>>
1253 <SET STR <ANDUP .TRUTH <ANDUPC .VARTBL .STR>>>)>
1255 <ORUP <COND (.ORER .TRUTH) (ELSE .UNTRUTH)>
1256 <ORUPC .VARTBL .SINF>>>)>
1259 <COND (.ORER <SET SUNT <ANDUPC .VARTBL .SUNT>>)
1260 (ELSE <SET STR <ANDUPC .VARTBL .STR>>)>
1261 <SET SINF <ORUPC .VARTBL .SINF>>)
1263 <SET STR <ANDUP <COPY-TYPE-LIST .TRUTH>
1264 <BUILD-TYPE-LIST .VARTBL <>>>>
1265 <SET SUNT <ANDUP <COPY-TYPE-LIST .UNTRUTH>
1266 <BUILD-TYPE-LIST .VARTBL <>>>>
1267 <SET SINF <ANDUP <COND (.ORER .TRUTH) (T .UNTRUTH)>
1268 <BUILD-TYPE-LIST .VARTBL>>>
1270 <ASSERT-TYPES <COND (.ORER .SUNT) (ELSE .STR)>>
1271 <SET TRUTH <SET UNTRUTH ()>>
1272 <OR .FIRST <RESTORE-L-D-STATE .L-D .VARTBL>>
1273 <COND (<==? .TY NO-RETURN>
1275 <COMPILE-WARNING "AND/OR clause is unreachable: "
1278 <ASSERT-TYPES .SINF>
1279 <MAPSTOP NO-RETURN>)
1280 (.LAST <ASSERT-TYPES <ORUPC .VARTBL .SINF>> <MAPSTOP .TY>)
1281 (<AND .ORER .NFNOK> <MAPRET>)
1286 <COND (<AND .FNOK .ORER> <SET FTY <TYPE-OK? .FTY '<NOT FALSE>>>)>)>>
1287 <COND (.FLG <SET TRUTH .STR> <SET UNTRUTH .SUNT>)>
1290 <DEFINE COPY-TYPE-LIST (L)
1294 #DECL ((LL) <LIST ANY ANY ANY>)
1295 (<1 .LL> <2 .LL> <3 .LL>)>
1298 <DEFINE AND-ANA (NOD RTYP)
1300 <PUT .NOD ,NODE-TYPE ,AND-CODE>
1301 <BOOL-AN .NOD .RTYP <>>>
1303 <COND (<GASSIGNED? AND-ANA> <PUTPROP ,AND ANALYSIS ,AND-ANA>)>
1305 <DEFINE OR-ANA (NOD RTYP)
1307 <PUT .NOD ,NODE-TYPE ,OR-CODE>
1308 <BOOL-AN .NOD .RTYP T>>
1310 <COND (<GASSIGNED? OR-ANA> <PUTPROP ,OR ANALYSIS ,OR-ANA>)>
1314 <DEFINE CASE-ANA (N R) <COND-CASE .N .R T>>
1316 <DEFINE COND-ANA (N R) <COND-CASE .N .R <>>>
1319 <DEFINE COND-CASE (NOD RTYP CASE?
1320 "AUX" (L <KIDS .NOD>) (FIRST T) (LAST <>) TT FNOK NFNOK STR
1321 SUNT (FIRST1 T) PRAT (DFLG <>) TST-TYP SVWHO
1322 (PRED-FLG <==? .PRED <PARENT .NOD>>))
1323 #DECL ((NOD) NODE (L) <LIST [REST NODE]> (RTYP) ANY)
1324 <PROG ((TRUTH ()) (UNTRUTH ()) (TINF1 ()) (TINF ()) L-D L-D1 (PRED .PRED))
1325 #DECL ((TRUTH UNTRUTH) <SPECIAL LIST> (TINF1 TINF L-D L-D1) LIST
1326 (PRED) <SPECIAL <OR FALSE NODE>>)
1328 (<EMPTY? .L> <TYPE-OK? FALSE .RTYP>)
1331 <SET PRAT <NODE-NAME <1 <KIDS <1 .L>>>>>
1332 <PROG ((WHON .NOD) (WHO ()))
1333 #DECL ((WHO) <SPECIAL LIST> (WHON) <SPECIAL NODE>)
1334 <SET TST-TYP <EANA <2 .L> ANY CASE>>
1336 <SET L <REST .L 2>>)>
1339 <FUNCTION (BRN "AUX" (BR <1 .BRN>) (EC T) STR1 SUNT1)
1340 #DECL ((BRN) <LIST NODE> (BR) NODE)
1341 <COND (<N==? <NODE-TYPE .BR> ,QUOTE-CODE>
1342 <PUT .BR ,SIDE-EFFECTS <>>)>
1344 <COND (<AND .CASE? <==? <NODE-TYPE .BR> ,QUOTE-CODE> <SET DFLG T>>
1346 <COND (<NOT <PREDIC .BR>>
1347 <COMPILE-ERROR "Empty COND clause: " .BR>)>
1348 <SET UNTRUTH <SET TRUTH ()>>
1349 <SET LAST <EMPTY? <REST .BRN>>>
1351 <COND (<NOT <EMPTY? <CLAUSES .BR>>> <SET EC <>> ANY)
1353 (ELSE <TYPE-MERGE .RTYP FALSE>)>>
1356 <SPEC-ANA <NODE-NAME <CHTYPE <PREDIC .BR> NODE>>
1363 (ELSE <ANA <PREDIC .BR> .TT>)>>
1364 <SET DFLG <SET PRED <>>>
1365 <SET FNOK <OR <==? .TT NO-RETURN> <NOT <TYPE-OK? .TT FALSE>>>>
1366 <SET NFNOK <==? <ISTYPE? .TT> FALSE>>
1373 ("Cond predicate always FALSE: "
1375 !<COND (<EMPTY? <CLAUSES .BR>> ())
1376 (ELSE (" and non-reachable code in clause."))>)>)>
1378 (<AND .FNOK <NOT .LAST>>
1381 ("Cond ended prematurely because predicate always true: "
1386 <SET STR1 <ANDUP <COPY-TYPE-LIST .TRUTH>
1387 <BUILD-TYPE-LIST .VARTBL <>>>>
1388 <SET SUNT1 <ANDUP <COPY-TYPE-LIST .UNTRUTH>
1389 <BUILD-TYPE-LIST .VARTBL <>>>>)>
1390 <COND (<NOT <OR .FNOK <AND <NOT .LAST> .NFNOK>>>
1391 <SET L-D <SAVE-L-D-STATE .VARTBL>>
1394 <ANDUP .UNTRUTH <BUILD-TYPE-LIST .VARTBL>>>)
1396 <SET TINF <ANDUP .UNTRUTH <ORUPC .VARTBL .TINF>>>)>
1397 <COND (<NOT .EC> <ASSERT-TYPES .TRUTH>)>
1399 <COND (<AND <NOT .NFNOK>
1400 <OR .EC <SET TT <SEQ-AN <CLAUSES .BR>
1402 <COND (<N==? .TT NO-RETURN>
1409 <SET STR <ORUP .STR .STR1>>
1411 <ANDUP .SUNT .SUNT1>>)>)
1415 <ANDUPC .VARTBL .STR1>>>
1416 <SET SUNT <ORUP .SUNT1 .UNTRUTH>>)
1423 <ORUP .SUNT1 .UNTRUTH>>>)>)>
1425 <SET TINF1 <BUILD-TYPE-LIST .VARTBL>>
1426 <SET L-D1 <SAVE-L-D-STATE .VARTBL>>)
1428 <SET TINF1 <ORUPC .VARTBL .TINF1>>
1429 <SET L-D1 <MSAVE-L-D-STATE .L-D1 .VARTBL>>)>
1431 <OR .FIRST <RESTORE-L-D-STATE .L-D .VARTBL>>
1433 <AND <NOT .FNOK> <SET TT <TYPE-MERGE .TT FALSE>>>)
1434 (.EC <SET TT <TYPE-OK? .TT '<NOT FALSE>>>)>)
1435 (.NFNOK <SET TT FALSE>)>
1436 <UPDATE-SIDE-EFFECTS .BR .NOD>
1438 (<AND <OR .LAST .FNOK> .TT>
1440 <ASSERT-TYPES .TINF1>
1441 <OR .FIRST1 <RESTORE-L-D-STATE .L-D1 .VARTBL>>)
1444 <ASSERT-TYPES .TINF>
1445 <OR .FIRST <RESTORE-L-D-STATE .L-D .VARTBL>>)
1447 <ASSERT-TYPES <ORUP .TINF .TINF1>>
1448 <MRESTORE-L-D-STATE .L-D1 .L-D .VARTBL>)>)>
1450 (.TT <ASSERT-TYPES .TINF> .TT)
1452 (ELSE <ASSERT-TYPES .TINF> <MAPRET>)>>
1456 <SET UNTRUTH .SUNT>)>
1459 " PROG/REPEAT analyzer. Hacks bindings and sets up info for GO/RETURN/AGAIN
1462 <DEFINE PRG-REP-ANA (PPNOD RT
1463 "AUX" (OV .VARTBL) (VARTBL <SYMTAB .PPNOD>) TT L-D
1464 (OPN <AND <ASSIGNED? PNOD> .PNOD>) PNOD PRTYP)
1465 #DECL ((PNOD) <SPECIAL NODE> (VARTBL) <SPECIAL SYMTAB> (OV) SYMTAB
1466 (L-D) LIST (PPNOD) NODE)
1467 <COND (<N==? <NODE-SUBR .PPNOD> ,BIND> <SET PNOD .PPNOD>)
1468 (.OPN <SET PNOD .OPN>)>
1469 <PROG ((TMPS 0) (HTMPS 0) (ACT? <ACTIV? <BINDING-STRUCTURE .PPNOD> T>))
1470 #DECL ((TMPS HTMPS) <SPECIAL FIX>)
1471 <BIND-AN <BINDING-STRUCTURE .PPNOD>>
1472 <SET L-D <SAVE-L-D-STATE .VARTBL>>
1473 <RESET-VARS .VARTBL .OV T>
1474 <COND (<NOT <SET PRTYP <TYPE-OK? .RT <INIT-DECL-TYPE .PPNOD>>>>
1476 "Required type of PROG/REPEAT call violates its decl."
1479 " and value decl is "
1480 <INIT-DECL-TYPE .PPNOD>>)>
1481 <PUT .PPNOD ,RESULT-TYPE .PRTYP>
1482 <PROG ((STMPS .TMPS) (SHTMPS .HTMPS) (LL .LIFE) (OV .VERBOSE))
1483 #DECL ((STMPS SHTMPS) FIX (LL LIFE) LIST)
1484 <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
1485 <MUNG-L-D-STATE .VARTBL>
1487 <PUT .PPNOD ,AGND <>>
1488 <PUT .PPNOD ,DEAD-VARS ()>
1489 <PUT .PPNOD ,VSPCD ()>
1490 <PUT .PPNOD ,LIVE-VARS ()>
1493 <PUT .PPNOD ,ASSUM <BUILD-TYPE-LIST .VARTBL>>
1494 <PUT .PPNOD ,ACCUM-TYPE NO-RETURN>
1496 <SEQ-AN <KIDS .PPNOD>
1497 <COND (<N==? <NODE-SUBR .PPNOD> ,REPEAT> .PRTYP)
1499 <COND (.ACT? <SPEC-FLUSH> <PUT-FLUSH ALL>)>
1501 (<OR .ACT? <==? <NODE-SUBR .PPNOD> ,REPEAT> <AGND .PPNOD>>
1503 (<NOT <ASSUM-OK? <ASSUM .PPNOD>
1504 <COND (<AND <N==? <NODE-SUBR .PPNOD> ,REPEAT>
1508 <ORUPC .VARTBL <CHTYPE <AGND .PPNOD> LIST>>)
1509 (ELSE <BUILD-TYPE-LIST .VARTBL>)>>>
1511 (<AND <NOT .ACT?> <SET ACT? <ACTIV? <BINDING-STRUCTURE .PPNOD> T>>>
1512 <ASSERT-TYPES <ASSUM .PPNOD>>
1514 <COND (<==? <NODE-SUBR .PPNOD> ,REPEAT>
1515 <COND (<AGND .PPNOD>
1518 <MSAVE-L-D-STATE <LIVE-VARS .PPNOD> .VARTBL>>)
1519 (ELSE <PUT .PPNOD ,LIVE-VARS <SAVE-L-D-STATE .VARTBL>>)>)>
1520 <SAVE-SURVIVORS .L-D .LIFE T>
1521 <SAVE-SURVIVORS <LIVE-VARS .PPNOD> .LIFE>
1523 <COMPILE-ERROR "PROG/REPEAT returns incorrect type "
1526 <COND (<NOT <OR <==? .TT NO-RETURN> <==? <NODE-SUBR .PPNOD> ,REPEAT>>>
1529 <MSAVE-L-D-STATE <DEAD-VARS .PPNOD> .VARTBL>>
1530 <COND (<N==? <ACCUM-TYPE .PPNOD> NO-RETURN>
1531 <ASSERT-TYPES <ORUPC .VARTBL <VSPCD .PPNOD>>>)>)
1532 (<N==? <ACCUM-TYPE .PPNOD> NO-RETURN>
1533 <ASSERT-TYPES <VSPCD .PPNOD>>)>
1534 <FREST-L-D-STATE <DEAD-VARS .PPNOD>>
1535 <SET LIFE <KILL-REM .LIFE .OV>>
1538 <COND (.ACT? <PUT .PPNOD ,SIDE-EFFECTS (ALL)> .PRTYP)
1539 (<==? <NODE-SUBR .PPNOD> ,REPEAT> <ACCUM-TYPE .PPNOD>)
1540 (ELSE <TYPE-MERGE .TT <ACCUM-TYPE .PPNOD>>)>>>
1541 <ACCUM-TYPE .PPNOD>>
1543 " Determine if assumptions made for this loop are still valid."
1545 <DEFINE ASSUM-OK? (AS TY "AUX" (OK? T))
1546 #DECL ((TY AS) <LIST [REST <LIST SYMTAB ANY ANY>]>)
1550 <FUNCTION (L "AUX" (SYM <1 .L>) (TT <>))
1551 #DECL ((L) <LIST SYMTAB <OR ATOM FORM SEGMENT>>)
1556 <COND (<AND <SET TT <==? <1 .LL> .SYM>>
1557 <N=? <2 .L> <2 .LL>>
1558 <OR <==? <2 .L> NO-RETURN>
1559 <TYPE-OK? <2 .LL> <NOTIFY <2 .L>>>>>
1561 <SET BACKTRACK <+ .BACKTRACK 1>>
1563 <UPDATE-STATUS "Comp" <> "ANA"
1566 <AND <GASSIGNED? DEBUGSW>
1568 <PRIN1 <NAME-SYM .SYM>>
1569 <PRINC " NOT OK current type: ">
1571 <PRINC " assumed type: ">
1575 <PUT .L 2 <TYPE-MERGE <2 .LL> <2 .L>>>
1579 <COND (<NOT .OK?> <ASSERT-TYPES .AS>)>)>
1583 <COND (<AND <TYPE? .D FORM> <==? <LENGTH .D> 2> <==? <1 .D> NOT>>
1585 (ELSE <FORM NOT .D>)>>
1587 " Analyze RETURN from a PROG/REPEAT. Check with PROGs final type."
1589 <DEFINE RETURN-ANA (NOD RTYP "AUX" (TT <KIDS .NOD>) N (LN <LENGTH .TT>) TEM)
1590 #DECL ((NOD) NODE (TT) <LIST [REST NODE]> (LN) FIX (N) <OR NODE
1592 <SET RET-OR-AGAIN T>
1593 <COND (<G? .LN 2> <COMPILE-ERROR "Too many args to RETURN." .NOD>)
1594 (<OR <AND <==? .LN 2> <SET N <ACT-CHECK <2 .TT>>>>
1595 <AND <L=? .LN 1> <SET N <PROGCHK RETURN .NOD>>>>
1596 <SET N <CHTYPE .N NODE>>
1600 <SET TT (<NODE1 ,QUOTE-CODE .NOD ATOM T ()>)>>>
1601 <SET TEM <EANA <1 .TT> <INIT-DECL-TYPE .N> RETURN>>
1602 <COND (<==? <ACCUM-TYPE .N> NO-RETURN>
1603 <PUT .N ,VSPCD <BUILD-TYPE-LIST <SYMTAB .N>>>
1604 <PUT .N ,DEAD-VARS <SAVE-L-D-STATE .VARTBL>>)
1606 <PUT .N ,VSPCD <ORUPC <SYMTAB .N> <VSPCD .N>>>
1609 <MSAVE-L-D-STATE <DEAD-VARS .N> .VARTBL>>)>
1610 <PUT .N ,ACCUM-TYPE <TYPE-MERGE .TEM <ACCUM-TYPE .N>>>
1611 <PUT .NOD ,NODE-TYPE ,RETURN-CODE>
1613 (ELSE <SUBR-C-AN .NOD ANY>)>>
1615 <COND (<GASSIGNED? RETURN-ANA> <PUTPROP ,RETURN ANALYSIS ,RETURN-ANA>)>
1617 <DEFINE MULTI-RETURN-ANA (NOD RTYP
1618 "AUX" (TT <KIDS .NOD>) N (LN <LENGTH .TT>) TEM
1619 (SEG <>) (TYPS <FORM MULTI>)
1620 (TP <CHTYPE .TYPS LIST>))
1621 #DECL ((NOD) NODE (TT) <LIST [REST NODE]> (LN) FIX (N) <OR NODE
1623 <COND (<L? .LN 1> <COMPILE-ERROR "Too few args to MULTI-RETURN." .NOD>)
1625 <COND (<AND <==? <NODE-TYPE <SET N <1 .TT>>> ,QUOTE-CODE>
1626 <==? <NODE-NAME .N> <>>>
1627 <SET N <PROGCHK MULTI-RETURN .N>>)
1628 (<SET N <ACT-CHECK .N>>)
1629 (ELSE <EANA <1 .TT> '<OR FRAME T$FRAME> MULTI-RETURN>)>
1631 <FUNCTION (NP "AUX" (NN <1 .NP>) TY)
1633 <COND (<==? <NODE-TYPE .NN> ,SEGMENT-CODE>
1635 <EANA <1 <KIDS .NN>>
1636 '<OR MULTI STRUCTURED>
1638 <COND (<AND <N==? .TY ANY>
1640 <GET-ELE-TYPE .TY ALL>>
1642 <COND (<AND <NOT .SEG>
1643 <EMPTY? <REST .NP>>>
1644 <PUTREST .TP ([REST .TY])>)
1645 (<AND <EMPTY? <REST .NP>>
1653 <TYPE-MERGE .SEG .TY>>)>)
1654 (ELSE <SET SEG ANY>)>)
1656 <SET TY <EANA .NN ANY MULTI-RETURN>>
1658 <PUTREST .TP <SET TP (.TY)>>)>)>>
1660 <COND (<AND .N <==? <ACCUM-TYPE .N> NO-RETURN>>
1661 <PUT .N ,VSPCD <BUILD-TYPE-LIST <SYMTAB .N>>>
1662 <PUT .N ,DEAD-VARS <SAVE-L-D-STATE .VARTBL>>)
1664 <PUT .N ,VSPCD <ORUPC <SYMTAB .N> <VSPCD .N>>>
1667 <MSAVE-L-D-STATE <DEAD-VARS .N> .VARTBL>>)>
1668 <COND (.N <PUT .N ,ACCUM-TYPE <TYPE-MERGE .TYPS
1670 <PUT .NOD ,NODE-TYPE ,MULTI-RETURN-CODE>
1673 <COND (<AND <GASSIGNED? MULTI-RETURN> <GASSIGNED? MULTI-RETURN-ANA>>
1674 <PUTPROP ,MULTI-RETURN ANALYSIS ,MULTI-RETURN-ANA>)>
1676 <DEFINE ACT-CHECK (N "OPT" (RETMNG T) "AUX" SYM RAO N1 (NT <NODE-TYPE .N>))
1677 #DECL ((N N1) NODE (SYM) <OR SYMTAB FALSE> (RAO VALUE) <OR FALSE NODE>
1679 <COND (<OR <AND <==? .NT ,LVAL-CODE>
1680 <TYPE? <NODE-NAME .N> SYMTAB>
1681 <PURE-SYM <SET SYM <NODE-NAME .N>>>
1682 <==? <CODE-SYM .SYM> 1>>
1683 <AND <OR <==? .NT ,RSUBR-CODE> <==? .NT ,SUBR-CODE>>
1684 <==? <NODE-SUBR .N> ,LVAL>
1685 <==? <LENGTH <KIDS .N>> 1>
1686 <==? <NODE-TYPE <SET N1 <1 <KIDS .N>>>> ,QUOTE-CODE>
1687 <TYPE? <NODE-NAME .N1> ATOM>
1688 <SET SYM <SRCH-SYM <NODE-NAME .N1>>>
1690 <==? <CODE-SYM .SYM> 1>>>
1691 <SET RAO <RET-AGAIN-ONLY <CHTYPE .SYM SYMTAB>>>
1692 <EANA .N FRAME AGAIN-RETURN>
1693 <COND (.RETMNG <PUT <CHTYPE .SYM SYMTAB> ,RET-AGAIN-ONLY .RAO>)>
1698 <DEFINE AGAIN-ANA (NOD RTYP "AUX" (TEM <KIDS .NOD>) N)
1699 #DECL ((NOD) NODE (TEM) <LIST [REST NODE]> (N) <OR FALSE NODE>)
1700 <SET RET-OR-AGAIN T>
1701 <COND (<OR <AND <EMPTY? .TEM> <SET N <PROGCHK AGAIN .NOD>>>
1702 <AND <EMPTY? <REST .TEM>> <SET N <ACT-CHECK <1 .TEM>>>>>
1703 <PUT .NOD ,NODE-TYPE ,AGAIN-CODE>
1704 <SET N <CHTYPE .N NODE>>
1708 <MSAVE-L-D-STATE <LIVE-VARS .N> .VARTBL>>)
1709 (ELSE <PUT .N ,LIVE-VARS <SAVE-L-D-STATE .VARTBL>>)>
1712 <COND (<NOT <AGND .N>> <BUILD-TYPE-LIST <SYMTAB .N>>)
1713 (ELSE <ORUPC <SYMTAB .N> <AGND .N>>)>>
1715 (<EMPTY? <REST .TEM>>
1716 <COND (<NOT <ANA <1 .TEM> FRAME>>
1717 <COMPILE-ERROR "Again not passed an activation" .NOD>)>
1719 (ELSE <COMPILE-ERROR "Too many arguments to AGAIN" .NOD>)>>
1721 <COND (<GASSIGNED? AGAIN-ANA> <PUTPROP ,AGAIN ANALYSIS ,AGAIN-ANA>)>
1723 " If not in PROG/REPEAT complain about NAME."
1725 <DEFINE PROGCHK (NAME NOD)
1727 <COND (<NOT <ASSIGNED? PNOD>>
1728 <COMPILE-ERROR "Not in PROG/REPEAT " .NAME .NOD>)>
1731 " Dispatch to special handlers for SUBRs. Or use standard."
1733 <DEFINE SUBR-ANA (NOD RTYP)
1735 <APPLY <GETPROP <NODE-SUBR .NOD> ANALYSIS ',SUBR-C-AN> .NOD .RTYP>>
1737 " Hairy SUBR call analyzer. Also looks for internal calls."
1739 <DEFINE SUBR-C-AN (NOD RTYP
1740 "AUX" (ARGS 0) (TYP ANY) (TMPL <GET-TMP <NODE-SUBR .NOD>>)
1742 #DECL ((NOD) <SPECIAL NODE> (ARGS) <SPECIAL FIX> (TYP NRGS1) <SPECIAL ANY>
1743 (TMPL) <SPECIAL LIST>)
1745 <FUNCTION ("TUPLE" T
1746 "AUX" NARGS TEM (NARGS1 .NRGS1) (N .NOD) (TPL .TMPL)
1748 #DECL ((T) TUPLE (ARGS RGS TL) FIX (TMPL TPL) <LIST ANY ANY>
1749 (N NOD) NODE (NARGS) <LIST FIX FIX>)
1754 <COND (<TYPE? .TYP ATOM FORM>) (ELSE <SET TYP ANY>)>)
1756 <COND (<TYPE? .NARGS1 FIX>
1757 <ARGCHK .RGS .NARGS1 <NODE-NAME .N> .NOD>)
1758 (<TYPE? .NARGS1 LIST>
1759 <COND (<G? .RGS <2 <SET NARGS .NARGS1>>>
1760 <COMPILE-ERROR "Too many arguments to "
1763 <COND (<L? .RGS <1 .NARGS>>
1765 "Too few arguments to "
1768 <COND (<TYPE? .TYP ATOM FORM>)
1769 (ELSE <SET TYP <APPLY .TYP !.T>>)>
1771 <FUNCTION (N "AUX" TYP)
1772 #DECL ((N NOD) NODE (ARGS) FIX (ARGACS) <PRIMTYPE LIST>)
1773 <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE>
1774 <EANA <1 <KIDS .N>> '<OR MULTI STRUCTURED> SEGMENT>
1777 (ELSE <SET ARGS <+ .ARGS 1>> <SET TYP <ANA .N ANY>> .TYP)>>
1779 <PUT .NOD ,SIDE-EFFECTS (ALL)>
1780 <TYPE-OK? .TYP .RTYP>>
1782 <DEFINE SEGMENT-ANA (NOD RTYP)
1783 <COMPILE-ERROR "Illegal segment (not in form or structure)" .NOD>>
1785 " Analyze VECTOR, UVECTOR and LIST builders."
1787 <DEFINE COPY-AN (NOD RTYP
1788 "AUX" (ARGS 0) (RT <ISTYPE? <RESULT-TYPE .NOD>>)
1789 (K <KIDS .NOD>) N (LWIN <==? .RT LIST>) NN COD)
1790 #DECL ((NOD N) NODE (ARGS) FIX (K) <LIST [REST NODE]>)
1793 <REPEAT (DC STY PTY TEM TT (SG <>) (FRM <FORM .RT>)
1794 (FRME <CHTYPE .FRM LIST>) (GOTDC <>))
1795 #DECL ((FRM) FORM (FRME) <LIST ANY>)
1798 <COND (<==? .RT LIST>
1800 <COND (<EMPTY? <REST .FRM>> <1 .FRM>)
1802 <COND (.DC <PUTREST .FRME ([REST .DC])>)
1803 (.STY <PUTREST .FRME ([REST .STY])>)
1804 (.PTY <PUTREST .FRME ([REST <FORM PRIMTYPE .PTY>])>)>
1805 <RETURN <SET RT .FRM>>)
1806 (<OR <==? <SET COD <NODE-TYPE <SET N <1 .K>>>> ,SEGMENT-CODE>
1807 <==? .COD ,SEG-CODE>>
1808 <SET TEM <GET-ELE-TYPE <EANA <1 <KIDS .N>>
1809 '<OR MULTI STRUCTURED> SEGMENT> ALL>>
1811 <COND (<NOT .SG> <SET GOTDC <>>)>
1814 <MEMQ <STRUCTYP <RESULT-TYPE <1 <KIDS .N>>>>
1815 '[LIST VECTOR UVECTOR TUPLE]>>)
1816 (ELSE <SET LWIN <>>)>)
1817 (ELSE <SET ARGS <+ .ARGS 2>> <SET TEM <ANA .N ANY>>)>
1821 <COND (<SET STY <ISTYPE? <SET DC .TEM>>> <MTYPR .STY>)>>)
1822 (<OR <NOT .DC> <N==? .DC .TEM>>
1824 <COND (<OR <N==? <SET TT <ISTYPE? .TEM>> .STY> <NOT .STY>>
1826 <COND (<AND .PTY <==? .PTY <AND .TT <MTYPR .TT>>>>)
1827 (ELSE <SET PTY <>>)>)>)>
1828 <COND (<NOT .SG> <SET FRME <REST <PUTREST .FRME (.TEM)>>>)>
1829 <SET K <REST .K>>>)>
1830 <PUT .NOD ,RESULT-TYPE .RT>
1832 (<AND <GASSIGNED? COPY-LIST-CODE> .LWIN>
1836 <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE>
1837 <PUT .N ,NODE-TYPE ,SEG-CODE>)>>
1839 <COND (<AND <==? <LENGTH <SET K <KIDS .NOD>>> 1>
1840 <==? <NODE-TYPE <1 .K>> ,SEG-CODE>
1841 <==? <STRUCTYP <RESULT-TYPE <SET NN <1 <KIDS <1 .K>>>>>>
1843 <COND (<NOT <EMPTY? <PARENT .NOD>>>
1845 <FUNCTION (L "AUX" (N <1 .L>))
1846 #DECL ((N) NODE (L) <LIST [REST NODE]>)
1847 <COND (<==? .NOD .N>
1850 <KIDS <CHTYPE <PARENT .NOD> NODE>>>)>
1851 <PUT .NN ,PARENT <CHTYPE <PARENT .NOD> NODE>>
1852 <SET RT <RESULT-TYPE .NN>>)
1853 (ELSE <PUT .NOD ,NODE-TYPE ,COPY-LIST-CODE>)>)
1858 <COND (<==? <NODE-TYPE .N> ,SEG-CODE>
1859 <PUT .N ,NODE-TYPE ,SEGMENT-CODE>)>>
1861 <PUT .NOD ,NODE-TYPE ,COPY-CODE>)>
1862 <TYPE-OK? .RT .RTYP>>
1864 " Analyze quoted objects, for structures hack type specs."
1866 <DEFINE QUOTE-ANA (NOD RTYP)
1868 <TYPE-OK? <GEN-DECL <NODE-NAME .NOD>> .RTYP>>
1870 <DEFINE QUOTE-ANA2 (NOD RTYP)
1872 <COND (<1? <LENGTH <KIDS .NOD>>>
1873 <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
1874 <PUT .NOD ,NODE-NAME <1 <KIDS .NOD>>>
1876 <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>)
1877 (ELSE <COMPILE-ERROR "Empty QUOTE?">)>>
1879 <COND (<GASSIGNED? QUOTE-ANA2> <PUTPROP ,QUOTE ANALYSIS ,QUOTE-ANA2>)>
1881 " Analyze a call to an RSUBR."
1883 <DEFINE RSUBR-ANA (NOD RTYP
1885 (DCL:<LIST [REST !<LIST ATOM ANY!>]> <TYPE-INFO .NOD>)
1886 (SEGF <>) (MUST-EMPTY T) FRST (TUPF <>) (OPTF <>)
1887 (K:<LIST [REST NODE]> <KIDS .NOD>)
1888 (NM:ATOM <NODE-NAME .NOD>) (RT <>))
1889 #DECL ((NOD) NODE (ARGS) FIX)
1891 <FUNCTION (ARG "AUX" TY ET)
1892 #DECL ((ARG NOD) NODE)
1893 <COND (<NOT <EMPTY? .DCL>>
1894 <COND (<==? <SET FRST <1 <SET RT <1 .DCL>>>> OPTIONAL>
1896 (<==? .FRST TUPLE> <SET TUPF T>)>
1898 <SET DCL <REST .DCL>>)
1899 (<NOT .TUPF> <SET OPTF <SET RT <>>>)>
1900 <COND (<==? <NODE-TYPE .ARG> ,SEGMENT-CODE>
1903 <GET-ELE-TYPE <SET TY <ANA <1 <KIDS .ARG>> ANY>> ALL>>
1904 <COND (<COND (.TUPF <TYPE-OK? <GET-ELE-TYPE .RT ALL> .ET>)
1905 (.RT <TYPE-OK? .RT .ET>)>)
1906 (<AND <OR <NOT .RT> .TUPF .OPTF> <L=? <MINL .TY> 0>>
1908 <COMPILE-WARNING "Segment must be empty: " .NOD>)
1909 (<NOT .RT> <COMPILE-ERROR "Too many arguments to: "
1912 <COMPILE-ERROR "Argument wrong type to: "
1917 <SET ARGS <+ .ARGS 1>>
1919 <COND (.TUPF <GET-ELE-TYPE .RT <COND (.SEGF ALL)
1923 <COND (<OR <==? .NM PRINC> <==? .NM PRINT> <==? .NM PRIN1>>
1924 <RESULT-TYPE .NOD <TYPE-AND <RESULT-TYPE .NOD>
1925 <RESULT-TYPE <1 .K>>>>)>
1928 <PUT .NOD ,SIDE-EFFECTS (ALL)>
1929 <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>>
1931 " Analyze CHTYPE, in some cases do it at compile time."
1933 <DEFINE CHTYPE-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) NTN NT OBN OB TARG S1 S2
1935 #DECL ((NOD OBN NTN) NODE (K) <LIST [REST NODE]> (NT) ATOM)
1937 (<SEGFLUSH .NOD .RTYP>)
1939 <ARGCHK <LENGTH .K> 2 CHTYPE .NOD>
1940 <SET OB <ANA <SET OBN <1 .K>> ANY>>
1941 <EANA <SET NTN <2 .K>> ATOM CHTYPE>
1943 (<==? <NODE-TYPE .NTN> ,QUOTE-CODE>
1944 <COND (<NOT <ISTYPE? <SET NT <NODE-NAME .NTN>>>>
1945 <COMPILE-ERROR "Second arg to CHTYPE not a type " .NT .NOD>)>
1946 <COND (<NOT <TYPE-OK? .OB <FORM PRIMTYPE <MTYPR .NT>>>>
1947 <COMPILE-ERROR "Primtypes differ in CHTYPE" .OB .NT .NOD>)>
1948 <COND (<==? <NODE-TYPE .OBN> ,QUOTE-CODE>
1949 <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
1951 <PUT .NOD ,NODE-NAME <CHTYPE <NODE-NAME .OBN> .NT>>)
1953 <COMPILE-WARNING "Redundant CHTYPE" .NOD>
1954 <PUT .NOD ,NODE-TYPE ,ID-CODE>)
1955 (<SET TDECL <GET-DECL .NT>>
1957 (<FORM PRIMTYPE <TYPEPRIM .NT>> !<REST .TDECL>)
1959 <COND (<NOT <TYPE-OK? .OB .TDECL>>
1960 <COMPILE-ERROR "DECL violation in CHTYPE "
1962 <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>)
1963 (ELSE <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>)>
1964 <PUT .NOD ,RESULT-TYPE .NT>
1965 <TYPE-OK? .NT .RTYP>)
1966 (<AND <==? <NODE-TYPE .NTN> ,RSUBR-CODE> <==? <NODE-NAME .NTN> TYPE>>
1968 (<AND <SET S1 <PRIMITIVE-TYPE .OB>>
1970 <PRIMITIVE-TYPE <SET TARG <RESULT-TYPE <1 <KIDS .NTN>>>>>>
1971 <NOT <TYPE-OK? .S1 .S2>>>
1972 <COMPILE-ERROR "Primtypes differ in CHTYPE" .OB .TARG .NOD>)
1974 <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>
1975 <PUT .NOD ,RESULT-TYPE .TARG>
1976 <TYPE-OK? .TARG .RTYP>)>)
1978 <COND (.VERBOSE <ADDVMESS .NOD ("Can't open compile CHTYPE.")>)>
1979 <TYPE-OK? ANY .RTYP>)>)>>
1981 <COND (<GASSIGNED? CHTYPE-ANA> <PUTPROP ,CHTYPE ANALYSIS ,CHTYPE-ANA>)>
1983 " Analyze use of ASCII sometimes do at compile time."
1985 <DEFINE ASCII-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) ITM TYP TEM)
1986 #DECL ((NOD ITM) NODE (K) <LIST [REST NODE]>)
1987 <COND (<SEGFLUSH .NOD .RTYP>)
1989 <ARGCHK <LENGTH .K> 1 ASCII .NOD>
1990 <SET TYP <EANA <SET ITM <1 .K>> '<OR FIX CHARACTER> ASCII>>
1991 <COND (<==? <NODE-TYPE .ITM> ,QUOTE-CODE>
1992 <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
1993 <PUT .NOD ,NODE-NAME <SET TEM <ASCII <NODE-NAME .ITM>>>>
1994 <PUT .NOD ,RESULT-TYPE <TYPE .TEM>>
1995 <PUT .NOD ,KIDS ()>)
1996 (<==? <ISTYPE? .TYP> FIX>
1997 <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>
1998 <PUT .NOD ,RESULT-TYPE CHARACTER>)
1999 (<==? .TYP CHARACTER>
2000 <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>
2001 <PUT .NOD ,RESULT-TYPE FIX>)
2002 (ELSE <PUT .NOD ,RESULT-TYPE '<OR FIX CHARACTER>>)>
2003 <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>)>>
2005 <COND (<GASSIGNED? ASCII-ANA> <PUTPROP ,ASCII ANALYSIS ,ASCII-ANA>)>
2007 <DEFINE UNWIND-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) ITYP)
2008 #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
2009 <SET ITYP <EANAQ <1 .K> ANY UNWIND .NOD>>
2010 <EANA <2 .K> ANY UNWIND>
2011 <PUTPROP .FCN UNWIND T>
2012 <TYPE-OK? .ITYP .RTYP>>
2014 " Analyze READ type SUBRS in two cases (print uncertain usage message maybe?)"
2016 <DEFINE READ-ANA (N R)
2019 <FUNCTION (NN "AUX" TY)
2021 <COND (<==? <NODE-TYPE .NN> ,EOF-CODE>
2024 <SET TY <EANAQ <1 <KIDS .NN>> ANY <NODE-NAME .N> .N>>
2025 <COND (<TYPE-OK? .TY '<OR FORM LIST VECTOR UVECTOR>>
2027 "Uncertain use of " <NODE-NAME .N> .N>)
2028 (ELSE <PUT .N ,NODE-TYPE ,READ-EOF2-CODE>)>)
2029 (ELSE <EANA .NN ANY <NODE-NAME .N>>)>>
2035 <DEFINE READ2-ANA (N R)
2040 <COND (<==? <NODE-TYPE .NN> ,EOF-CODE>
2041 <EANAQ <1 <KIDS .NN>> ANY <NODE-NAME .N> .N>)
2042 (ELSE <EANA .NN ANY <NODE-NAME .N>>)>>
2048 <DEFINE GET-ANA (N R "AUX" TY (K <KIDS .N>) (NAM <NODE-NAME .N>))
2049 #DECL ((N) NODE (K) <LIST NODE NODE NODE>)
2050 <EANA <1 .K> ANY .NAM>
2051 <EANA <2 .K> ANY .NAM>
2052 <SET TY <EANAQ <3 .K> ANY .NAM .N>>
2053 <COND (<TYPE-OK? .TY '<OR LIST VECTOR UVECTOR FORM>>
2054 <COMPILE-WARNING "Uncertain use of " .NAM .N>
2057 (ELSE <PUT .N ,NODE-TYPE ,GET2-CODE>)>
2060 <DEFINE GET2-ANA (N R
2061 "AUX" (K <KIDS .N>) (NAM <NODE-NAME .N>) (LN <LENGTH .K>))
2062 #DECL ((N) NODE (K) <LIST NODE NODE [REST NODE]> (LN) FIX)
2063 <EANA <1 .K> ANY .NAM>
2064 <EANA <2 .K> ANY .NAM>
2065 <COND (<==? .LN 3> <EANAQ <3 .K> ANY .NAM .N>)>
2068 <DEFINE EANAQ (N R NAM INOD "AUX" SPCD)
2069 #DECL ((N) NODE (SPCD) LIST)
2070 <SET SPCD <BUILD-TYPE-LIST .VARTBL>>
2071 <SET R <EANA .N .R .NAM>>
2072 <ASSERT-TYPES <ORUPC .VARTBL .SPCD>>
2075 <DEFINE ACTIV? (BST NOACT)
2076 #DECL ((BST) <LIST [REST SYMTAB]>)
2078 <AND <EMPTY? .BST> <RETURN <>>>
2079 <AND <==? <CODE-SYM <1 .BST>> 1>
2081 <NOT <RET-AGAIN-ONLY <1 .BST>>>
2082 <SPEC-SYM <1 .BST>>>
2084 <SET BST <REST .BST>>>>
2086 <DEFINE SAME-DECL? (D1 D2) <OR <=? .D1 .D2> <NOT <TYPE-OK? .D2 <NOTIFY .D1>>>>>
2088 <DEFINE SPECIALIZE (OBJ "AUX" T1 T2 SYM OB)
2089 #DECL ((T1) FIX (OB) FORM (T2) <OR FALSE SYMTAB>)
2090 <COND (<AND <TYPE? .OBJ FORM SEGMENT>
2091 <SET OB <CHTYPE .OBJ FORM>>
2092 <OR <AND <==? <SET T1 <LENGTH .OB>> 2>
2094 <TYPE? <SET SYM <2 .OB>> ATOM>>
2097 <TYPE? <SET SYM <2 .OB>> ATOM>>>
2098 <SET T2 <SRCH-SYM .SYM>>>
2099 <COND (<NOT <SPEC-SYM .T2>>
2100 <COMPILE-NOTE "Redeclared special " .SYM>
2101 <PUT .T2 ,SPEC-SYM T>)>)>
2102 <COND (<MEMQ <PRIMTYPE .OBJ> '[FORM LIST UVECTOR VECTOR]>
2103 <MAPF <> ,SPECIALIZE .OBJ>)>>
2105 <DEFINE ADECL-ANA (NOD RTYP "AUX" (RT <NODE-NAME .NOD>) (N <1 <KIDS .NOD>>) TY)
2107 <COND (<NOT <SET TY <TYPE-OK? .RT .RTYP>>>
2108 <COMPILE-ERROR "ADECL asserts incompatible type."
2113 (<NOT <SET RT <ANA .N .TY>>>
2114 <COMPILE-ERROR "ADECL asserts incompatible type."
2119 <PUT .NOD ,RESULT-TYPE .RT>
2122 <DEFINE CALL-ANA (N R "AUX" (K <KIDS .N>) INS TYP NN)
2123 #DECL ((N INS) NODE (K) <LIST [REST NODE]> (NN) <OR FALSE NODE>)
2125 (<EMPTY? .K> <COMPILE-ERROR "CALL has no instruction supplied" .N>)
2126 (<AND <==? <NODE-TYPE <SET INS <1 .K>>> ,QUOTE-CODE>
2127 <TYPE? <NODE-NAME .INS> ATOM>
2128 <SET TYP <LEGAL-MIM-INS .INS>>>
2129 <PUT .N ,SIDE-EFFECTS (.N !<SIDE-EFFECTS .N>)>
2130 <COND (<==? <NODE-NAME .INS> `RTUPLE>
2131 <EANA <2 .K> FIX RTUPLE>
2132 <COND (<SET NN <ACT-CHECK <3 .K> <>>>
2133 <COND (<==? <ACCUM-TYPE .NN> NO-RETURN>
2134 <PUT .NN ,VSPCD <BUILD-TYPE-LIST <SYMTAB .NN>>>
2135 <PUT .NN ,DEAD-VARS <SAVE-L-D-STATE .VARTBL>>)
2137 <PUT .NN ,VSPCD <ORUPC <SYMTAB .NN> <VSPCD .NN>>>
2140 <MSAVE-L-D-STATE <DEAD-VARS .NN> .VARTBL>>)>
2141 <PUT .NN ,ACCUM-TYPE <TYPE-MERGE TUPLE <ACCUM-TYPE .NN>>>)
2142 (ELSE <EANA <3 .K> FRAME RTUPLE>)>)
2147 <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE>
2148 <EANA <1 <KIDS .N>> '<OR MULTI STRUCTURED> CALL>)
2149 (ELSE <EANA .N ANY CALL>)>>
2152 (ELSE <COMPILE-ERROR "CALL with a non-instruction: " .N>)>>
2154 <DEFINE LEGAL-MIM-INS (N "AUX" (ATM <NODE-NAME .N>) MIMOP)
2155 #DECL ((FCN N) NODE (ATM) ATOM)
2156 <COND (<SET MIMOP <LOOKUP <SPNAME .ATM> ,MIM-OBL>>
2157 <PUT .N ,NODE-NAME .MIMOP>
2158 <COND (<=? <SPNAME .MIMOP> "ACTIVATION">
2159 <PUT .FCN ,ACTIVATED T>)>
2160 <COND (<GETPROP .MIMOP TYPE>) (ELSE ANY)>)>>
2162 <DEFINE APPLY-ANA (N R "AUX" (K <KIDS .N>))
2163 #DECL ((N) NODE (K) <LIST [REST NODE]>)
2164 <COND (<EMPTY? .K> <COMPILE-ERROR "APPLY has nothing to apply" .N>)
2166 <PUT .N ,SIDE-EFFECTS (.N !<SIDE-EFFECTS .N>)>
2170 <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE>
2172 '<OR MULTI STRUCTURED> CALL>)
2173 (ELSE <EANA .N ANY CALL>)>>
2175 <PUT .N ,NODE-TYPE ,APPLY-CODE>
2176 <TYPE-OK? .R ANY>)>>
2178 <COND (<GASSIGNED? APPLY-ANA> <PUTPROP ,APPLY ANALYSIS ,APPLY-ANA>)>
2180 <DEFINE ANALYSIS-DISPATCHER (NOD RTYP)
2183 (,QUOTE-CODE <QUOTE-ANA .NOD .RTYP>)
2184 (,FUNCTION-CODE <FUNC-ANA .NOD .RTYP>)
2185 (,SEGMENT-CODE <SEGMENT-ANA .NOD .RTYP>)
2186 (,FORM-CODE <FORM-AN .NOD .RTYP>)
2187 (,PROG-CODE <PRG-REP-ANA .NOD .RTYP>)
2188 (,SUBR-CODE <SUBR-ANA .NOD .RTYP>)
2189 (,COND-CODE <COND-ANA .NOD .RTYP>)
2190 (,COPY-CODE <COPY-AN .NOD .RTYP>)
2191 (,RSUBR-CODE <RSUBR-ANA .NOD .RTYP>)
2192 (,ISTRUC-CODE <ISTRUC-ANA .NOD .RTYP>)
2193 (,ISTRUC2-CODE <ISTRUC2-ANA .NOD .RTYP>)
2194 (,READ-EOF-CODE <READ-ANA .NOD .RTYP>)
2195 (,READ-EOF2-CODE <READ2-ANA .NOD .RTYP>)
2196 (,GET-CODE <GET-ANA .NOD .RTYP>)
2197 (,GET2-CODE <GET2-ANA .NOD .RTYP>)
2198 (,MAP-CODE <MAPPER-AN .NOD .RTYP>)
2199 (,MARGS-CODE <MARGS-ANA .NOD .RTYP>)
2200 (,ARITH-CODE <ARITH-ANA .NOD .RTYP>)
2201 (,TEST-CODE <ARITHP-ANA .NOD .RTYP>)
2202 (,0-TST-CODE <ARITHP-ANA .NOD .RTYP>)
2203 (,1?-CODE <ARITHP-ANA .NOD .RTYP>)
2204 (,MIN-MAX-CODE <ARITH-ANA .NOD .RTYP>)
2205 (,ABS-CODE <ABS-ANA .NOD .RTYP>)
2206 (,FIX-CODE <FIX-ANA .NOD .RTYP>)
2207 (,FLOAT-CODE <FLOAT-ANA .NOD .RTYP>)
2208 (,MOD-CODE <MOD-ANA .NOD .RTYP>)
2209 (,LNTH-CODE <LENGTH-ANA .NOD .RTYP>)
2210 (,MT-CODE <EMPTY?-ANA .NOD .RTYP>)
2211 (,NTH-CODE <NTH-ANA .NOD .RTYP>)
2212 (,REST-CODE <REST-ANA .NOD .RTYP>)
2213 (,PUT-CODE <PUT-ANA .NOD .RTYP>)
2214 (,PUTR-CODE <PUTREST-ANA .NOD .RTYP>)
2215 (,UNWIND-CODE <UNWIND-ANA .NOD .RTYP>)
2216 (,FORM-F-CODE <FORM-F-ANA .NOD .RTYP>)
2217 (,IRSUBR-CODE <IRSUBR-ANA .NOD .RTYP>)
2218 (,ROT-CODE <ROT-ANA .NOD .RTYP>)
2219 (,LSH-CODE <LSH-ANA .NOD .RTYP>)
2220 (,BIT-TEST-CODE <BIT-TEST-ANA .NOD .RTYP>)
2221 (,CASE-CODE <CASE-ANA .NOD .RTYP>)
2222 (,COPY-LIST-CODE <COPY-AN .NOD .RTYP>)
2223 (,ADECL-CODE <ADECL-ANA .NOD .RTYP>)
2224 (,CALL-CODE <CALL-ANA .NOD .RTYP>)
2225 (,APPLY-CODE <APPLY-ANA .NOD .RTYP>)
2226 (,FGETBITS-CODE <FGETBITS-ANA .NOD .RTYP>)
2227 (,FPUTBITS-CODE <FPUTBITS-ANA .NOD .RTYP>)
2228 (,STACK-CODE <STACK-ANA .NOD .RTYP>)
2229 (,BACK-CODE <BACK-ANA .NOD .RTYP>)
2230 (,TOP-CODE <TOP-ANA .NOD .RTYP>)
2231 (,CHANNEL-OP-CODE <CHANNEL-OP-ANA .NOD .RTYP>)
2232 (,ATOM-PART-CODE <ATOM-PART-ANA .NOD .RTYP>)
2233 (,OFFSET-PART-CODE <OFFSET-PART-ANA .NOD .RTYP>)
2234 (,PUT-GET-DECL-CODE <PUT-GET-DECL-ANA .NOD .RTYP>)
2235 (,SUBSTRUC-CODE <SUBSTRUC-ANA .NOD .RTYP>)
2236 (,MULTI-SET-CODE <MULTI-SET-ANA .NOD .RTYP>)
2238 (<SUBR-ANA .NOD .RTYP>)>>
2240 <DEFINE SPEC-ANA (CONST PRED-NAME OTYPE RTYP DFLG NOD WHO "AUX" TEM PAT)
2243 <COND (<TYPE? .CONST LIST>
2244 <COND (<==? .PRED-NAME ==?> <GEN-DECL <1 .CONST>>)
2245 (<==? .PRED-NAME TYPE?> <TYPE-MERGE !.CONST>)
2248 <FUNCTION (X) <FORM PRIMTYPE .X>>
2251 <COND (<==? .PRED-NAME ==?> <GEN-DECL .CONST>)
2252 (<==? .PRED-NAME TYPE?> .CONST)
2253 (ELSE <FORM PRIMTYPE .CONST>)>)>>
2255 (.DFLG <PUT .NOD ,RESULT-TYPE <SET TEM <TYPE-OK? ATOM .RTYP>>> .TEM)
2257 <COND (<AND <N==? .PRED-NAME ==?>
2259 <NOT <TYPE-OK? <FORM NOT .PAT> .OTYPE>>>
2261 (<TYPE-OK? .OTYPE .PAT> <SET TEM '<OR FALSE ATOM>>)
2262 (ELSE <SET TEM FALSE>)>
2264 <FUNCTION (L "AUX" (FLG <1 .L>) (SYM <2 .L>))
2265 #DECL ((L) <LIST <OR ATOM FALSE> SYMTAB> (SYM) SYMTAB)
2267 <ADD-TYPE-LIST .SYM .PAT .TRUTH .FLG <REST .L 2>>>
2276 <PUT .NOD ,RESULT-TYPE <SET TEM <TYPE-OK? .TEM .RTYP>>>
2279 <DEFINE ISTRUC-ANA (N R "AUX" (K <KIDS .N>) FM NUM TY (NEL REST) SIZ)
2280 #DECL ((N FM NUM) NODE)
2281 <EANA <SET NUM <1 .K>> FIX <NODE-NAME .N>>
2283 <EANA <SET FM <2 .K>>
2284 <COND (<==? <NODE-NAME .FM> ISTRING> CHARACTER)
2285 (<==? <NODE-NAME .FM> IBYTES> FIX)
2286 (<==? <NODE-NAME .FM> UVECTOR> FIX)
2289 <COND (<TYPE-OK? .TY '<OR FORM LIST VECTOR UVECTOR LVAL GVAL>>
2290 <COMPILE-WARNING "Explicit EVAL required: " <NODE-NAME .N> .N>
2293 <COND (<==? <NODE-TYPE .NUM> ,QUOTE-CODE> <SET NEL <NODE-NAME .NUM>>)>
2294 <COND (<TYPE-OK? .TY FORM> <SET TY ANY>)>
2295 <TYPE-OK? <FORM <ISTYPE? <RESULT-TYPE .N>>
2296 !<COND (<TYPE? .NEL FIX> ([.NEL .TY])) (ELSE ())>
2297 !<COND (<==? .TY ANY> ()) (ELSE ([REST .TY]))>>
2300 <DEFINE ISTRUC2-ANA (N R "AUX" (K <KIDS .N>) GD NUM TY (NEL REST) SIZ)
2301 #DECL ((N NUM GD) NODE)
2302 <EANA <SET NUM <1 .K>> FIX <NODE-NAME .N>>
2304 <COND (<==? <NODE-NAME .N> ISTRING> CHARACTER)
2305 (<OR <==? <NODE-NAME .N> IBYTES>
2306 <==? <NODE-NAME .N> IUVECTOR>>
2309 <COND (<==? <LENGTH .K> 2>
2310 <SET TY <EANA <SET GD <2 .K>> .TY <NODE-NAME .N>>>)>
2311 <COND (<==? <NODE-TYPE .NUM> ,QUOTE-CODE> <SET NEL <NODE-NAME .NUM>>)>
2312 <TYPE-OK? <COND (<AND <==? .NEL REST> <==? .TY ANY>>
2313 <ISTYPE? <RESULT-TYPE .N>>)
2315 <FORM <ISTYPE? <RESULT-TYPE .N>>
2316 !<COND (<N==? .NEL REST> ([.NEL .TY]))
2318 !<COND (<==? .TY ANY> ())
2319 (ELSE ([REST .TY]))>>)>
2322 <DEFINE STACK-ANA (N R) #DECL ((N) NODE) <EANA <1 <KIDS .N>> .R STACK>>
2324 <DEFINE CHANNEL-OP-ANA (N R "AUX" (K <KIDS .N>) TY)
2325 #DECL ((N) NODE (K) <LIST [REST NODE]>)
2326 <COND (<SEGFLUSH .N .R>)
2328 <PUT .N ,SIDE-EFFECTS (.N !<SIDE-EFFECTS .N>)>
2329 <COND (<L? <LENGTH .K> 2> <ARGCHK <LENGTH .K> 2 CHANNEL-OP .N>)>
2330 <SET TY <EANA <1 .K> CHANNEL CHANNEL-OP>>
2331 <EANA <2 .K> ATOM CHANNEL-OP>
2333 <FUNCTION (NN) #DECL ((NN) NODE) <ANA .NN ANY>>
2335 <COND (<AND <TYPE? .TY FORM SEGMENT>
2336 <==? <LENGTH .TY> 2>
2337 <TYPE? <SET TY <2 .TY>> FORM>
2338 <==? <LENGTH .TY> 2>
2340 <TYPE? <2 .TY> ATOM>>
2341 <PUT .N ,NODE-TYPE ,CHANNEL-OP-CODE>
2342 <PUT .N ,NODE-SUBR <2 .TY>>)>
2343 <TYPE-OK? .R ANY>)>>
2345 <COND (<AND <GASSIGNED? CHANNEL-OP> <GASSIGNED? CHANNEL-OP-ANA>>
2346 <PUTPROP ,CHANNEL-OP ANALYSIS ,CHANNEL-OP-ANA>)>