3 <USE "CHKDCL" "COMPDEC">
5 <DEFINE CASE-FCN (OBJ AP
6 "AUX" (OP .PARENT) (PARENT .PARENT) (FLG T) (WIN T) TYP
8 #DECL ((PARENT) <SPECIAL NODE> (OBJ) <FORM ANY> (VALUE) NODE)
13 <COND (<OR <AND <==? <TYPE <SET X <2 .OBJ>>> GVAL>
14 <==? <SET P <CHTYPE .X ATOM>> ==?>>
15 <AND <TYPE? <SET X <2 .OBJ>> FORM>
18 <==? <SET P <2 .X>> ==?>
19 ;<MEMQ <SET P <2 .X>> '[==? TYPE? PRIMTYPE?]>>>)
25 (<AND .FLG <==? .O DEFAULT>> <SET DF T>)
26 (<AND .DF <TYPE? .O LIST>> <SET DF <>> <SET FLG <>>)
27 (<AND <NOT .DF> <TYPE? .O LIST> <NOT <EMPTY? .O>>>
29 (<SET TEM <VAL-CHK <1 .O>>>
30 <COND (<ASSIGNED? TYP> <OR <==? .TYP <TYPE .TEM>> <SET WIN <>>>)
31 (ELSE <SET TYP <TYPE .TEM>>)>)
32 (<AND <TYPE? <SET TEM <1 .O>> SEGMENT>
35 <NOT <MONAD? <SET TEM <2 .TEM>>>>>
38 <COND (<NOT <SET TY <VAL-CHK .TY>>> <SET WIN <>>)
40 <COND (<ASSIGNED? TYP>
41 <OR <==? .TYP <TYPE .TY>>
43 (ELSE <SET TYP <TYPE .TY>>)>)>>
51 <NOT <OR <AND <MEMQ <TYPEPRIM .TYP> '[WORD FIX]>
53 <AND <N==? .P ==?> <==? .TYP ATOM>>>>>
57 <SET PARENT <NODECOND ,CASE-CODE .OP <> CASE ()>>
61 (<PCOMP <2 .OBJ> .PARENT>
62 <PCOMP <3 .OBJ> .PARENT>
64 <FUNCTION (CLA "AUX" TT)
65 #DECL ((CLA) <OR ATOM LIST> (TT) NODE)
66 <COND (.DF <SET CLA (ELSE !.CLA)>)>
68 (<NOT <TYPE? .CLA ATOM>>
69 <PUT <SET TT <NODEB ,BRANCH-CODE .PARENT <> <> ()>>
71 <PCOMP <COND (<TYPE? <SET TEM <1 .CLA>> SEGMENT>
73 <MAPF ,LIST ,VAL-CHK <2 .TEM>>>)
76 <MAPF ,LIST ,VAL-CHK .TEM>>)
77 (ELSE <VAL-CHK .TEM>)>
82 <FUNCTION (O) <PCOMP .O .TT>>
86 (ELSE <SET DF T> <PCOMP .CLA .PARENT>)>>
88 (ELSE <PMACRO .OBJ .OP>)>)
89 (ELSE <COMPILE-ERROR "CASE in incorrect format " .OBJ>)>>