3 <ENTRY MAPPER-AN MAPRET-STOP-ANA MAPLEAVE-ANA MENTROPY MAUX MAUX1 MTUPLE MBAD
4 MOPT MOPT2 MARGS-ANA MNORM>
6 <USE "SYMANA" "CHKDCL" "COMPDEC" "ADVMESS">
8 <SETG SPECIAL-MAPF-R-SUBRS ![,LIST ,+ ,* ,MAX ,MIN!]>
10 <DEFINE MAPPER-AN (MNOD MRTYP
11 "AUX" (K <KIDS .MNOD>) TT ITRNOD FAP T TF (MPSTRS ())
12 (R? <==? <NODE-SUBR .MNOD> ,MAPR>) (TUPCNT 1)
13 (RETYPS NO-RETURN) TEM ASSU L-D L-V D-V VALSPCD SBR
14 (SBRL <>) (SEGFX ()) FINTYPE STATE (FRET T) (FSTOP T)
15 (OV .VARTBL) NSTR (CHF <>))
16 #DECL ((FAP ITRNOD) NODE (K) <LIST [REST NODE]> (TUPCNT TT NSTR) FIX
17 (MPSTRS L-V D-V) <SPECIAL LIST> (R?) <SPECIAL <OR ATOM FALSE>>
18 (STATE) <SPECIAL FIX> (SEGFX) <SPECIAL <LIST [REST NODE]>>
19 (MNOD) <SPECIAL NODE> (OV) SYMTAB
20 (FRET FSTOP MRTYP RETYPS) <SPECIAL ANY> (VALSPCD) <SPECIAL LIST>
21 (ASSU L-D) LIST (SBRL) <OR UVECTOR FALSE>)
22 <SET TF <EANA <SET FAP <1 .K>> ANY <NODE-NAME .MNOD>>>
23 <COND (<AND <SET SBR <SUBAP? .FAP>>
24 <SET SBRL <MEMQ ,.SBR ,SPECIAL-MAPF-R-SUBRS>>>
25 <PUT .FAP ,NODE-TYPE ,MFIRST-CODE>
26 <COND (<N==? ,.SBR ,LIST> <SET FINTYPE '<OR FIX FLOAT>> <SET STATE 1>)
27 (ELSE <SET FINTYPE LIST>)>
28 <PUT .FAP ,NODE-SUBR <LENGTH .SBRL>>)>
29 <PUT .MNOD ,STACKS <* <SET NSTR <- <LENGTH .K> 2>> 2>>
34 <COND (<L? <MINL <RESULT-TYPE .N>> 1> <SET CHF T>)>>
37 (<==? <SET TT <NODE-TYPE .ITRNOD>> ,MFCN-CODE>
38 <PUT .ITRNOD ,SIDE-EFFECTS <>>
40 <FUNCTION (N "AUX" RT R)
42 <SET RT <EANA .N STRUCTURED <NODE-NAME .MNOD>>>
44 <OR <NOT <SET R <STRUCTYP .RT>>> <==? .R TEMPLATE>>>
47 ("Non-specific structure for MAPF/R: "
52 <SET L-D <SAVE-L-D-STATE .VARTBL>>
53 <PROG ((HTMPS 0) (TMPS 0) (VARTBL <SYMTAB .ITRNOD>) (KK .K) (LL .LIFE)
55 #DECL ((HTMPS TMPS) <SPECIAL FIX> (VARTBL) <SPECIAL SYMTAB>
56 (KK) <LIST [REST NODE]>)
57 <COND (.VERBOSE <PUTREST <SET VERBOSE .OVV> ()>)>
61 <RESET-VARS .VARTBL .OV>
62 <MUNG-L-D-STATE .VARTBL>
64 <SET RETYPS NO-RETURN>
65 <SET ASSU <BUILD-TYPE-LIST .OV>>
66 <SET VALSPCD <BUILD-TYPE-LIST .OV>>
67 <REPEAT ((CNT <+ .NSTR 1>) (B <BINDING-STRUCTURE .ITRNOD>))
68 #DECL ((B) <LIST [REST SYMTAB]> (CNT) FIX)
69 <COND (<L? <SET CNT <- .CNT 1>> 0> <RETURN>)>
70 <PUT <1 .B> ,CODE-SYM 3>
71 <PUT <1 .B> ,USED-AT-ALL T>
73 <REPEAT ((BNDS <REST <BINDING-STRUCTURE .ITRNOD> <+ .NSTR 1>>))
75 <AND <NOT <EMPTY? .K>>
77 "MAPF FUNC TAKES TOO FEW ARGS. "
80 <AND <APPLY <NTH ,MAPANALS <CODE-SYM <1 .BNDS>>>
82 <COND (<NOT <EMPTY? .K>> <1 .K>)>>
83 <SET BNDS <REST .BNDS>>>
84 <OR <EMPTY? .K> <SET K <REST .K>>>>
85 <PUT .ITRNOD ,VSPCD (())>
86 <PROG ((STMPS .TMPS) (SHTMPS .HTMPS) (LL .LIFE) (OV .VERBOSE))
87 #DECL ((STMPS SHTMPS) FIX)
88 <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
93 <PUT .ITRNOD ,ASSUM <BUILD-TYPE-LIST .VARTBL>>
94 <PUT .ITRNOD ,ACCUM-TYPE NO-RETURN>
95 <SET TEM <SEQ-AN <KIDS .ITRNOD> <INIT-DECL-TYPE .ITRNOD>>>
96 <OR <NOT <AGND .ITRNOD>>
97 <ASSUM-OK? <ASSUM .ITRNOD> <AGND .ITRNOD>>
99 <COND (<N==? .TEM NO-RETURN>
101 <SET L-V <MSAVE-L-D-STATE .L-V .OV>>
102 <ASSERT-TYPES <ORUPC .VARTBL <VSPCD .ITRNOD>>>)
103 (ELSE <SET L-V <SAVE-L-D-STATE .OV>>)>)
104 (<N==? <ACCUM-TYPE .ITRNOD> NO-RETURN>
105 <ASSERT-TYPES <VSPCD .ITRNOD>>)>
106 <SET VALSPCD <ORUPC .OV .VALSPCD>>
107 <OR <ASSUM-OK? .ASSU <BUILD-TYPE-LIST .VARTBL>> <AGAIN>>
108 <PUT .ITRNOD ,ACCUM-TYPE <TYPE-MERGE .TEM <ACCUM-TYPE .ITRNOD>>>
111 <TYPE-OK? <ACCUM-TYPE .ITRNOD> <INIT-DECL-TYPE .ITRNOD>>>>
112 <ASSERT-TYPES .VALSPCD>
113 <COND (<ASSIGNED? STATE>
114 <FIX-STATE <ACCUM-TYPE .ITRNOD> .ITRNOD>
117 <PUT .FAP ,NODE-TYPE ,GVAL-CODE>
118 <SET FINTYPE '<OR FIX FLOAT>>)
120 <SET FINTYPE <NTH '![FIX FLOAT FLOAT!] <- .STATE 1>>>)>)>
121 <SAVE-SURVIVORS .L-D .LIFE T>
122 <SAVE-SURVIVORS .L-V .LIFE>
124 <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
125 (ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
126 <FREST-L-D-STATE .D-V>
127 <SET LIFE <KILL-REM .LIFE .OV>>
128 <COND (.SBRL <MUNG-SEGS .SEGFX>)>
129 <COND (<SIDE-EFFECTS .ITRNOD>
132 (!<SIDE-EFFECTS .ITRNOD> !<SIDE-EFFECTS .MNOD>)>)>
133 <COND (<AND <==? <NODE-TYPE .FAP> ,QUOTE-CODE>
134 <==? <NODE-NAME .FAP> #FALSE ()>>
135 <TYPE-OK? <COND (.CHF <TYPE-MERGE FALSE .TEM .RETYPS>)
136 (ELSE <TYPE-OK? <TYPE-MERGE .TEM .RETYPS> .MRTYP>)>
139 <COND (<==? .FINTYPE LIST>
140 <TYPE-OK? <TYPE-MERGE <FORM LIST
141 [REST <RESULT-TYPE .ITRNOD>]>
144 (ELSE <TYPE-OK? <TYPE-MERGE .FINTYPE .RETYPS> .MRTYP>)>)
145 (<AND <==? <NODE-TYPE .FAP> ,GVAL-CODE>
146 <MEMQ <NODE-NAME .FAP> '![VECTOR UVECTOR!]>>
147 <SET TEM <FORM <NODE-NAME .FAP> [REST .TEM]>>
148 <TYPE-OK? <TYPE-MERGE .RETYPS .TEM> .MRTYP>)
149 (ELSE <TYPE-OK? <TYPE-MERGE <APPLTYP .FAP> .RETYPS> .MRTYP>)>)
151 <COND (<N==? .TT ,MPSBR-CODE> <EANA .ITRNOD APPLICABLE <NODE-NAME .MNOD>>)>
153 <FUNCTION (N "AUX" RT R)
155 <SET RT <EANA .N STRUCTURED <NODE-NAME .MNOD>>>
157 <OR <NOT <SET R <STRUCTYP .RT>>> <==? .R TEMPLATE>>>
160 ("Non-specific structure for MAPF/R: "
164 <SET MPSTRS <REST .K 2>>>
165 <COND (<==? .TT ,MPSBR-CODE>
166 <SET TEM <EANA <1 <KIDS .ITRNOD>> ANY <NODE-NAME .MNOD>>>
167 <COND (.CHF <SET TEM <TYPE-MERGE .TEM FALSE>>)>)
168 (ELSE <SET TEM ANY>)>
169 <COND (<ASSIGNED? STATE>
170 <FIX-STATE .TEM <1 <KIDS .ITRNOD>>>
173 <PUT .FAP ,NODE-TYPE ,GVAL-CODE>
174 <SET FINTYPE '<OR FIX FLOAT>>)
176 <SET FINTYPE <NTH '![FIX FLOAT FLOAT!] <- .STATE 1>>>)>)>
177 <COND (.SBRL <MUNG-SEGS .SEGFX>)>
178 <COND (<AND <==? <NODE-TYPE .FAP> ,QUOTE-CODE>
179 <==? <NODE-NAME .FAP> #FALSE ()>>
180 <TYPE-OK? .TEM .MRTYP>)
182 <COND (<==? .FINTYPE LIST>
183 <TYPE-OK? <FORM LIST [REST .TEM]> .MRTYP>)
184 (ELSE <TYPE-OK? .FINTYPE .MRTYP>)>)
185 (<AND <==? <NODE-TYPE .FAP> ,GVAL-CODE>
186 <MEMQ <NODE-NAME .FAP> '![VECTOR UVECTOR!]>>
187 <SET TEM <FORM <NODE-NAME .FAP> [REST .TEM]>>
188 <TYPE-OK? <TYPE-MERGE .RETYPS .TEM> .MRTYP>)
189 (ELSE <TYPE-OK? <APPLTYP .FAP> .MRTYP>)>)>>
193 <DEFINE FIX-STATE (TEM N "AUX" TT (SG <MEMQ <NODE-TYPE .N> ,SEG-CODES>))
194 #DECL ((STATE TT) FIX (N) NODE)
196 <COND (<==? .TEM FIX> 1)
198 (<NOT <TYPE-OK? .TEM FLOAT>>
202 <TYPE-MERGE '<STRUCTURED [REST FIX]>
206 (<NOT <TYPE-OK? .TEM FIX>>
210 <TYPE-MERGE '<STRUCTURED [REST FLOAT]>
215 <SET STATE <NTH <NTH ,ASTATE .STATE> .TT>>>
217 <SETG SEG-CODES ![,SEG-CODE ,SEGMENT-CODE!]>
219 <DEFINE MUNG-SEGS (SEGS)
220 #DECL ((SEGS) <LIST [REST NODE]>)
222 <FUNCTION (N) #DECL ((N) NODE) <PUT .N ,NODE-TYPE ,SEG-CODE>>
225 <DEFINE MARGS-ANA (N R "AUX" (MK .MPSTRS) (NN <NODE-NAME .N>))
226 #DECL ((N) NODE (NN) FIX (MK) <LIST [REST NODE]>)
228 <TYPE-OK? <GET-ELE-TYPE <RESULT-TYPE <NTH .MK .NN>> ALL .R?>
230 <COND (.R? <TYPE-OK? .R '<STRUCTURED ANY>>) (ELSE .R)>>
232 <DEFINE MAUX (SYM STRUC)
233 #DECL ((SYM) SYMTAB (STRUC) <OR FALSE NODE>)
234 <COND (.STRUC <MESSAGE ERROR "TOO MANY ARGS TOO MAPF FCN ">)
235 (ELSE <NORM-BAN .SYM>)>
238 <DEFINE MAUX1 (SYM STRUC)
239 #DECL ((SYM) SYMTAB (STRUC) <OR FALSE NODE>)
240 <COND (.STRUC <MESSAGE ERROR "TOO MANY ARGS TO MAPF FCN ">)>
243 <DEFINE MNORM (SYM STRUC "AUX" (VARTBL <NEXT-SYM .SYM>) TEM COD N)
244 #DECL ((SYM) SYMTAB (STRUC) <OR NODE FALSE> (VARTBL) <SPECIAL SYMTAB>
247 <PUT .SYM ,PURE-SYM <>> ;"Tell VARANA to allocate me."
249 <TYPE-OK? <GET-ELE-TYPE <RESULT-TYPE .STRUC> ALL .R?>
250 <1 <DECL-SYM .SYM>>>>
251 <MESSAGE ERROR "BAD MAP FUNC ARG " <NAME-SYM .SYM>>>
252 <COND (.R? <SET TEM <TYPE-AND .TEM '<STRUCTURED ANY>>>)>
253 <COND (<N=? .TEM <1 <DECL-SYM .SYM>>>
254 <PUT .SYM ,CURRENT-TYPE .TEM>)>
255 <PUT .SYM ,COMPOSIT-TYPE .TEM>)
256 (ELSE <MESSAGE ERROR "TOO FEW MAPF ARGS FOR FCN ">)>
259 <DEFINE MOPT (SYM STRUC "AUX" (VARTBL <NEXT-SYM .SYM>))
260 #DECL ((SYM) SYMTAB (VARTBL) <SPECIAL SYMTAB> (STRUC) <OR FALSE NODE>)
261 <COND (.STRUC <PUT .SYM ,INIT-SYM <>> <MNORM .SYM .STRUC>)
262 (ELSE <NORM-BAN .SYM>)>
265 <DEFINE MBAD (SYM STRUC) <MESSAGE ERROR "BAD ARG DECL IN MAP FCN " <NAME-SYM .SYM>>>
267 <DEFINE MOPT2 (SYM STRUC) <COND (.STRUC <MNORM .SYM .STRUC>)> T>
270 <DEFINE MTUPLE (SYM STRUC
271 "AUX" (VARTBL <NEXT-SYM .SYM>)
273 <GET-ELE-TYPE <1 <DECL-SYM .SYM>>
274 <SET TUPCNT <+ .TUPCNT 1>>>))
277 <SET TEM <EANA .STRUC STRUCTURED .NAME>>
278 <==? <STRUCTYP .TEM> <STRUCTYP .ATYP>>)
280 <OR <TYPE-OK? <GET-ELE-TYPE <EANA .STRUC STRUCTURED .NAME>
283 <MESSAGE ERROR "BAD MAP FCN ARG " <NAME-SYM .SYM>>>)>
287 <DEFINE MENTROPY (N R) T>
304 "Additional SUBR analyzers associated with MAP hackers."
306 <DEFINE MAPLEAVE-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>) TEM)
307 #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
308 <COND (<ASSIGNED? MNOD>
309 <ARGCHK .LN '(0 1) MAPLEAVE>
313 <SET K (<NODE1 ,QUOTE-CODE .N ATOM T ()>)>>)>
314 <SET TEM <EANA <1 .K> .MRTYP MAPLEAVE>>
315 <SET VALSPCD <ORUPC .VARTBL .VALSPCD>>
317 <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
318 (ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
320 <SET RETYPS <TYPE-MERGE .RETYPS .TEM>>
321 <PUT .N ,NODE-TYPE ,MAPLEAVE-CODE>)
322 (ELSE <SUBR-C-AN .N .R>)>
327 <DEFINE MAPRET-STOP-ANA (NOD R "AUX" (ARGS 0) (TYP NO-RETURN) TYP1 ITRNOD)
328 #DECL ((MNOD NOD ITRNOD) NODE (ARGS) FIX)
330 <OR <ASSIGNED? MNOD> <RETURN <SUBR-C-AN .NOD .R>>>
331 <SET ITRNOD <2 <KIDS .MNOD>>>
332 <OR <NODE-NAME <1 <KIDS .MNOD>>>
333 <MESSAGE ERROR " NOTHING TO MAPSTOP/RET TO " .MNOD>>
337 <COND (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
338 <==? <NODE-TYPE .N> ,SEG-CODE>>
341 <COND (<ASSIGNED? STATE>
342 '<STRUCTURED [REST <OR FIX FLOAT>]>)
345 <COND (<ASSIGNED? STATE> <SET STATE 5>)
346 (ELSE <SET SEGFX (.N !.SEGFX)>)>
347 <SET TYP <TYPE-MERGE .TYP <GET-ELE-TYPE .TYP1 ALL>>>
350 <SET ARGS <+ .ARGS 1>>
355 <COND (<ASSIGNED? STATE> '<OR FIX FLOAT>)
357 <NODE-NAME .NOD>>>>)>>
359 <AND <ASSIGNED? STATE> <N==? .TYP NO-RETURN> <FIX-STATE .TYP .NOD>>
360 <COND (<==? <NODE-SUBR .NOD> ,MAPRET>
362 <COND (.FRET <SAVE-L-D-STATE .VARTBL>)
363 (ELSE <MSAVE-L-D-STATE .L-V .VARTBL>)>>
366 <COND (.FRET <BUILD-TYPE-LIST .VARTBL>)
367 (ELSE <ORUPC .VARTBL <VSPCD .ITRNOD>>)>>
371 <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
372 (ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
373 <SET VALSPCD <ORUPC .VARTBL .VALSPCD>>
375 <PUT <2 <KIDS .MNOD>>
377 <TYPE-MERGE <ACCUM-TYPE <2 <KIDS .MNOD>>> .TYP>>
378 <PUT .NOD ,STACKS <* .ARGS 2>>
379 <PUT .NOD ,NODE-TYPE ,MAPRET-STOP-CODE>>
382 <PUT ,MAPLEAVE ANALYSIS ,MAPLEAVE-ANA>
384 <PUT ,MAPRET ANALYSIS ,MAPRET-STOP-ANA>
386 <PUT ,MAPSTOP ANALYSIS ,MAPRET-STOP-ANA>
388 <DEFINE SUBAP? (NOD "AUX" TT (COD 0))
389 #DECL ((COD) FIX (NOD) NODE)
390 <AND <OR <==? <SET COD <NODE-TYPE .NOD>> ,FGVAL-CODE>
391 <==? .COD ,GVAL-CODE>
392 <==? .COD ,MFIRST-CODE>>
393 <==? <NODE-TYPE <SET NOD <1 <KIDS .NOD>>>> ,QUOTE-CODE>
394 <GASSIGNED? <SET TT <NODE-NAME .NOD>>>