source: project/release/5/lalr/trunk/lalr.scm @ 37660

Last change on this file since 37660 was 37660, checked in by Ivan Raikov, 4 months ago

lalr: changed lalr-keyword? to use keyword? instead of symbol_ [thanks to Peter Bex]

File size: 46.7 KB
Line 
1;;;
2;;;; An Efficient and Portable LALR(1) Parser Generator for Scheme
3;;;
4;; Copyright 2014  Jan Nieuwenhuizen <janneke@gnu.org>
5;; Copyright 1993, 2010 Dominique Boucher
6;;
7;; This program is free software: you can redistribute it and/or
8;; modify it under the terms of the GNU Lesser General Public License
9;; as published by the Free Software Foundation, either version 3 of
10;; the License, or (at your option) any later version.
11;;
12;; This program is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15;; GNU Lesser General Public License for more details.
16;;
17;; You should have received a copy of the GNU General Public License
18;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
19
20
21; ---------- CHICKEN DEPENDENT SECTION -----------------
22 
23
24(module lalr *
25
26        (import scheme (chicken base) (chicken pretty-print) (chicken bitwise) (chicken keyword))
27
28(define pprint pretty-print)
29(define lalr-keyword? keyword?)
30
31(define-syntax BITS-PER-WORD 
32  (er-macro-transformer
33   (lambda (f r c) 30)))
34
35(define-syntax logical-or
36  (er-macro-transformer
37   (lambda (f r c)
38     (let ((x (cadr f))
39           (y (cddr f)))
40       `(bitwise-ior ,x ,@y)))
41   ))
42
43(define-syntax lalr-error
44  (er-macro-transformer
45   (lambda (f r c)
46     (let ((msg (cadr f))
47           (obj (caddr f)))
48       `(error ,msg ,obj)))
49  ))
50
51
52; ---------- END OF CHICKEN DEPENDENT SECTION ------------
53
54(define *lalr-scm-version* "2.5.0")
55
56  (define (set-bit v b)
57    (let ((x (quotient b (BITS-PER-WORD)))
58          (y (expt 2 (remainder b (BITS-PER-WORD)))))
59      (vector-set! v x (logical-or (vector-ref v x) y))))
60
61  (define (bit-union v1 v2 n)
62    (do ((i 0 (+ i 1)))
63        ((= i n))
64      (vector-set! v1 i (logical-or (vector-ref v1 i)
65                                    (vector-ref v2 i)))))
66
67  ;; - Macro pour les structures de donnees
68
69  (define (new-core)              (make-vector 4 0))
70  (define (set-core-number! c n)  (vector-set! c 0 n))
71  (define (set-core-acc-sym! c s) (vector-set! c 1 s))
72  (define (set-core-nitems! c n)  (vector-set! c 2 n))
73  (define (set-core-items! c i)   (vector-set! c 3 i))
74  (define (core-number c)         (vector-ref c 0))
75  (define (core-acc-sym c)        (vector-ref c 1))
76  (define (core-nitems c)         (vector-ref c 2))
77  (define (core-items c)          (vector-ref c 3))
78
79  (define (new-shift)              (make-vector 3 0))
80  (define (set-shift-number! c x)  (vector-set! c 0 x))
81  (define (set-shift-nshifts! c x) (vector-set! c 1 x))
82  (define (set-shift-shifts! c x)  (vector-set! c 2 x))
83  (define (shift-number s)         (vector-ref s 0))
84  (define (shift-nshifts s)        (vector-ref s 1))
85  (define (shift-shifts s)         (vector-ref s 2))
86
87  (define (new-red)                (make-vector 3 0))
88  (define (set-red-number! c x)    (vector-set! c 0 x))
89  (define (set-red-nreds! c x)     (vector-set! c 1 x))
90  (define (set-red-rules! c x)     (vector-set! c 2 x))
91  (define (red-number c)           (vector-ref c 0))
92  (define (red-nreds c)            (vector-ref c 1))
93  (define (red-rules c)            (vector-ref c 2))
94
95
96  (define (new-set nelem)
97    (make-vector nelem 0))
98
99
100  (define (vector-map f v)
101    (let ((vm-n (- (vector-length v) 1)))
102      (let loop ((vm-low 0) (vm-high vm-n))
103        (if (= vm-low vm-high)
104            (vector-set! v vm-low (f (vector-ref v vm-low) vm-low))
105            (let ((vm-middle (quotient (+ vm-low vm-high) 2)))
106              (loop vm-low vm-middle)
107              (loop (+ vm-middle 1) vm-high))))))
108
109
110  ;; - Constantes
111  (define STATE-TABLE-SIZE 1009)
112
113
114  ;; - Tableaux
115  (define rrhs         #f)
116  (define rlhs         #f)
117  (define ritem        #f)
118  (define nullable     #f)
119  (define derives      #f)
120  (define fderives     #f)
121  (define firsts       #f)
122  (define kernel-base  #f)
123  (define kernel-end   #f)
124  (define shift-symbol #f)
125  (define shift-set    #f)
126  (define red-set      #f)
127  (define state-table  #f)
128  (define acces-symbol #f)
129  (define reduction-table #f)
130  (define shift-table  #f)
131  (define consistent   #f)
132  (define lookaheads   #f)
133  (define LA           #f)
134  (define LAruleno     #f)
135  (define lookback     #f)
136  (define goto-map     #f)
137  (define from-state   #f)
138  (define to-state     #f)
139  (define includes     #f)
140  (define F            #f)
141  (define action-table #f)
142
143  ;; - Variables
144  (define nitems          #f)
145  (define nrules          #f)
146  (define nvars           #f)
147  (define nterms          #f)
148  (define nsyms           #f)
149  (define nstates         #f)
150  (define first-state     #f)
151  (define last-state      #f)
152  (define final-state     #f)
153  (define first-shift     #f)
154  (define last-shift      #f)
155  (define first-reduction #f)
156  (define last-reduction  #f)
157  (define nshifts         #f)
158  (define maxrhs          #f)
159  (define ngotos          #f)
160  (define token-set-size  #f)
161
162  (define driver-name     'lr-driver)
163
164  (define (glr-driver?)
165    (eq? driver-name 'glr-driver))
166  (define (lr-driver?)
167    (eq? driver-name 'lr-driver))
168
169  (define (gen-tables! tokens gram )
170    (initialize-all)
171    (rewrite-grammar
172     tokens
173     gram
174     (lambda (terms terms/prec vars gram gram/actions)
175       (set! the-terminals/prec (list->vector terms/prec))
176       (set! the-terminals (list->vector terms))
177       (set! the-nonterminals (list->vector vars))
178       (set! nterms (length terms))
179       (set! nvars  (length vars))
180       (set! nsyms  (+ nterms nvars))
181       (let ((no-of-rules (length gram/actions))
182             (no-of-items (let loop ((l gram/actions) (count 0))
183                            (if (null? l)
184                                count
185                                (loop (cdr l) (+ count (length (caar l))))))))
186         (pack-grammar no-of-rules no-of-items gram)
187         (set-derives)
188         (set-nullable)
189         (generate-states)
190         (lalr)
191         (build-tables)
192         (compact-action-table terms)
193         gram/actions))))
194
195
196  (define (initialize-all)
197    (set! rrhs         #f)
198    (set! rlhs         #f)
199    (set! ritem        #f)
200    (set! nullable     #f)
201    (set! derives      #f)
202    (set! fderives     #f)
203    (set! firsts       #f)
204    (set! kernel-base  #f)
205    (set! kernel-end   #f)
206    (set! shift-symbol #f)
207    (set! shift-set    #f)
208    (set! red-set      #f)
209    (set! state-table  (make-vector STATE-TABLE-SIZE '()))
210    (set! acces-symbol #f)
211    (set! reduction-table #f)
212    (set! shift-table  #f)
213    (set! consistent   #f)
214    (set! lookaheads   #f)
215    (set! LA           #f)
216    (set! LAruleno     #f)
217    (set! lookback     #f)
218    (set! goto-map     #f)
219    (set! from-state   #f)
220    (set! to-state     #f)
221    (set! includes     #f)
222    (set! F            #f)
223    (set! action-table #f)
224    (set! nstates         #f)
225    (set! first-state     #f)
226    (set! last-state      #f)
227    (set! final-state     #f)
228    (set! first-shift     #f)
229    (set! last-shift      #f)
230    (set! first-reduction #f)
231    (set! last-reduction  #f)
232    (set! nshifts         #f)
233    (set! maxrhs          #f)
234    (set! ngotos          #f)
235    (set! token-set-size  #f)
236    (set! rule-precedences '()))
237
238
239  (define (pack-grammar no-of-rules no-of-items gram)
240    (set! nrules (+  no-of-rules 1))
241    (set! nitems no-of-items)
242    (set! rlhs (make-vector nrules #f))
243    (set! rrhs (make-vector nrules #f))
244    (set! ritem (make-vector (+ 1 nitems) #f))
245
246    (let loop ((p gram) (item-no 0) (rule-no 1))
247      (if (not (null? p))
248          (let ((nt (caar p)))
249            (let loop2 ((prods (cdar p)) (it-no2 item-no) (rl-no2 rule-no))
250              (if (null? prods)
251                  (loop (cdr p) it-no2 rl-no2)
252                  (begin
253                    (vector-set! rlhs rl-no2 nt)
254                    (vector-set! rrhs rl-no2 it-no2)
255                    (let loop3 ((rhs (car prods)) (it-no3 it-no2))
256                      (if (null? rhs)
257                          (begin
258                            (vector-set! ritem it-no3 (- rl-no2))
259                            (loop2 (cdr prods) (+ it-no3 1) (+ rl-no2 1)))
260                          (begin
261                            (vector-set! ritem it-no3 (car rhs))
262                            (loop3 (cdr rhs) (+ it-no3 1))))))))))))
263
264
265  (define (set-derives)
266    (define delts (make-vector (+ nrules 1) 0))
267    (define dset  (make-vector nvars -1))
268
269    (let loop ((i 1) (j 0))             ; i = 0
270      (if (< i nrules)
271          (let ((lhs (vector-ref rlhs i)))
272            (if (>= lhs 0)
273                (begin
274                  (vector-set! delts j (cons i (vector-ref dset lhs)))
275                  (vector-set! dset lhs j)
276                  (loop (+ i 1) (+ j 1)))
277                (loop (+ i 1) j)))))
278
279    (set! derives (make-vector nvars 0))
280
281    (let loop ((i 0))
282      (if (< i nvars)
283          (let ((q (let loop2 ((j (vector-ref dset i)) (s '()))
284                     (if (< j 0)
285                         s
286                         (let ((x (vector-ref delts j)))
287                           (loop2 (cdr x) (cons (car x) s)))))))
288            (vector-set! derives i q)
289            (loop (+ i 1))))))
290
291
292
293  (define (set-nullable)
294    (set! nullable (make-vector nvars #f))
295    (let ((squeue (make-vector nvars #f))
296          (rcount (make-vector (+ nrules 1) 0))
297          (rsets  (make-vector nvars #f))
298          (relts  (make-vector (+ nitems nvars 1) #f)))
299      (let loop ((r 0) (s2 0) (p 0))
300        (let ((*r (vector-ref ritem r)))
301          (if *r
302              (if (< *r 0)
303                  (let ((symbol (vector-ref rlhs (- *r))))
304                    (if (and (>= symbol 0)
305                             (not (vector-ref nullable symbol)))
306                        (begin
307                          (vector-set! nullable symbol #t)
308                          (vector-set! squeue s2 symbol)
309                          (loop (+ r 1) (+ s2 1) p))))
310                  (let loop2 ((r1 r) (any-tokens #f))
311                    (let* ((symbol (vector-ref ritem r1)))
312                      (if (> symbol 0)
313                          (loop2 (+ r1 1) (or any-tokens (>= symbol nvars)))
314                          (if (not any-tokens)
315                              (let ((ruleno (- symbol)))
316                                (let loop3 ((r2 r) (p2 p))
317                                  (let ((symbol (vector-ref ritem r2)))
318                                    (if (> symbol 0)
319                                        (begin
320                                          (vector-set! rcount ruleno
321                                                       (+ (vector-ref rcount ruleno) 1))
322                                          (vector-set! relts p2
323                                                       (cons (vector-ref rsets symbol)
324                                                             ruleno))
325                                          (vector-set! rsets symbol p2)
326                                          (loop3 (+ r2 1) (+ p2 1)))
327                                        (loop (+ r2 1) s2 p2)))))
328                              (loop (+ r1 1) s2 p))))))
329              (let loop ((s1 0) (s3 s2))
330                (if (< s1 s3)
331                    (let loop2 ((p (vector-ref rsets (vector-ref squeue s1))) (s4 s3))
332                      (if p
333                          (let* ((x (vector-ref relts p))
334                                 (ruleno (cdr x))
335                                 (y (- (vector-ref rcount ruleno) 1)))
336                            (vector-set! rcount ruleno y)
337                            (if (= y 0)
338                                (let ((symbol (vector-ref rlhs ruleno)))
339                                  (if (and (>= symbol 0)
340                                           (not (vector-ref nullable symbol)))
341                                      (begin
342                                        (vector-set! nullable symbol #t)
343                                        (vector-set! squeue s4 symbol)
344                                        (loop2 (car x) (+ s4 1)))
345                                      (loop2 (car x) s4)))
346                                (loop2 (car x) s4))))
347                      (loop (+ s1 1) s4)))))))))
348
349
350
351  (define (set-firsts)
352    (set! firsts (make-vector nvars '()))
353
354    ;; -- initialization
355    (let loop ((i 0))
356      (if (< i nvars)
357          (let loop2 ((sp (vector-ref derives i)))
358            (if (null? sp)
359                (loop (+ i 1))
360                (let ((sym (vector-ref ritem (vector-ref rrhs (car sp)))))
361                  (if (< -1 sym nvars)
362                      (vector-set! firsts i (sinsert sym (vector-ref firsts i))))
363                  (loop2 (cdr sp)))))))
364
365    ;; -- reflexive and transitive closure
366    (let loop ((continue #t))
367      (if continue
368          (let loop2 ((i 0) (cont #f))
369            (if (>= i nvars)
370                (loop cont)
371                (let* ((x (vector-ref firsts i))
372                       (y (let loop3 ((l x) (z x))
373                            (if (null? l)
374                                z
375                                (loop3 (cdr l)
376                                       (sunion (vector-ref firsts (car l)) z))))))
377                  (if (equal? x y)
378                      (loop2 (+ i 1) cont)
379                      (begin
380                        (vector-set! firsts i y)
381                        (loop2 (+ i 1) #t))))))))
382
383    (let loop ((i 0))
384      (if (< i nvars)
385          (begin
386            (vector-set! firsts i (sinsert i (vector-ref firsts i)))
387            (loop (+ i 1))))))
388
389
390
391
392  (define (set-fderives)
393    (set! fderives (make-vector nvars #f))
394
395    (set-firsts)
396
397    (let loop ((i 0))
398      (if (< i nvars)
399          (let ((x (let loop2 ((l (vector-ref firsts i)) (fd '()))
400                     (if (null? l)
401                         fd
402                         (loop2 (cdr l)
403                                (sunion (vector-ref derives (car l)) fd))))))
404            (vector-set! fderives i x)
405            (loop (+ i 1))))))
406
407
408  (define (closure core)
409    ;; Initialization
410    (define ruleset (make-vector nrules #f))
411
412    (let loop ((csp core))
413      (if (not (null? csp))
414          (let ((sym (vector-ref ritem (car csp))))
415            (if (< -1 sym nvars)
416                (let loop2 ((dsp (vector-ref fderives sym)))
417                  (if (not (null? dsp))
418                      (begin
419                        (vector-set! ruleset (car dsp) #t)
420                        (loop2 (cdr dsp))))))
421            (loop (cdr csp)))))
422
423    (let loop ((ruleno 1) (csp core) (itemsetv '())) ; ruleno = 0
424      (if (< ruleno nrules)
425          (if (vector-ref ruleset ruleno)
426              (let ((itemno (vector-ref rrhs ruleno)))
427                (let loop2 ((c csp) (itemsetv2 itemsetv))
428                  (if (and (pair? c)
429                           (< (car c) itemno))
430                      (loop2 (cdr c) (cons (car c) itemsetv2))
431                      (loop (+ ruleno 1) c (cons itemno itemsetv2)))))
432              (loop (+ ruleno 1) csp itemsetv))
433          (let loop2 ((c csp) (itemsetv2 itemsetv))
434            (if (pair? c)
435                (loop2 (cdr c) (cons (car c) itemsetv2))
436                (reverse itemsetv2))))))
437
438
439
440  (define (allocate-item-sets)
441    (set! kernel-base (make-vector nsyms 0))
442    (set! kernel-end  (make-vector nsyms #f)))
443
444
445  (define (allocate-storage)
446    (allocate-item-sets)
447    (set! red-set (make-vector (+ nrules 1) 0)))
448
449                                        ; --
450
451
452  (define (initialize-states)
453    (let ((p (new-core)))
454      (set-core-number! p 0)
455      (set-core-acc-sym! p #f)
456      (set-core-nitems! p 1)
457      (set-core-items! p '(0))
458
459      (set! first-state (list p))
460      (set! last-state first-state)
461      (set! nstates 1)))
462
463
464
465  (define (generate-states)
466    (allocate-storage)
467    (set-fderives)
468    (initialize-states)
469    (let loop ((this-state first-state))
470      (if (pair? this-state)
471          (let* ((x (car this-state))
472                 (is (closure (core-items x))))
473            (save-reductions x is)
474            (new-itemsets is)
475            (append-states)
476            (if (> nshifts 0)
477                (save-shifts x))
478            (loop (cdr this-state))))))
479
480
481  (define (new-itemsets itemset)
482    ;; - Initialization
483    (set! shift-symbol '())
484    (let loop ((i 0))
485      (if (< i nsyms)
486          (begin
487            (vector-set! kernel-end i '())
488            (loop (+ i 1)))))
489
490    (let loop ((isp itemset))
491      (if (pair? isp)
492          (let* ((i (car isp))
493                 (sym (vector-ref ritem i)))
494            (if (>= sym 0)
495                (begin
496                  (set! shift-symbol (sinsert sym shift-symbol))
497                  (let ((x (vector-ref kernel-end sym)))
498                    (if (null? x)
499                        (begin
500                          (vector-set! kernel-base sym (cons (+ i 1) x))
501                          (vector-set! kernel-end sym (vector-ref kernel-base sym)))
502                        (begin
503                          (set-cdr! x (list (+ i 1)))
504                          (vector-set! kernel-end sym (cdr x)))))))
505            (loop (cdr isp)))))
506
507    (set! nshifts (length shift-symbol)))
508
509
510
511  (define (get-state sym)
512    (let* ((isp  (vector-ref kernel-base sym))
513           (n    (length isp))
514           (key  (let loop ((isp1 isp) (k 0))
515                   (if (null? isp1)
516                       (modulo k STATE-TABLE-SIZE)
517                       (loop (cdr isp1) (+ k (car isp1))))))
518           (sp   (vector-ref state-table key)))
519      (if (null? sp)
520          (let ((x (new-state sym)))
521            (vector-set! state-table key (list x))
522            (core-number x))
523          (let loop ((sp1 sp))
524            (if (and (= n (core-nitems (car sp1)))
525                     (let loop2 ((i1 isp) (t (core-items (car sp1))))
526                       (if (and (pair? i1)
527                                (= (car i1)
528                                   (car t)))
529                           (loop2 (cdr i1) (cdr t))
530                           (null? i1))))
531                (core-number (car sp1))
532                (if (null? (cdr sp1))
533                    (let ((x (new-state sym)))
534                      (set-cdr! sp1 (list x))
535                      (core-number x))
536                    (loop (cdr sp1))))))))
537
538
539  (define (new-state sym)
540    (let* ((isp  (vector-ref kernel-base sym))
541           (n    (length isp))
542           (p    (new-core)))
543      (set-core-number! p nstates)
544      (set-core-acc-sym! p sym)
545      (if (= sym nvars) (set! final-state nstates))
546      (set-core-nitems! p n)
547      (set-core-items! p isp)
548      (set-cdr! last-state (list p))
549      (set! last-state (cdr last-state))
550      (set! nstates (+ nstates 1))
551      p))
552
553
554                                        ; --
555
556  (define (append-states)
557    (set! shift-set
558          (let loop ((l (reverse shift-symbol)))
559            (if (null? l)
560                '()
561                (cons (get-state (car l)) (loop (cdr l)))))))
562
563                                        ; --
564
565  (define (save-shifts core)
566    (let ((p (new-shift)))
567      (set-shift-number! p (core-number core))
568      (set-shift-nshifts! p nshifts)
569      (set-shift-shifts! p shift-set)
570      (if last-shift
571          (begin
572            (set-cdr! last-shift (list p))
573            (set! last-shift (cdr last-shift)))
574          (begin
575            (set! first-shift (list p))
576            (set! last-shift first-shift)))))
577
578  (define (save-reductions core itemset)
579    (let ((rs (let loop ((l itemset))
580                (if (null? l)
581                    '()
582                    (let ((item (vector-ref ritem (car l))))
583                      (if (< item 0)
584                          (cons (- item) (loop (cdr l)))
585                          (loop (cdr l))))))))
586      (if (pair? rs)
587          (let ((p (new-red)))
588            (set-red-number! p (core-number core))
589            (set-red-nreds!  p (length rs))
590            (set-red-rules!  p rs)
591            (if last-reduction
592                (begin
593                  (set-cdr! last-reduction (list p))
594                  (set! last-reduction (cdr last-reduction)))
595                (begin
596                  (set! first-reduction (list p))
597                  (set! last-reduction first-reduction)))))))
598
599
600                                        ; --
601
602  (define (lalr)
603    (set! token-set-size (+ 1 (quotient nterms (BITS-PER-WORD))))
604    (set-accessing-symbol)
605    (set-shift-table)
606    (set-reduction-table)
607    (set-max-rhs)
608    (initialize-LA)
609    (set-goto-map)
610    (initialize-F)
611    (build-relations)
612    (digraph includes)
613    (compute-lookaheads))
614
615  (define (set-accessing-symbol)
616    (set! acces-symbol (make-vector nstates #f))
617    (let loop ((l first-state))
618      (if (pair? l)
619          (let ((x (car l)))
620            (vector-set! acces-symbol (core-number x) (core-acc-sym x))
621            (loop (cdr l))))))
622
623  (define (set-shift-table)
624    (set! shift-table (make-vector nstates #f))
625    (let loop ((l first-shift))
626      (if (pair? l)
627          (let ((x (car l)))
628            (vector-set! shift-table (shift-number x) x)
629            (loop (cdr l))))))
630
631  (define (set-reduction-table)
632    (set! reduction-table (make-vector nstates #f))
633    (let loop ((l first-reduction))
634      (if (pair? l)
635          (let ((x (car l)))
636            (vector-set! reduction-table (red-number x) x)
637            (loop (cdr l))))))
638
639  (define (set-max-rhs)
640    (let loop ((p 0) (curmax 0) (length 0))
641      (let ((x (vector-ref ritem p)))
642        (if x
643            (if (>= x 0)
644                (loop (+ p 1) curmax (+ length 1))
645                (loop (+ p 1) (max curmax length) 0))
646            (set! maxrhs curmax)))))
647
648  (define (initialize-LA)
649    (define (last l)
650      (if (null? (cdr l))
651          (car l)
652          (last (cdr l))))
653
654    (set! consistent (make-vector nstates #f))
655    (set! lookaheads (make-vector (+ nstates 1) #f))
656
657    (let loop ((count 0) (i 0))
658      (if (< i nstates)
659          (begin
660            (vector-set! lookaheads i count)
661            (let ((rp (vector-ref reduction-table i))
662                  (sp (vector-ref shift-table i)))
663              (if (and rp
664                       (or (> (red-nreds rp) 1)
665                           (and sp
666                                (not
667                                 (< (vector-ref acces-symbol
668                                                (last (shift-shifts sp)))
669                                    nvars)))))
670                  (loop (+ count (red-nreds rp)) (+ i 1))
671                  (begin
672                    (vector-set! consistent i #t)
673                    (loop count (+ i 1))))))
674
675          (begin
676            (vector-set! lookaheads nstates count)
677            (let ((c (max count 1)))
678              (set! LA (make-vector c #f))
679              (do ((j 0 (+ j 1))) ((= j c)) (vector-set! LA j (new-set token-set-size)))
680              (set! LAruleno (make-vector c -1))
681              (set! lookback (make-vector c #f)))
682            (let loop ((i 0) (np 0))
683              (if (< i nstates)
684                  (if (vector-ref consistent i)
685                      (loop (+ i 1) np)
686                      (let ((rp (vector-ref reduction-table i)))
687                        (if rp
688                            (let loop2 ((j (red-rules rp)) (np2 np))
689                              (if (null? j)
690                                  (loop (+ i 1) np2)
691                                  (begin
692                                    (vector-set! LAruleno np2 (car j))
693                                    (loop2 (cdr j) (+ np2 1)))))
694                            (loop (+ i 1) np))))))))))
695
696
697  (define (set-goto-map)
698    (set! goto-map (make-vector (+ nvars 1) 0))
699    (let ((temp-map (make-vector (+ nvars 1) 0)))
700      (let loop ((ng 0) (sp first-shift))
701        (if (pair? sp)
702            (let loop2 ((i (reverse (shift-shifts (car sp)))) (ng2 ng))
703              (if (pair? i)
704                  (let ((symbol (vector-ref acces-symbol (car i))))
705                    (if (< symbol nvars)
706                        (begin
707                          (vector-set! goto-map symbol
708                                       (+ 1 (vector-ref goto-map symbol)))
709                          (loop2 (cdr i) (+ ng2 1)))
710                        (loop2 (cdr i) ng2)))
711                  (loop ng2 (cdr sp))))
712
713            (let loop ((k 0) (i 0))
714              (if (< i nvars)
715                  (begin
716                    (vector-set! temp-map i k)
717                    (loop (+ k (vector-ref goto-map i)) (+ i 1)))
718
719                  (begin
720                    (do ((i 0 (+ i 1)))
721                        ((>= i nvars))
722                      (vector-set! goto-map i (vector-ref temp-map i)))
723
724                    (set! ngotos ng)
725                    (vector-set! goto-map nvars ngotos)
726                    (vector-set! temp-map nvars ngotos)
727                    (set! from-state (make-vector ngotos #f))
728                    (set! to-state (make-vector ngotos #f))
729
730                    (do ((sp first-shift (cdr sp)))
731                        ((null? sp))
732                      (let* ((x (car sp))
733                             (state1 (shift-number x)))
734                        (do ((i (shift-shifts x) (cdr i)))
735                            ((null? i))
736                          (let* ((state2 (car i))
737                                 (symbol (vector-ref acces-symbol state2)))
738                            (if (< symbol nvars)
739                                (let ((k (vector-ref temp-map symbol)))
740                                  (vector-set! temp-map symbol (+ k 1))
741                                  (vector-set! from-state k state1)
742                                  (vector-set! to-state k state2))))))))))))))
743
744
745  (define (map-goto state symbol)
746    (let loop ((low (vector-ref goto-map symbol))
747               (high (- (vector-ref goto-map (+ symbol 1)) 1)))
748      (if (> low high)
749          (begin
750            (display (list "Error in map-goto" state symbol)) (newline)
751            0)
752          (let* ((middle (quotient (+ low high) 2))
753                 (s (vector-ref from-state middle)))
754            (cond
755             ((= s state)
756              middle)
757             ((< s state)
758              (loop (+ middle 1) high))
759             (else
760              (loop low (- middle 1))))))))
761
762
763  (define (initialize-F)
764    (set! F (make-vector ngotos #f))
765    (do ((i 0 (+ i 1))) ((= i ngotos)) (vector-set! F i (new-set token-set-size)))
766
767    (let ((reads (make-vector ngotos #f)))
768
769      (let loop ((i 0) (rowp 0))
770        (if (< i ngotos)
771            (let* ((rowf (vector-ref F rowp))
772                   (stateno (vector-ref to-state i))
773                   (sp (vector-ref shift-table stateno)))
774              (if sp
775                  (let loop2 ((j (shift-shifts sp)) (edges '()))
776                    (if (pair? j)
777                        (let ((symbol (vector-ref acces-symbol (car j))))
778                          (if (< symbol nvars)
779                              (if (vector-ref nullable symbol)
780                                  (loop2 (cdr j) (cons (map-goto stateno symbol)
781                                                       edges))
782                                  (loop2 (cdr j) edges))
783                              (begin
784                                (set-bit rowf (- symbol nvars))
785                                (loop2 (cdr j) edges))))
786                        (if (pair? edges)
787                            (vector-set! reads i (reverse edges))))))
788              (loop (+ i 1) (+ rowp 1)))))
789      (digraph reads)))
790
791  (define (add-lookback-edge stateno ruleno gotono)
792    (let ((k (vector-ref lookaheads (+ stateno 1))))
793      (let loop ((found #f) (i (vector-ref lookaheads stateno)))
794        (if (and (not found) (< i k))
795            (if (= (vector-ref LAruleno i) ruleno)
796                (loop #t i)
797                (loop found (+ i 1)))
798
799            (if (not found)
800                (begin (display "Error in add-lookback-edge : ")
801                       (display (list stateno ruleno gotono)) (newline))
802                (vector-set! lookback i
803                             (cons gotono (vector-ref lookback i))))))))
804
805
806  (define (transpose r-arg n)
807    (let ((new-end (make-vector n #f))
808          (new-R  (make-vector n #f)))
809      (do ((i 0 (+ i 1)))
810          ((= i n))
811        (let ((x (list 'bidon)))
812          (vector-set! new-R i x)
813          (vector-set! new-end i x)))
814      (do ((i 0 (+ i 1)))
815          ((= i n))
816        (let ((sp (vector-ref r-arg i)))
817          (if (pair? sp)
818              (let loop ((sp2 sp))
819                (if (pair? sp2)
820                    (let* ((x (car sp2))
821                           (y (vector-ref new-end x)))
822                      (set-cdr! y (cons i (cdr y)))
823                      (vector-set! new-end x (cdr y))
824                      (loop (cdr sp2))))))))
825      (do ((i 0 (+ i 1)))
826          ((= i n))
827        (vector-set! new-R i (cdr (vector-ref new-R i))))
828
829      new-R))
830
831
832
833  (define (build-relations)
834
835    (define (get-state stateno symbol)
836      (let loop ((j (shift-shifts (vector-ref shift-table stateno)))
837                 (stno stateno))
838        (if (null? j)
839            stno
840            (let ((st2 (car j)))
841              (if (= (vector-ref acces-symbol st2) symbol)
842                  st2
843                  (loop (cdr j) st2))))))
844
845    (set! includes (make-vector ngotos #f))
846    (do ((i 0 (+ i 1)))
847        ((= i ngotos))
848      (let ((state1 (vector-ref from-state i))
849            (symbol1 (vector-ref acces-symbol (vector-ref to-state i))))
850        (let loop ((rulep (vector-ref derives symbol1))
851                   (edges '()))
852          (if (pair? rulep)
853              (let ((*rulep (car rulep)))
854                (let loop2 ((rp (vector-ref rrhs *rulep))
855                            (stateno state1)
856                            (states (list state1)))
857                  (let ((*rp (vector-ref ritem rp)))
858                    (if (> *rp 0)
859                        (let ((st (get-state stateno *rp)))
860                          (loop2 (+ rp 1) st (cons st states)))
861                        (begin
862
863                          (if (not (vector-ref consistent stateno))
864                              (add-lookback-edge stateno *rulep i))
865
866                          (let loop2 ((done #f)
867                                      (stp (cdr states))
868                                      (rp2 (- rp 1))
869                                      (edgp edges))
870                            (if (not done)
871                                (let ((*rp (vector-ref ritem rp2)))
872                                  (if (< -1 *rp nvars)
873                                      (loop2 (not (vector-ref nullable *rp))
874                                             (cdr stp)
875                                             (- rp2 1)
876                                             (cons (map-goto (car stp) *rp) edgp))
877                                      (loop2 #t stp rp2 edgp)))
878
879                                (loop (cdr rulep) edgp))))))))
880              (vector-set! includes i edges)))))
881    (set! includes (transpose includes ngotos)))
882
883
884
885  (define (compute-lookaheads)
886    (let ((n (vector-ref lookaheads nstates)))
887      (let loop ((i 0))
888        (if (< i n)
889            (let loop2 ((sp (vector-ref lookback i)))
890              (if (pair? sp)
891                  (let ((LA-i (vector-ref LA i))
892                        (F-j  (vector-ref F (car sp))))
893                    (bit-union LA-i F-j token-set-size)
894                    (loop2 (cdr sp)))
895                  (loop (+ i 1))))))))
896
897
898
899  (define (digraph relation)
900    (define infinity (+ ngotos 2))
901    (define INDEX (make-vector (+ ngotos 1) 0))
902    (define VERTICES (make-vector (+ ngotos 1) 0))
903    (define top 0)
904    (define R relation)
905
906    (define (traverse i)
907      (set! top (+ 1 top))
908      (vector-set! VERTICES top i)
909      (let ((height top))
910        (vector-set! INDEX i height)
911        (let ((rp (vector-ref R i)))
912          (if (pair? rp)
913              (let loop ((rp2 rp))
914                (if (pair? rp2)
915                    (let ((j (car rp2)))
916                      (if (= 0 (vector-ref INDEX j))
917                          (traverse j))
918                      (if (> (vector-ref INDEX i)
919                             (vector-ref INDEX j))
920                          (vector-set! INDEX i (vector-ref INDEX j)))
921                      (let ((F-i (vector-ref F i))
922                            (F-j (vector-ref F j)))
923                        (bit-union F-i F-j token-set-size))
924                      (loop (cdr rp2))))))
925          (if (= (vector-ref INDEX i) height)
926              (let loop ()
927                (let ((j (vector-ref VERTICES top)))
928                  (set! top (- top 1))
929                  (vector-set! INDEX j infinity)
930                  (if (not (= i j))
931                      (begin
932                        (bit-union (vector-ref F i)
933                                   (vector-ref F j)
934                                   token-set-size)
935                        (loop)))))))))
936
937    (let loop ((i 0))
938      (if (< i ngotos)
939          (begin
940            (if (and (= 0 (vector-ref INDEX i))
941                     (pair? (vector-ref R i)))
942                (traverse i))
943            (loop (+ i 1))))))
944
945
946  ;; ----------------------------------------------------------------------
947  ;; operator precedence management
948  ;; ----------------------------------------------------------------------
949     
950  ;; a vector of precedence descriptors where each element
951  ;; is of the form (terminal type precedence)
952  (define the-terminals/prec #f)   ; terminal symbols with precedence
953                                        ; the precedence is an integer >= 0
954  (define (get-symbol-precedence sym)
955    (caddr (vector-ref the-terminals/prec sym)))
956                                        ; the operator type is either 'none, 'left, 'right, or 'nonassoc
957  (define (get-symbol-assoc sym)
958    (cadr (vector-ref the-terminals/prec sym)))
959
960  (define rule-precedences '())
961  (define (add-rule-precedence! rule sym)
962    (set! rule-precedences
963          (cons (cons rule sym) rule-precedences)))
964
965  (define (get-rule-precedence ruleno)
966    (cond
967     ((assq ruleno rule-precedences)
968      => (lambda (p)
969           (get-symbol-precedence (cdr p))))
970     (else
971      ;; process the rule symbols from left to right
972      (let loop ((i    (vector-ref rrhs ruleno))
973                 (prec 0))
974        (let ((item (vector-ref ritem i)))
975          ;; end of rule
976          (if (< item 0)
977              prec
978              (let ((i1 (+ i 1)))
979                (if (>= item nvars)
980                    ;; it's a terminal symbol
981                    (loop i1 (get-symbol-precedence (- item nvars)))
982                    (loop i1 prec)))))))))
983
984  ;; ----------------------------------------------------------------------
985  ;; Build the various tables
986  ;; ----------------------------------------------------------------------
987
988  (define expected-conflicts 0)
989
990  (define (build-tables)
991
992    (define (resolve-conflict sym rule)
993      (let ((sym-prec   (get-symbol-precedence sym))
994            (sym-assoc  (get-symbol-assoc sym))
995            (rule-prec  (get-rule-precedence rule)))
996        (cond
997         ((> sym-prec rule-prec)     'shift)
998         ((< sym-prec rule-prec)     'reduce)
999         ((eq? sym-assoc 'left)      'reduce)
1000         ((eq? sym-assoc 'right)     'shift)
1001         (else                       'none))))
1002
1003    (define conflict-messages '())
1004
1005    (define (add-conflict-message . l)
1006      (set! conflict-messages (cons l conflict-messages)))
1007
1008    (define (log-conflicts)
1009      (if (> (length conflict-messages) expected-conflicts)
1010          (for-each
1011           (lambda (message)
1012             (for-each display message)
1013             (newline))
1014           conflict-messages)))
1015
1016    ;; --- Add an action to the action table
1017    (define (add-action state symbol new-action)
1018      (let* ((state-actions (vector-ref action-table state))
1019             (actions       (assv symbol state-actions)))
1020        (if (pair? actions)
1021            (let ((current-action (cadr actions)))
1022              (if (not (= new-action current-action))
1023                  ;; -- there is a conflict
1024                  (begin
1025                    (if (and (<= current-action 0) (<= new-action 0))
1026                        ;; --- reduce/reduce conflict
1027                        (begin
1028                          (add-conflict-message
1029                           "%% Reduce/Reduce conflict (reduce " (- new-action) ", reduce " (- current-action) 
1030                           ") on '" (get-symbol (+ symbol nvars)) "' in state " state)
1031                          (if (glr-driver?)
1032                              (set-cdr! (cdr actions) (cons new-action (cddr actions)))
1033                              (set-car! (cdr actions) (max current-action new-action))))
1034                        ;; --- shift/reduce conflict
1035                        ;; can we resolve the conflict using precedences?
1036                        (case (resolve-conflict symbol (- current-action))
1037                          ;; -- shift
1038                          ((shift)   (if (glr-driver?)
1039                                         (set-cdr! (cdr actions) (cons new-action (cddr actions)))
1040                                         (set-car! (cdr actions) new-action)))
1041                          ;; -- reduce
1042                          ((reduce)  #f) ; well, nothing to do...
1043                          ;; -- signal a conflict!
1044                          (else      (add-conflict-message
1045                                      "%% Shift/Reduce conflict (shift " new-action ", reduce " (- current-action)
1046                                      ") on '" (get-symbol (+ symbol nvars)) "' in state " state)
1047                                     (if (glr-driver?)
1048                                         (set-cdr! (cdr actions) (cons new-action (cddr actions)))
1049                                         (set-car! (cdr actions) new-action))))))))
1050         
1051            (vector-set! action-table state (cons (list symbol new-action) state-actions)))
1052        ))
1053
1054    (define (add-action-for-all-terminals state action)
1055      (do ((i 1 (+ i 1)))
1056          ((= i nterms))
1057        (add-action state i action)))
1058
1059    (set! action-table (make-vector nstates '()))
1060
1061    (do ((i 0 (+ i 1)))                 ; i = state
1062        ((= i nstates))
1063      (let ((red (vector-ref reduction-table i)))
1064        (if (and red (>= (red-nreds red) 1))
1065            (if (and (= (red-nreds red) 1) (vector-ref consistent i))
1066                (if (glr-driver?)
1067                    (add-action-for-all-terminals i (- (car (red-rules red))))
1068                    (add-action i 'default (- (car (red-rules red)))))
1069                (let ((k (vector-ref lookaheads (+ i 1))))
1070                  (let loop ((j (vector-ref lookaheads i)))
1071                    (if (< j k)
1072                        (let ((rule (- (vector-ref LAruleno j)))
1073                              (lav  (vector-ref LA j)))
1074                          (let loop2 ((token 0) (x (vector-ref lav 0)) (y 1) (z 0))
1075                            (if (< token nterms)
1076                                (begin
1077                                  (let ((in-la-set? (modulo x 2)))
1078                                    (if (= in-la-set? 1)
1079                                        (add-action i token rule)))
1080                                  (if (= y (BITS-PER-WORD))
1081                                      (loop2 (+ token 1)
1082                                             (vector-ref lav (+ z 1))
1083                                             1
1084                                             (+ z 1))
1085                                      (loop2 (+ token 1) (quotient x 2) (+ y 1) z)))))
1086                          (loop (+ j 1)))))))))
1087
1088      (let ((shiftp (vector-ref shift-table i)))
1089        (if shiftp
1090            (let loop ((k (shift-shifts shiftp)))
1091              (if (pair? k)
1092                  (let* ((state (car k))
1093                         (symbol (vector-ref acces-symbol state)))
1094                    (if (>= symbol nvars)
1095                        (add-action i (- symbol nvars) state))
1096                    (loop (cdr k))))))))
1097
1098    (add-action final-state 0 'accept)
1099    (log-conflicts))
1100
1101  (define (compact-action-table terms)
1102    (define (most-common-action acts)
1103      (let ((accums '()))
1104        (let loop ((l acts))
1105          (if (pair? l)
1106              (let* ((x (cadar l))
1107                     (y (assv x accums)))
1108                (if (and (number? x) (< x 0))
1109                    (if y
1110                        (set-cdr! y (+ 1 (cdr y)))
1111                        (set! accums (cons `(,x . 1) accums))))
1112                (loop (cdr l)))))
1113
1114        (let loop ((l accums) (max 0) (sym #f))
1115          (if (null? l)
1116              sym
1117              (let ((x (car l)))
1118                (if (> (cdr x) max)
1119                    (loop (cdr l) (cdr x) (car x))
1120                    (loop (cdr l) max sym)))))))
1121
1122    (define (translate-terms acts)
1123      (map (lambda (act)
1124             (cons (list-ref terms (car act))
1125                   (cdr act)))
1126           acts))
1127
1128    (do ((i 0 (+ i 1)))
1129        ((= i nstates))
1130      (let ((acts (vector-ref action-table i)))
1131        (if (vector? (vector-ref reduction-table i))
1132            (let ((act (most-common-action acts)))
1133              (vector-set! action-table i
1134                           (cons `(*default* ,(if act act '*error*))
1135                                 (translate-terms
1136                                  (lalr-filter (lambda (x)
1137                                                 (not (and (= (length x) 2)
1138                                                           (eq? (cadr x) act))))
1139                                               acts)))))
1140            (vector-set! action-table i
1141                         (cons `(*default* *error*)
1142                               (translate-terms acts)))))))
1143
1144
1145
1146  ;; --
1147
1148  (define (rewrite-grammar tokens grammar k)
1149
1150    (define eoi '*eoi*)
1151
1152    (define (check-terminal term terms)
1153      (cond
1154       ((not (valid-terminal? term))
1155        (lalr-error "invalid terminal: " term))
1156       ((member term terms)
1157        (lalr-error "duplicate definition of terminal: " term))))
1158
1159    (define (prec->type prec)
1160      (cdr (assq prec '((left:     . left)
1161                        (right:    . right)
1162                        (nonassoc: . nonassoc)))))
1163
1164    (cond
1165     ;; --- a few error conditions
1166     ((not (list? tokens))
1167      (lalr-error "Invalid token list: " tokens))
1168     ((not (pair? grammar))
1169      (lalr-error "Grammar definition must have a non-empty list of productions" '()))
1170
1171     (else
1172      ;; --- check the terminals
1173      (let loop1 ((lst            tokens)
1174                  (rev-terms      '())
1175                  (rev-terms/prec '())
1176                  (prec-level     0))
1177        (if (pair? lst)
1178            (let ((term (car lst)))
1179              (cond
1180               ((pair? term)
1181                (if (and (memq (car term) '(left: right: nonassoc:))
1182                         (not (null? (cdr term))))
1183                    (let ((prec    (+ prec-level 1))
1184                          (optype  (prec->type (car term))))
1185                      (let loop-toks ((l             (cdr term))
1186                                      (rev-terms      rev-terms)
1187                                      (rev-terms/prec rev-terms/prec))
1188                        (if (null? l)
1189                            (loop1 (cdr lst) rev-terms rev-terms/prec prec)
1190                            (let ((term (car l)))
1191                              (check-terminal term rev-terms)
1192                              (loop-toks
1193                               (cdr l)
1194                               (cons term rev-terms)
1195                               (cons (list term optype prec) rev-terms/prec))))))
1196
1197                    (lalr-error "invalid operator precedence specification: " term)))
1198
1199               (else
1200                (check-terminal term rev-terms)
1201                (loop1 (cdr lst)
1202                       (cons term rev-terms)
1203                       (cons (list term 'none 0) rev-terms/prec)
1204                       prec-level))))
1205
1206            ;; --- check the grammar rules
1207            (let loop2 ((lst grammar) (rev-nonterm-defs '()))
1208              (if (pair? lst)
1209                  (let ((def (car lst)))
1210                    (if (not (pair? def))
1211                        (lalr-error "Nonterminal definition must be a non-empty list" '())
1212                        (let ((nonterm (car def)))
1213                          (cond ((not (valid-nonterminal? nonterm))
1214                                 (lalr-error "Invalid nonterminal:" nonterm))
1215                                ((or (member nonterm rev-terms)
1216                                     (assoc nonterm rev-nonterm-defs))
1217                                 (lalr-error "Nonterminal previously defined:" nonterm))
1218                                (else
1219                                 (loop2 (cdr lst)
1220                                        (cons def rev-nonterm-defs)))))))
1221                  (let* ((terms        (cons eoi            (cons 'error          (reverse rev-terms))))
1222                         (terms/prec   (cons '(eoi none 0)  (cons '(error none 0) (reverse rev-terms/prec))))
1223                         (nonterm-defs (reverse rev-nonterm-defs))
1224                         (nonterms     (cons '*start* (map car nonterm-defs))))
1225                    (if (= (length nonterms) 1)
1226                        (lalr-error "Grammar must contain at least one nonterminal" '())
1227                        (let loop-defs ((defs      (cons `(*start* (,(cadr nonterms) ,eoi) : $1)
1228                                                         nonterm-defs))
1229                                        (ruleno    0)
1230                                        (comp-defs '()))
1231                          (if (pair? defs)
1232                              (let* ((nonterm-def  (car defs))
1233                                     (compiled-def (rewrite-nonterm-def
1234                                                    nonterm-def
1235                                                    ruleno
1236                                                    terms nonterms)))
1237                                (loop-defs (cdr defs)
1238                                           (+ ruleno (length compiled-def))
1239                                           (cons compiled-def comp-defs)))
1240
1241                              (let ((compiled-nonterm-defs (reverse comp-defs)))
1242                                (k terms
1243                                   terms/prec
1244                                   nonterms
1245                                   (map (lambda (x) (cons (caaar x) (map cdar x)))
1246                                        compiled-nonterm-defs)
1247                                   (apply append compiled-nonterm-defs))))))))))))))
1248
1249
1250  (define (rewrite-nonterm-def nonterm-def ruleno terms nonterms)
1251
1252    (define No-NT (length nonterms))
1253
1254    (define (encode x)
1255      (let ((PosInNT (pos-in-list x nonterms)))
1256        (if PosInNT
1257            PosInNT
1258            (let ((PosInT (pos-in-list x terms)))
1259              (if PosInT
1260                  (+ No-NT PosInT)
1261                  (lalr-error "undefined symbol : " x))))))
1262
1263    (define (process-prec-directive rhs ruleno)
1264      (let loop ((l rhs))
1265        (if (null? l)
1266            '()
1267            (let ((first (car l))
1268                  (rest  (cdr l)))
1269              (cond
1270               ((or (member first terms) (member first nonterms))
1271                (cons first (loop rest)))
1272               ((and (pair? first)
1273                     (eq? (car first) 'prec:))
1274                (if (and (pair? (cdr first))
1275                         (null? (cddr first))
1276                         (member (cadr first) terms))
1277                    (if (null? rest)
1278                        (begin
1279                          (add-rule-precedence! ruleno (pos-in-list (cadr first) terms))
1280                          (loop rest))
1281                        (lalr-error "prec: directive should be at end of rule: " rhs))
1282                    (lalr-error "Invalid prec: directive: " first)))
1283               (else
1284                (lalr-error "Invalid terminal or nonterminal: " first)))))))
1285
1286    (define (check-error-production rhs)
1287      (let loop ((rhs rhs))
1288        (if (pair? rhs)
1289            (begin
1290              (if (and (eq? (car rhs) 'error)
1291                       (or (null? (cdr rhs))
1292                           (not (member (cadr rhs) terms))
1293                           (not (null? (cddr rhs)))))
1294                  (lalr-error "Invalid 'error' production. A single terminal symbol must follow the 'error' token.:" rhs))
1295              (loop (cdr rhs))))))
1296
1297
1298    (if (not (pair? (cdr nonterm-def)))
1299        (lalr-error "At least one production needed for nonterminal:" (car nonterm-def))
1300        (let ((name (symbol->string (car nonterm-def))))
1301          (let loop1 ((lst (cdr nonterm-def))
1302                      (i 1)
1303                      (rev-productions-and-actions '()))
1304            (if (not (pair? lst))
1305                (reverse rev-productions-and-actions)
1306                (let* ((rhs  (process-prec-directive (car lst) (+ ruleno i -1)))
1307                       (rest (cdr lst))
1308                       (prod (map encode (cons (car nonterm-def) rhs))))
1309                  ;; -- check for undefined tokens
1310                  (for-each (lambda (x)
1311                              (if (not (or (member x terms) (member x nonterms)))
1312                                  (lalr-error "Invalid terminal or nonterminal:" x)))
1313                            rhs)
1314                  ;; -- check 'error' productions
1315                  (check-error-production rhs)
1316
1317                  (if (and (pair? rest)
1318                           (eq? (car rest) ':)
1319                           (pair? (cdr rest)))
1320                      (loop1 (cddr rest)
1321                             (+ i 1)
1322                             (cons (cons prod (cadr rest))
1323                                   rev-productions-and-actions))
1324                      (let* ((rhs-length (length rhs))
1325                             (action
1326                              (cons 'vector
1327                                    (cons (list 'quote (string->symbol
1328                                                        (string-append
1329                                                         name
1330                                                         "-"
1331                                                         (number->string i))))
1332                                          (let loop-j ((j 1))
1333                                            (if (> j rhs-length)
1334                                                '()
1335                                                (cons (string->symbol
1336                                                       (string-append
1337                                                        "$"
1338                                                        (number->string j)))
1339                                                      (loop-j (+ j 1)))))))))
1340                        (loop1 rest
1341                               (+ i 1)
1342                               (cons (cons prod action)
1343                                     rev-productions-and-actions))))))))))
1344
1345  (define (valid-nonterminal? x)
1346    (symbol? x))
1347
1348  (define (valid-terminal? x)
1349    (symbol? x))                        ; DB
1350
1351  ;; ----------------------------------------------------------------------
1352  ;; Miscellaneous
1353  ;; ----------------------------------------------------------------------
1354  (define (pos-in-list x lst)
1355    (let loop ((lst lst) (i 0))
1356      (cond ((not (pair? lst))    #f)
1357            ((equal? (car lst) x) i)
1358            (else                 (loop (cdr lst) (+ i 1))))))
1359
1360  (define (sunion lst1 lst2)            ; union of sorted lists
1361    (let loop ((L1 lst1)
1362               (L2 lst2))
1363      (cond ((null? L1)    L2)
1364            ((null? L2)    L1)
1365            (else
1366             (let ((x (car L1)) (y (car L2)))
1367               (cond
1368                ((> x y)
1369                 (cons y (loop L1 (cdr L2))))
1370                ((< x y)
1371                 (cons x (loop (cdr L1) L2)))
1372                (else
1373                 (loop (cdr L1) L2))
1374                ))))))
1375
1376  (define (sinsert elem lst)
1377    (let loop ((l1 lst))
1378      (if (null? l1)
1379          (cons elem l1)
1380          (let ((x (car l1)))
1381            (cond ((< elem x)
1382                   (cons elem l1))
1383                  ((> elem x)
1384                   (cons x (loop (cdr l1))))
1385                  (else
1386                   l1))))))
1387
1388  (define (lalr-filter p lst)
1389    (let loop ((l lst))
1390      (if (null? l)
1391          '()
1392          (let ((x (car l)) (y (cdr l)))
1393            (if (p x)
1394                (cons x (loop y))
1395                (loop y))))))
1396     
1397  ;; ----------------------------------------------------------------------
1398  ;; Debugging tools ...
1399  ;; ----------------------------------------------------------------------
1400  (define the-terminals #f)             ; names of terminal symbols
1401  (define the-nonterminals #f)          ; non-terminals
1402
1403  (define (print-item item-no)
1404    (let loop ((i item-no))
1405      (let ((v (vector-ref ritem i)))
1406        (if (>= v 0)
1407            (loop (+ i 1))
1408            (let* ((rlno    (- v))
1409                   (nt      (vector-ref rlhs rlno)))
1410              (display (vector-ref the-nonterminals nt)) (display " --> ")
1411              (let loop ((i (vector-ref rrhs rlno)))
1412                (let ((v (vector-ref ritem i)))
1413                  (if (= i item-no)
1414                      (display ". "))
1415                  (if (>= v 0)
1416                      (begin
1417                        (display (get-symbol v))
1418                        (display " ")
1419                        (loop (+ i 1)))
1420                      (begin
1421                        (display "   (rule ")
1422                        (display (- v))
1423                        (display ")")
1424                        (newline))))))))))
1425
1426  (define (get-symbol n)
1427    (if (>= n nvars)
1428        (vector-ref the-terminals (- n nvars))
1429        (vector-ref the-nonterminals n)))
1430
1431
1432  (define (print-states)
1433    (define (print-action act)
1434      (cond
1435       ((eq? act '*error*)
1436        (display " : Error"))
1437       ((eq? act 'accept)
1438        (display " : Accept input"))
1439       ((< act 0)
1440        (display " : reduce using rule ")
1441        (display (- act)))
1442       (else
1443        (display " : shift and goto state ")
1444        (display act)))
1445      (newline)
1446      #t)
1447
1448    (define (print-actions acts)
1449      (let loop ((l acts))
1450        (if (null? l)
1451            #t
1452            (let ((sym (caar l))
1453                  (act (cadar l)))
1454              (display "   ")
1455              (cond
1456               ((eq? sym 'default)
1457                (display "default action"))
1458               (else
1459                (if (number? sym)
1460                    (display (get-symbol (+ sym nvars)))
1461                    (display sym))))
1462              (print-action act)
1463              (loop (cdr l))))))
1464
1465    (if (not action-table)
1466        (begin
1467          (display "No generated parser available!")
1468          (newline)
1469          #f)
1470        (begin
1471          (display "State table") (newline)
1472          (display "-----------") (newline) (newline)
1473
1474          (let loop ((l first-state))
1475            (if (null? l)
1476                #t
1477                (let* ((core  (car l))
1478                       (i     (core-number core))
1479                       (items (core-items core))
1480                       (actions (vector-ref action-table i)))
1481                  (display "state ") (display i) (newline)
1482                  (newline)
1483                  (for-each (lambda (x) (display "   ") (print-item x))
1484                            items)
1485                  (newline)
1486                  (print-actions actions)
1487                  (newline)
1488                  (loop (cdr l))))))))
1489
1490
1491
1492  ;; ----------------------------------------------------------------------
1493     
1494  (define build-goto-table
1495    (lambda ()
1496      `(vector
1497        ,@(map
1498           (lambda (shifts)
1499             (list 'quote
1500                   (if shifts
1501                       (let loop ((l (shift-shifts shifts)))
1502                         (if (null? l)
1503                             '()
1504                             (let* ((state  (car l))
1505                                    (symbol (vector-ref acces-symbol state)))
1506                               (if (< symbol nvars)
1507                                   (cons `(,symbol . ,state)
1508                                         (loop (cdr l)))
1509                                   (loop (cdr l))))))
1510                       '())))
1511           (vector->list shift-table)))))
1512
1513
1514  (define build-reduction-table
1515    (lambda (gram/actions)
1516      `(vector
1517        '()
1518        ,@(map
1519           (lambda (p)
1520             (let ((act (cdr p)))
1521               `(lambda ,(if (eq? driver-name 'lr-driver)
1522                             '(___stack ___sp ___goto-table ___push yypushback)
1523                             '(___sp ___goto-table ___push))
1524                  ,(let* ((nt (caar p)) (rhs (cdar p)) (n (length rhs)))
1525                     `(let* (,@(if act
1526                                   (let loop ((i 1) (l rhs))
1527                                     (if (pair? l)
1528                                         (let ((rest (cdr l))
1529                                               (ns (number->string (+ (- n i) 1))))
1530                                           (cons
1531                                            `(tok ,(if (eq? driver-name 'lr-driver)
1532                                                       `(vector-ref ___stack (- ___sp ,(- (* i 2) 1)))
1533                                                       `(list-ref ___sp ,(+ (* (- i 1) 2) 1))))
1534                                            (cons
1535                                             `(,(string->symbol (string-append "$" ns))
1536                                               (if (lexical-token? tok) (lexical-token-value tok) tok))
1537                                             (cons
1538                                              `(,(string->symbol (string-append "@" ns))
1539                                                (if (lexical-token? tok) (lexical-token-source tok) tok))
1540                                              (loop (+ i 1) rest)))))
1541                                         '()))
1542                                   '()))
1543                        ,(if (= nt 0)
1544                             '$1
1545                             `(___push ,n ,nt ,(cdr p) ,@(if (eq? driver-name 'lr-driver) '() '(___sp)) 
1546                                       ,(if (eq? driver-name 'lr-driver)
1547                                            `(vector-ref ___stack (- ___sp ,(length rhs)))
1548                                            `(list-ref ___sp ,(length rhs))))))))))
1549
1550           gram/actions))))
1551
1552
1553
1554  ;; Options
1555
1556  (define *valid-options*
1557    (list
1558     (cons 'out-table:
1559           (lambda (option)
1560             (and (list? option)
1561                  (= (length option) 2)
1562                  (string? (cadr option)))))
1563     (cons 'output:
1564           (lambda (option)
1565             (and (list? option)
1566                  (= (length option) 3)
1567                  (symbol? (cadr option))
1568                  (string? (caddr option)))))
1569     (cons 'expect:
1570           (lambda (option)
1571             (and (list? option)
1572                  (= (length option) 2)
1573                  (integer? (cadr option))
1574                  (>= (cadr option) 0))))
1575
1576     (cons 'driver:
1577           (lambda (option)
1578             (and (list? option)
1579                  (= (length option) 2)
1580                  (symbol? (cadr option))
1581                  (memq (cadr option) '(lr glr)))))))
1582
1583
1584  (define (validate-options options)
1585    (for-each
1586     (lambda (option)
1587       (let ((p (assoc (car option) *valid-options*)))
1588         (if (or (not p)
1589                 (not ((cdr p) option)))
1590             (lalr-error "Invalid option:" option))))
1591     options))
1592
1593
1594  (define (output-parser! options code)
1595    (let ((option (assq 'output: options)))
1596      (if option
1597          (let ((parser-name (cadr option))
1598                (file-name   (caddr option)))
1599            (with-output-to-file file-name
1600              (lambda ()
1601                (pprint `(define ,parser-name ,code))
1602                (newline)))))))
1603
1604
1605  (define (output-table! options)
1606    (let ((option (assq 'out-table: options)))
1607      (if option
1608          (let ((file-name (cadr option)))
1609            (with-output-to-file file-name print-states)))))
1610
1611
1612  (define (set-expected-conflicts! options)
1613    (let ((option (assq 'expect: options)))
1614      (set! expected-conflicts (if option (cadr option) 0))))
1615
1616  (define (set-driver-name! options)
1617    (let ((option (assq 'driver: options)))
1618      (if option
1619          (let ((driver-type (cadr option)))
1620            (set! driver-name (if (eq? driver-type 'glr) 'glr-driver 'lr-driver))))))
1621
1622
1623  ;; -- arguments
1624
1625  (define (extract-arguments lst proc)
1626    (let loop ((options '())
1627               (tokens  '())
1628               (rules   '())
1629               (lst     lst))
1630      (if (pair? lst)
1631          (let ((p (car lst)))
1632            (cond
1633             ((and (pair? p)
1634                   (lalr-keyword? (car p))
1635                   (assq (car p) *valid-options*))
1636              (loop (cons p options) tokens rules (cdr lst)))
1637             (else
1638              (proc options p (cdr lst)))))
1639          (lalr-error "Malformed lalr-parser form" lst))))
1640
1641
1642  (define (build-driver options tokens rules)
1643    (validate-options options)
1644    (set-expected-conflicts! options)
1645    (set-driver-name! options)
1646    (let* ((gram/actions (gen-tables! tokens rules))
1647           (code         `(,driver-name ',action-table ,(build-goto-table) ,(build-reduction-table gram/actions))))
1648   
1649      (output-table! options)
1650      (output-parser! options code)
1651      code))
1652
1653
1654(define-syntax lalr-parser
1655  (er-macro-transformer
1656   (lambda (f r c)
1657     (let ((arguments (cdr f)))
1658       `(extract-arguments ',arguments build-driver)))
1659   ))
1660 
1661)
Note: See TracBrowser for help on using the repository browser.