6 <USE "CODGEN" "MIMGEN" "CHKDCL" "COMPDEC" "SORTX">
11 "AUX" (K <KIDS .N>) (P <NODE-NAME <1 <KIDS <1 .K>>>>)
12 (N1 <2 .K>) (SKIP-CH <>) (RW .W) (LNT 0) (DF <>) DN
13 (DFT <MAKE-TAG "CASEDF">) MI MX RNGS (TAGS (X)) LLABS
14 LABS (ET <MAKE-TAG "CASEND">) NOW (WSET <>) LOCN DAC TG
15 TT W2 (FIRST T) S1 (S2 ()) TNUM LRT)
16 #DECL ((N DN N1) NODE (P) ATOM (RNGS) UVECTOR)
17 <SET TT <ISTYPE? <RESULT-TYPE .N1>>>
18 <COND (<OR <==? .W ,POP-STACK>
21 <N==? <TEMP-NO-RECYCLE .W> ANY>>>
25 <FUNCTION (NP "AUX" (N <1 .NP>))
27 <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE>
30 <COND (.DF <SET DN .N> <SET DF <>> <MAPRET>)>
31 <COND (<==? <RESULT-TYPE .N> FALSE>
32 <COMPILE-NOTE "Case phrase always false " .N>
34 <COND (<AND <==? <RESULT-TYPE .N> ATOM>
35 <NOT <EMPTY? <REST .NP>>>>
36 <COMPILE-NOTE "Non reachable CASE clauses "
45 <FUNCTION (L "AUX" (N <1 .L>) (NN <NODE-NAME <PREDIC .N>>))
47 <PUT .L 3 <MAKE-TAG "CASE">>
50 <COND (<TYPE? .NN LIST>
51 <MAPR <> <FUNCTION (L) <PUT .L 1 <FIX <1 .L>>>> .NN>)
52 (ELSE <SET NN <CHTYPE .NN FIX>>)>)
54 <COND (<TYPE? .NN LIST>
56 <FUNCTION (L "AUX" TT)
57 <COND (<G? <SET TT <CHTYPE <1 .L> FIX>> ,PMAX>
62 <COND (<G? <SET NN <CHTYPE <TYPE-C .NN> FIX>> ,PMAX>
67 <FUNCTION (L) <PUT .L 1 <CHTYPE <PTYPE-C <1 .L>> FIX>>>
69 (ELSE <SET NN <CHTYPE <PTYPE-C .NN> FIX>>)>
70 <COND (<TYPE? .NN LIST> <PUT .L 2 .NN> <MAPRET !.NN>)
71 (ELSE <PUT .L 2 (.NN)> .NN)>>
75 <COND (<L=? .LNT 3> <SET SKIP-CH T>)
76 (<G? <- <SET MX <NTH .RNGS .LNT>> <SET MI .TNUM>>
81 <COND (<==? .NUM .TNUM>
82 <COMPILE-ERROR "Duplicate case entry " .N>)>
85 <SET W2 <GEN .N1 DONT-CARE>>
89 (<NOT <ISTYPE? <RESULT-TYPE .N1>>>
92 <TYPE <COND (<TYPE? <SET TT <NODE-NAME <PREDIC <1 <1 .K>>>>> LIST>
102 <SET LLABS <SET LABS (.MI)>>
104 <COND (<EMPTY? .RNGS> <RETURN>)>
105 <COND (<N==? .NOW <+ <1 .RNGS> 1>>
107 <PUTREST .LLABS <SET LLABS (.DFT)>>)
109 <PUTREST .LLABS <SET LLABS (<DOTAGS <1 .RNGS> .K>)>>
111 <SET RNGS <REST .RNGS>>)>>
112 <IEMIT `DISPATCH .W2 !.LABS>
114 <COND (<ASSIGNED? DN>
115 <SET LOCN <SEQ-GEN <KIDS .DN> .W>>
116 <COND (<AND <NOT .WSET> <N==? .LOCN ,NO-DATUM> <N==? .W FLUSHED>>
117 <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
119 <COND (<OR <N==? <RESULT-TYPE .DN> NO-RETURN>
120 <N==? .LOCN ,NO-DATUM>>
123 <COND (<N==? .W FLUSHED>
124 <SET LOCN <MOVE-ARG <REFERENCE <>> .W>>
125 <COND (<AND <NOT .WSET>
126 <N==? .LOCN ,NO-DATUM>
128 <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
132 <FUNCTION (L "AUX" (N <1 .L>) (TG <3 .L>))
133 <COND (<AND <NOT .FIRST> <N==? .LRT NO-RETURN>> <BRANCH-TAG .ET>)
134 (ELSE <SET FIRST <>>)>
135 <SET LRT <RESULT-TYPE .N>>
138 (<NOT <EMPTY? <KIDS .N>>>
139 <SET LOCN <SEQ-GEN <KIDS .N> .W>>
140 <COND (<AND <NOT .WSET> <N==? .LOCN ,NO-DATUM> <N==? .W FLUSHED>>
141 <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
146 <REFERENCE <COND (<==? .P ==?> T)
147 (ELSE <NODE-NAME <PREDIC .N>>)>>
149 <COND (<AND <NOT .WSET> <N==? .LOCN ,NO-DATUM> <N==? .W FLUSHED>>
150 <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
154 <REPEAT (L KK) #DECL ((KK L) LIST)
155 <COND (<EMPTY? .K> <RETURN>)>
156 <DISTAG <2 <SET L <1 .K>>> .W2 <SET TG <3 .L>>>
157 <COND (<NOT <EMPTY? <SET KK <KIDS <1 .L>>>>>
158 <SET LOCN <SEQ-GEN .KK .W>>)
159 (<N==? .W FLUSHED> <SET LOCN <MOVE-ARG <REFERENCE T> .W>>)>
160 <COND (<AND <NOT .WSET> <N==? .LOCN ,NO-DATUM> <N==? .W FLUSHED>>
161 <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
163 <COND (<AND <NOT <EMPTY? .KK>>
164 <N==? <RESULT-TYPE <NTH .KK <LENGTH .KK>>> NO-RETURN>>
168 <COND (<ASSIGNED? DN> <SET LOCN <SEQ-GEN <KIDS .DN> .W>>)
169 (ELSE <SET LOCN <MOVE-ARG <REFERENCE <>> .W>>)>
170 <COND (<AND <NOT .WSET> <N==? .LOCN ,NO-DATUM> <N==? .W FLUSHED>>
171 <SET LOCN <SET W <FIXUP-TEMP .W .LOCN>>>
177 #DECL ((N) FIX (L) <LIST [REST <LIST NODE <LIST [REST FIX]> ATOM>]>)
179 <FUNCTION (LL) <COND (<MEMQ .N <2 .LL>> <MAPLEAVE <3 .LL>>)>>
182 <DEFINE DISTAG (L DAC ATM "AUX" TG)
183 #DECL ((L) <LIST [REST FIX]> (ATM) ATOM)
184 <COND (<G=? <LENGTH .L> 2> <SET TG <MAKE-TAG>>)>
188 <AND <ASSIGNED? TG> <LABEL-TAG .TG>>
191 <IEMIT `VEQUAL? .DAC <1 .L> - .ATM>
192 <AND <ASSIGNED? TG> <LABEL-TAG .TG>>
194 (ELSE <IEMIT `VEQUAL? .DAC <1 .L> + .TG>)>
195 <SET L <REST .L 1>>>>
197 <DEFINE PTYPE-C (ATM) <PRIM-CODE <TYPE-C .ATM>>>
199 <DEFINE FIXUP-TEMP (W LOCN)
200 <COND (<AND <TYPE? .LOCN TEMP> <L=? <TEMP-REFS .LOCN> 1>> .LOCN)
201 (<==? .LOCN .W> .LOCN)
202 (ELSE <MOVE-ARG .LOCN <GEN-TEMP <>>>)>>