Commit | Line | Data |
---|---|---|
0f4556f1 | 1 | (setq SCCS-parser.l "@(#)parser.l 1.1 4/27/83") |
3e772ab7 SB |
2 | ; FP interpreter/compiler |
3 | ; Copyright (c) 1982 Scott B. Baden | |
4 | ; Berkeley, California | |
5 | ||
6 | (include specials.l) | |
7 | (declare (special flag) | |
8 | (localf get_condit trap_err Push | |
9 | prs_fn get_def get_constr get_while Pop)) | |
10 | ||
11 | (defun parse (a_flag) | |
12 | (let ((flag a_flag)) | |
13 | (do | |
14 | ((tkn (get_tkn) (get_tkn)) | |
15 | (rslt nil) (action nil) (wslen 0) (stk nil)) | |
16 | ||
17 | ((eq tkn 'eof$$) (cond ((eq flag 'top_lev) 'eof$$) | |
18 | (t (*throw 'parse$err '(err$$ eof))))) | |
19 | ||
20 | (cond ((null (plist (prs_fn))) (*throw 'parse$err `(err$$ unknown ,tkn)))) | |
21 | (cond ((find 'badtkn$$ tkn) (*throw 'parse$err `(err$$ badtkn ,(cadr tkn))))) | |
22 | (setq action (get (prs_fn) flag)) | |
23 | (cond ((null action) (*throw 'parse$err `(err$$ illeg ,tkn)))) | |
24 | (setq rslt (funcall action)) | |
25 | (cond ((eq rslt 'cmd$$) (return rslt))) | |
26 | (cond ((not (listp rslt)) (*throw 'parse$err `(err$$ fatal1 ,stk ,tkn ,rslt)))) | |
27 | (cond ((eq (car rslt) 'return) | |
28 | (return | |
29 | (cond ((eq (cadr rslt) 'done) (cdr rslt)) | |
30 | (t (cadr rslt))))) | |
31 | ||
32 | ((eq (car rslt) 'Push) | |
33 | (cond ((eq flag 'while$$) | |
34 | (cond ((or (zerop wslen) (onep wslen)) | |
35 | (Push (cadr rslt))) | |
36 | ((twop wslen) (*throw 'parse$err `(err$$ bad_whl ,stk ,tkn))) | |
37 | (t (*throw 'parse$err '(err$$ bad_while parse))))) | |
38 | (t | |
39 | (cond ((null stk) (Push (cadr rslt))) | |
40 | (t (*throw 'parse$err `(err$$ stk_ful ,stk ,tkn))))))) | |
41 | ||
42 | ((eq (car rslt) 'nothing)) | |
43 | (t (*throw 'parse$err `(err$$ fatal2 ,stk ,tkn ,rslt))))))) | |
44 | ||
45 | ||
46 | ; These are the parse action functions. | |
47 | ; There is one for each token-context combination. | |
48 | ; The contexts are: | |
49 | ; top_lev,constr$$,compos$$,alpha$$,insert$$. | |
50 | ; The name of each function is formed by appending p$ to the | |
51 | ; name of the token just parsed. | |
52 | ; For each function name there is actually a set of functions | |
53 | ; associated by a plist (keyed on the context). | |
54 | ||
55 | (defun (p$lbrace$$ top_lev) nil | |
56 | (cond (in_def (*throw 'parse$err '(err$$ ill_lbrace))) | |
57 | (t (list 'nothing (get_def))))) | |
58 | ||
59 | (defun (p$rbrace$$ top_lev) nil | |
60 | (cond ((not in_def) (*throw 'parse$err '(err$$ ill_rbrace))) | |
61 | (t (progn | |
62 | (cond ((null stk) (*throw 'parse$err '(err$$ stk_emp))) | |
63 | ((null infile) | |
64 | (do | |
65 | ((c (Tyi) (Tyi))) | |
66 | ((eq c 10))))) | |
67 | `(return ,(Pop)))))) | |
68 | ||
69 | (defun (p$rbrace$$ semi$$) nil | |
70 | (cond | |
71 | ((not in_def) (*throw 'parse$err '(err$$ ill_rbrace))) | |
72 | (t (progn | |
73 | (cond ((null stk) (*throw 'parse$err '(err$$ stk_emp))) | |
74 | ((null infile) | |
75 | (do | |
76 | ((c (Tyi) (Tyi))) | |
77 | ((eq c 10))))) | |
78 | `(rbrace$$ ,(Pop)))))) | |
79 | ||
80 | (defun trap_err (p) | |
81 | (cond ((find 'err$$ p) (*throw 'parse$err p)) | |
82 | (t p))) | |
83 | ||
84 | (defun (p$lparen$$ top_lev) nil | |
85 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) | |
86 | (t `(Push ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) | |
87 | ||
88 | (defun (p$lparen$$ constr$$) nil | |
89 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) | |
90 | (t `(Push ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) | |
91 | ||
92 | (defun (p$lparen$$ compos$$) nil | |
93 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) | |
94 | (t `(return ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) | |
95 | ||
96 | (defun (p$lparen$$ alpha$$) nil | |
97 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) | |
98 | (t `(return ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) | |
99 | ||
100 | (defun (p$lparen$$ ti$$) nil | |
101 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) | |
102 | (t `(return ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) | |
103 | ||
104 | (defun (p$lparen$$ insert$$) nil | |
105 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) | |
106 | (t `(return ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) | |
107 | ||
108 | (defun (p$lparen$$ arrow$$) nil | |
109 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) | |
110 | (t `(Push ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) | |
111 | ||
112 | (defun (p$lparen$$ semi$$) nil | |
113 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) | |
114 | (t `(Push ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) | |
115 | ||
116 | (defun (p$lparen$$ lparen$$) nil | |
117 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) | |
118 | (t `(Push ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) | |
119 | ||
120 | (defun (p$lparen$$ while$$) nil | |
121 | (cond ((twop wslen) (*throw 'parse$err '(err$$ ill_lpar))) | |
122 | (t `(Push ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) | |
123 | ||
124 | (defun (p$rparen$$ lparen$$) nil | |
125 | `(return ,(Pop))) | |
126 | ||
127 | (defun (p$rparen$$ top_lev) nil ; process commands | |
128 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ unbalparen))) | |
129 | (t (cond ((null infile) (get_cmd)) | |
130 | (t (patom "commands may not be issued from a file") | |
131 | (terpri) | |
132 | 'cmd$$))))) | |
133 | ||
134 | (defun (p$rparen$$ semi$$) nil | |
135 | `(return ,(Pop))) | |
136 | ||
137 | (defun (p$rparen$$ while$$) nil | |
138 | `(return ,(nreverse (list (Pop) (Pop))))) | |
139 | ||
140 | (defun (p$alpha$$ top_lev) nil | |
141 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) | |
142 | (t `(Push ,(frm_hnk 'alpha$$ (parse tkn)))))) | |
143 | ||
144 | (defun (p$alpha$$ compos$$) nil | |
145 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) | |
146 | (t `(return ,(frm_hnk 'alpha$$ (parse tkn)))))) | |
147 | ||
148 | (defun (p$alpha$$ constr$$) nil | |
149 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) | |
150 | (t `(Push ,(frm_hnk 'alpha$$ (parse tkn)))))) | |
151 | ||
152 | (defun (p$alpha$$ insert$$) nil | |
153 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) | |
154 | (t `(return ,(frm_hnk 'alpha$$ (parse tkn)))))) | |
155 | ||
156 | (defun (p$alpha$$ ti$$) nil | |
157 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) | |
158 | (t `(return ,(frm_hnk 'alpha$$ (parse tkn)))))) | |
159 | ||
160 | (defun (p$alpha$$ alpha$$) nil | |
161 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) | |
162 | (t `(return ,(frm_hnk 'alpha$$ (parse tkn)))))) | |
163 | ||
164 | (defun (p$alpha$$ lparen$$) nil | |
165 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) | |
166 | (t `(Push ,(frm_hnk 'alpha$$ (parse tkn)))))) | |
167 | ||
168 | (defun (p$alpha$$ arrow$$) nil | |
169 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) | |
170 | (t `(Push ,(frm_hnk 'alpha$$ (parse tkn)))))) | |
171 | ||
172 | (defun (p$alpha$$ semi$$) nil | |
173 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) | |
174 | (t `(Push ,(frm_hnk 'alpha$$ (parse tkn)))))) | |
175 | ||
176 | (defun (p$alpha$$ while$$) nil | |
177 | (cond ((twop wslen) (*throw 'parse$err '(err$$ ill_alpha))) | |
178 | (t `(Push ,(frm_hnk 'alpha$$ (parse tkn)))))) | |
179 | ||
180 | ||
181 | (defun (p$insert$$ top_lev) nil | |
182 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) | |
183 | (t `(Push ,(frm_hnk 'insert$$ (parse tkn)))))) | |
184 | ||
185 | (defun (p$insert$$ compos$$) nil | |
186 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) | |
187 | (t `(return ,(frm_hnk 'insert$$ (parse tkn)))))) | |
188 | ||
189 | (defun (p$insert$$ constr$$) nil | |
190 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) | |
191 | (t `(Push ,(frm_hnk 'insert$$ (parse tkn)))))) | |
192 | ||
193 | (defun (p$insert$$ insert$$) nil | |
194 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) | |
195 | (t `(return ,(frm_hnk 'insert$$ (parse tkn)))))) | |
196 | ||
197 | (defun (p$insert$$ ti$$) nil | |
198 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) | |
199 | (t `(return ,(frm_hnk 'insert$$ (parse tkn)))))) | |
200 | ||
201 | (defun (p$insert$$ alpha$$) nil | |
202 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) | |
203 | (t `(return ,(frm_hnk 'insert$$ (parse tkn)))))) | |
204 | ||
205 | (defun (p$insert$$ lparen$$) nil | |
206 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) | |
207 | (t `(Push ,(frm_hnk 'insert$$ (parse tkn)))))) | |
208 | ||
209 | (defun (p$insert$$ arrow$$) nil | |
210 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) | |
211 | (t `(Push ,(frm_hnk 'insert$$ (parse tkn)))))) | |
212 | ||
213 | (defun (p$insert$$ semi$$) nil | |
214 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) | |
215 | (t `(Push ,(frm_hnk 'insert$$ (parse tkn)))))) | |
216 | ||
217 | (defun (p$insert$$ while$$) nil | |
218 | (cond ((twop wslen) (*throw 'parse$err '(err$$ ill_insert))) | |
219 | (t `(Push ,(frm_hnk 'insert$$ (parse tkn)))))) | |
220 | ||
221 | ||
222 | (defun (p$ti$$ top_lev) nil | |
223 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) | |
224 | (t `(Push ,(frm_hnk 'ti$$ (parse tkn)))))) | |
225 | ||
226 | (defun (p$ti$$ compos$$) nil | |
227 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) | |
228 | (t `(return ,(frm_hnk 'ti$$ (parse tkn)))))) | |
229 | ||
230 | (defun (p$ti$$ constr$$) nil | |
231 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) | |
232 | (t `(Push ,(frm_hnk 'ti$$ (parse tkn)))))) | |
233 | ||
234 | (defun (p$ti$$ insert$$) nil | |
235 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) | |
236 | (t `(return ,(frm_hnk 'ti$$ (parse tkn)))))) | |
237 | ||
238 | (defun (p$ti$$ ti$$) nil | |
239 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) | |
240 | (t `(return ,(frm_hnk 'ti$$ (parse tkn)))))) | |
241 | ||
242 | (defun (p$ti$$ alpha$$) nil | |
243 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) | |
244 | (t `(return ,(frm_hnk 'ti$$ (parse tkn)))))) | |
245 | ||
246 | (defun (p$ti$$ lparen$$) nil | |
247 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) | |
248 | (t `(Push ,(frm_hnk 'ti$$ (parse tkn)))))) | |
249 | ||
250 | (defun (p$ti$$ arrow$$) nil | |
251 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) | |
252 | (t `(Push ,(frm_hnk 'ti$$ (parse tkn)))))) | |
253 | ||
254 | (defun (p$ti$$ semi$$) nil | |
255 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) | |
256 | (t `(Push ,(frm_hnk 'ti$$ (parse tkn)))))) | |
257 | ||
258 | (defun (p$ti$$ while$$) nil | |
259 | (cond ((twop wslen) (*throw 'parse$err '(err$$ ill_ai))) | |
260 | (t `(Push ,(frm_hnk 'ti$$ (parse tkn)))))) | |
261 | ||
262 | ||
263 | (defun (p$compos$$ top_lev) nil | |
264 | `(Push ,(frm_hnk 'compos$$ (Pop) (parse tkn)))) | |
265 | ||
266 | (defun (p$compos$$ compos$$) nil | |
267 | `(Push ,(frm_hnk 'compos$$ (Pop) (parse tkn)))) | |
268 | ||
269 | (defun (p$compos$$ constr$$) nil | |
270 | `(Push ,(frm_hnk 'compos$$ (Pop) (parse tkn)))) | |
271 | ||
272 | (defun (p$compos$$ lparen$$) nil | |
273 | `(Push ,(frm_hnk 'compos$$ (Pop) (parse tkn)))) | |
274 | ||
275 | (defun (p$compos$$ arrow$$) nil | |
276 | `(Push ,(frm_hnk 'compos$$ (Pop) (parse tkn)))) | |
277 | ||
278 | (defun (p$compos$$ semi$$) nil | |
279 | `(Push ,(frm_hnk 'compos$$ (Pop) (parse tkn)))) | |
280 | ||
281 | (defun (p$compos$$ while$$) nil | |
282 | `(Push ,(frm_hnk 'compos$$ (Pop) (parse tkn)))) | |
283 | ||
284 | ||
285 | (defun (p$comma$$ constr$$) nil | |
286 | `(return ,(Pop))) | |
287 | ||
288 | (defun (p$comma$$ semi$$) nil | |
289 | `(comma$$ ,(Pop))) | |
290 | ||
291 | ||
292 | (defun (p$lbrack$$ top_lev) nil | |
293 | `(Push ,(get_constr))) | |
294 | ||
295 | (defun (p$lbrack$$ compos$$) nil | |
296 | `(return ,(get_constr))) | |
297 | ||
298 | (defun (p$lbrack$$ constr$$) nil | |
299 | `(Push ,(get_constr))) | |
300 | ||
301 | (defun (p$lbrack$$ lparen$$) nil | |
302 | `(Push ,(get_constr))) | |
303 | ||
304 | (defun (p$lbrack$$ arrow$$) nil | |
305 | `(Push ,(get_constr))) | |
306 | ||
307 | (defun (p$lbrack$$ semi$$) nil | |
308 | `(Push ,(get_constr))) | |
309 | ||
310 | (defun (p$lbrack$$ alpha$$) nil | |
311 | `(return ,(get_constr))) | |
312 | ||
313 | (defun (p$lbrack$$ insert$$) nil | |
314 | `(return ,(get_constr))) | |
315 | ||
316 | (defun (p$lbrack$$ ti$$) nil | |
317 | `(return ,(get_constr))) | |
318 | ||
319 | (defun (p$lbrack$$ while$$) nil | |
320 | `(Push ,(get_constr))) | |
321 | ||
322 | ||
323 | (defun (p$rbrack$$ constr$$) nil | |
324 | `(return done ,(cond ((null stk) nil) | |
325 | (t (Pop))))) | |
326 | ||
327 | (defun (p$rbrack$$ semi$$) nil | |
328 | `(rbrack$$ ,`(done ,(cond ((null stk) nil) | |
329 | (t (Pop)))))) | |
330 | ||
331 | ||
332 | (defun (p$defined$$ top_lev) nil | |
333 | `(Push ,(concat (cadr tkn) '_fp))) | |
334 | ||
335 | (defun (p$defined$$ compos$$) nil | |
336 | `(return ,(concat (cadr tkn) '_fp))) | |
337 | ||
338 | (defun (p$defined$$ constr$$) nil | |
339 | `(Push ,(concat (cadr tkn) '_fp))) | |
340 | ||
341 | (defun (p$defined$$ lparen$$) nil | |
342 | `(Push ,(concat (cadr tkn) '_fp))) | |
343 | ||
344 | (defun (p$defined$$ arrow$$) nil | |
345 | `(Push ,(concat (cadr tkn) '_fp))) | |
346 | ||
347 | (defun (p$defined$$ semi$$) nil | |
348 | `(Push ,(concat (cadr tkn) '_fp))) | |
349 | ||
350 | (defun (p$defined$$ alpha$$) nil | |
351 | `(return ,(concat (cadr tkn) '_fp))) | |
352 | ||
353 | (defun (p$defined$$ insert$$) nil | |
354 | `(return ,(concat (cadr tkn) '_fp))) | |
355 | ||
356 | (defun (p$defined$$ ti$$) nil | |
357 | `(return ,(concat (cadr tkn) '_fp))) | |
358 | ||
359 | (defun (p$defined$$ while$$) nil | |
360 | `(Push ,(concat (cadr tkn) '_fp))) | |
361 | ||
362 | ||
363 | (defun (p$builtin$$ top_lev) nil | |
364 | `(Push ,(concat (cadr tkn) '$fp))) | |
365 | ||
366 | (defun (p$builtin$$ compos$$) nil | |
367 | `(return ,(concat (cadr tkn) '$fp))) | |
368 | ||
369 | (defun (p$builtin$$ constr$$) nil | |
370 | `(Push ,(concat (cadr tkn) '$fp))) | |
371 | ||
372 | (defun (p$builtin$$ lparen$$) nil | |
373 | `(Push ,(concat (cadr tkn) '$fp))) | |
374 | ||
375 | (defun (p$builtin$$ arrow$$) nil | |
376 | `(Push ,(concat (cadr tkn) '$fp))) | |
377 | ||
378 | (defun (p$builtin$$ semi$$) nil | |
379 | `(Push ,(concat (cadr tkn) '$fp))) | |
380 | ||
381 | (defun (p$builtin$$ alpha$$) nil | |
382 | `(return ,(concat (cadr tkn) '$fp))) | |
383 | ||
384 | (defun (p$builtin$$ insert$$) nil | |
385 | `(return ,(concat (cadr tkn) '$fp))) | |
386 | ||
387 | (defun (p$builtin$$ ti$$) nil | |
388 | `(return ,(concat (cadr tkn) '$fp))) | |
389 | ||
390 | (defun (p$builtin$$ while$$) nil | |
391 | `(Push ,(concat (cadr tkn) '$fp))) | |
392 | ||
393 | ||
394 | (defun (p$select$$ top_lev) nil | |
395 | `(Push ,(makhunk tkn))) | |
396 | ||
397 | (defun (p$select$$ compos$$) nil | |
398 | `(return ,(makhunk tkn))) | |
399 | ||
400 | (defun (p$select$$ constr$$) nil | |
401 | `(Push ,(makhunk tkn))) | |
402 | ||
403 | (defun (p$select$$ lparen$$) nil | |
404 | `(Push ,(makhunk tkn))) | |
405 | ||
406 | (defun (p$select$$ arrow$$) nil | |
407 | `(Push ,(makhunk tkn))) | |
408 | ||
409 | (defun (p$select$$ semi$$) nil | |
410 | `(Push ,(makhunk tkn))) | |
411 | ||
412 | (defun (p$select$$ alpha$$) nil | |
413 | `(return ,(makhunk tkn))) | |
414 | ||
415 | (defun (p$select$$ while$$) nil | |
416 | `(Push ,(makhunk tkn))) | |
417 | ||
418 | ||
419 | (defun (p$constant$$ top_lev) nil | |
420 | `(Push ,(makhunk tkn))) | |
421 | ||
422 | (defun (p$constant$$ compos$$) nil | |
423 | `(return ,(makhunk tkn))) | |
424 | ||
425 | (defun (p$constant$$ constr$$) nil | |
426 | `(Push ,(makhunk tkn))) | |
427 | ||
428 | (defun (p$constant$$ lparen$$) nil | |
429 | `(Push ,(makhunk tkn))) | |
430 | ||
431 | (defun (p$constant$$ arrow$$) nil | |
432 | `(Push ,(makhunk tkn))) | |
433 | ||
434 | (defun (p$constant$$ semi$$) nil | |
435 | `(Push ,(makhunk tkn))) | |
436 | ||
437 | (defun (p$constant$$ alpha$$) nil | |
438 | `(return ,(makhunk tkn))) | |
439 | ||
440 | (defun (p$constant$$ while$$) nil | |
441 | `(Push ,(makhunk tkn))) | |
442 | ||
443 | ||
444 | (defun (p$colon$$ top_lev) nil | |
445 | (cond (in_def (*throw 'parse$err '(err$$ ill_appl))) | |
446 | (t `(return ,(Pop))))) | |
447 | ||
448 | (defun (p$colon$$ semi$$) nil | |
449 | (cond (in_def (*throw 'parse$err '(err$$ ill_appl))) | |
450 | (t `(colon$$ ,(Pop))))) | |
451 | ||
452 | ||
453 | (defun (p$arrow$$ lparen$$) nil | |
454 | (get_condit)) | |
455 | ||
456 | ||
457 | (defun (p$semi$$ arrow$$) nil | |
458 | `(return ,(Pop))) | |
459 | ||
460 | (defun (p$while$$ lparen$$) nil | |
461 | (cond ((not (null stk)) (*throw 'parse$err '(err$$ bad_while))) | |
462 | (t (get_while)))) | |
463 | ||
464 | ||
465 | ; parse action support functions | |
466 | ||
467 | (defun get_condit nil | |
468 | (prog (q r) | |
469 | (setq q (parse 'arrow$$)) | |
470 | (cond ((and (listp q) (find 'err$$ q)) (*throw 'parse$err q))) | |
471 | (setq r (parse 'semi$$)) | |
472 | (cond ((and (listp r) (find 'err$$ r)) (*throw 'parse$err r))) | |
473 | (*throw 'end_condit (frm_hnk 'condit$$ (Pop) q r)))) | |
474 | ||
475 | ||
476 | (defun Push (value) | |
477 | (cond ((eq flag 'while$$) | |
478 | (cond | |
479 | ((zerop wslen) (setq stk value) (setq wslen 1)) | |
480 | ((onep wslen) (setq stk (list stk value)) (setq wslen 2)) | |
481 | (t (*throw 'parse$err '(err$$ bad_while Push))))) | |
482 | (t (setq stk value)))) | |
483 | ||
484 | (defun Pop nil | |
485 | (cond | |
486 | ((null stk) (*throw 'parse$err '(err$$ stk_emp))) | |
487 | (t | |
488 | (prog (tmp) | |
489 | (setq tmp stk) | |
490 | (cond ((eq flag 'while$$) | |
491 | (cond ((onep wslen) (setq stk nil) (setq wslen 0) (return tmp)) | |
492 | ((twop wslen) | |
493 | (setq stk (car tmp)) (setq wslen 1) (return (cadr tmp))) | |
494 | (t (*throw 'parse$err '(err$$ bad_while Pop))))) | |
495 | (t (setq stk nil) | |
496 | (return tmp))))))) | |
497 | ||
498 | (defun get_def nil | |
499 | (prog (dummy) | |
500 | (setq in_def t) | |
501 | (setq dummy (get_tkn)) | |
502 | (cond ((find 'builtin$$ dummy) (*throw 'parse$err '(err$$ redef))) | |
503 | ((not (find 'defined$$ dummy)) (*throw 'parse$err '(err$$ bad_nam))) | |
504 | (t (setq fn_name (concat (cadr dummy) '_fp)))))) | |
505 | ||
506 | ||
507 | (defun get_constr nil | |
508 | (cond ((eq flag 'while$$) (cond | |
509 | ((twop wslen) (*throw 'parse$err `(err$$ bad_whl ,stk ,tkn))))) | |
510 | (t (cond ((not (null stk)) (*throw 'parse$err '(err$$ bad_constr parse)))))) | |
511 | (do | |
512 | ((v (parse 'constr$$) (parse 'constr$$)) | |
513 | (temp nil) | |
514 | (fn_lst nil)) | |
515 | ||
516 | ((eq tkn 'eof$$) (*throw 'parse$err '(err$$ eof$$))) | |
517 | ||
518 | (cond | |
519 | ((listp v) | |
520 | (cond ((eq (car v) 'err$$) (*throw 'parse$err v)) | |
521 | ((eq (car v) 'done) | |
522 | (cond ((eq (cadr v) 'err$$) (*throw 'parse$err (cdr v))) | |
523 | (t (return | |
524 | (makhunk (cons 'constr$$ (reverse (cons (cadr v) fn_lst)))))))) | |
525 | (t (setq fn_lst (cons v fn_lst))))) | |
526 | (t (setq fn_lst (cons v fn_lst)))))) | |
527 | ||
528 | (def frm_hnk (lexpr (z) | |
529 | (prog (l bad_one) | |
530 | (setq l (listify z)) | |
531 | (setq bad_one (assq 'err$$ (cdr l))) | |
532 | (cond ((null bad_one) (return (makhunk l))) | |
533 | (t (*throw 'parse$err bad_one)))))) | |
534 | ||
535 | ||
536 | ||
537 | (defun prs_fn nil | |
538 | (concat 'p$ (cond ((atom tkn) tkn) | |
539 | (t (car tkn))))) | |
540 | ||
541 | (defun get_while nil | |
542 | (let ((r (parse 'while$$))) | |
543 | (cond ((and (listp r) (find 'err$$ r)) (*throw 'parse$err r)) | |
544 | (t (*throw 'end_while (frm_hnk 'while$$ (car r) (cadr r))))))) | |
545 | ||
546 | (defun twop (x) | |
547 | (eq 2 x)) | |
548 |