/[cmucl]/src/contrib/ops/ops-compile.lisp
ViewVC logotype

Contents of /src/contrib/ops/ops-compile.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Sun May 31 02:19:25 1992 UTC (21 years, 10 months ago) by ram
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, RELENG_18, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.1: +2 -2 lines
Encode pairs with shifting, not multiplication.
1 ;
2 ;************************************************************************
3 ;
4 ; VPS2 -- Interpreter for OPS5
5 ;
6 ;
7 ;
8 ; This Common Lisp version of OPS5 is in the public domain. It is based
9 ; in part on based on a Franz Lisp implementation done by Charles L. Forgy
10 ; at Carnegie-Mellon University, which was placed in the public domain by
11 ; the author in accordance with CMU policies. This version has been
12 ; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
13 ; and Dan Kuokka.
14 ;
15 ; This code is made available is, and without warranty of any kind by the
16 ; authors or by Carnegie-Mellon University.
17 ;
18
19 ;;;; This file contains functions compile productions.
20
21 (in-package "OPS")
22 (shadow '(remove write)) ; Should get this by requiring ops-rhs
23 (export '--> )
24
25
26 ;;; External global variables
27
28 (defvar *real-cnt*)
29 (defvar *virtual-cnt*)
30 (defvar *last-node*)
31 (defvar *first-node*)
32 (defvar *pcount*)
33
34
35 ;;; Internal global variables
36
37 (defvar *matrix*)
38 (defvar *curcond*)
39 (defvar *feature-count*)
40 (defvar *ce-count*)
41 (defvar *vars*)
42 (defvar *ce-vars*)
43 (defvar *rhs-bound-vars*)
44 (defvar *rhs-bound-ce-vars*)
45 (defvar *last-branch*)
46 (defvar *subnum*)
47 (defvar *cur-vars*)
48 (defvar *action-type*)
49
50
51
52 (defun compile-init ()
53 (setq *real-cnt* (setq *virtual-cnt* 0.))
54 (setq *pcount* 0.)
55 (make-bottom-node))
56
57
58 ;;; LHS Compiler
59
60 (defun ops-p (z)
61 (finish-literalize)
62 (princ '*)
63 ;(drain) commented out temporarily
64 (force-output) ;@@@ clisp drain?
65 (compile-production (car z) (cdr z)))
66
67
68 (defun compile-production (name matrix) ;jgk inverted args to catch and quoted tag
69 (setq *p-name* name)
70 (catch '!error! (cmp-p name matrix))
71 (setq *p-name* nil))
72 #|
73 (defun compile-production (name matrix) ;jgk inverted args to catch
74 (prog (erm) ;and quoted tag
75 (setq *p-name* name)
76 (setq erm (catch '!error! (cmp-p name matrix)))
77 (setq *p-name* nil)))
78 |#
79
80 (defun peek-lex nil (car *matrix*))
81
82 (defun lex nil
83 (prog2 nil (car *matrix*) (setq *matrix* (cdr *matrix*))))
84
85 (defun end-of-p nil (atom *matrix*))
86
87 (defun rest-of-p nil *matrix*)
88
89 (defun prepare-lex (prod) (setq *matrix* prod))
90
91
92 (defun peek-sublex nil (car *curcond*))
93
94 (defun sublex nil
95 (prog2 nil (car *curcond*) (setq *curcond* (cdr *curcond*))))
96
97 (defun end-of-ce nil (atom *curcond*))
98
99 (defun rest-of-ce nil *curcond*)
100
101 (defun prepare-sublex (ce) (setq *curcond* ce))
102
103 (defun make-bottom-node nil (setq *first-node* (list '&bus nil)))
104
105 (defun cmp-p (name matrix)
106 (prog (m bakptrs)
107 (cond ((or (null name) (consp name)) ;dtpr\consp gdw
108 (%error '|illegal production name| name))
109 ((equal (get name 'production) matrix)
110 (return nil)))
111 (prepare-lex matrix)
112 (excise-p name)
113 (setq bakptrs nil)
114 (setq *pcount* (1+ *pcount*)) ;"plus" changed to "+" by gdw
115 (setq *feature-count* 0.)
116 (setq *ce-count* 0)
117 (setq *vars* nil)
118 (setq *ce-vars* nil)
119 (setq *rhs-bound-vars* nil)
120 (setq *rhs-bound-ce-vars* nil)
121 (setq *last-branch* nil)
122 (setq m (rest-of-p))
123 l1 (and (end-of-p) (%error '|no '-->' in production| m))
124 (cmp-prin)
125 (setq bakptrs (cons *last-branch* bakptrs))
126 (or (eq '--> (peek-lex)) (go l1))
127 (lex)
128 (check-rhs (rest-of-p))
129 (link-new-node (list '&p
130 *feature-count*
131 name
132 (encode-dope)
133 (encode-ce-dope)
134 (cons 'progn (rest-of-p))))
135 (putprop name (cdr (nreverse bakptrs)) 'backpointers)
136 (putprop name matrix 'production)
137 (putprop name *last-node* 'topnode)))
138
139 (defun rating-part (pnode) (cadr pnode))
140
141 (defun var-part (pnode) (car (cdddr pnode)))
142
143 (defun ce-var-part (pnode) (cadr (cdddr pnode)))
144
145 (defun rhs-part (pnode) (caddr (cdddr pnode)))
146
147 (defun cmp-prin nil
148 (prog nil
149 (setq *last-node* *first-node*)
150 (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta))
151 ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
152 (t (cmp-posce) (cmp-and)))))
153
154 (defun cmp-negce nil (lex) (cmp-ce))
155
156 (defun cmp-posce nil
157 (setq *ce-count* (1+ *ce-count*)) ;"plus" changed to "+" by gdw
158 (cond ((eq (peek-lex) '\{) (cmp-ce+cevar)) ;"plus" changed to "+" by gdw
159 (t (cmp-ce))))
160
161 (defun cmp-ce+cevar nil
162 (prog (z)
163 (lex)
164 (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
165 (t (cmp-ce) (cmp-cevar)))
166 (setq z (lex))
167 (or (eq z '\}) (%error '|missing '}'| z))))
168
169 (defun new-subnum (k)
170 (or (numberp k) (%error '|tab must be a number| k))
171 (setq *subnum* (fix k)))
172
173 (defun incr-subnum nil (setq *subnum* (1+ *subnum*)))
174
175 (defun cmp-ce nil
176 (prog (z)
177 (new-subnum 0.)
178 (setq *cur-vars* nil)
179 (setq z (lex))
180 (and (atom z)
181 (%error '|atomic conditions are not allowed| z))
182 (prepare-sublex z)
183 la (and (end-of-ce) (return nil))
184 (incr-subnum)
185 (cmp-element)
186 (go la)))
187
188 (defun cmp-element nil
189 (and (eq (peek-sublex) '^) (cmp-tab))
190 (cond ((eq (peek-sublex) '\{) (cmp-product))
191 (t (cmp-atomic-or-any))))
192
193 (defun cmp-atomic-or-any nil
194 (cond ((eq (peek-sublex) '<<) (cmp-any))
195 (t (cmp-atomic))))
196
197 (defun cmp-any nil
198 (prog (a z)
199 (sublex)
200 (setq z nil)
201 la (cond ((end-of-ce) (%error '|missing '>>'| a)))
202 (setq a (sublex))
203 (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
204 (link-new-node (list '&any nil (current-field) z))))
205
206
207 (defun cmp-tab nil
208 (prog (r)
209 (sublex)
210 (setq r (sublex))
211 (setq r ($litbind r))
212 (new-subnum r)))
213
214 (defun get-bind (x)
215 (prog (r)
216 (cond ((and (symbolp x) (setq r (literal-binding-of x)))
217 (return r))
218 (t (return nil)))))
219
220 (defun cmp-atomic nil
221 (prog (test x)
222 (setq x (peek-sublex))
223 (cond ((eq x '= ) (setq test 'eq) (sublex))
224 ((eq x '<>) (setq test 'ne) (sublex))
225 ((eq x '<) (setq test 'lt) (sublex))
226 ((eq x '<=) (setq test 'le) (sublex))
227 ((eq x '>) (setq test 'gt) (sublex))
228 ((eq x '>=) (setq test 'ge) (sublex))
229 ((eq x '<=>) (setq test 'xx) (sublex))
230 (t (setq test 'eq)))
231 (cmp-symbol test)))
232
233 (defun cmp-product nil
234 (prog (save)
235 (setq save (rest-of-ce))
236 (sublex)
237 la (cond ((end-of-ce)
238 (cond ((member '\} save :test #'equal)
239 (%error '|wrong contex for '}'| save))
240 (t (%error '|missing '}'| save))))
241 ((eq (peek-sublex) '\}) (sublex) (return nil)))
242 (cmp-atomic-or-any)
243 (go la)))
244
245 (defun cmp-symbol (test)
246 (prog (flag)
247 (setq flag t)
248 (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil)))
249 (cond ((and flag (variablep (peek-sublex)))
250 (cmp-var test))
251 ((numberp (peek-sublex)) (cmp-number test))
252 ((symbolp (peek-sublex)) (cmp-constant test))
253 (t (%error '|unrecognized symbol| (sublex))))))
254
255 (defun cmp-constant (test) ;jgk inserted concatenate form
256 (or (member test '(eq ne xx))
257 (%error '|non-numeric constant after numeric predicate| (sublex)))
258 (link-new-node (list (intern (concatenate 'string
259 "T"
260 (symbol-name test)
261 "A"))
262 nil
263 (current-field)
264 (sublex))))
265
266 (defun cmp-number (test) ;jgk inserted concatenate form
267 (link-new-node (list (intern (concatenate 'string
268 "T"
269 (symbol-name test)
270 ;@@@ error? reported by laird fix\ "A"))
271 "N"))
272 nil
273 (current-field)
274 (sublex))))
275
276 (defun current-field nil (field-name *subnum*))
277
278 (defun field-name (num)
279 (if (< 0 num 127)
280 (svref '#(nil *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9* *c10* *c11*
281 *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19* *c20* *c21*
282 *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29* *c30* *c31*
283 *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39* *c40* *c41*
284 *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49* *c50* *c51*
285 *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59* *c60* *c61*
286 *c62* *c63* *c64* *c65* *c66* *c67* *c68* *c69* *c70* *c71*
287 *c72* *c73* *c74* *c75* *c76* *c77* *c78* *c79* *c80* *c81*
288 *c82* *c83* *c84* *c85* *c86* *c87* *c88* *c89* *c90* *c91*
289 *c92* *c93* *c94* *c95* *c96* *c97* *c98* *c99* *c100*
290 *c101* *c102* *c103* *c104* *c105* *c106* *c107* *c108*
291 *c109* *c110* *c111* *c112* *c113* *c114* *c115* *c116*
292 *c117* *c118* *c119* *c120* *c121* *c122* *c123* *c124*
293 *c125* *c126* *c127*)
294 num)
295 (%error '|condition is too long| (rest-of-ce))))
296
297 ;;; Compiling variables
298 ;
299 ;
300 ;
301 ; *cur-vars* are the variables in the condition element currently
302 ; being compiled. *vars* are the variables in the earlier condition
303 ; elements. *ce-vars* are the condition element variables. note
304 ; that the interpreter will not confuse condition element and regular
305 ; variables even if they have the same name.
306 ;
307 ; *cur-vars* is a list of triples: (name predicate subelement-number)
308 ; eg: ( (<x> eq 3)
309 ; (<y> ne 1)
310 ; . . . )
311 ;
312 ; *vars* is a list of triples: (name ce-number subelement-number)
313 ; eg: ( (<x> 3 3)
314 ; (<y> 1 1)
315 ; . . . )
316 ;
317 ; *ce-vars* is a list of pairs: (name ce-number)
318 ; eg: ( (ce1 1)
319 ; (<c3> 3)
320 ; . . . )
321
322 (defmacro var-dope (var) `(assq ,var *vars*))
323
324 (defmacro ce-var-dope (var) `(assq ,var *ce-vars*))
325
326 (defun cmp-var (test)
327 (prog (old name)
328 (setq name (sublex))
329 (setq old (assq name *cur-vars*))
330 (cond ((and old (eq (cadr old) 'eq))
331 (cmp-old-eq-var test old))
332 ((and old (eq test 'eq)) (cmp-new-eq-var name old))
333 (t (cmp-new-var name test)))))
334
335 (defun cmp-new-var (name test)
336 (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*)))
337
338 (defun cmp-old-eq-var (test old) ; jgk inserted concatenate form
339 (link-new-node (list (intern (concatenate 'string
340 "T"
341 (symbol-name test)
342 "S"))
343 nil
344 (current-field)
345 (field-name (caddr old)))))
346
347
348
349 (defun cmp-new-eq-var (name old) ;jgk inserted concatenate form
350 (prog (pred next)
351 (setq *cur-vars* (delq old *cur-vars*))
352 (setq next (assq name *cur-vars*))
353 (cond (next (cmp-new-eq-var name next))
354 (t (cmp-new-var name 'eq)))
355 (setq pred (cadr old))
356 (link-new-node (list (intern (concatenate 'string
357 "T"
358 (symbol-name pred)
359 "S"))
360 nil
361 (field-name (caddr old))
362 (current-field)))))
363
364 (defun cmp-cevar nil
365 (prog (name old)
366 (setq name (lex))
367 (setq old (assq name *ce-vars*))
368 (and old
369 (%error '|condition element variable used twice| name))
370 (setq *ce-vars* (cons (list name 0.) *ce-vars*))))
371
372 (defun cmp-not nil (cmp-beta '&not))
373
374 (defun cmp-nobeta nil (cmp-beta nil))
375
376 (defun cmp-and nil (cmp-beta '&and))
377
378 (defun cmp-beta (kind)
379 (prog (tlist vdope vname #|vpred vpos|# old)
380 (setq tlist nil)
381 la (and (atom *cur-vars*) (go lb))
382 (setq vdope (car *cur-vars*))
383 (setq *cur-vars* (cdr *cur-vars*))
384 (setq vname (car vdope))
385 ;; (setq vpred (cadr vdope)) Dario - commented out (unused)
386 ;; (setq vpos (caddr vdope))
387 (setq old (assq vname *vars*))
388 (cond (old (setq tlist (add-test tlist vdope old)))
389 ((not (eq kind '&not)) (promote-var vdope)))
390 (go la)
391 lb (and kind (build-beta kind tlist))
392 (or (eq kind '&not) (fudge))
393 (setq *last-branch* *last-node*)))
394
395 (defun add-test (list new old) ; jgk inserted concatenate form
396 (prog (ttype lloc rloc)
397 (setq *feature-count* (1+ *feature-count*))
398 (setq ttype (intern (concatenate 'string "T"
399 (symbol-name (cadr new))
400 "B")))
401 (setq rloc (encode-singleton (caddr new)))
402 (setq lloc (encode-pair (cadr old) (caddr old)))
403 (return (cons ttype (cons lloc (cons rloc list))))))
404
405 ; the following two functions encode indices so that gelm can
406 ; decode them as fast as possible
407
408 (defun encode-pair (a b)
409 (logior (ash (1- a) encode-pair-shift) (1- b)))
410
411 (defun encode-singleton (a) (1- a))
412
413 (defun promote-var (dope)
414 (prog (vname vpred vpos new)
415 (setq vname (car dope))
416 (setq vpred (cadr dope))
417 (setq vpos (caddr dope))
418 (or (eq 'eq vpred)
419 (%error '|illegal predicate for first occurrence|
420 (list vname vpred)))
421 (setq new (list vname 0. vpos))
422 (setq *vars* (cons new *vars*))))
423
424 (defun fudge nil
425 (mapc (function fudge*) *vars*)
426 (mapc (function fudge*) *ce-vars*))
427
428 (defun fudge* (z)
429 (prog (a) (setq a (cdr z)) (rplaca a (1+ (car a)))))
430
431 (defun build-beta (type tests)
432 (prog (rpred lpred lnode lef)
433 (link-new-node (list '&mem nil nil (protomem)))
434 (setq rpred *last-node*)
435 (cond ((eq type '&and)
436 (setq lnode (list '&mem nil nil (protomem))))
437 (t (setq lnode (list '&two nil nil))))
438 (setq lpred (link-to-branch lnode))
439 (cond ((eq type '&and) (setq lef lpred))
440 (t (setq lef (protomem))))
441 (link-new-beta-node (list type nil lef rpred tests))))
442
443 (defun protomem nil (list nil))
444
445 (defun memory-part (mem-node) (car (cadddr mem-node)))
446
447 (defun encode-dope nil
448 (prog (r all z k)
449 (setq r nil)
450 (setq all *vars*)
451 la (and (atom all) (return r))
452 (setq z (car all))
453 (setq all (cdr all))
454 (setq k (encode-pair (cadr z) (caddr z)))
455 (setq r (cons (car z) (cons k r)))
456 (go la)))
457
458 (defun encode-ce-dope nil
459 (prog (r all z k)
460 (setq r nil)
461 (setq all *ce-vars*)
462 la (and (atom all) (return r))
463 (setq z (car all))
464 (setq all (cdr all))
465 (setq k (cadr z))
466 (setq r (cons (car z) (cons k r)))
467 (go la)))
468
469
470
471 ;;; Linking the nodes
472
473 (defun link-new-node (r)
474 (cond ((not (member (car r) '(&p &mem &two &and &not) :test #'equal))
475 (setq *feature-count* (1+ *feature-count*))))
476 (setq *virtual-cnt* (1+ *virtual-cnt*))
477 (setq *last-node* (link-left *last-node* r)))
478
479 (defun link-to-branch (r)
480 (setq *virtual-cnt* (1+ *virtual-cnt*))
481 (setq *last-branch* (link-left *last-branch* r)))
482
483 (defun link-new-beta-node (r)
484 (setq *virtual-cnt* (1+ *virtual-cnt*))
485 (setq *last-node* (link-both *last-branch* *last-node* r))
486 (setq *last-branch* *last-node*))
487
488 (defun link-left (pred succ)
489 (prog (a r)
490 (setq a (left-outs pred))
491 (setq r (find-equiv-node succ a))
492 (and r (return r))
493 (setq *real-cnt* (1+ *real-cnt*))
494 (attach-left pred succ)
495 (return succ)))
496
497 (defun link-both (left right succ)
498 (prog (a r)
499 (setq a (interq (left-outs left) (right-outs right)))
500 (setq r (find-equiv-beta-node succ a))
501 (and r (return r))
502 (setq *real-cnt* (1+ *real-cnt*))
503 (attach-left left succ)
504 (attach-right right succ)
505 (return succ)))
506
507 (defun attach-right (old new)
508 (rplaca (cddr old) (cons new (caddr old))))
509
510 (defun attach-left (old new)
511 (rplaca (cdr old) (cons new (cadr old))))
512
513 (defun right-outs (node) (caddr node))
514
515 (defun left-outs (node) (cadr node))
516
517 (defun find-equiv-node (node list)
518 (prog (a)
519 (setq a list)
520 l1 (cond ((atom a) (return nil))
521 ((equiv node (car a)) (return (car a))))
522 (setq a (cdr a))
523 (go l1)))
524
525 (defun find-equiv-beta-node (node list)
526 (prog (a)
527 (setq a list)
528 l1 (cond ((atom a) (return nil))
529 ((beta-equiv node (car a)) (return (car a))))
530 (setq a (cdr a))
531 (go l1)))
532
533 ; do not look at the predecessor fields of beta nodes; they have to be
534 ; identical because of the way the candidate nodes were found
535
536 (defun equiv (a b)
537 (and (eq (car a) (car b))
538 (or (eq (car a) '&mem)
539 (eq (car a) '&two)
540 (equal (caddr a) (caddr b)))
541 (equal (cdddr a) (cdddr b))))
542
543 (defun beta-equiv (a b)
544 (and (eq (car a) (car b))
545 (equal (cddddr a) (cddddr b))
546 (or (eq (car a) '&and) (equal (caddr a) (caddr b)))))
547
548 ; the equivalence tests are set up to consider the contents of
549 ; node memories, so they are ready for the build action
550
551
552
553 ;;; Check the RHSs of productions
554
555
556 (defun check-rhs (rhs) (mapc (function check-action) rhs))
557
558 (defun check-action (x)
559 (prog (a)
560 (cond ((atom x)
561 (%warn '|atomic action| x)
562 (return nil)))
563 (setq a (setq *action-type* (car x)))
564 (case a
565 (bind (check-bind x))
566 (cbind (check-cbind x))
567 (make (check-make x))
568 (modify (check-modify x))
569 (remove (check-remove x))
570 (write (check-write x))
571 (call (check-call x))
572 (halt (check-halt x))
573 (openfile (check-openfile x))
574 (closefile (check-closefile x))
575 (default (check-default x))
576 (build (check-build x))
577 (t (%warn '|undefined rhs action| a)))))
578
579
580 ;(defun chg-to-write (x)
581 ; (setq x (cons 'write (cdr x))))
582
583 (defun check-build (z)
584 (and (null (cdr z)) (%warn '|needs arguments| z))
585 (check-build-collect (cdr z)))
586
587 (defun check-build-collect (args)
588 (prog (r)
589 top (and (null args) (return nil))
590 (setq r (car args))
591 (setq args (cdr args))
592 (cond ((consp r) (check-build-collect r)) ;dtpr\consp gdw
593 ((eq r '\\)
594 (and (null args) (%warn '|nothing to evaluate| r))
595 (check-rhs-value (car args))
596 (setq args (cdr args))))
597 (go top)))
598
599 (defun check-remove (z) ;@@@ kluge by gdw
600 (and (null (cdr z)) (%warn '|needs arguments| z))
601 (mapc (function check-rhs-ce-var) (cdr z)))
602
603 ;(defun check-remove (z) ;original
604 ; (and (null (cdr z)) (%warn '|needs arguments| z))
605 ;(mapc (function check-rhs-ce-var) (cdr z)))
606
607 (defun check-make (z)
608 (and (null (cdr z)) (%warn '|needs arguments| z))
609 (check-change& (cdr z)))
610
611 (defun check-openfile (z)
612 (and (null (cdr z)) (%warn '|needs arguments| z))
613 (check-change& (cdr z)))
614
615 (defun check-closefile (z)
616 (and (null (cdr z)) (%warn '|needs arguments| z))
617 (check-change& (cdr z)))
618
619 (defun check-default (z)
620 (and (null (cdr z)) (%warn '|needs arguments| z))
621 (check-change& (cdr z)))
622
623 (defun check-modify (z)
624 (and (null (cdr z)) (%warn '|needs arguments| z))
625 (check-rhs-ce-var (cadr z))
626 (and (null (cddr z)) (%warn '|no changes to make| z))
627 (check-change& (cddr z)))
628
629 (defun check-write (z) ;note this works w/write
630 (and (null (cdr z)) (%warn '|needs arguments| z))
631 (check-change& (cdr z)))
632
633 (defun check-call (z)
634 (prog (f)
635 (and (null (cdr z)) (%warn '|needs arguments| z))
636 (setq f (cadr z))
637 (and (variablep f)
638 (%warn '|function name must be a constant| z))
639 (or (symbolp f)
640 (%warn '|function name must be a symbolic atom| f))
641 (or (externalp f)
642 (%warn '|function name not declared external| f))
643 (check-change& (cddr z))))
644
645 (defun check-halt (z)
646 (or (null (cdr z)) (%warn '|does not take arguments| z)))
647
648 (defun check-cbind (z)
649 (prog (v)
650 (or (= (length z) 2.) (%warn '|takes only one argument| z))
651 (setq v (cadr z))
652 (or (variablep v) (%warn '|takes variable as argument| z))
653 (note-ce-variable v)))
654
655 (defun check-bind (z)
656 (prog (v)
657 (or (> (length z) 1.) (%warn '|needs arguments| z))
658 (setq v (cadr z))
659 (or (variablep v) (%warn '|takes variable as argument| z))
660 (note-variable v)
661 (check-change& (cddr z))))
662
663
664 (defun check-change& (z)
665 (prog (r tab-flag)
666 (setq tab-flag nil)
667 la (and (atom z) (return nil))
668 (setq r (car z))
669 (setq z (cdr z))
670 (cond ((eq r '^)
671 (and tab-flag
672 (%warn '|no value before this tab| (car z)))
673 (setq tab-flag t)
674 (check-tab-index (car z))
675 (setq z (cdr z)))
676 ((eq r '//) (setq tab-flag nil) (setq z (cdr z)))
677 (t (setq tab-flag nil) (check-rhs-value r)))
678 (go la)))
679
680 (defun check-rhs-ce-var (v)
681 (cond ((and (not (numberp v)) (not (ce-bound? v)))
682 (%warn '|unbound element variable| v))
683 ((and (numberp v) (or (< v 1.) (> v *ce-count*)))
684 (%warn '|numeric element designator out of bounds| v))))
685
686 (defun check-rhs-value (x)
687 (cond ((consp x) (check-rhs-function x)) ;dtpr\consp gdw
688 (t (check-rhs-atomic x))))
689
690 (defun check-rhs-atomic (x)
691 (and (variablep x)
692 (not (bound? x))
693 (%warn '|unbound variable| x)))
694
695 (defun check-rhs-function (x)
696 (prog (a)
697 (setq a (car x))
698 (cond ((eq a 'compute) (check-compute x))
699 ((eq a 'arith) (check-compute x))
700 ((eq a 'substr) (check-substr x))
701 ((eq a 'accept) (check-accept x))
702 ((eq a 'acceptline) (check-acceptline x))
703 ((eq a 'crlf) (check-crlf x))
704 ((eq a 'genatom) (check-genatom x))
705 ((eq a 'litval) (check-litval x))
706 ((eq a 'tabto) (check-tabto x))
707 ((eq a 'rjust) (check-rjust x))
708 ((not (externalp a))
709 (%warn '"rhs function not declared external" a)))))
710
711 (defun externalp (x)
712 ; (cond ((symbolp x) (get x 'external-routine)) ;) @@@
713 ;ok, I'm eliminating this temporarily @@@@
714 (cond ((symbolp x) t)
715 (t (%warn '|not a legal function name| x) nil)))
716
717
718 (defun check-litval (x)
719 (or (= (length x) 2) (%warn '|wrong number of arguments| x))
720 (check-rhs-atomic (cadr x)))
721
722 (defun check-accept (x)
723 (cond ((= (length x) 1) nil)
724 ((= (length x) 2) (check-rhs-atomic (cadr x)))
725 (t (%warn '|too many arguments| x))))
726
727 (defun check-acceptline (x)
728 (mapc (function check-rhs-atomic) (cdr x)))
729
730 (defun check-crlf (x)
731 (check-0-args x))
732
733 (defun check-genatom (x) (check-0-args x))
734
735 (defun check-tabto (x)
736 (or (= (length x) 2) (%warn '|wrong number of arguments| x))
737 (check-print-control (cadr x)))
738
739 (defun check-rjust (x)
740 (or (= (length x) 2) (%warn '|wrong number of arguments| x))
741 (check-print-control (cadr x)))
742
743 (defun check-0-args (x)
744 (or (= (length x) 1.) (%warn '|should not have arguments| x)))
745
746 (defun check-substr (x)
747 (or (= (length x) 4.) (%warn '|wrong number of arguments| x))
748 (check-rhs-ce-var (cadr x))
749 (check-substr-index (caddr x))
750 (check-last-substr-index (cadddr x)))
751
752 (defun check-compute (x) (check-arithmetic (cdr x)))
753
754 (defun check-arithmetic (l)
755 (cond ((atom l)
756 (%warn '|syntax error in arithmetic expression| l))
757 ((atom (cdr l)) (check-term (car l)))
758 ((not (member (cadr l) '(+ - * // \\))) ;"plus" changed to "+" by gdw
759 (%warn '|unknown operator| l))
760 (t (check-term (car l)) (check-arithmetic (cddr l)))))
761
762 (defun check-term (x)
763 (cond ((consp x) (check-arithmetic x)) ;dtpr\consp gdw
764 (t (check-rhs-atomic x))))
765
766 (defun check-last-substr-index (x)
767 (or (eq x 'inf) (check-substr-index x)))
768
769 (defun check-substr-index (x)
770 (prog (v)
771 (cond ((bound? x) (return x)))
772 (setq v ($litbind x))
773 (cond ((not (numberp v))
774 (%warn '|unbound symbol used as index in substr| x))
775 ((or (< v 1.) (> v 127.))
776 (%warn '|index out of bounds in tab| x)))))
777
778 (defun check-print-control (x)
779 (prog ()
780 (cond ((bound? x) (return x)))
781 (cond ((or (not (numberp x)) (< x 1.) (> x 127.))
782 (%warn '|illegal value for printer control| x)))))
783
784 (defun check-tab-index (x)
785 (prog (v)
786 (cond ((bound? x) (return x)))
787 (setq v ($litbind x))
788 (cond ((not (numberp v))
789 (%warn '|unbound symbol occurs after ^| x))
790 ((or (< v 1.) (> v 127.))
791 (%warn '|index out of bounds after ^| x)))))
792
793 (defun note-variable (var)
794 (setq *rhs-bound-vars* (cons var *rhs-bound-vars*)))
795
796 (defun bound? (var)
797 (or (member var *rhs-bound-vars*)
798 (var-dope var)))
799
800 (defun note-ce-variable (ce-var)
801 (setq *rhs-bound-ce-vars* (cons ce-var *rhs-bound-ce-vars*)))
802
803 (defun ce-bound? (ce-var)
804 (or (member ce-var *rhs-bound-ce-vars*)
805 (ce-var-dope ce-var)))

  ViewVC Help
Powered by ViewVC 1.1.5