3 <ENTRY CASE-FCN CASE-GEN>
5 <USE "PASS1" "CODGEN" "CHKDCL" "CACS" "COMPDEC" "COMCOD">
7 <SETG PMAX ,NUMPRI!-MUDDLE>
15 <DEFINE CASE-FCN (OBJ AP
16 "AUX" (OP!-PACKAGE .PARENT) (PARENT .PARENT) (FLG T) (WIN T)
18 #DECL ((PARENT) <SPECIAL NODE> (OBJ) <FORM ANY> (VALUE) NODE)
23 <COND (<AND <TYPE? <SET X <2 .OBJ>> FORM>
26 <MEMQ <SET P <2 .X>> '![==? TYPE? PRIMTYPE?!]>>)
32 (<AND .FLG <==? .O DEFAULT>> <SET DF T>)
33 (<AND .DF <TYPE? .O LIST>> <SET DF <>> <SET FLG <>>)
34 (<AND <NOT .DF> <TYPE? .O LIST> <NOT <EMPTY? .O>>>
36 (<SET TEM <VAL-CHK <1 .O>>>
37 <COND (<ASSIGNED? TYP> <OR <==? .TYP <TYPE .TEM>> <SET WIN <>>>)
38 (ELSE <SET TYP <TYPE .TEM>>)>)
39 (<OR <TYPE? <SET TEM <1 .O>> OR>
44 <NOT <MONAD? <SET TEM <2 .TEM>>>>>>
47 <COND (<NOT <SET TY <VAL-CHK .TY>>> <SET WIN <>>)
49 <COND (<ASSIGNED? TYP>
50 <OR <==? .TYP <TYPE .TY>>
52 (ELSE <SET TYP <TYPE .TY>>)>)>>
60 <NOT <OR <AND <==? <TYPEPRIM .TYP> WORD> <==? .P ==?>>
61 <AND <N==? .P ==?> <==? .TYP ATOM>>>>>
65 <SET PARENT <NODECOND ,CASE-CODE .OP!-PACKAGE <> CASE ()>>
69 (<PCOMP <2 .OBJ> .PARENT>
70 <PCOMP <3 .OBJ> .PARENT>
72 <FUNCTION (CLA "AUX" TT)
73 #DECL ((CLA) <OR ATOM LIST> (TT) NODE)
74 <COND (.DF <SET CLA (ELSE !.CLA)>)>
76 (<NOT <TYPE? .CLA ATOM>>
77 <PUT <SET TT <NODEB ,BRANCH-CODE .PARENT <> <> ()>>
79 <PCOMP <COND (<TYPE? <SET TEM <1 .CLA>> SEGMENT>
81 <MAPF ,LIST ,VAL-CHK <2 .TEM>>>)
83 <FORM QUOTE <MAPF ,LIST ,VAL-CHK .TEM>>)
84 (ELSE <VAL-CHK .TEM>)>
89 <FUNCTION (O) <PCOMP .O .TT>>
93 (ELSE <SET DF T> <PCOMP .CLA .PARENT>)>>
95 (ELSE <PMACRO .OBJ .OP!-PACKAGE>)>)
96 (ELSE <MESSAGE ERROR "BAD CASE USAGE" .OBJ>)>>
98 <DEFINE VAL-CHK (TEM "AUX" TT)
99 <OR <AND <OR <TYPE? .TEM ATOM> <==? <PRIMTYPE .TEM> WORD>>
101 <AND <TYPE? .TEM FORM>
102 <==? <LENGTH .TEM> 2>
103 <OR <AND <==? <1 .TEM> QUOTE> <2 .TEM>>
104 <AND <==? <1 .TEM> GVAL> <MANIFESTQ <2 .TEM>> ,<2 .TEM>>
105 <AND <==? <1 .TEM> ASCII>
106 <TYPE? <2 .TEM> CHARACTER FIX>
108 <AND <TYPE? .TEM FORM>
109 <==? <LENGTH .TEM> 3>
110 <==? <1 .TEM> CHTYPE>
111 <TYPE? <3 .TEM> ATOM>
112 <NOT <TYPE? <2 .TEM> FORM LIST VECTOR UVECTOR SEGMENT>>
114 <AND <TYPE? .TEM FORM>
116 <TYPE? <SET TT <1 .TEM>> ATOM>
119 <VAL-CHK <EMACRO .TEM>>>>>
121 <DEFINE EMACRO (OBJ "AUX" (ERR <GET ERROR!-INTERRUPTS INTERRUPT>) TEM)
122 <COND (.ERR <OFF .ERR>)>
124 <FUNCTION (FR "TUPLE" T)
125 <COND (<AND <GASSIGNED? MACACT> <LEGAL? ,MACACT>>
126 <DISMISS [!.T] ,MACACT>)
127 (ELSE <APPLY ,<PARSE "OVALRET!-COMBAT!-"> " ">)>>
129 <COND (<TYPE? <SET TEM
130 <PROG MACACT () #DECL ((MACACT) <SPECIAL ACTIVATION>)
131 <SETG MACACT .MACACT>
135 <COND (.ERR <EVENT .ERR>)>
136 <ERROR " MACRO EXPANSION LOSSAGE " !.TEM>)
137 (ELSE <OFF "ERROR"> <AND .ERR <EVENT .ERR>> <1 .TEM>)>>
141 <DEFINE DATFIX (W) <COND (<TYPE? .W DATUM> <DATUM !.W>) (ELSE .W)>>
143 <DEFINE CASE-GEN (N W
144 "AUX" (K <KIDS .N>) (P <NODE-NAME <1 <KIDS <1 .K>>>>)
145 (N1 <2 .K>) (SKIP-CH <>) (RW .W) (LNT 0) (DF <>) DN
146 (DFT <MAKE:TAG "CASEDF">) MI MX RNGS W1 (TAGS (X))
147 (TBL <MAKE:TAG "CASETBL">) (ET <MAKE:TAG "CASEND">) NOW
148 DAC TG TT W2 (FIRST T) S1 (S2 ()) TNUM)
149 #DECL ((N DN N1) NODE (P) ATOM (S1) SAVED-STATE
150 (S2) <LIST [REST SAVED-STATE]> (RNGS) UVECTOR)
153 <COND (<==? .W FLUSHED> FLUSHED) (ELSE <GOODACS .N .W>)>>
157 <COND (<AND <==? .P ==?> <SET TT <ISTYPE? <RESULT-TYPE .N1>>>>
162 <FUNCTION (NP "AUX" (N <1 .NP>))
164 <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE>
167 <COND (.DF <SET DN .N> <SET DF <>> <MAPRET>)>
168 <COND (<==? <RESULT-TYPE .N> FALSE>
169 <MESSAGE NOTE " CASE PHRASE ALWAYS FALSE " .N>
171 <COND (<AND <==? <RESULT-TYPE .N> ATOM>
172 <NOT <EMPTY? <REST .NP>>>>
174 " NON REACHABLE CASE CLAUSE(S) "
183 <FUNCTION (L "AUX" (N <1 .L>) (NN <NODE-NAME <PREDIC .N>>))
185 <PUT .L 3 <MAKE:TAG "CASE">>
188 <COND (<TYPE? .NN LIST>
189 <MAPR <> <FUNCTION (L) <PUT .L 1 <FIX <1 .L>>>> .NN>)
190 (ELSE <SET NN <CHTYPE .NN FIX>>)>)
192 <COND (<TYPE? .NN LIST>
194 <FUNCTION (L "AUX" TT)
195 <COND (<G? <SET TT <CHTYPE <1 .L> FIX>> ,PMAX>
200 <COND (<G? <SET NN <CHTYPE <TYPE-C .NN> FIX>> ,PMAX>
205 <FUNCTION (L) <PUT .L 1 <CHTYPE <PTYPE-C <1 .L>> FIX>>>
207 (ELSE <SET NN <CHTYPE <PTYPE-C .NN> FIX>>)>
208 <COND (<TYPE? .NN LIST> <PUT .L 2 .NN> <MAPRET !.NN>)
209 (ELSE <PUT .L 2 (.NN)> .NN)>>
212 <COND (<L=? .LNT 3> <SET SKIP-CH T>)
213 (<G? <- <SET MX <NTH .RNGS .LNT>> <SET MI <SET TNUM <1 .RNGS>>>>
218 <COND (<==? .NUM .TNUM>
219 <MESSAGE ERROR " DUPLICATE CASE ENTRY " .N>)>
226 <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O !<ADDR:TYPE .W2>>>
232 TYPE-CODE!-OP!-PACKAGE
233 <TYPE <COND (<TYPE? <SET TT <NODE-NAME <PREDIC <1 <1 .K>>>>> LIST>
238 <SET DAC <DATVAL .W2>>)
240 <SET DAC <GETREG <>>>
241 <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE
245 <SET DAC <GETREG <>>>
246 <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE
249 <EMIT <INSTRUCTION `ASH <ACSYM .DAC> 1>>
250 <EMIT <INSTRUCTION `ADD <ACSYM .DAC> TYPVEC!-MUDDLE 1 `(TVP) >>
251 <EMIT <INSTRUCTION `LDB
253 [<FORM (576) (<ADDRSYM .DAC>)>]>>)>
258 <COND (<0? .MI> <EMIT <INSTRUCTION `JUMPL <ACSYM .DAC> .DFT>>)
260 <EMIT <INSTRUCTION `JUMPLE <ACSYM .DAC> .DFT>>)
262 <IMCHK '(`CAMGE `CAIGE) <ACSYM .DAC> <REFERENCE:ADR .MI>>
264 <COND (<0? .MX> <EMIT <INSTRUCTION `JUMPG <ACSYM .DAC> .DFT>>)
266 <EMIT <INSTRUCTION `JUMPGE <ACSYM .DAC> .DFT>>)
268 <IMCHK '(`CAMLE `CAILE) <ACSYM .DAC> <REFERENCE:ADR .MX>>
270 <EMIT <INSTRUCTION `ADD <ACSYM .DAC> [<INSTRUCTION `SETZ .TBL>]>>
271 <EMIT <INSTRUCTION `JRST `@ <- .MI> (<ADDRSYM .DAC>)>>
273 <SET S1 <SAVE-STATE>>
274 <COND (<ASSIGNED? DN>
275 <SET W1 <SEQ-GEN <KIDS .DN> <DATFIX .W>>>
277 <COND (<N==? <RESULT-TYPE .DN> NO-RETURN>
278 <SET S2 (<SAVE-STATE>)>
282 <SET W1 <MOVE:ARG <REFERENCE <>> <DATFIX .W>>>
284 <SET S2 (<SAVE-STATE>)>
290 <COND (<EMPTY? .RNGS> <RETURN>)>
291 <COND (<N==? .NOW <+ <1 .RNGS> 1>>
293 <EMIT <INSTRUCTION `SETZ .DFT>>)
295 <EMIT <INSTRUCTION `SETZ <DOTAGS <1 .RNGS> .K>>>
297 <SET RNGS <REST .RNGS>>)>>
299 <FUNCTION (L "AUX" (N <1 .L>) (TG <3 .L>))
302 <COND (<NOT .FIRST> <OR <==? .W1 ,NO-DATUM> <BRANCH:TAG .ET>>)
303 (ELSE <SET FIRST <>>)>
306 (<NOT <EMPTY? <KIDS .N>>>
307 <SET W1 <SEQ-GEN <KIDS .N> <DATFIX .W>>>)
311 <REFERENCE <COND (<==? .P ==?> T)
312 (ELSE <NODE-NAME <PREDIC .N>>)>>
314 <OR <==? .W1 ,NO-DATUM> <SET S2 (<SAVE-STATE> !.S2)>>
319 <SET S1 <SAVE-STATE>>
321 <COND (<EMPTY? .K> <RETURN>)>
322 <DISTAG <2 <SET L <1 .K>>> .DAC <SET TG <3 .L>>>
323 <COND (<NOT <EMPTY? <KIDS <1 .L>>>>
324 <SET W1 <SEQ-GEN <KIDS <1 .L>> <DATFIX .W>>>)
325 (ELSE <SET W1 <MOVE:ARG <REFERENCE T> <DATFIX .W>>>)>
326 <OR <==? .W1 ,NO-DATUM> <SET S2 (<SAVE-STATE> !.S2)>>
330 <OR <==? .W1 ,NO-DATUM> <BRANCH:TAG .ET>>
334 <COND (<ASSIGNED? DN> <SET W1 <SEQ-GEN <KIDS .DN> <DATFIX .W>>>)
335 (ELSE <SET W1 <MOVE:ARG <REFERENCE <>> <DATFIX .W>>>)>
336 <OR <==? .W1 ,NO-DATUM> <SET S2 (<SAVE-STATE> !.S2)>>)>
337 <COND (<AND <TYPE? .W DATUM> <N==? <RESULT-TYPE .N> NO-RETURN>>
339 <AND <ISTYPE? <DATTYP .W2>>
340 <TYPE? <DATTYP .W1> AC>
341 <NOT <==? <DATTYP .W2> <DATTYP .W1>>>
342 <RET-TMP-AC <DATTYP .W1> .W1>>
343 <AND <TYPE? <DATTYP .W2> AC>
344 <FIX-ACLINK <DATTYP .W2> .W2 .W1>>
345 <AND <TYPE? <DATVAL .W2> AC>
346 <FIX-ACLINK <DATVAL .W2> .W2 .W1>>)>
352 #DECL ((N) FIX (L) <UVECTOR [REST <LIST NODE <LIST [REST FIX]> ATOM>]>)
354 <FUNCTION (LL) <COND (<MEMQ .N <2 .LL>> <MAPLEAVE <3 .LL>>)>>
357 <DEFINE DISTAG (L DAC ATM "AUX" TG)
358 #DECL ((L) <LIST [REST FIX]> (DAC) AC (ATM) ATOM)
359 <COND (<G=? <LENGTH .L> 2> <SET TG <MAKE:TAG>>)>
363 <AND <ASSIGNED? TG> <LABEL:TAG .TG>>
366 <IMCHK '(`CAME `CAIE) <ACSYM .DAC> <REFERENCE:ADR <1 .L>>>
368 <AND <ASSIGNED? TG> <LABEL:TAG .TG>>
371 <IMCHK '(`CAME `CAIE) <ACSYM .DAC> <REFERENCE:ADR <1 .L>>>
372 <IMCHK '(`CAMN `CAIN) <ACSYM .DAC> <REFERENCE:ADR <2 .L>>>
374 <SET L <REST .L 2>>>>
376 <DEFINE PTYPE-C (ATM) <PRIM-CODE <TYPE-C .ATM>>>