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 ())
32 #DECL ((PRED) <SPECIAL ANY> (TRUTH UNTRUTH) <SPECIAL LIST>)
33 <COND (<SET TEM <SEGFLUSH .NOD .RTYP>> <SET FLG <>>)
35 <ARGCHK <LENGTH <KIDS .NOD>> 1 NOT .NOD>
36 <SET TEM <ANA <1 <KIDS .NOD>> ANY>>
37 <PUT .NOD ,NODE-TYPE ,NOT-CODE>
39 <COND (<==? <ISTYPE? .TEM> FALSE>
40 <TYPE-OK? BOOL-TRUE .RTYP>)
41 (<TYPE-OK? .TEM FALSE>
42 <TYPE-OK? BOOLEAN .RTYP>)
43 (ELSE <TYPE-OK? BOOL-FALSE .RTYP>)>>
51 " Analyze N==? and ==? usage. Complain if types differ such that
52 the args can never be ==?."
54 <DEFINE ==?-ANA (NOD RTYP
56 (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>) (WHO ())
57 KT NT (GLN .NOD) (GLE ()))
58 #DECL ((NOD) NODE (K) <LIST [REST NODE]> (WHON GLN) <SPECIAL NODE>
59 (WHO GLE) <SPECIAL LIST>)
60 <COND (<SEGFLUSH .NOD .RTYP>)
62 <COND (<AND <==? <LENGTH .K> 1>
63 <==? <NODE-TYPE <SET NT <1 <KIDS .NOD>>>>
65 <==? <NODE-NAME .NT> LENGTH>
66 <==? <LENGTH <SET KT <KIDS .NT>>> 2>>
68 "Attempting to repair probable erroneous code:
74 <PUTREST .K <REST .KT>>
76 <PUT <1 .KT> ,PARENT .NOD>>
79 <ARGCHK 2 <LENGTH .K> ==? .NOD>
82 <PUT .NOD ,NODE-TYPE ,EQ-CODE>
83 <COND (<AND <==? <ISTYPE? <RESULT-TYPE <1 .K>>> FIX>
84 <==? <ISTYPE? <RESULT-TYPE <2 .K>>> FIX>>
85 <PUT .NOD ,NODE-TYPE ,TEST-CODE>
86 <HACK-BOUNDS .WHO .GLE .NOD .K>)>
87 <TYPE-OK? BOOLEAN .RTYP>)>>
90 " Ananlyze TYPE? usage warn about any potential losers by using
93 <DEFINE TYPE?-ANA (NOD RTYP
94 "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) ITYP (ALLGOOD T)
95 (WHO ()) (FTYP ()) (FNOK <>)
96 (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>) TTYP)
97 #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX (ITYP) ANY
98 (ALLGOOD) <OR FALSE ATOM> (WHON) <SPECIAL <OR NODE FALSE>>
99 (WHO) <SPECIAL LIST> (FTYP) LIST)
101 (<SEGFLUSH .NOD .RTYP> <TYPE-OK? .RTYP '<OR ATOM FALSE>>)
104 <COMPILE-ERROR "Too few arguments to TYPE? " .NOD>)>
105 <SET ITYP <EANA <1 .K> ANY TYPE?>>
107 <FUNCTION (N "AUX" FLG)
111 <COND (<N==? <NODE-TYPE .N> ,QUOTE-CODE>
112 <RETURN <SET ALLGOOD <>>>)>
113 <COND (<NOT <ISTYPE? <NODE-NAME .N>>>
115 "Argument to TYPE? not a type "
117 <AND <TYPE-OK? <NODE-NAME .N> .ITYP>
118 <SET FTYP (<NODE-NAME .N> !.FTYP)>>>>
120 <COND (<AND .ALLGOOD <NOT <EMPTY? .FTYP>>>
122 <COND (<EMPTY? <REST .FTYP>> <1 .FTYP>)
123 (ELSE <CHTYPE (OR !.FTYP) FORM>)>>
124 <PUT .NOD ,NODE-TYPE ,TY?-CODE>
125 <SET FNOK <NOT <TYPE-OK? <FORM NOT .TTYP> .ITYP>>>
127 <FUNCTION (L "AUX" (FLG <1 .L>) (SYM <2 .L>))
128 #DECL ((L) <LIST <OR ATOM FALSE> SYMTAB> (SYM) SYMTAB)
143 (.ALLGOOD <PUT .NOD ,NODE-TYPE ,TY?-CODE>)
145 <AND .VERBOSE <ADDVMESS .NOD ("Not open compiled.")>>
146 <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
147 <TYPE-OK? <COND (<NOT .ALLGOOD> '<OR FALSE ATOM>)
148 (<EMPTY? .FTYP> FALSE)
150 (ELSE '<OR FALSE ATOM>)>
154 <DEFINE VALID-TYPE?-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>))
155 #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
156 <COND (<SEGFLUSH .N .R>)
158 <ARGCHK 1 .LN VALID-TYPE? .N>
159 <EANA <1 .K> ATOM VALID-TYPE?>
160 <PUT .N ,NODE-TYPE ,VALID-CODE>
161 <TYPE-OK? .R '<OR FALSE TYPE-C>>)>>
163 <DEFINE TYPE-C-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>))
164 #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
165 <COND (<SEGFLUSH .N .R>)
167 <ARGCHK .LN '(1 2) VALID-TYPE? .N>
168 <EANA <1 .K> ATOM TYPE-C>
169 <COND (<==? .LN 2> <EANA <2 .K> ATOM TYPE-C>)>
170 <PUT .N ,NODE-TYPE ,TYPE-C-CODE>
171 <TYPE-OK? .R TYPE-C>)>>
173 <DEFINE =?-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>) N1 N2 T1 T2)
174 #DECL ((N N1 N2) NODE (K) <LIST [REST NODE]> (LN) FIX)
175 <COND (<SEGFLUSH .N .R>)
177 <ARGCHK .LN 2 <NODE-NAME .N> .N>
178 <EANA <SET N1 <1 .K>> ANY <NODE-NAME .N>>
179 <EANA <SET N2 <2 .K>> ANY <NODE-NAME .N>>
180 <COND (<==? <NODE-TYPE .N1> ,QUOTE-CODE>
183 <SET T2 <ISTYPE? <RESULT-TYPE .N2>>>
184 <COND (<OR <==? <SET T1 <ISTYPE? <RESULT-TYPE .N1>>> STRING>
186 <PUT .N ,NODE-TYPE ,=?-STRING-CODE>
187 <TYPE-OK? BOOLEAN .R>)
188 (<AND .T1 .T2 <N==? .T1 .T2>> <TYPE-OK? BOOL-FALSE .R>)
189 (ELSE <TYPE-OK? BOOLEAN .R>)>)>>
191 <DEFINE S=?-ANA (N R "AUX" (K <KIDS .N>))
192 #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
193 <COND (<SEGFLUSH .N .R>)
195 <ARGCHK <LENGTH .K> 2 <NODE-NAME .N> .N>
196 <EANA <1 .K> STRING S=?>
197 <EANA <2 .K> STRING S=?>
198 <PUT .N ,NODE-TYPE ,=?-STRING-CODE>
199 <TYPE-OK? BOOLEAN .R>)>>
201 <DEFINE ATOM-PART-ANA (N R "AUX" (K <KIDS .N>) (NM <NODE-NAME .N>) NN)
202 #DECL ((NN N) NODE (K) <LIST [REST NODE]> (NM) ATOM)
203 <COND (<SEGFLUSH .N .R>)
205 <ARGCHK <LENGTH .K> <COND (<OR <==? .NM GBIND>
206 <==? .NM LBIND>> '(1 2))
208 <EANA <1 .K> ATOM .NM>
209 <COND (<NOT <EMPTY? <REST .K>>> <EANA <SET NN <2 .K>> ANY .NM>)>
210 <COND (<AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
213 <PUT .N ,NODE-TYPE ,QUOTE-CODE>
215 <PUT .N ,NODE-NAME <APPLY ,.NM <NODE-NAME <1 .K>>>>
216 <TYPE-OK? <TYPE <NODE-NAME .N>> .R>)
218 <COND (<OR <AND <N==? .NM GBIND> <N==? .NM LBIND>>
220 <AND <==? <NODE-TYPE .NN> ,QUOTE-CODE>
221 <NOT <NODE-NAME .NN>>>>
222 <PUT .N ,NODE-TYPE ,ATOM-PART-CODE>)>
223 <TYPE-OK? .R <COND (<==? .NM SPNAME> STRING)
224 (<==? .NM OBLIST?> '<OR FALSE OBLIST>)
227 <DEFINE PUT-GET-DECL-ANA (N R "AUX" (K <KIDS .N>) (NM <NODE-NAME .N>) ST)
228 #DECL ((N) NODE (K) <LIST [REST NODE]> (NM) ATOM)
229 <COND (<SEGFLUSH .N .R>)
231 <ARGCHK <LENGTH .K> <COND (<==? .NM PUT-DECL> 2)
233 <SET ST <EANA <1 .K> '<OR ATOM OFFSET GBIND LBIND> .NM>>
234 <COND (<==? .NM PUT-DECL>
235 <SET ST <OR <TYPE-AND .ST .R> .ST>>
236 <EANA <2 .K> '<OR ATOM FALSE FORM SEGMENT> .NM>
237 <PUT .N ,SIDE-EFFECTS (.N !<SIDE-EFFECTS .N>)>)>
238 <COND (<AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE> <==? .NM GET-DECL>>
239 <PUT .N ,NODE-TYPE ,QUOTE-CODE>
241 <PUT .N ,NODE-NAME <GET-DECL <NODE-NAME <1 .K>>>>
242 <TYPE-OK? <TYPE <NODE-NAME .N>> .R>)
244 <COND (<MEMQ <ISTYPE? .ST> '[LBIND GBIND OFFSET]>
245 <PUT .N ,NODE-TYPE ,PUT-GET-DECL-CODE>)
247 <ADDVMESS .N (.NM "Not open compiled because type is "
249 <TYPE-OK? <COND (<==? .NM GET-DECL>
250 '<OR ATOM FALSE FORM SEGMENT>)
253 <DEFINE OFFSET-PART-ANA (N R "AUX" (K <KIDS .N>) (NM <NODE-NAME .N>))
254 #DECL ((N) NODE (K) <LIST [REST NODE]> (NM) ATOM)
255 <COND (<SEGFLUSH .N .R>)
257 <ARGCHK <LENGTH .K> <COND (<==? .NM INDEX> 1)
258 (ELSE '(1 2))> .NM .N>
259 <EANA <1 .K> OFFSET .NM>
260 <COND (<NOT <EMPTY? <REST .K>>>
261 <EANA <2 .K> '<OR ATOM FALSE FORM SEGMENT> .NM>)>
262 <COND (<AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
264 <PUT .N ,NODE-TYPE ,QUOTE-CODE>
266 <PUT .N ,NODE-NAME <APPLY ,.NM <NODE-NAME <1 .K>>>>
267 <TYPE-OK? <TYPE <NODE-NAME .N>> .R>)
269 <PUT .N ,NODE-TYPE ,OFFSET-PART-CODE>
271 <COND (<==? .NM INDEX> FIX)
272 (<NOT <EMPTY? <REST .K>>> OFFSET)
273 (ELSE '<OR ATOM FALSE FORM SEGMENT>)>>)>)>>
275 <DEFINE STRCOMP-ANA (N R "AUX" (K <KIDS .N>))
276 #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
277 <COND (<SEGFLUSH .N .R>)
279 <ARGCHK <LENGTH .K> 2 <NODE-NAME .N> .N>
280 <EANA <1 .K> STRING STRCOMP>
281 <EANA <2 .K> STRING STRCOMP>
282 <PUT .N ,NODE-TYPE ,=?-STRING-CODE>
285 <DEFINE SUBSTRUC-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>) ST)
286 #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
287 <COND (<SEGFLUSH .N .R>)
289 <ARGCHK .LN '(1 4) <NODE-NAME .N> .N>
290 <SET ST <EANA <1 .K> STRUCTURED SUBSTRUC>>
291 <COND (<G? .LN 1> <EANA <2 .K> FIX SUBSTRUC>)>
292 <COND (<G? .LN 2> <EANA <3 .K> FIX SUBSTRUC>)>
294 <SET ST <STRUCTYP .ST>>
295 <SET ST <EANA <4 .K> <COND (.ST <FORM PRIMTYPE .ST>)
298 <PUT .N ,SIDE-EFFECTS (.N !<SIDE-EFFECTS .N>)>)>
299 <COND (<MEMQ <STRUCTYP .ST> '[STRING VECTOR UVECTOR BYTES]>
300 <PUT .N ,NODE-TYPE ,SUBSTRUC-CODE>)>
301 <TYPE-OK? <STRUCTYP .ST> .R>)>>
304 <COND (<AND <GASSIGNED? NOT-ANA> <GASSIGNED? ELEMENT-DECL>>
305 <PUTPROP ,NOT ANALYSIS ,NOT-ANA>
306 <PUTPROP ,==? ANALYSIS ,==?-ANA>
307 <PUTPROP ,N==? ANALYSIS ,==?-ANA>
308 <PUTPROP ,TYPE? ANALYSIS ,TYPE?-ANA>
309 <PUTPROP ,=? ANALYSIS ,=?-ANA>
310 <PUTPROP ,N=? ANALYSIS ,=?-ANA>
311 <PUTPROP ,VALID-TYPE? ANALYSIS ,VALID-TYPE?-ANA>
312 <PUTPROP ,TYPE-C ANALYSIS ,TYPE-C-ANA>
313 <PUTPROP ,INDEX ANALYSIS ,OFFSET-PART-ANA>
314 <PUTPROP ,ELEMENT-DECL ANALYSIS ,OFFSET-PART-ANA>
315 <PUTPROP ,PUT-DECL ANALYSIS ,PUT-GET-DECL-ANA>
316 <PUTPROP ,GET-DECL ANALYSIS ,PUT-GET-DECL-ANA>
317 <PUTPROP ,SPNAME ANALYSIS ,ATOM-PART-ANA>
318 <PUTPROP ,OBLIST? ANALYSIS ,ATOM-PART-ANA>
319 <PUTPROP ,LBIND ANALYSIS ,ATOM-PART-ANA>
320 <PUTPROP ,GBIND ANALYSIS ,ATOM-PART-ANA>
321 <PUTPROP ,S=? ANALYSIS ,S=?-ANA>
322 <PUTPROP ,STRCOMP ANALYSIS ,STRCOMP-ANA>
323 <PUTPROP ,SUBSTRUC ANALYSIS ,SUBSTRUC-ANA>)>