3 <ENTRY NOT-ANA TYPE?-ANA ==?-ANA>
5 <USE "SYMANA" "CHKDCL" "COMPDEC" "CARANA" "ADVMESS">
8 " This module contains analysis and generation functions for
9 NOT, TYPE? and ==?. See SYMANA for more details about ANALYSIS and
10 CODGEN for more detali abour code generation.
13 "Analyze NOT usage make sure arg can be FALSE."
15 <DEFINE NOT-ANA (NOD RTYP
16 "AUX" TEM (FLG <==? .PRED <PARENT .NOD>>) (STR .TRUTH)
19 <PROG ((PRED <AND .FLG .NOD>) (TRUTH ()) (UNTRUTH ()))
20 #DECL ((PRED) <SPECIAL ANY> (TRUTH UNTRUTH) <SPECIAL LIST>)
21 <COND (<SET TEM <SEGFLUSH .NOD .RTYP>> <SET FLG <>>)
23 <OR <1? <LENGTH <KIDS .NOD>>>
24 <MESSAGE ERROR "WRONG NUMBER OF ARGS TO NOT " .NOD>>
25 <SET TEM <ANA <1 <KIDS .NOD>> ANY>>
26 <PUT .NOD ,NODE-TYPE ,NOT-CODE>
28 <COND (<==? <ISTYPE? .TEM> FALSE>
29 <TYPE-OK? ATOM .RTYP>)
30 (<TYPE-OK? .TEM FALSE>
31 <TYPE-OK? '<OR FALSE ATOM> .RTYP>)
32 (ELSE <TYPE-OK? FALSE .RTYP>)>>
36 <SET TRUTH (!.STR !.TRUTH)>
37 <SET UNTRUTH (!.SUNT !.UNTRUTH)>)>
40 <PUT ,NOT ANALYSIS ,NOT-ANA>
42 " Analyze N==? and ==? usage. Complain if types differ such that
43 the args can never be ==?."
45 <DEFINE ==?-ANA (NOD RTYP
47 (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>) (WHO ())
49 #DECL ((NOD) NODE (K) <LIST [REST NODE]> (WHON GLN) <SPECIAL NODE>
50 (WHO GLE) <SPECIAL LIST>)
51 <COND (<SEGFLUSH .NOD .RTYP>)
53 <ARGCHK 2 <LENGTH .K> ==?>
56 <PUT .NOD ,NODE-TYPE ,EQ-CODE>
57 <COND (<AND <==? <ISTYPE? <RESULT-TYPE <1 .K>>> FIX>
58 <==? <ISTYPE? <RESULT-TYPE <2 .K>>> FIX>>
59 <PUT .NOD ,NODE-TYPE ,TEST-CODE>
60 <HACK-BOUNDS .WHO .GLE .NOD .K>)>
61 <TYPE-OK? '<OR FALSE ATOM> .RTYP>)>>
63 <PUT ,==? ANALYSIS ,==?-ANA>
65 <PUT ,N==? ANALYSIS ,==?-ANA>
67 " Ananlyze TYPE? usage warn about any potential losers by using
70 <DEFINE TYPE?-ANA (NOD RTYP
71 "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) ITYP (ALLGOOD T)
72 (WHO ()) (FTYP ()) (FNOK <>)
73 (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>) TTYP)
74 #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX (ITYP) ANY
75 (ALLGOOD) <OR FALSE ATOM> (WHON) <SPECIAL <OR NODE FALSE>>
76 (WHO) <SPECIAL LIST> (FTYP) LIST)
78 (<SEGFLUSH .NOD .RTYP>)
81 <MESSAGE ERROR "TOO FEW ARGS TO TYPE? " .NOD>>
82 <SET ITYP <EANA <1 .K> ANY TYPE?>>
84 <FUNCTION (N "AUX" FLG)
88 <OR <==? <NODE-TYPE .N> ,QUOTE-CODE>
89 <RETURN <SET ALLGOOD <>>>>
90 <OR <MEMQ <NODE-NAME .N> <ALLTYPES>>
92 "ARG TO TYPE? NOT A TYPE "
94 <AND <TYPE-OK? <NODE-NAME .N> .ITYP>
95 <SET FTYP (<NODE-NAME .N> !.FTYP)>>>>
97 <COND (<AND .ALLGOOD <NOT <EMPTY? .FTYP>>>
99 <COND (<EMPTY? <REST .FTYP>> <1 .FTYP>)
100 (ELSE <CHTYPE (OR !.FTYP) FORM>)>>
101 <PUT .NOD ,NODE-TYPE ,TY?-CODE>
102 <SET FNOK <NOT <TYPE-OK? <FORM NOT .TTYP> .ITYP>>>
104 <FUNCTION (L "AUX" (FLG <1 .L>) (SYM <2 .L>))
105 #DECL ((L) <LIST <OR ATOM FALSE> SYMTAB> (SYM) SYMTAB)
120 (.ALLGOOD <PUT .NOD ,NODE-TYPE ,TY?-CODE>)
122 <AND .VERBOSE <ADDVMESS .NOD ("Not open compiled.")>>
123 <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>)>
124 <TYPE-OK? <COND (<NOT .ALLGOOD> '<OR FALSE ATOM>)
125 (<EMPTY? .FTYP> FALSE)
127 (ELSE '<OR FALSE ATOM>)>
130 <PUT ,TYPE? ANALYSIS ,TYPE?-ANA>
132 <ENDPACKAGE>
\ 3\ 3\ 3\ 3