17 <USE "SYMANA" "CHKDCL" "COMPDEC" "CARANA" "ADVMESS" "NPRINT">
19 " This module contains analysis and generation functions for
20 NOT, TYPE? and ==?. See SYMANA for more details about ANALYSIS and
21 CODGEN for more detali abour code generation.
24 "Analyze NOT usage make sure arg can be FALSE."
26 <DEFINE NOT-ANA (NOD RTYP
27 "AUX" TEM (FLG <==? .PRED <PARENT .NOD>>) (STR .TRUTH)
29 #DECL ((NOD) NODE (STR SUNT) LIST)
30 <PROG ((PRED <AND .FLG .NOD>) (TRUTH ()) (UNTRUTH ()))
31 #DECL ((PRED) <SPECIAL ANY> (TRUTH UNTRUTH) <SPECIAL LIST>)
32 <COND (<SET TEM <SEGFLUSH .NOD .RTYP>> <SET FLG <>>)
34 <ARGCHK <LENGTH <KIDS .NOD>> 1 NOT .NOD>
35 <SET TEM <ANA <1 <KIDS .NOD>> ANY>>
36 <PUT .NOD ,NODE-TYPE ,NOT-CODE>
38 <COND (<==? <ISTYPE? .TEM> FALSE>
39 <TYPE-OK? BOOL-TRUE .RTYP>)
40 (<TYPE-OK? .TEM FALSE>
41 <TYPE-OK? BOOLEAN .RTYP>)
42 (ELSE <TYPE-OK? BOOL-FALSE .RTYP>)>>
46 <SET TRUTH (!.STR !.TRUTH)>
47 <SET UNTRUTH (!.SUNT !.UNTRUTH)>)>
50 " Analyze N==? and ==? usage. Complain if types differ such that
51 the args can never be ==?."
53 <DEFINE ==?-ANA (NOD RTYP
55 (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>) (WHO ())
56 KT NT (GLN .NOD) (GLE ()))
57 #DECL ((NOD) NODE (K) <LIST [REST NODE]> (WHON GLN) <SPECIAL NODE>
58 (WHO GLE) <SPECIAL LIST>)
59 <COND (<SEGFLUSH .NOD .RTYP>)
61 <COND (<AND <==? <LENGTH .K> 1>
62 <==? <NODE-TYPE <SET NT <1 <KIDS .NOD>>>>
64 <==? <NODE-NAME .NT> LENGTH>
65 <==? <LENGTH <SET KT <KIDS .NT>>> 2>>
67 "Attempting to repair probable erroneous code:
73 <PUTREST .K <REST .KT>>
75 <PUT <1 .KT> ,PARENT .NOD>>
78 <ARGCHK 2 <LENGTH .K> ==? .NOD>
81 <COND (<AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
82 <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
83 <COND (<==? <NODE-NAME .NOD> ==?>
84 <PUT .NOD ,NODE-NAME <==? <NODE-NAME <1 .K>>
87 <PUT .NOD ,NODE-NAME <N==? <NODE-NAME <1 .K>>
88 <NODE-NAME <2 .K>>>>)>
90 <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
91 <COND (<NODE-NAME .NOD> <TYPE-OK? ATOM .RTYP>)
92 (ELSE <TYPE-OK? FALSE .RTYP>)>)
94 <PUT .NOD ,NODE-TYPE ,EQ-CODE>
95 <COND (<AND <==? <ISTYPE? <RESULT-TYPE <1 .K>>> FIX>
96 <==? <ISTYPE? <RESULT-TYPE <2 .K>>> FIX>>
97 <PUT .NOD ,NODE-TYPE ,TEST-CODE>
98 <HACK-BOUNDS .WHO .GLE .NOD .K>)>
99 <TYPE-OK? BOOLEAN .RTYP>)>)>>
102 " Ananlyze TYPE? usage warn about any potential losers by using
105 <DEFINE TYPE?-ANA (NOD RTYP
106 "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) ITYP (ALLGOOD T)
107 (WHO ()) (FTYP ()) (FNOK <>)
108 (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>) TTYP)
109 #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX (ITYP) ANY
110 (ALLGOOD) <OR FALSE ATOM> (WHON) <SPECIAL <OR NODE FALSE>>
111 (WHO) <SPECIAL LIST> (FTYP) LIST)
113 (<SEGFLUSH .NOD .RTYP> <TYPE-OK? .RTYP '<OR ATOM FALSE>>)
116 <COMPILE-ERROR "Too few arguments to TYPE? " .NOD>)>
117 <SET ITYP <EANA <1 .K> ANY TYPE?>>
119 <FUNCTION (N "AUX" FLG)
123 <COND (<N==? <NODE-TYPE .N> ,QUOTE-CODE>
124 <RETURN <SET ALLGOOD <>>>)>
125 <COND (<NOT <ISTYPE? <NODE-NAME .N>>>
127 "Argument to TYPE? not a type "
129 <AND <TYPE-OK? <NODE-NAME .N> .ITYP>
130 <SET FTYP (<NODE-NAME .N> !.FTYP)>>>>
132 <COND (<AND .ALLGOOD <NOT <EMPTY? .FTYP>>>
134 <COND (<EMPTY? <REST .FTYP>> <1 .FTYP>)
135 (ELSE <CHTYPE (OR !.FTYP) FORM>)>>
136 <PUT .NOD ,NODE-TYPE ,TY?-CODE>
137 <SET FNOK <NOT <TYPE-OK? <FORM NOT .TTYP> .ITYP>>>
139 <FUNCTION (L "AUX" (FLG <1 .L>) (SYM <2 .L>))
140 #DECL ((L) <LIST <OR ATOM FALSE> SYMTAB> (SYM) SYMTAB)
155 (.ALLGOOD <PUT .NOD ,NODE-TYPE ,TY?-CODE>)
157 <AND .VERBOSE <ADDVMESS .NOD ("Not open compiled.")>>
158 <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
159 <TYPE-OK? <COND (<NOT .ALLGOOD> '<OR FALSE ATOM>)
160 (<EMPTY? .FTYP> FALSE)
162 (ELSE '<OR FALSE ATOM>)>
166 <DEFINE VALID-TYPE?-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>))
167 #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
168 <COND (<SEGFLUSH .N .R>)
170 <ARGCHK 1 .LN VALID-TYPE? .N>
171 <EANA <1 .K> ATOM VALID-TYPE?>
172 <PUT .N ,NODE-TYPE ,VALID-CODE>
173 <TYPE-OK? .R '<OR FALSE TYPE-C>>)>>
175 <DEFINE TYPE-C-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>))
176 #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
177 <COND (<SEGFLUSH .N .R>)
179 <ARGCHK .LN '(1 2) VALID-TYPE? .N>
180 <EANA <1 .K> ATOM TYPE-C>
181 <COND (<==? .LN 2> <EANA <2 .K> ATOM TYPE-C>)>
182 <PUT .N ,NODE-TYPE ,TYPE-C-CODE>
183 <TYPE-OK? .R TYPE-C>)>>
185 <DEFINE =?-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>) N1 N2 T1 T2)
186 #DECL ((N N1 N2) NODE (K) <LIST [REST NODE]> (LN) FIX)
187 <COND (<SEGFLUSH .N .R>)
189 <ARGCHK .LN 2 <NODE-NAME .N> .N>
190 <EANA <SET N1 <1 .K>> ANY <NODE-NAME .N>>
191 <EANA <SET N2 <2 .K>> ANY <NODE-NAME .N>>
192 <COND (<==? <NODE-TYPE .N1> ,QUOTE-CODE>
195 <SET T2 <ISTYPE? <RESULT-TYPE .N2>>>
196 <COND (<OR <==? <SET T1 <ISTYPE? <RESULT-TYPE .N1>>> STRING>
198 <PUT .N ,NODE-TYPE ,=?-STRING-CODE>
199 <TYPE-OK? BOOLEAN .R>)
200 (<AND .T1 .T2 <N==? .T1 .T2>> <TYPE-OK? BOOL-FALSE .R>)
201 (ELSE <TYPE-OK? BOOLEAN .R>)>)>>
203 <DEFINE S=?-ANA (N R "AUX" (K <KIDS .N>))
204 #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
205 <COND (<SEGFLUSH .N .R>)
207 <ARGCHK <LENGTH .K> 2 <NODE-NAME .N> .N>
208 <EANA <1 .K> STRING S=?>
209 <EANA <2 .K> STRING S=?>
210 <PUT .N ,NODE-TYPE ,=?-STRING-CODE>
211 <TYPE-OK? BOOLEAN .R>)>>
213 <DEFINE ATOM-PART-ANA (N R "AUX" (K <KIDS .N>) (NM <NODE-NAME .N>) NN)
214 #DECL ((NN N) NODE (K) <LIST [REST NODE]> (NM) ATOM)
215 <COND (<SEGFLUSH .N .R>)
217 <ARGCHK <LENGTH .K> <COND (<OR <==? .NM GBIND>
218 <==? .NM LBIND>> '(1 2))
220 <EANA <1 .K> ATOM .NM>
221 <COND (<NOT <EMPTY? <REST .K>>> <EANA <SET NN <2 .K>> ANY .NM>)>
222 <COND (<AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
225 <PUT .N ,NODE-TYPE ,QUOTE-CODE>
227 <PUT .N ,NODE-NAME <APPLY ,.NM <NODE-NAME <1 .K>>>>
228 <TYPE-OK? <TYPE <NODE-NAME .N>> .R>)
230 <COND (<OR <AND <N==? .NM GBIND> <N==? .NM LBIND>>
232 <AND <==? <NODE-TYPE .NN> ,QUOTE-CODE>
233 <NOT <NODE-NAME .NN>>>>
234 <PUT .N ,NODE-TYPE ,ATOM-PART-CODE>)>
235 <TYPE-OK? .R <COND (<==? .NM SPNAME> STRING)
236 (<==? .NM OBLIST?> '<OR FALSE OBLIST>)
239 <DEFINE PUT-GET-DECL-ANA (N R "AUX" (K <KIDS .N>) (NM <NODE-NAME .N>) ST)
240 #DECL ((N) NODE (K) <LIST [REST NODE]> (NM) ATOM)
241 <COND (<SEGFLUSH .N .R>)
243 <ARGCHK <LENGTH .K> <COND (<==? .NM PUT-DECL> 2)
245 <SET ST <EANA <1 .K> '<OR ATOM OFFSET GBIND LBIND> .NM>>
246 <COND (<==? .NM PUT-DECL>
247 <SET ST <OR <TYPE-AND .ST .R> .ST>>
248 <EANA <2 .K> '<OR ATOM FALSE FORM SEGMENT> .NM>
249 <PUT .N ,SIDE-EFFECTS (.N !<SIDE-EFFECTS .N>)>)>
250 <COND (<AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE> <==? .NM GET-DECL>>
251 <PUT .N ,NODE-TYPE ,QUOTE-CODE>
253 <PUT .N ,NODE-NAME <GET-DECL <NODE-NAME <1 .K>>>>
254 <TYPE-OK? <TYPE <NODE-NAME .N>> .R>)
256 <COND (<MEMQ <ISTYPE? .ST> '[LBIND GBIND OFFSET]>
257 <PUT .N ,NODE-TYPE ,PUT-GET-DECL-CODE>)
259 <ADDVMESS .N (.NM "Not open compiled because type is "
261 <TYPE-OK? <COND (<==? .NM GET-DECL>
262 '<OR ATOM FALSE FORM SEGMENT>)
265 <DEFINE OFFSET-PART-ANA (N R "AUX" (K <KIDS .N>) (NM <NODE-NAME .N>))
266 #DECL ((N) NODE (K) <LIST [REST NODE]> (NM) ATOM)
267 <COND (<SEGFLUSH .N .R>)
269 <ARGCHK <LENGTH .K> <COND (<==? .NM INDEX> 1)
270 (ELSE '(1 2))> .NM .N>
271 <EANA <1 .K> OFFSET .NM>
272 <COND (<NOT <EMPTY? <REST .K>>>
273 <EANA <2 .K> '<OR ATOM FALSE FORM SEGMENT> .NM>)>
274 <COND (<AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
276 <PUT .N ,NODE-TYPE ,QUOTE-CODE>
278 <PUT .N ,NODE-NAME <APPLY ,.NM <NODE-NAME <1 .K>>>>
279 <TYPE-OK? <TYPE <NODE-NAME .N>> .R>)
281 <PUT .N ,NODE-TYPE ,OFFSET-PART-CODE>
283 <COND (<==? .NM INDEX> FIX)
284 (<NOT <EMPTY? <REST .K>>> OFFSET)
285 (ELSE '<OR ATOM FALSE FORM SEGMENT>)>>)>)>>
287 <DEFINE STRCOMP-ANA (N R "AUX" (K <KIDS .N>))
288 #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
289 <COND (<SEGFLUSH .N .R>)
291 <ARGCHK <LENGTH .K> 2 <NODE-NAME .N> .N>
292 <COND (<AND <STRCOMP-ARG-ANA <1 .K> .N 1>
293 <STRCOMP-ARG-ANA <2 .K> .N 2>>
294 <PUT .N ,NODE-TYPE ,=?-STRING-CODE>)>
297 <DEFINE STRCOMP-ARG-ANA (N:NODE P:NODE IDX:FIX "AUX" TYP ITYP NN:NODE)
298 <SET TYP <EANA .N ANY STRCOMP>>
299 <COND (<SET ITYP <ISTYPE? .TYP>>
300 <COND (<==? .ITYP ATOM>
301 <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE>
302 <PUT .N ,NODE-NAME <SPNAME <NODE-NAME .N>>>
303 <PUT .N ,RESULT-TYPE STRING>)
305 <SET NN <NODEFM ,ATOM-PART-CODE .P STRING SPNAME
307 <PUT <KIDS .P> .IDX .NN>
308 <PUT .N ,PARENT .NN>)>)>
310 (<=? .TYP '<OR ATOM STRING>> T)
311 (<NOT <TYPE-OK? .TYP '<OR ATOM STRING>>>
312 <COMPILE-ERROR "Argument wrong type to: " STRCOMP .P>)
315 <DEFINE SUBSTRUC-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>) ST)
316 #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
317 <COND (<SEGFLUSH .N .R>)
319 <ARGCHK .LN '(1 4) <NODE-NAME .N> .N>
320 <SET ST <EANA <1 .K> STRUCTURED SUBSTRUC>>
321 <COND (<G? .LN 1> <EANA <2 .K> FIX SUBSTRUC>)>
322 <COND (<G? .LN 2> <EANA <3 .K> FIX SUBSTRUC>)>
324 <SET ST <STRUCTYP .ST>>
325 <SET ST <EANA <4 .K> <COND (.ST <FORM PRIMTYPE .ST>)
328 <PUT .N ,SIDE-EFFECTS (.N !<SIDE-EFFECTS .N>)>)>
329 <COND (<MEMQ <STRUCTYP .ST> '[STRING VECTOR UVECTOR BYTES]>
330 <PUT .N ,NODE-TYPE ,SUBSTRUC-CODE>)>
331 <TYPE-OK? <STRUCTYP .ST> .R>)>>
334 <COND (<AND <GASSIGNED? NOT-ANA> <GASSIGNED? ELEMENT-DECL>>
335 <PUTPROP ,NOT ANALYSIS ,NOT-ANA>
336 <PUTPROP ,==? ANALYSIS ,==?-ANA>
337 <PUTPROP ,N==? ANALYSIS ,==?-ANA>
338 <PUTPROP ,TYPE? ANALYSIS ,TYPE?-ANA>
339 <PUTPROP ,=? ANALYSIS ,=?-ANA>
340 <PUTPROP ,N=? ANALYSIS ,=?-ANA>
341 <PUTPROP ,VALID-TYPE? ANALYSIS ,VALID-TYPE?-ANA>
342 <PUTPROP ,TYPE-C ANALYSIS ,TYPE-C-ANA>
343 <PUTPROP ,INDEX ANALYSIS ,OFFSET-PART-ANA>
344 <PUTPROP ,ELEMENT-DECL ANALYSIS ,OFFSET-PART-ANA>
345 <PUTPROP ,PUT-DECL ANALYSIS ,PUT-GET-DECL-ANA>
346 <PUTPROP ,GET-DECL ANALYSIS ,PUT-GET-DECL-ANA>
347 <PUTPROP ,SPNAME ANALYSIS ,ATOM-PART-ANA>
348 <PUTPROP ,OBLIST? ANALYSIS ,ATOM-PART-ANA>
349 <PUTPROP ,LBIND ANALYSIS ,ATOM-PART-ANA>
350 <PUTPROP ,GBIND ANALYSIS ,ATOM-PART-ANA>
351 <PUTPROP ,S=? ANALYSIS ,S=?-ANA>
352 <PUTPROP ,STRCOMP ANALYSIS ,STRCOMP-ANA>
353 <PUTPROP ,SUBSTRUC ANALYSIS ,SUBSTRUC-ANA>)>