4 <ENTRY DO CASE INC DEC CHOP IF IF-NOT PRIMTYPE?>
9 \"UNTIL\" (<==? .Y STOP>
12 \"GEN\" (Z .FOO <REST .FOO .X> <EMPTY? .Z> <ERROR Z-RAN-OUT> T)
14 <COND (<SET Y <NTH ,DATA .X>>
21 "AUX" (PRE-CODE ()) (POST-CODE ()) (PRE-TEST ()) (POST-TEST ())
22 (STATE ,COLON-FOR) (RETURNS ()))
23 #DECL ((ARGL BODY) LIST (STATE) FIX (RETURNS) <SPECIAL LIST>
24 (POST-CODE PRE-TEST POST-TEST) <SPECIAL <LIST [REST <LIST ANY>]>>
25 (PRE-CODE) <SPECIAL LIST> (VALUE) FORM)
29 <COND (<TYPE? .NAM STRING>
30 <COND (<=? .NAM "FOR"> <SET STATE ,COLON-FOR>)
31 (<=? .NAM "GEN"> <SET STATE ,COLON-GEN>)
33 <SET STATE ,COLON-WHILE>)
35 <SET STATE ,COLON-UNTIL>)
37 <SET STATE ,COLON-VALUE>)
38 (<OR <=? .NAM "AUX"> <=? .NAM "AUX">>
39 <SET STATE ,COLON-NONE>)
40 (ELSE <SET STATE ,COLON-NONE> <MAPRET .NAM>)>)
41 (<==? .STATE ,COLON-NONE> <MAPRET .NAM>)
43 <COND (<NOT <TYPE? .NAM LIST>>
46 (,COLON-FOR <MAPRET <DO-FOR !.NAM>>)
47 (,COLON-GEN <MAPRET <DO-GEN !.NAM>>)
48 (,COLON-WHILE <DO-WHILE !.NAM>)
49 (,COLON-UNTIL <DO-UNTIL !.NAM>)
50 (,COLON-VALUE <DO-VALUE !.NAM>)>)>
53 <SET RETURNS <COND-BODY '(<RETURN T>) .RETURNS>>
56 !<MAPF ,LIST <FUNCTION (L)
57 #DECL ((L) <LIST ANY>)
58 <MAKE-COND <1 .L> .RETURNS <REST .L>>>
59 .PRE-CODE> ;"FOR tests"
60 !<MAPF ,LIST <FUNCTION (L)
61 #DECL ((L) <LIST ANY>)
62 <MAKE-COND <1 .L> .RETURNS <REST .L>>>
63 .PRE-TEST> ;"WHILE tests"
65 !<MAPF ,LIST <FUNCTION (L)
66 #DECL ((L) <LIST ANY>)
67 <MAKE-COND <1 .L> .RETURNS <REST .L>>>
68 .POST-TEST> ;"UNTIL tests"
69 !.POST-CODE ;"FOR updates">>
72 <AND? <SETG COLON-NONE 0>
78 <MANIFEST COLON-NONE COLON-FOR COLON-GEN COLON-UNTIL COLON-WHILE COLON-VALUE>>
83 <DEFINE DO-FOR ;"Make a variable declaration and a test for FOR looping"
84 (VARIABLE "OPTIONAL" (INITIAL 1) FINAL (STEP 1) "TUPLE" VAL)
85 #DECL ((VAL) TUPLE (PRE-CODE POST-CODE) LIST)
86 <COND (<OR <NOT <ASSIGNED? FINAL>>
88 <==? .STEP 0.0000000>>)
89 (<AND <TYPE? .STEP FIX FLOAT> <G? .STEP 0>> ;"Stepping up ?"
92 (<FORM G? <FORM LVAL .VARIABLE> .FINAL> !.VAL))>)
93 (<AND <TYPE? .STEP FIX FLOAT> <L? .STEP 0>> ;"Stepping down ?"
96 (<FORM L? <FORM LVAL .VARIABLE> .FINAL> !.VAL))>)
97 (ELSE ;"Assume unknown stepping direction"
102 <FORM G? <FORM LVAL .VARIABLE> .FINAL>)
104 <FORM L? <FORM LVAL .VARIABLE> .FINAL>)>
108 <FORM SET .VARIABLE <FORM + <FORM LVAL .VARIABLE> .STEP>>)>
109 (.VARIABLE .INITIAL)>
111 <DEFINE DO-GEN ;"Make a variable declaration and a test for FOR looping"
112 (VARIABLE "OPTIONAL" (INITIAL ()) STEP PRED "TUPLE" VAL)
113 #DECL ((VARIABLE) ATOM (VAL) TUPLE (PRE-CODE POST-CODE) LIST)
114 <COND (<ASSIGNED? PRED>
116 (!.PRE-CODE (.PRED !.VAL))>)>
117 <COND (<ASSIGNED? STEP>
118 <SET POST-CODE (!.POST-CODE <FORM SET .VARIABLE .STEP>)>)>
119 (.VARIABLE .INITIAL)>
121 <DEFINE DO-WHILE (EXPR "TUPLE" VAL) ;"Make a test to do looping WHILE"
122 #DECL ((VAL) TUPLE (PRE-TEST) LIST)
125 (<FORM NOT .EXPR> !.VAL))>>
127 <DEFINE DO-UNTIL (EXPR "TUPLE" VAL) ;"Make a test to do looping UNTIL"
128 #DECL ((VAL) TUPLE (POST-TEST) LIST)
130 (!.POST-TEST (.EXPR !.VAL))>>
132 <DEFINE DO-VALUE ("TUPLE" BODY)
133 #DECL ((BODY) TUPLE (RETURNS) LIST)
134 <COND (<NOT <EMPTY? .RETURNS>>
135 <ERROR TOO-MANY!-ERRORS "VALUE" DO>)
136 (ELSE <SET RETURNS (!.BODY)>)>>
138 <DEFINE MAKE-COND (PRED DEF BODY)
139 #DECL ((VALUE) <FORM ATOM LIST> (DEF BODY) LIST)
140 <FORM COND (.PRED !<COND-BODY .DEF .BODY>)>>
142 <DEFINE COND-BODY (DEF BODY)
143 #DECL ((VALUE) LIST (DEF BODY) LIST)
144 <COND (<EMPTY? .BODY> .DEF)
146 <SET DEF <REST .BODY <- <LENGTH .BODY> 1>>>
147 <PUT .DEF 1 <FORM RETURN <1 .DEF>>>
154 <CASE ,TYPE? <GET .FOO DATA>
155 (ATOM <PRINT IDENTIFIER> 0)
156 (FIX <PRINT INTEGER> 1)
157 (FLOAT <PRINT REAL> 2)
160 (!'(LIST VECTOR UVECTOR ,XTRA) <PRINT STRUCTURE> 4)
161 (STRING <PRINT STRING> 5)>
164 <DEFMAC CASE ('PRED 'EXPR "ARGS" CASES "AUX" (DEFAULT-CASE <>))
165 #DECL ((CASES) LIST (DEFAULT-CASE) <OR FALSE LIST> (VALUE) FORM)
166 <COND (<AND <TYPE? .PRED FORM>
167 <==? <LENGTH .PRED> 2>
169 <TYPE? <2 .PRED> ATOM>>
170 <SET PRED <2 .PRED>>)
171 (<TYPE? .PRED GVAL> <SET PRED <CHTYPE .PRED ATOM>>)>
178 <FUNCTION (PHRASE "AUX" EXPR)
179 <COND (<==? .PHRASE DEFAULT>
181 <ERROR TOO-MANY-DEFAULTS!-ERRORS CASE>)
182 (ELSE <SET DEFAULT-CASE ()>)>
184 (<OR <NOT <TYPE? .PHRASE LIST>> <EMPTY? .PHRASE>>
185 <ERROR BAD-CLAUSE!-ERRORS CASE>)
186 (<AND .DEFAULT-CASE <EMPTY? .DEFAULT-CASE>>
187 <SET DEFAULT-CASE ((DEFAULT !.PHRASE))>
189 (<NOT <TYPE? <SET EXPR <1 .PHRASE>> SEGMENT>>
190 (<FORM .PRED '.OB .EXPR> !<REST .PHRASE>))
191 (<EMPTY? .EXPR> (<FORM .PRED '.OB> !<REST .PHRASE>))
192 (<==? <1 .EXPR> QUOTE>
193 <COND (<OR <EMPTY? <REST .EXPR>>
194 <NOT <STRUCTURED? <2 .EXPR>>>>
195 <ERROR ILLEGAL-SEGMENT!-ERRORS CASE>)
197 (<DO-SEG .PRED (!<2 .EXPR>)> !<REST .PHRASE>))>)
198 (ELSE (<FORM .PRED '.OB .EXPR> !<REST .PHRASE>))>>
202 <DEFINE DO-SEG (PRED OPS)
203 #DECL ((OPS) LIST (VALUE) FORM)
204 <COND (<OR <==? .PRED TYPE?> <==? .PRED PRIMTYPE?> <EMPTY? .OPS>>
205 <CHTYPE (.PRED '.OB !.OPS) FORM>)
209 <FUNCTION (X) <FORM .PRED '.OB .X>>
215 <DEFMAC INC ('ATM "OPTIONAL" ('AMT 1))
216 <FORM SET .ATM <FORM + <FORM LVAL .ATM> .AMT>>>
218 <DEFMAC DEC ('ATM "OPTIONAL" ('AMT 1))
219 <FORM SET .ATM <FORM - <FORM LVAL .ATM> .AMT>>>
221 <DEFMAC CHOP ('ATM "OPTIONAL" ('AMT 1))
222 <FORM SET .ATM <FORM REST <FORM LVAL .ATM> .AMT>>>
224 <DEFMAC IF ("ARGS" BODY) <FORM COND .BODY>>
226 <DEFMAC IF-NOT ('PRED "ARGS" BODY) <FORM COND (<FORM NOT .PRED> !.BODY)>>
228 <DEFMAC PRIMTYPE? ('EXPR "ARGS" BODY)
230 <COND (<EMPTY? .BODY>
231 <ERROR TOO-FEW-ARGUMENTS-SUPPLIED!-ERRORS PRIMTYPE?>)
232 (<EMPTY? <REST .BODY>>
233 <FORM ==? <FORM PRIMTYPE .EXPR> <1 .BODY>>)
236 ((OB <FORM PRIMTYPE .EXPR>))
237 #DECL ((OB) ATOM (VALUE) <OR FALSE ATOM>)
241 <FUNCTION (X) <FORM ==? '.OB .X>>