3 <ENTRY ARITH-ANA MOD-ANA ABS-ANA ROT-ANA LSH-ANA FIX-ANA FLOAT-ANA ARITHP-ANA
4 HACK-BOUNDS BIT-TEST-ANA>
6 <USE "SYMANA" "CHKDCL" "COMPDEC" "ADVMESS">
8 " This file contains analyzers and code generators for arithmetic
9 SUBRs and predicates. For convenience many of the SUBRs that are
10 similar are combined into one analyzer/generator. For more info
11 on analyzers see SYMANA and on generators see CODGEN.
14 <SETG ASTATE ![![2 3 5!] ![2 4 5!] ![4 3 5!] ![4 4 5!] ![5 5 5!]!]>
16 " Analyze +,-,* and /. Take care of no arg and one arg problems."
18 <DEFINE ARITH-ANA (NOD RTYP
19 "AUX" (NN <NODE-NAME .NOD>) (DEFLT <GET-DF .NN>) (STATE 1)
20 (K <KIDS .NOD>) (FIXDIV <>) RT)
21 #DECL ((NOD) <SPECIAL NODE> (K) <LIST [REST NODE]> (STYP) FIX
22 (STATE) <SPECIAL FIX> (DEFLT) <OR FIX FLOAT>)
23 <SET RT <COND (<NOT <TYPE-OK? .RTYP FLOAT>> FIX) (ELSE '<OR FIX FLOAT>)>>
26 <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
27 <PUT .NOD ,RESULT-TYPE <TYPE .DEFLT>>
28 <PUT .NOD ,NODE-NAME .DEFLT>
30 <TYPE-OK? <TYPE .DEFLT> .RTYP>)
31 (<AND <EMPTY? <REST .K>>
32 <N==? <NODE-TYPE <1 .K>> ,SEGMENT-CODE>
33 <N==? <NODE-TYPE <1 .K>> ,SEG-CODE>
34 <COND (<==? <NODE-SUBR .NOD> ,/>
39 (<NODE1 ,QUOTE-CODE .NOD <TYPE .DEFLT> .DEFLT ()>
43 <COND (<==? <NODE-SUBR .NOD> ,-> <PUT .NOD ,NODE-TYPE ,ABS-CODE>
46 (ELSE <PUT .NOD ,NODE-TYPE ,ID-CODE>)>
47 <EANA <1 .K> .RT <NODE-NAME .NOD>>)
49 <MAPF <> <FUNCTION (N) <ARITH-ELE .N .RT>> .K>
51 <COND (<AND .FIXDIV <N==? .STATE 2>>
52 <PUT <PUT <1 .K> ,NODE-NAME 1.0> ,RESULT-TYPE FLOAT>)>
55 <COND (<OR <==? .NN MAX> <==? .NN MIN>> ,MIN-MAX-CODE)
60 <COND (<==? <NODE-TYPE .NN> ,SEGMENT-CODE>
61 <PUT .NN ,NODE-TYPE ,SEG-CODE>)>>
64 <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>
68 <FUNCTION (N "AUX" (CD <NODE-TYPE .N>))
69 #DECL ((N) NODE (CD) FIX)
70 <COND (<OR <==? .CD ,SEGMENT-CODE>
73 <PUT .N ,NODE-TYPE ,SEGMENT-CODE>
78 <TYPE-OK? <NTH '[FIX FLOAT FLOAT <OR FIX FLOAT>] <- .STATE 1>> .RTYP>)>>
82 <NTH '[0 0 1 1 1.7014117E+38 -1.7014117E+38]
83 <LENGTH <MEMQ .S '![MAX MIN * / - +!]>>>>
85 <DEFINE ARITH-ELE (N RT "AUX" TT TEM (FL <>))
86 #DECL ((N NOD) NODE (STATE TT) FIX)
87 <COND (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
88 <==? <NODE-TYPE .N> ,SEG-CODE>>
92 <FORM STRUCTURED [REST .RT]>
94 <PUT .N ,RESULT-TYPE <RESULT-TYPE <1 <KIDS .N>>>>
95 <SET TEM <OR <AND <ISTYPE? .TEM> <GET-ELE-TYPE .TEM ALL>> ANY>>)
97 <SET TEM <EANA .N .RT <NODE-NAME .NOD>>>
98 <AND <==? <NODE-TYPE .N> ,QUOTE-CODE>
99 <OR <==? .STATE 4> <==? .STATE 3>>
100 <PUT .N ,NODE-NAME <FLOAT <NODE-NAME .N>>>
101 <PUT .N ,RESULT-TYPE FLOAT>>)>
103 <COND (<==? <ISTYPE? .TEM> FIX> 1)
105 (<NOT <TYPE-OK? .TEM FLOAT>>
109 <TYPE-MERGE '<STRUCTURED [REST FIX]>
113 (<NOT <TYPE-OK? .TEM FIX>>
117 <TYPE-MERGE '<STRUCTURED [REST FLOAT]>
122 <COND (<AND .VERBOSE <==? .TT 3>>
123 <ADDVMESS <PARENT .N>
124 ("Arithmetic can't open compile because: " .N
125 " is of type: " .TEM)>)>
126 <SET STATE <NTH <NTH ,ASTATE .STATE> .TT>>>
128 <DEFINE ABS-ANA (N RT "AUX" (K <KIDS .N>) TEM)
129 #DECL ((N) NODE (K) <LIST [REST NODE]>)
130 <COND (<SEGFLUSH .N .RT>)
132 <ARGCHK <LENGTH .K> 1 ABS>
133 <PUT .N ,NODE-TYPE ,ABS-CODE>
134 <SET TEM <EANA <1 .K> '<OR FIX FLOAT> ABS>>
135 <TYPE-OK? <TYPE-OK? '<OR FLOAT <FIX (0 34359738367)>> .RT>
138 <PUT ,ABS ANALYSIS ,ABS-ANA>
140 <DEFINE MOD-ANA (N R "AUX" (K <KIDS .N>))
141 #DECL ((N) NODE (K) <LIST [REST NODE]>)
142 <COND (<SEGFLUSH .N .R>)
144 <ARGCHK <LENGTH .K> 2 MOD>
145 <EANA <1 .K> FIX MOD>
146 <EANA <2 .K> FIX MOD>
147 <PUT .N ,NODE-TYPE ,MOD-CODE>)>
148 <TYPE-OK? <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
149 <FORM FIX (0 <- <NODE-NAME <2 .K>> 1>)>)
152 <PUT ,MOD ANALYSIS ,MOD-ANA>
154 <DEFINE ROT-LSH-ANA (N R COD "AUX" (K <KIDS .N>) (NAM <NODE-NAME .N>))
155 <COND (<SEGFLUSH .N .R>)
157 <ARGCHK <LENGTH .K> 2 .NAM>
158 <EANA <1 .K> '<PRIMTYPE WORD> .NAM>
159 <EANA <2 .K> FIX .NAM>
160 <PUT .N ,NODE-TYPE .COD>)>
163 <DEFINE ROT-ANA (N R) <ROT-LSH-ANA .N .R ,ROT-CODE>>
165 <DEFINE LSH-ANA (N R) <ROT-LSH-ANA .N .R ,LSH-CODE>>
167 <PUT ,ROT ANALYSIS ,ROT-ANA>
169 <PUT ,LSH ANALYSIS ,LSH-ANA>
171 <DEFINE FLOAT-ANA (N R)
173 <FL-FI-ANA .N .R FLOAT FIX ,FLOAT-CODE>>
175 <PUT ,FLOAT ANALYSIS ,FLOAT-ANA>
177 <DEFINE FIX-ANA (N R) #DECL ((N) NODE) <FL-FI-ANA .N .R FIX FLOAT ,FIX-CODE>>
179 <PUT ,FIX ANALYSIS ,FIX-ANA>
181 <DEFINE FL-FI-ANA (N RT OT IT COD "AUX" (K <KIDS .N>) TY NUM)
182 #DECL ((N NUM) NODE (OT IT) ATOM (K) <LIST [REST NODE]> (COD) FIX)
183 <COND (<SEGFLUSH .N .RT>)
185 <ARGCHK <LENGTH .K> 1 .OT>
186 <SET TY <EANA <SET NUM <1 .K>> '<OR FIX FLOAT> .OT>>
187 <COND (<==? <NODE-TYPE .NUM> ,QUOTE-CODE>
188 <PUT .N ,NODE-TYPE ,QUOTE-CODE>
189 <PUT .N ,NODE-NAME <APPLY ,.OT <NODE-NAME .NUM>>>)
191 <PUT .N ,NODE-TYPE .COD>)>)>
194 <DEFINE ARITHP-ANA (NOD RTYP
195 "AUX" (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>) (WHO ())
196 (GLN .NOD) (GLE ()) (NN <NODE-NAME .NOD>)
198 <COND (<OR <==? .NN 0?>
200 <==? <NODE-TYPE .NOD> ,0-TST-CODE>>
202 (ELSE 2)>) (K <KIDS .NOD>) TEM (STATE 1))
203 #DECL ((WHO) <SPECIAL LIST> (WHON GLN) <SPECIAL ANY>
204 (NOD NOD2) <SPECIAL NODE> (TEM) NODE (K) <LIST [REST NODE]>
205 (STATE) <SPECIAL FIX> (COD N) FIX (GLE) <SPECIAL LIST>)
206 <COND (<SEGFLUSH .NOD .RTYP>)
208 <ARGCHK <LENGTH .K> .N <NODE-NAME .NOD>>
209 <MAPF <> <FUNCTION (N) <ARITH-ELE .N '<OR FIX FLOAT>>> .K>
210 <COND (<AND <==? .N 2>
211 <OR <AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
212 <0? <NODE-NAME <1 .K>>>
216 <FLOPP <NODE-NAME .NOD>>>>
217 <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
218 <0? <NODE-NAME <2 .K>>>
220 <PUT .NOD ,NODE-TYPE ,0-TST-CODE>
221 <PUT .NOD ,KIDS (.TEM)>)
222 (<==? <NODE-TYPE .NOD> ,0-TST-CODE>)
223 (<OR <==? <NODE-NAME .NOD> 0?> <==? <NODE-NAME .NOD> N0?>>
224 <PUT .NOD ,NODE-TYPE ,0-TST-CODE>)
228 <COND (<==? .N 2> ,TEST-CODE)
229 (<==? <NODE-NAME .NOD> 0?> ,0-TST-CODE)
231 (<==? <NODE-SUBR .NOD> ,1?> <PUT .NOD ,NODE-TYPE ,1?-CODE>)
232 (<OR <==? <NODE-SUBR .NOD> ,==?>
233 <==? <NODE-SUBR .NOD> ,N==?>>
234 <PUT .NOD ,NODE-TYPE ,EQ-CODE>)
235 (ELSE <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
236 <COND (<==? .STATE 2> <HACK-BOUNDS .WHO .GLE .NOD .K>)>
237 <CHECK-FOR-BIT-HACK .NOD>)>
238 <TYPE-OK? '<OR FALSE ATOM> .RTYP>>
240 <DEFINE CHECK-FOR-BIT-HACK (N "AUX" (NN <1 <KIDS .N>>) DATA CONST K)
241 #DECL ((NN DATA N) NODE (CONST) <PRIMTYPE WORD>)
242 <COND (<AND <==? <NODE-TYPE .N> ,0-TST-CODE>
243 <==? <NODE-TYPE .NN> ,CHTYPE-CODE>
244 <SET NN <1 <KIDS .NN>>>
245 <OR <AND <==? <NODE-TYPE .NN> ,GETBITS-CODE>
247 <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
249 <SET CONST <PUTBITS 0 <NODE-NAME <2 .K>> -1>>>
250 <AND <==? <NODE-TYPE .NN> ,BITL-CODE>
251 <==? <NODE-SUBR .NN> ,ANDB>
252 <==? <LENGTH <SET K <KIDS .NN>>> 2>
253 <OR <AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
254 <SET CONST <NODE-NAME <1 .K>>>
256 <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
257 <SET CONST <NODE-NAME <2 .K>>>
260 <PUT .N ,NODE-TYPE ,BIT-TEST-CODE>
261 <PUT .N ,NODE-SUBR .CONST>
262 <PUT .N ,KIDS <COND (<ASSIGNED? DATA> (.DATA)) (ELSE .K)>>
263 <COND (<ASSIGNED? DATA> <PUT .DATA ,PARENT .N>)
265 <PUT <1 .K> ,PARENT .N>
266 <PUT <2 .K> ,PARENT .N>)>)>>
268 <DEFINE BIT-TEST-ANA (N R "AUX" (K <KIDS .N>))
269 #DECL ((N) NODE (K) <LIST [REST NODE]>)
270 <EANA <1 .K> '<PRIMTYPE WORD> BIT-TEST>
271 <COND (<NOT <EMPTY? <SET K <REST .K>>>>
272 <EANA <1 .K> '<PRIMTYPE WORD> BIT-TEST>)>
273 <TYPE-OK? <RESULT-TYPE .N> .R>>
275 <DEFINE HACK-BOUNDS (WHO GLE NOD K "AUX" NUM YES NO NOD2 (HACKT <>))
276 #DECL ((WHO GLE) LIST (NOD NOD2) NODE (K) <LIST [REST NODE]>)
278 <COND (<OR <==? <NODE-NAME .NOD> 0?> <==? <NODE-TYPE .NOD> ,0-TST-CODE>>
281 (<==? <NODE-NAME .NOD> 1?> <SET NOD2 <1 .K>> 1)
282 (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
285 (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
287 <PUT .NOD ,NODE-NAME <FLOPP <NODE-NAME .NOD>>>
288 <PUT .NOD ,KIDS (<2 .K> <1 .K>)>
289 <NODE-NAME <2 .K>>)>>
291 <SET YES <FORM FIX <GTV .NOD .NUM>>>
292 <SET NO <FORM FIX <NGTV .NOD .NUM>>>
294 <FUNCTION (L "AUX" (SYM <2 .L>))
295 #DECL ((L) <LIST ANY SYMTAB> (SYM) SYMTAB)
297 <ADD-TYPE-LIST .SYM .YES .TRUTH <> <REST .L 2>>>
299 <ADD-TYPE-LIST .SYM .NO .UNTRUTH <> <REST .L 2>>>>
301 <COND (<AND .NUM <G=? .NUM 0>>
302 <COND (<OR <AND <NOT <0? .NUM>>
303 <OR <==? <NODE-NAME .NOD> G=?>
304 <==? <NODE-NAME .NOD> L?>>>
306 <OR <AND <==? <NODE-NAME .NOD> G?> <SET HACKT T>>
307 <==? <NODE-NAME .NOD> L=?>>>>
308 <SET NUM <+ .NUM 1>>)>
309 <OR .HACKT <SET HACKT <MEMQ <NODE-NAME .NOD> '![1? L? L=? ==?!]>>>
310 <COND (<==? <NODE-NAME .NOD> 0?> <SET NUM 1>)>
311 <COND (<L=? .NUM 0> STRUCTURED)
312 (ELSE <SET NUM <CHTYPE (STRUCTURED !<ANY-PAT .NUM>) FORM>>)>
314 <FUNCTION (L "AUX" (SYM <2 .L>) (FLG <1 .L>))
315 #DECL ((L) <LIST ANY SYMTAB> (SYM) SYMTAB)
333 <SETG APSUBTAB [1? 0? L? L=? G? G=? ==? N==?]>
338 ('<+ .VAL 1> ,PLUSINF)
340 (,MINUSINF '<- .VAL 1>)
343 (,MINUSINF '<- .VAL 1> '<+ .VAL 1> ,PLUSINF)]>
346 [(,MINUSINF 0 2 ,PLUSINF)
347 (,MINUSINF -1 1 ,PLUSINF)
349 (,MINUSINF '<- .VAL 1>)
351 ('<+ .VAL 1> ,PLUSINF)
352 (,MINUSINF '<- .VAL 1> '<+ .VAL 1> ,PLUSINF)
355 <DEFINE NGTV (NOD VAL)
356 #DECL ((VAL) <SPECIAL ANY> (NOD) NODE)
358 <- 9 <LENGTH <MEMQ <NODE-NAME .NOD> ,APSUBTAB>>>>>>
360 <DEFINE GTV (NOD VAL)
361 #DECL ((NOD) NODE (VAL) <SPECIAL ANY>)
363 <- 9 <LENGTH <MEMQ <NODE-NAME .NOD> ,APSUBTAB>>>>>>
366 #DECL ((SUBR VALUE) ATOM)
367 <1 <REST <MEMQ .SUBR '![G? L? G? G=? L=? G=? ==? ==? N==? N==?!]>>>>
369 <PUT ,+ ANALYSIS ,ARITH-ANA>
371 <PUT ,- ANALYSIS ,ARITH-ANA>
373 <PUT ,* ANALYSIS ,ARITH-ANA>
375 <PUT ,/ ANALYSIS ,ARITH-ANA>
377 <PUT ,MAX ANALYSIS ,ARITH-ANA>
379 <PUT ,MIN ANALYSIS ,ARITH-ANA>
381 <PUT ,0? ANALYSIS ,ARITHP-ANA>
383 <PUT ,1? ANALYSIS ,ARITHP-ANA>
385 <PUT ,L? ANALYSIS ,ARITHP-ANA>
387 <PUT ,G? ANALYSIS ,ARITHP-ANA>
389 <PUT ,G=? ANALYSIS ,ARITHP-ANA>
391 <PUT ,L=? ANALYSIS ,ARITHP-ANA>
393 <ENDPACKAGE>
\ 3\ 3\ 3\ 3