17 <USE "COMPDEC" "SYMANA" "CHKDCL" "CARANA" "ADVMESS">
19 <SETG SPECIAL-MAPF-R-SUBRS [,LIST ,+ ,* ,MAX ,MIN]>
21 <DEFINE MAPPER-AN (MNOD MRTYP
22 "AUX" (K <KIDS .MNOD>) TT ITRNOD FAP T TF (MPSTRS ())
23 (R? <==? <NODE-SUBR .MNOD> ,MAPR>) (TUPCNT 1)
24 (RETYPS NO-RETURN) TEM ASSU L-D L-V D-V VALSPCD SBR
25 (SBRL <>) (SEGFX ()) FINTYPE STATE (FRET T) (FSTOP T)
26 (OV .VARTBL) NSTR (CHF <>))
27 #DECL ((FAP ITRNOD) NODE (K) <LIST [REST NODE]> (TT NSTR) FIX
28 (MPSTRS L-V D-V) <SPECIAL LIST> (R?) <SPECIAL <OR ATOM FALSE>>
29 (STATE TUPCNT) <SPECIAL FIX> (SEGFX) <SPECIAL <LIST [REST NODE]>>
30 (MNOD) <SPECIAL NODE> (OV) <SPECIAL SYMTAB>
31 (FRET FSTOP MRTYP RETYPS) <SPECIAL ANY> (VALSPCD) <SPECIAL LIST>
32 (ASSU L-D) LIST (SBRL) <OR VECTOR FALSE>)
33 <SET TF <EANA <SET FAP <1 .K>> ANY <NODE-NAME .MNOD>>>
34 <COND (<AND <SET SBR <SUBAP? .FAP>>
35 <SET SBRL <MEMQ ,.SBR ,SPECIAL-MAPF-R-SUBRS>>>
36 <PUT .FAP ,NODE-TYPE ,MFIRST-CODE>
37 <COND (<N==? ,.SBR ,LIST>
38 <SET FINTYPE '<OR FIX FLOAT>>
40 (ELSE <SET FINTYPE LIST>)>
41 <PUT .FAP ,NODE-SUBR <LENGTH .SBRL>>)>
46 <COND (<L? <MINL <RESULT-TYPE .N>> 1> <SET CHF T>)>>
49 (<==? <SET TT <NODE-TYPE .ITRNOD>> ,MFCN-CODE>
50 <PUT .ITRNOD ,SIDE-EFFECTS <>>
52 <FUNCTION (N "AUX" RT R)
54 <COND (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
55 <==? <NODE-TYPE .N> ,SEG-CODE>>
56 <SET RT <EANA <1 <KIDS .N>> STRUCTURED <NODE-NAME .MNOD>>>
57 <SET RT <GET-ELE-TYPE .RT ALL>>
58 <COND (<NOT <TYPE-OK? .RT STRUCTURED>>
59 <COMPILE-ERROR "MAPF/R on non structured object(s)"
61 (ELSE <SET RT <EANA .N STRUCTURED <NODE-NAME .MNOD>>>)>
63 <OR <NOT <SET R <STRUCTYP .RT>>> <==? .R TEMPLATE>>>
66 ("Non-specific structure for MAPF/R: "
71 <SET L-D <SAVE-L-D-STATE .VARTBL>>
72 <PROG ((HTMPS 0) (TMPS 0) (VARTBL <SYMTAB .ITRNOD>) (KK .K) (LL .LIFE)
74 #DECL ((HTMPS TMPS) <SPECIAL FIX> (VARTBL) <SPECIAL SYMTAB>
75 (KK) <LIST [REST NODE]>)
76 <COND (.VERBOSE <PUTREST <SET VERBOSE .OVV> ()>)>
80 <RESET-VARS .VARTBL .OV>
81 <MUNG-L-D-STATE .VARTBL>
83 <SET RETYPS NO-RETURN>
84 <SET ASSU <BUILD-TYPE-LIST .OV>>
85 <SET VALSPCD <BUILD-TYPE-LIST .OV>>
86 <REPEAT ((BNDS <BINDING-STRUCTURE .ITRNOD>) (TUPF <>) (LAST-SEG <>)
89 <COND (<AND <NOT .LAST-SEG> <NOT <EMPTY? .K>>>
91 "MAPF/R function takes too few args "
94 <COND (<==? <CODE-SYM <1 .BNDS>> ,ARGL-TUPLE> <SET TUPF T>)>
95 <COND (<AND <NOT <EMPTY? .K>>
96 <OR <==? <NODE-TYPE <1 .K>> ,SEG-CODE>
97 <==? <NODE-TYPE <1 .K>> ,SEGMENT-CODE>>>
98 <COND (<EMPTY? <REST .K>> <SET LAST-SEG 1>)>
99 <COND (<NOT <OR .LAST-SEG .TUPF>> <SET SKIPF T>)>)>
100 <COND (<OR <MANAL-DISP <1 .BNDS>
101 <COND (<NOT <EMPTY? .K>> <1 .K>)>
105 <SET BNDS <REST .BNDS>>)>
106 <COND (<AND <NOT <EMPTY? .BNDS>>
107 <SPEC-SYM <1 .BNDS>>>
108 <PUT .ITRNOD ,SPCS-X T>)>
109 <COND (.LAST-SEG <SET LAST-SEG <+ .LAST-SEG 1>>)>
110 <COND (<AND <NOT .LAST-SEG> <NOT <EMPTY? .K>>>
112 <PUT .ITRNOD ,VSPCD (())>
113 <PROG ((STMPS .TMPS) (SHTMPS .HTMPS) (LL .LIFE) (OVV .VERBOSE))
114 #DECL ((STMPS SHTMPS) FIX)
115 <COND (.VERBOSE <PUTREST <SET VERBOSE .OVV> ()>)>
120 <PUT .ITRNOD ,ASSUM <BUILD-TYPE-LIST .VARTBL>>
121 <PUT .ITRNOD ,ACCUM-TYPE NO-RETURN>
122 <SET TEM <SEQ-AN <KIDS .ITRNOD> <INIT-DECL-TYPE .ITRNOD>>>
123 <OR <NOT <AGND .ITRNOD>>
124 <ASSUM-OK? <ASSUM .ITRNOD> <AGND .ITRNOD>>
126 <COND (<N==? .TEM NO-RETURN>
128 <SET L-V <MSAVE-L-D-STATE .L-V .OV>>
129 <ASSERT-TYPES <ORUPC .VARTBL <VSPCD .ITRNOD>>>)
130 (ELSE <SET L-V <SAVE-L-D-STATE .OV>>)>)
131 (<N==? <ACCUM-TYPE .ITRNOD> NO-RETURN>
132 <ASSERT-TYPES <VSPCD .ITRNOD>>)>
133 <SET VALSPCD <ORUPC .OV .VALSPCD>>
134 <OR <ASSUM-OK? .ASSU <BUILD-TYPE-LIST .VARTBL>> <AGAIN>>
135 <PUT .ITRNOD ,ACCUM-TYPE <TYPE-MERGE .TEM <ACCUM-TYPE .ITRNOD>>>
138 <TYPE-OK? <ACCUM-TYPE .ITRNOD> <INIT-DECL-TYPE .ITRNOD>>>>
139 <ASSERT-TYPES .VALSPCD>
140 <COND (<ASSIGNED? STATE>
141 <FIX-STATE <ACCUM-TYPE .ITRNOD> .ITRNOD>
144 <PUT .FAP ,NODE-TYPE ,GVAL-CODE>
145 <SET FINTYPE '<OR FIX FLOAT>>)
147 <SET FINTYPE <NTH '[FIX FLOAT FLOAT] <- .STATE 1>>>)>)>
148 <SAVE-SURVIVORS .L-D .LIFE T>
149 <SAVE-SURVIVORS .L-V .LIFE>
151 <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
152 (ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
153 <FREST-L-D-STATE .D-V>
154 <SET LIFE <KILL-REM .LIFE .OV>>
155 <COND (.SBRL <MUNG-SEGS .SEGFX>)>
156 <COND (<SIDE-EFFECTS .ITRNOD>
157 <UPDATE-SIDE-EFFECTS .ITRNOD .MNOD>)>
158 <COND (<AND <==? <NODE-TYPE .FAP> ,QUOTE-CODE>
159 <==? <NODE-NAME .FAP> #FALSE ()>>
160 <TYPE-OK? <COND (.CHF <TYPE-MERGE FALSE .TEM .RETYPS>)
161 (ELSE <TYPE-OK? <TYPE-MERGE .TEM .RETYPS> .MRTYP>)>
164 <COND (<==? .FINTYPE LIST>
165 <TYPE-OK? <TYPE-MERGE <FORM LIST
166 [REST <RESULT-TYPE .ITRNOD>]>
169 (ELSE <TYPE-OK? <TYPE-MERGE .FINTYPE .RETYPS> .MRTYP>)>)
170 (<AND <==? <NODE-TYPE .FAP> ,GVAL-CODE>
171 <MEMQ <NODE-NAME .FAP> '[TUPLE VECTOR UVECTOR]>>
172 <SET TEM <FORM <NODE-NAME .FAP> [REST .TEM]>>
173 <TYPE-OK? <TYPE-MERGE .RETYPS .TEM> .MRTYP>)
174 (ELSE <TYPE-OK? <TYPE-MERGE <APPLTYP .FAP> .RETYPS> .MRTYP>)>)
176 <COND (<N==? .TT ,MPSBR-CODE>
177 <EANA .ITRNOD APPLICABLE <NODE-NAME .MNOD>>)>
179 <FUNCTION (N "AUX" RT R)
181 <COND (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
182 <==? <NODE-TYPE .N> ,SEG-CODE>>
183 <SET RT <EANA <1 <KIDS .N>> STRUCTURED <NODE-NAME .MNOD>>>
184 <SET RT <GET-ELE-TYPE .RT ALL>>)
185 (ELSE <SET RT <EANA .N STRUCTURED <NODE-NAME .MNOD>>>)>
187 <OR <NOT <SET R <STRUCTYP .RT>>> <==? .R TEMPLATE>>>
190 ("Non-specific structure for MAPF/R: "
194 <SET MPSTRS <REST .K 2>>>
195 <COND (<==? .TT ,MPSBR-CODE>
196 <SET TEM <EANA <1 <KIDS .ITRNOD>> ANY <NODE-NAME .MNOD>>>
197 <COND (.CHF <SET TEM <TYPE-MERGE .TEM FALSE>>)>)
198 (ELSE <SET TEM ANY>)>
199 <COND (<ASSIGNED? STATE>
200 <FIX-STATE .TEM <1 <KIDS .ITRNOD>>>
203 <PUT .FAP ,NODE-TYPE ,GVAL-CODE>
204 <SET FINTYPE '<OR FIX FLOAT>>)
206 <SET FINTYPE <NTH '[FIX FLOAT FLOAT] <- .STATE 1>>>)>)>
207 <COND (.SBRL <MUNG-SEGS .SEGFX>)>
208 <COND (<AND <==? <NODE-TYPE .FAP> ,QUOTE-CODE>
209 <==? <NODE-NAME .FAP> #FALSE ()>>
210 <TYPE-OK? .TEM .MRTYP>)
212 <COND (<==? .FINTYPE LIST>
213 <TYPE-OK? <FORM LIST [REST .TEM]> .MRTYP>)
214 (ELSE <TYPE-OK? .FINTYPE .MRTYP>)>)
215 (<AND <==? <NODE-TYPE .FAP> ,GVAL-CODE>
216 <MEMQ <NODE-NAME .FAP> '[TUPLE VECTOR UVECTOR]>>
217 <SET TEM <FORM <NODE-NAME .FAP> [REST .TEM]>>
218 <TYPE-OK? <TYPE-MERGE .RETYPS .TEM> .MRTYP>)
219 (ELSE <TYPE-OK? <APPLTYP .FAP> .MRTYP>)>)>>
223 <DEFINE FIX-STATE (TEM N "AUX" TT (SG <MEMQ <NODE-TYPE .N> ,SEG-CODES>))
224 #DECL ((STATE TT) FIX (N) NODE)
226 <COND (<==? .TEM FIX> 1)
228 (<NOT <TYPE-OK? .TEM FLOAT>>
232 <TYPE-MERGE '<STRUCTURED [REST FIX]>
236 (<NOT <TYPE-OK? .TEM FIX>>
240 <TYPE-MERGE '<STRUCTURED [REST FLOAT]>
245 <SET STATE <NTH <NTH ,ASTATE .STATE> .TT>>>
247 <SETG SEG-CODES [,SEG-CODE ,SEGMENT-CODE]>
249 <DEFINE MUNG-SEGS (SEGS)
250 #DECL ((SEGS) <LIST [REST NODE]>)
252 <FUNCTION (N) #DECL ((N) NODE) <PUT .N ,NODE-TYPE ,SEG-CODE>>
255 <DEFINE MARGS-ANA (N R "AUX" (MK .MPSTRS) (NN <NODE-NAME .N>))
256 #DECL ((N) NODE (NN) FIX (MK) <LIST [REST NODE]>)
258 <TYPE-OK? <GET-ELE-TYPE <RESULT-TYPE <NTH .MK .NN>> ALL .R?> .R>>
259 <COND (.R? <TYPE-OK? .R '<STRUCTURED ANY>>) (ELSE .R)>>
261 <DEFINE MAUX (SYM STRUC SKIPF LAST-SEG)
262 #DECL ((SYM) SYMTAB (STRUC) <OR FALSE NODE> (MNOD) NODE)
263 <COND (<AND .STRUC <NOT .SKIPF> <NOT .LAST-SEG>>
264 <COMPILE-ERROR "MAPF/R function takes too many args "
266 (ELSE <NORM-BAN .SYM>)>
269 <DEFINE MAUX1 (SYM STRUC SKIPF LAST-SEG)
270 #DECL ((SYM) SYMTAB (STRUC) <OR FALSE NODE> (MNOD) NODE)
271 <COND (<AND .STRUC <NOT .SKIPF> <NOT .LAST-SEG>>
272 <COMPILE-ERROR "MAPF/R function takes too many args "
276 <COND (.ANALY-OK NO-RETURN) (ELSE <DECL-SYM .SYM>)>>
277 <PUT .SYM ,CURRENT-TYPE <COND (.ANALY-OK NO-RETURN) (ELSE ANY)>>
280 <DEFINE MNORM (SYM STRUC SKIPF LAST-SEG
281 "AUX" (VARTBL <NEXT-SYM .SYM>) TEM COD N TYP)
282 #DECL ((SYM) SYMTAB (STRUC) <OR NODE FALSE> (VARTBL) <SPECIAL SYMTAB>
284 <COND (<AND .STRUC <NOT .SKIPF>>
288 <EANA <1 <KIDS .STRUC>> STRUCTURED MAPF/R>
290 (ELSE <SET TYP <EANA .STRUC ANY MAPF/R>>)>
292 <TYPE-OK? <GET-ELE-TYPE .TYP ALL .R?>
294 <COMPILE-ERROR "MAPF/R structure violates arg DECL "
299 <COND (.R? <SET TEM <TYPE-AND .TEM '<STRUCTURED ANY>>>)>
300 <COND (<N=? .TEM <DECL-SYM .SYM>>
301 <PUT .SYM ,CURRENT-TYPE .TEM>)>
302 <PUT .SYM ,COMPOSIT-TYPE .TEM>)
304 <COMPILE-ERROR "Too fewa argumens MAPF/R function" .MNOD>)>
307 <DEFINE MOPT (SYM STRUC SKIPF LAST-SEG "AUX" (VARTBL <NEXT-SYM .SYM>))
308 #DECL ((SYM) SYMTAB (VARTBL) <SPECIAL SYMTAB> (STRUC) <OR FALSE NODE>)
310 <PUT .SYM ,INIT-SYM <>>
311 <MNORM .SYM .STRUC .SKIPF .LAST-SEG>)>
312 <COND (<OR <NOT .STRUC> .SKIPF .LAST-SEG> <NORM-BAN .SYM>)>
315 <DEFINE MBAD (SYM STRUC SKIPF LAST-SEG)
316 <COMPILE-ERROR "Unrecognized arg decl in MAPF/R function "
319 <DEFINE MOPT2 (SYM STRUC SKIPF LAST-SEG)
320 <COND (.STRUC <MNORM .SYM .STRUC .SKIPF .LAST-SEG>)>
325 <DEFINE MTUPLE (SYM STRUC SKIPF LAST-SEG
326 "AUX" (VARTBL <NEXT-SYM .SYM>) TYP
328 <GET-ELE-TYPE <DECL-SYM .SYM>
329 <COND (.LAST-SEG ALL)
330 (ELSE <SET TUPCNT <+ .TUPCNT 1>>)>>)
332 #DECL ((VARTBL) <SPECIAL ANY> (TUPCNT) FIX)
334 (<AND .STRUC <NOT .SKIPF>>
336 <COND (<NOT <COND (.LAST-SEG
338 <EANA <1 <KIDS .STRUC>> STRUCTURED MAPF/R>>
339 <==? <STRUCTYP <GET-ELE-TYPE .TEM ALL>>
342 <SET TEM <EANA .STRUC STRUCTURED MAPF/R>>
343 <==? <STRUCTYP .TEM> <STRUCTYP .ATYP>>)>>
344 <COMPILE-ERROR "Bad argument to MAPF/R function "
348 <SET TEM <EANA <1 <KIDS .STRUC>> STRUCTURED MAPF/R>>
349 <COND (<NOT <TYPE-OK? <GET-ELE-TYPE <GET-ELE-TYPE .TEM ALL>
352 <COMPILE-ERROR "Bad argument to MAPF/R function "
355 (<AND .STRUC .SKIPF> <ANA .STRUC ANY>)
357 <COND (<NOT <TYPE-OK? <GET-ELE-TYPE <EANA .STRUC STRUCTURED MAPF/R>
360 <COMPILE-ERROR "Bad argument to MAPF/R function "
366 <DEFINE MENTROPY (N R "OPT" X Y) T>
368 <DEFINE MANAL-DISP (SYM NOD SKIPF LAST-SEG "AUX" (COD <CODE-SYM .SYM>))
371 (,ARGL-ACT <MENTROPY .SYM .NOD .SKIPF .LAST-SEG>)
372 (,ARGL-IAUX <MAUX .SYM .NOD .SKIPF .LAST-SEG>)
373 (,ARGL-AUX <MAUX1 .SYM .NOD .SKIPF .LAST-SEG>)
374 (,ARGL-TUPLE <MTUPLE .SYM .NOD .SKIPF .LAST-SEG>)
375 (,ARGL-ARGS <MBAD .SYM .NOD .SKIPF .LAST-SEG>)
376 (,ARGL-QIOPT <MOPT .SYM .NOD .SKIPF .LAST-SEG>)
377 (,ARGL-IOPT <MOPT .SYM .NOD .SKIPF .LAST-SEG>)
378 (,ARGL-QOPT <MOPT2 .SYM .NOD .SKIPF .LAST-SEG>)
379 (,ARGL-OPT <MOPT2 .SYM .NOD .SKIPF .LAST-SEG>)
380 (,ARGL-CALL <MBAD .SYM .NOD .SKIPF .LAST-SEG>)
381 (,ARGL-BIND <MENTROPY .SYM .NOD .SKIPF .LAST-SEG>)
382 (,ARGL-QUOTE <MNORM .SYM .NOD .SKIPF .LAST-SEG>)
383 (,ARGL-ARG <MNORM .SYM .NOD .SKIPF .LAST-SEG>)>>
385 "Additional SUBR analyzers associated with MAP hackers."
387 <DEFINE MAPLEAVE-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>) TEM)
388 #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
390 <COND (<ASSIGNED? MNOD>
391 <ARGCHK .LN '(0 1) MAPLEAVE .N>
395 <SET K (<NODE1 ,QUOTE-CODE .N ATOM T ()>)>>)>
396 <SET TEM <EANA <1 .K> .MRTYP MAPLEAVE>>
397 <SET VALSPCD <ORUPC .OV .VALSPCD>>
399 <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
400 (ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
402 <SET RETYPS <TYPE-MERGE .RETYPS .TEM>>
403 <PUT .N ,NODE-TYPE ,MAPLEAVE-CODE>)
404 (ELSE <SUBR-C-AN .N .R>)>
409 <DEFINE MAPRET-STOP-ANA (NOD R "AUX" (ARGS 0) (TYP NO-RETURN) TYP1 ITRNOD)
410 #DECL ((MNOD NOD ITRNOD) NODE (ARGS) FIX)
413 <OR <ASSIGNED? MNOD> <RETURN <SUBR-C-AN .NOD .R>>>
414 <PUT <SET ITRNOD <2 <KIDS .MNOD>>> ,ACTIVATED T>
415 ;"So frame will be built"
416 <COND (<NOT <NODE-NAME <1 <KIDS .MNOD>>>>
417 <COMPILE-ERROR "MAPRET/STOP with no final function." .MNOD>)>
422 (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
423 <==? <NODE-TYPE .N> ,SEG-CODE>>
426 <COND (<ASSIGNED? STATE>
427 '<STRUCTURED [REST <OR FIX FLOAT>]>)
430 <SET TYP <TYPE-MERGE .TYP <GET-ELE-TYPE .TYP1 ALL>>>
433 <SET ARGS <+ .ARGS 1>>
438 <COND (<ASSIGNED? STATE> '<OR FIX FLOAT>)
440 <NODE-NAME .NOD>>>>)>>
442 <AND <ASSIGNED? STATE> <N==? .TYP NO-RETURN> <FIX-STATE .TYP .NOD>>
443 <COND (<==? <NODE-SUBR .NOD> ,MAPRET>
445 <COND (.FRET <SAVE-L-D-STATE .VARTBL>)
446 (ELSE <MSAVE-L-D-STATE .L-V .VARTBL>)>>
449 <COND (.FRET <BUILD-TYPE-LIST .VARTBL>)
450 (ELSE <ORUPC .VARTBL <VSPCD .ITRNOD>>)>>
454 <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
455 (ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
456 <SET VALSPCD <ORUPC .OV .VALSPCD>>
458 <PUT <2 <KIDS .MNOD>>
460 <TYPE-MERGE <ACCUM-TYPE <2 <KIDS .MNOD>>> .TYP>>
461 <PUT .NOD ,NODE-TYPE ,MAPRET-STOP-CODE>>
464 <COND (<GASSIGNED? MAPLEAVE-ANA>
465 <PUTPROP ,MAPLEAVE ANALYSIS ,MAPLEAVE-ANA>
466 <PUTPROP ,MAPRET ANALYSIS ,MAPRET-STOP-ANA>
467 <PUTPROP ,MAPSTOP ANALYSIS ,MAPRET-STOP-ANA>)>
469 <DEFINE SUBAP? (NOD "AUX" TT (COD 0))
470 #DECL ((COD) FIX (NOD) NODE)
471 <AND <OR <==? <SET COD <NODE-TYPE .NOD>> ,FGVAL-CODE>
472 <==? .COD ,GVAL-CODE>
473 <==? .COD ,MFIRST-CODE>>
474 <==? <NODE-TYPE <SET NOD <1 <KIDS .NOD>>>> ,QUOTE-CODE>
475 <GASSIGNED? <SET TT <NODE-NAME .NOD>>>