2 ;;;; An Efficient and Portable LALR(1) Parser Generator for Scheme
4 ;; Copyright 1993, 2010 Dominique Boucher
6 ;; This program is free software: you can redistribute it and/or
7 ;; modify it under the terms of the GNU Lesser General Public License
8 ;; as published by the Free Software Foundation, either version 3 of
9 ;; the License, or (at your option) any later version.
11 ;; This program is distributed in the hope that it will be useful,
12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;; GNU Lesser General Public License for more details.
16 ;; You should have received a copy of the GNU General Public License
17 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
20 (define *lalr-scm-version* "2.4.1")
28 (define-macro (def-macro form . body)
29 `(define-macro ,form (let () ,@body)))
31 (def-macro (BITS-PER-WORD) 28)
32 (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y))
33 (def-macro (lalr-error msg obj) `(error ,msg ,obj))
35 (define pprint pretty-print)
36 (define lalr-keyword? keyword?))
40 (define-macro (def-macro form . body)
41 `(define-macro ,form (let () ,@body)))
43 (define pprint (lambda (obj) (write obj) (newline)))
44 (define lalr-keyword? keyword?)
45 (def-macro (BITS-PER-WORD) 29)
46 (def-macro (logical-or x . y) `(bit-or ,x ,@y))
47 (def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj)))
52 (define-macro (def-macro form . body)
53 `(define-macro ,form (let () ,@body)))
55 (define pprint pretty-print)
56 (define lalr-keyword? symbol?)
57 (def-macro (BITS-PER-WORD) 30)
58 (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y))
59 (def-macro (lalr-error msg obj) `(error ,msg ,obj)))
65 (define (pprint form) (pp form :port (current-output-port)))
67 (define lalr-keyword? keyword?)
68 (define-macro (BITS-PER-WORD) 30)
69 (define-macro (logical-or x . y) `(bit-or ,x ,@y))
70 (define-macro (lalr-error msg obj) `(error 'lalr-parser ,msg ,obj)))
74 (use-modules (ice-9 pretty-print))
75 (use-modules (srfi srfi-9))
77 (define pprint pretty-print)
78 (define lalr-keyword? symbol?)
79 (define-macro (BITS-PER-WORD) 30)
80 (define-macro (logical-or x . y) `(logior ,x ,@y))
81 (define-macro (lalr-error msg obj) `(error ,msg ,obj)))
85 (require 'pretty-print)
86 (define (BITS-PER-WORD) 30)
87 (define logical-or logior)
88 (define (lalr-keyword? obj) (keyword? obj))
89 (define (pprint obj) (pretty-print obj))
90 (define (lalr-error msg obj) (error msg obj)))
97 (define pprint pretty-print)
98 (define lalr-keyword? symbol?)
99 (define-macro BITS-PER-WORD (lambda () 32))
100 (define-macro logical-or (lambda (x . y) `(logor ,x ,@y)))
101 (define-macro (lalr-error msg obj) `(error "~a ~S:" ,msg ,obj)))
105 (error "Unsupported Scheme system")))
108 (define-record-type lexical-token
109 (make-lexical-token category source value)
111 (category lexical-token-category)
112 (source lexical-token-source)
113 (value lexical-token-value))
116 (define-record-type source-location
117 (make-source-location input line column offset length)
119 (input source-location-input)
120 (line source-location-line)
121 (column source-location-column)
122 (offset source-location-offset)
123 (length source-location-length))
127 ;; - Macros pour la gestion des vecteurs de bits
129 (define-macro (lalr-parser . arguments)
130 (define (set-bit v b)
131 (let ((x (quotient b (BITS-PER-WORD)))
132 (y (expt 2 (remainder b (BITS-PER-WORD)))))
133 (vector-set! v x (logical-or (vector-ref v x) y))))
135 (define (bit-union v1 v2 n)
138 (vector-set! v1 i (logical-or (vector-ref v1 i)
139 (vector-ref v2 i)))))
141 ;; - Macro pour les structures de donnees
143 (define (new-core) (make-vector 4 0))
144 (define (set-core-number! c n) (vector-set! c 0 n))
145 (define (set-core-acc-sym! c s) (vector-set! c 1 s))
146 (define (set-core-nitems! c n) (vector-set! c 2 n))
147 (define (set-core-items! c i) (vector-set! c 3 i))
148 (define (core-number c) (vector-ref c 0))
149 (define (core-acc-sym c) (vector-ref c 1))
150 (define (core-nitems c) (vector-ref c 2))
151 (define (core-items c) (vector-ref c 3))
153 (define (new-shift) (make-vector 3 0))
154 (define (set-shift-number! c x) (vector-set! c 0 x))
155 (define (set-shift-nshifts! c x) (vector-set! c 1 x))
156 (define (set-shift-shifts! c x) (vector-set! c 2 x))
157 (define (shift-number s) (vector-ref s 0))
158 (define (shift-nshifts s) (vector-ref s 1))
159 (define (shift-shifts s) (vector-ref s 2))
161 (define (new-red) (make-vector 3 0))
162 (define (set-red-number! c x) (vector-set! c 0 x))
163 (define (set-red-nreds! c x) (vector-set! c 1 x))
164 (define (set-red-rules! c x) (vector-set! c 2 x))
165 (define (red-number c) (vector-ref c 0))
166 (define (red-nreds c) (vector-ref c 1))
167 (define (red-rules c) (vector-ref c 2))
170 (define (new-set nelem)
171 (make-vector nelem 0))
174 (define (vector-map f v)
175 (let ((vm-n (- (vector-length v) 1)))
176 (let loop ((vm-low 0) (vm-high vm-n))
177 (if (= vm-low vm-high)
178 (vector-set! v vm-low (f (vector-ref v vm-low) vm-low))
179 (let ((vm-middle (quotient (+ vm-low vm-high) 2)))
180 (loop vm-low vm-middle)
181 (loop (+ vm-middle 1) vm-high))))))
185 (define STATE-TABLE-SIZE 1009)
196 (define kernel-base #f)
197 (define kernel-end #f)
198 (define shift-symbol #f)
199 (define shift-set #f)
201 (define state-table #f)
202 (define acces-symbol #f)
203 (define reduction-table #f)
204 (define shift-table #f)
205 (define consistent #f)
206 (define lookaheads #f)
211 (define from-state #f)
215 (define action-table #f)
224 (define first-state #f)
225 (define last-state #f)
226 (define final-state #f)
227 (define first-shift #f)
228 (define last-shift #f)
229 (define first-reduction #f)
230 (define last-reduction #f)
234 (define token-set-size #f)
236 (define driver-name 'lr-driver)
238 (define (gen-tables! tokens gram )
243 (lambda (terms terms/prec vars gram gram/actions)
244 (set! the-terminals/prec (list->vector terms/prec))
245 (set! the-terminals (list->vector terms))
246 (set! the-nonterminals (list->vector vars))
247 (set! nterms (length terms))
248 (set! nvars (length vars))
249 (set! nsyms (+ nterms nvars))
250 (let ((no-of-rules (length gram/actions))
251 (no-of-items (let loop ((l gram/actions) (count 0))
254 (loop (cdr l) (+ count (length (caar l))))))))
255 (pack-grammar no-of-rules no-of-items gram)
261 (compact-action-table terms)
265 (define (initialize-all)
273 (set! kernel-base #f)
275 (set! shift-symbol #f)
278 (set! state-table (make-vector STATE-TABLE-SIZE '()))
279 (set! acces-symbol #f)
280 (set! reduction-table #f)
281 (set! shift-table #f)
292 (set! action-table #f)
294 (set! first-state #f)
296 (set! final-state #f)
297 (set! first-shift #f)
299 (set! first-reduction #f)
300 (set! last-reduction #f)
304 (set! token-set-size #f)
305 (set! rule-precedences '()))
308 (define (pack-grammar no-of-rules no-of-items gram)
309 (set! nrules (+ no-of-rules 1))
310 (set! nitems no-of-items)
311 (set! rlhs (make-vector nrules #f))
312 (set! rrhs (make-vector nrules #f))
313 (set! ritem (make-vector (+ 1 nitems) #f))
315 (let loop ((p gram) (item-no 0) (rule-no 1))
318 (let loop2 ((prods (cdar p)) (it-no2 item-no) (rl-no2 rule-no))
320 (loop (cdr p) it-no2 rl-no2)
322 (vector-set! rlhs rl-no2 nt)
323 (vector-set! rrhs rl-no2 it-no2)
324 (let loop3 ((rhs (car prods)) (it-no3 it-no2))
327 (vector-set! ritem it-no3 (- rl-no2))
328 (loop2 (cdr prods) (+ it-no3 1) (+ rl-no2 1)))
330 (vector-set! ritem it-no3 (car rhs))
331 (loop3 (cdr rhs) (+ it-no3 1))))))))))))
334 (define (set-derives)
335 (define delts (make-vector (+ nrules 1) 0))
336 (define dset (make-vector nvars -1))
338 (let loop ((i 1) (j 0)) ; i = 0
340 (let ((lhs (vector-ref rlhs i)))
343 (vector-set! delts j (cons i (vector-ref dset lhs)))
344 (vector-set! dset lhs j)
345 (loop (+ i 1) (+ j 1)))
348 (set! derives (make-vector nvars 0))
352 (let ((q (let loop2 ((j (vector-ref dset i)) (s '()))
355 (let ((x (vector-ref delts j)))
356 (loop2 (cdr x) (cons (car x) s)))))))
357 (vector-set! derives i q)
362 (define (set-nullable)
363 (set! nullable (make-vector nvars #f))
364 (let ((squeue (make-vector nvars #f))
365 (rcount (make-vector (+ nrules 1) 0))
366 (rsets (make-vector nvars #f))
367 (relts (make-vector (+ nitems nvars 1) #f)))
368 (let loop ((r 0) (s2 0) (p 0))
369 (let ((*r (vector-ref ritem r)))
372 (let ((symbol (vector-ref rlhs (- *r))))
373 (if (and (>= symbol 0)
374 (not (vector-ref nullable symbol)))
376 (vector-set! nullable symbol #t)
377 (vector-set! squeue s2 symbol)
378 (loop (+ r 1) (+ s2 1) p))))
379 (let loop2 ((r1 r) (any-tokens #f))
380 (let* ((symbol (vector-ref ritem r1)))
382 (loop2 (+ r1 1) (or any-tokens (>= symbol nvars)))
384 (let ((ruleno (- symbol)))
385 (let loop3 ((r2 r) (p2 p))
386 (let ((symbol (vector-ref ritem r2)))
389 (vector-set! rcount ruleno
390 (+ (vector-ref rcount ruleno) 1))
391 (vector-set! relts p2
392 (cons (vector-ref rsets symbol)
394 (vector-set! rsets symbol p2)
395 (loop3 (+ r2 1) (+ p2 1)))
396 (loop (+ r2 1) s2 p2)))))
397 (loop (+ r1 1) s2 p))))))
398 (let loop ((s1 0) (s3 s2))
400 (let loop2 ((p (vector-ref rsets (vector-ref squeue s1))) (s4 s3))
402 (let* ((x (vector-ref relts p))
404 (y (- (vector-ref rcount ruleno) 1)))
405 (vector-set! rcount ruleno y)
407 (let ((symbol (vector-ref rlhs ruleno)))
408 (if (and (>= symbol 0)
409 (not (vector-ref nullable symbol)))
411 (vector-set! nullable symbol #t)
412 (vector-set! squeue s4 symbol)
413 (loop2 (car x) (+ s4 1)))
415 (loop2 (car x) s4))))
416 (loop (+ s1 1) s4)))))))))
421 (set! firsts (make-vector nvars '()))
426 (let loop2 ((sp (vector-ref derives i)))
429 (let ((sym (vector-ref ritem (vector-ref rrhs (car sp)))))
431 (vector-set! firsts i (sinsert sym (vector-ref firsts i))))
432 (loop2 (cdr sp)))))))
434 ;; -- reflexive and transitive closure
435 (let loop ((continue #t))
437 (let loop2 ((i 0) (cont #f))
440 (let* ((x (vector-ref firsts i))
441 (y (let loop3 ((l x) (z x))
445 (sunion (vector-ref firsts (car l)) z))))))
449 (vector-set! firsts i y)
450 (loop2 (+ i 1) #t))))))))
455 (vector-set! firsts i (sinsert i (vector-ref firsts i)))
461 (define (set-fderives)
462 (set! fderives (make-vector nvars #f))
468 (let ((x (let loop2 ((l (vector-ref firsts i)) (fd '()))
472 (sunion (vector-ref derives (car l)) fd))))))
473 (vector-set! fderives i x)
477 (define (closure core)
479 (define ruleset (make-vector nrules #f))
481 (let loop ((csp core))
482 (if (not (null? csp))
483 (let ((sym (vector-ref ritem (car csp))))
485 (let loop2 ((dsp (vector-ref fderives sym)))
486 (if (not (null? dsp))
488 (vector-set! ruleset (car dsp) #t)
489 (loop2 (cdr dsp))))))
492 (let loop ((ruleno 1) (csp core) (itemsetv '())) ; ruleno = 0
493 (if (< ruleno nrules)
494 (if (vector-ref ruleset ruleno)
495 (let ((itemno (vector-ref rrhs ruleno)))
496 (let loop2 ((c csp) (itemsetv2 itemsetv))
499 (loop2 (cdr c) (cons (car c) itemsetv2))
500 (loop (+ ruleno 1) c (cons itemno itemsetv2)))))
501 (loop (+ ruleno 1) csp itemsetv))
502 (let loop2 ((c csp) (itemsetv2 itemsetv))
504 (loop2 (cdr c) (cons (car c) itemsetv2))
505 (reverse itemsetv2))))))
509 (define (allocate-item-sets)
510 (set! kernel-base (make-vector nsyms 0))
511 (set! kernel-end (make-vector nsyms #f)))
514 (define (allocate-storage)
516 (set! red-set (make-vector (+ nrules 1) 0)))
521 (define (initialize-states)
522 (let ((p (new-core)))
523 (set-core-number! p 0)
524 (set-core-acc-sym! p #f)
525 (set-core-nitems! p 1)
526 (set-core-items! p '(0))
528 (set! first-state (list p))
529 (set! last-state first-state)
534 (define (generate-states)
538 (let loop ((this-state first-state))
539 (if (pair? this-state)
540 (let* ((x (car this-state))
541 (is (closure (core-items x))))
542 (save-reductions x is)
547 (loop (cdr this-state))))))
550 (define (new-itemsets itemset)
552 (set! shift-symbol '())
556 (vector-set! kernel-end i '())
559 (let loop ((isp itemset))
562 (sym (vector-ref ritem i)))
565 (set! shift-symbol (sinsert sym shift-symbol))
566 (let ((x (vector-ref kernel-end sym)))
569 (vector-set! kernel-base sym (cons (+ i 1) x))
570 (vector-set! kernel-end sym (vector-ref kernel-base sym)))
572 (set-cdr! x (list (+ i 1)))
573 (vector-set! kernel-end sym (cdr x)))))))
576 (set! nshifts (length shift-symbol)))
580 (define (get-state sym)
581 (let* ((isp (vector-ref kernel-base sym))
583 (key (let loop ((isp1 isp) (k 0))
585 (modulo k STATE-TABLE-SIZE)
586 (loop (cdr isp1) (+ k (car isp1))))))
587 (sp (vector-ref state-table key)))
589 (let ((x (new-state sym)))
590 (vector-set! state-table key (list x))
593 (if (and (= n (core-nitems (car sp1)))
594 (let loop2 ((i1 isp) (t (core-items (car sp1))))
598 (loop2 (cdr i1) (cdr t))
600 (core-number (car sp1))
601 (if (null? (cdr sp1))
602 (let ((x (new-state sym)))
603 (set-cdr! sp1 (list x))
605 (loop (cdr sp1))))))))
608 (define (new-state sym)
609 (let* ((isp (vector-ref kernel-base sym))
612 (set-core-number! p nstates)
613 (set-core-acc-sym! p sym)
614 (if (= sym nvars) (set! final-state nstates))
615 (set-core-nitems! p n)
616 (set-core-items! p isp)
617 (set-cdr! last-state (list p))
618 (set! last-state (cdr last-state))
619 (set! nstates (+ nstates 1))
625 (define (append-states)
627 (let loop ((l (reverse shift-symbol)))
630 (cons (get-state (car l)) (loop (cdr l)))))))
634 (define (save-shifts core)
635 (let ((p (new-shift)))
636 (set-shift-number! p (core-number core))
637 (set-shift-nshifts! p nshifts)
638 (set-shift-shifts! p shift-set)
641 (set-cdr! last-shift (list p))
642 (set! last-shift (cdr last-shift)))
644 (set! first-shift (list p))
645 (set! last-shift first-shift)))))
647 (define (save-reductions core itemset)
648 (let ((rs (let loop ((l itemset))
651 (let ((item (vector-ref ritem (car l))))
653 (cons (- item) (loop (cdr l)))
657 (set-red-number! p (core-number core))
658 (set-red-nreds! p (length rs))
659 (set-red-rules! p rs)
662 (set-cdr! last-reduction (list p))
663 (set! last-reduction (cdr last-reduction)))
665 (set! first-reduction (list p))
666 (set! last-reduction first-reduction)))))))
672 (set! token-set-size (+ 1 (quotient nterms (BITS-PER-WORD))))
673 (set-accessing-symbol)
675 (set-reduction-table)
682 (compute-lookaheads))
684 (define (set-accessing-symbol)
685 (set! acces-symbol (make-vector nstates #f))
686 (let loop ((l first-state))
689 (vector-set! acces-symbol (core-number x) (core-acc-sym x))
692 (define (set-shift-table)
693 (set! shift-table (make-vector nstates #f))
694 (let loop ((l first-shift))
697 (vector-set! shift-table (shift-number x) x)
700 (define (set-reduction-table)
701 (set! reduction-table (make-vector nstates #f))
702 (let loop ((l first-reduction))
705 (vector-set! reduction-table (red-number x) x)
708 (define (set-max-rhs)
709 (let loop ((p 0) (curmax 0) (length 0))
710 (let ((x (vector-ref ritem p)))
713 (loop (+ p 1) curmax (+ length 1))
714 (loop (+ p 1) (max curmax length) 0))
715 (set! maxrhs curmax)))))
717 (define (initialize-LA)
723 (set! consistent (make-vector nstates #f))
724 (set! lookaheads (make-vector (+ nstates 1) #f))
726 (let loop ((count 0) (i 0))
729 (vector-set! lookaheads i count)
730 (let ((rp (vector-ref reduction-table i))
731 (sp (vector-ref shift-table i)))
733 (or (> (red-nreds rp) 1)
736 (< (vector-ref acces-symbol
737 (last (shift-shifts sp)))
739 (loop (+ count (red-nreds rp)) (+ i 1))
741 (vector-set! consistent i #t)
742 (loop count (+ i 1))))))
745 (vector-set! lookaheads nstates count)
746 (let ((c (max count 1)))
747 (set! LA (make-vector c #f))
748 (do ((j 0 (+ j 1))) ((= j c)) (vector-set! LA j (new-set token-set-size)))
749 (set! LAruleno (make-vector c -1))
750 (set! lookback (make-vector c #f)))
751 (let loop ((i 0) (np 0))
753 (if (vector-ref consistent i)
755 (let ((rp (vector-ref reduction-table i)))
757 (let loop2 ((j (red-rules rp)) (np2 np))
761 (vector-set! LAruleno np2 (car j))
762 (loop2 (cdr j) (+ np2 1)))))
763 (loop (+ i 1) np))))))))))
766 (define (set-goto-map)
767 (set! goto-map (make-vector (+ nvars 1) 0))
768 (let ((temp-map (make-vector (+ nvars 1) 0)))
769 (let loop ((ng 0) (sp first-shift))
771 (let loop2 ((i (reverse (shift-shifts (car sp)))) (ng2 ng))
773 (let ((symbol (vector-ref acces-symbol (car i))))
776 (vector-set! goto-map symbol
777 (+ 1 (vector-ref goto-map symbol)))
778 (loop2 (cdr i) (+ ng2 1)))
779 (loop2 (cdr i) ng2)))
780 (loop ng2 (cdr sp))))
782 (let loop ((k 0) (i 0))
785 (vector-set! temp-map i k)
786 (loop (+ k (vector-ref goto-map i)) (+ i 1)))
791 (vector-set! goto-map i (vector-ref temp-map i)))
794 (vector-set! goto-map nvars ngotos)
795 (vector-set! temp-map nvars ngotos)
796 (set! from-state (make-vector ngotos #f))
797 (set! to-state (make-vector ngotos #f))
799 (do ((sp first-shift (cdr sp)))
802 (state1 (shift-number x)))
803 (do ((i (shift-shifts x) (cdr i)))
805 (let* ((state2 (car i))
806 (symbol (vector-ref acces-symbol state2)))
808 (let ((k (vector-ref temp-map symbol)))
809 (vector-set! temp-map symbol (+ k 1))
810 (vector-set! from-state k state1)
811 (vector-set! to-state k state2))))))))))))))
814 (define (map-goto state symbol)
815 (let loop ((low (vector-ref goto-map symbol))
816 (high (- (vector-ref goto-map (+ symbol 1)) 1)))
819 (display (list "Error in map-goto" state symbol)) (newline)
821 (let* ((middle (quotient (+ low high) 2))
822 (s (vector-ref from-state middle)))
827 (loop (+ middle 1) high))
829 (loop low (- middle 1))))))))
832 (define (initialize-F)
833 (set! F (make-vector ngotos #f))
834 (do ((i 0 (+ i 1))) ((= i ngotos)) (vector-set! F i (new-set token-set-size)))
836 (let ((reads (make-vector ngotos #f)))
838 (let loop ((i 0) (rowp 0))
840 (let* ((rowf (vector-ref F rowp))
841 (stateno (vector-ref to-state i))
842 (sp (vector-ref shift-table stateno)))
844 (let loop2 ((j (shift-shifts sp)) (edges '()))
846 (let ((symbol (vector-ref acces-symbol (car j))))
848 (if (vector-ref nullable symbol)
849 (loop2 (cdr j) (cons (map-goto stateno symbol)
851 (loop2 (cdr j) edges))
853 (set-bit rowf (- symbol nvars))
854 (loop2 (cdr j) edges))))
856 (vector-set! reads i (reverse edges))))))
857 (loop (+ i 1) (+ rowp 1)))))
860 (define (add-lookback-edge stateno ruleno gotono)
861 (let ((k (vector-ref lookaheads (+ stateno 1))))
862 (let loop ((found #f) (i (vector-ref lookaheads stateno)))
863 (if (and (not found) (< i k))
864 (if (= (vector-ref LAruleno i) ruleno)
866 (loop found (+ i 1)))
869 (begin (display "Error in add-lookback-edge : ")
870 (display (list stateno ruleno gotono)) (newline))
871 (vector-set! lookback i
872 (cons gotono (vector-ref lookback i))))))))
875 (define (transpose r-arg n)
876 (let ((new-end (make-vector n #f))
877 (new-R (make-vector n #f)))
880 (let ((x (list 'bidon)))
881 (vector-set! new-R i x)
882 (vector-set! new-end i x)))
885 (let ((sp (vector-ref r-arg i)))
890 (y (vector-ref new-end x)))
891 (set-cdr! y (cons i (cdr y)))
892 (vector-set! new-end x (cdr y))
893 (loop (cdr sp2))))))))
896 (vector-set! new-R i (cdr (vector-ref new-R i))))
902 (define (build-relations)
904 (define (get-state stateno symbol)
905 (let loop ((j (shift-shifts (vector-ref shift-table stateno)))
910 (if (= (vector-ref acces-symbol st2) symbol)
912 (loop (cdr j) st2))))))
914 (set! includes (make-vector ngotos #f))
917 (let ((state1 (vector-ref from-state i))
918 (symbol1 (vector-ref acces-symbol (vector-ref to-state i))))
919 (let loop ((rulep (vector-ref derives symbol1))
922 (let ((*rulep (car rulep)))
923 (let loop2 ((rp (vector-ref rrhs *rulep))
925 (states (list state1)))
926 (let ((*rp (vector-ref ritem rp)))
928 (let ((st (get-state stateno *rp)))
929 (loop2 (+ rp 1) st (cons st states)))
932 (if (not (vector-ref consistent stateno))
933 (add-lookback-edge stateno *rulep i))
935 (let loop2 ((done #f)
940 (let ((*rp (vector-ref ritem rp2)))
942 (loop2 (not (vector-ref nullable *rp))
945 (cons (map-goto (car stp) *rp) edgp))
946 (loop2 #t stp rp2 edgp)))
948 (loop (cdr rulep) edgp))))))))
949 (vector-set! includes i edges)))))
950 (set! includes (transpose includes ngotos)))
954 (define (compute-lookaheads)
955 (let ((n (vector-ref lookaheads nstates)))
958 (let loop2 ((sp (vector-ref lookback i)))
960 (let ((LA-i (vector-ref LA i))
961 (F-j (vector-ref F (car sp))))
962 (bit-union LA-i F-j token-set-size)
968 (define (digraph relation)
969 (define infinity (+ ngotos 2))
970 (define INDEX (make-vector (+ ngotos 1) 0))
971 (define VERTICES (make-vector (+ ngotos 1) 0))
977 (vector-set! VERTICES top i)
979 (vector-set! INDEX i height)
980 (let ((rp (vector-ref R i)))
985 (if (= 0 (vector-ref INDEX j))
987 (if (> (vector-ref INDEX i)
988 (vector-ref INDEX j))
989 (vector-set! INDEX i (vector-ref INDEX j)))
990 (let ((F-i (vector-ref F i))
991 (F-j (vector-ref F j)))
992 (bit-union F-i F-j token-set-size))
994 (if (= (vector-ref INDEX i) height)
996 (let ((j (vector-ref VERTICES top)))
998 (vector-set! INDEX j infinity)
1001 (bit-union (vector-ref F i)
1009 (if (and (= 0 (vector-ref INDEX i))
1010 (pair? (vector-ref R i)))
1015 ;; ----------------------------------------------------------------------
1016 ;; operator precedence management
1017 ;; ----------------------------------------------------------------------
1019 ;; a vector of precedence descriptors where each element
1020 ;; is of the form (terminal type precedence)
1021 (define the-terminals/prec #f) ; terminal symbols with precedence
1022 ; the precedence is an integer >= 0
1023 (define (get-symbol-precedence sym)
1024 (caddr (vector-ref the-terminals/prec sym)))
1025 ; the operator type is either 'none, 'left, 'right, or 'nonassoc
1026 (define (get-symbol-assoc sym)
1027 (cadr (vector-ref the-terminals/prec sym)))
1029 (define rule-precedences '())
1030 (define (add-rule-precedence! rule sym)
1031 (set! rule-precedences
1032 (cons (cons rule sym) rule-precedences)))
1034 (define (get-rule-precedence ruleno)
1036 ((assq ruleno rule-precedences)
1038 (get-symbol-precedence (cdr p))))
1040 ;; process the rule symbols from left to right
1041 (let loop ((i (vector-ref rrhs ruleno))
1043 (let ((item (vector-ref ritem i)))
1049 ;; it's a terminal symbol
1050 (loop i1 (get-symbol-precedence (- item nvars)))
1051 (loop i1 prec)))))))))
1053 ;; ----------------------------------------------------------------------
1054 ;; Build the various tables
1055 ;; ----------------------------------------------------------------------
1057 (define expected-conflicts 0)
1059 (define (build-tables)
1061 (define (resolve-conflict sym rule)
1062 (let ((sym-prec (get-symbol-precedence sym))
1063 (sym-assoc (get-symbol-assoc sym))
1064 (rule-prec (get-rule-precedence rule)))
1066 ((> sym-prec rule-prec) 'shift)
1067 ((< sym-prec rule-prec) 'reduce)
1068 ((eq? sym-assoc 'left) 'reduce)
1069 ((eq? sym-assoc 'right) 'shift)
1072 (define conflict-messages '())
1074 (define (add-conflict-message . l)
1075 (set! conflict-messages (cons l conflict-messages)))
1077 (define (log-conflicts)
1078 (if (> (length conflict-messages) expected-conflicts)
1081 (for-each display message)
1083 conflict-messages)))
1085 ;; --- Add an action to the action table
1086 (define (add-action state symbol new-action)
1087 (let* ((state-actions (vector-ref action-table state))
1088 (actions (assv symbol state-actions)))
1090 (let ((current-action (cadr actions)))
1091 (if (not (= new-action current-action))
1092 ;; -- there is a conflict
1094 (if (and (<= current-action 0) (<= new-action 0))
1095 ;; --- reduce/reduce conflict
1097 (add-conflict-message
1098 "%% Reduce/Reduce conflict (reduce " (- new-action) ", reduce " (- current-action)
1099 ") on '" (get-symbol (+ symbol nvars)) "' in state " state)
1100 (if (eq? driver-name 'glr-driver)
1101 (set-cdr! (cdr actions) (cons new-action (cddr actions)))
1102 (set-car! (cdr actions) (max current-action new-action))))
1103 ;; --- shift/reduce conflict
1104 ;; can we resolve the conflict using precedences?
1105 (case (resolve-conflict symbol (- current-action))
1107 ((shift) (if (eq? driver-name 'glr-driver)
1108 (set-cdr! (cdr actions) (cons new-action (cddr actions)))
1109 (set-car! (cdr actions) new-action)))
1111 ((reduce) #f) ; well, nothing to do...
1112 ;; -- signal a conflict!
1113 (else (add-conflict-message
1114 "%% Shift/Reduce conflict (shift " new-action ", reduce " (- current-action)
1115 ") on '" (get-symbol (+ symbol nvars)) "' in state " state)
1116 (if (eq? driver-name 'glr-driver)
1117 (set-cdr! (cdr actions) (cons new-action (cddr actions)))
1118 (set-car! (cdr actions) new-action))))))))
1120 (vector-set! action-table state (cons (list symbol new-action) state-actions)))))
1122 (define (add-action-for-all-terminals state action)
1125 (add-action state i action)))
1127 (set! action-table (make-vector nstates '()))
1129 (do ((i 0 (+ i 1))) ; i = state
1131 (let ((red (vector-ref reduction-table i)))
1132 (if (and red (>= (red-nreds red) 1))
1133 (if (and (= (red-nreds red) 1) (vector-ref consistent i))
1134 (add-action-for-all-terminals i (- (car (red-rules red))))
1135 (let ((k (vector-ref lookaheads (+ i 1))))
1136 (let loop ((j (vector-ref lookaheads i)))
1138 (let ((rule (- (vector-ref LAruleno j)))
1139 (lav (vector-ref LA j)))
1140 (let loop2 ((token 0) (x (vector-ref lav 0)) (y 1) (z 0))
1141 (if (< token nterms)
1143 (let ((in-la-set? (modulo x 2)))
1144 (if (= in-la-set? 1)
1145 (add-action i token rule)))
1146 (if (= y (BITS-PER-WORD))
1148 (vector-ref lav (+ z 1))
1151 (loop2 (+ token 1) (quotient x 2) (+ y 1) z)))))
1152 (loop (+ j 1)))))))))
1154 (let ((shiftp (vector-ref shift-table i)))
1156 (let loop ((k (shift-shifts shiftp)))
1158 (let* ((state (car k))
1159 (symbol (vector-ref acces-symbol state)))
1160 (if (>= symbol nvars)
1161 (add-action i (- symbol nvars) state))
1162 (loop (cdr k))))))))
1164 (add-action final-state 0 'accept)
1167 (define (compact-action-table terms)
1168 (define (most-common-action acts)
1170 (let loop ((l acts))
1172 (let* ((x (cadar l))
1173 (y (assv x accums)))
1174 (if (and (number? x) (< x 0))
1176 (set-cdr! y (+ 1 (cdr y)))
1177 (set! accums (cons `(,x . 1) accums))))
1180 (let loop ((l accums) (max 0) (sym #f))
1185 (loop (cdr l) (cdr x) (car x))
1186 (loop (cdr l) max sym)))))))
1188 (define (translate-terms acts)
1190 (cons (list-ref terms (car act))
1196 (let ((acts (vector-ref action-table i)))
1197 (if (vector? (vector-ref reduction-table i))
1198 (let ((act (most-common-action acts)))
1199 (vector-set! action-table i
1200 (cons `(*default* ,(if act act '*error*))
1202 (lalr-filter (lambda (x)
1203 (not (and (= (length x) 2)
1204 (eq? (cadr x) act))))
1206 (vector-set! action-table i
1207 (cons `(*default* *error*)
1208 (translate-terms acts)))))))
1214 (define (rewrite-grammar tokens grammar k)
1218 (define (check-terminal term terms)
1220 ((not (valid-terminal? term))
1221 (lalr-error "invalid terminal: " term))
1222 ((member term terms)
1223 (lalr-error "duplicate definition of terminal: " term))))
1225 (define (prec->type prec)
1226 (cdr (assq prec '((left: . left)
1228 (nonassoc: . nonassoc)))))
1231 ;; --- a few error conditions
1232 ((not (list? tokens))
1233 (lalr-error "Invalid token list: " tokens))
1234 ((not (pair? grammar))
1235 (lalr-error "Grammar definition must have a non-empty list of productions" '()))
1238 ;; --- check the terminals
1239 (let loop1 ((lst tokens)
1241 (rev-terms/prec '())
1244 (let ((term (car lst)))
1247 (if (and (memq (car term) '(left: right: nonassoc:))
1248 (not (null? (cdr term))))
1249 (let ((prec (+ prec-level 1))
1250 (optype (prec->type (car term))))
1251 (let loop-toks ((l (cdr term))
1252 (rev-terms rev-terms)
1253 (rev-terms/prec rev-terms/prec))
1255 (loop1 (cdr lst) rev-terms rev-terms/prec prec)
1256 (let ((term (car l)))
1257 (check-terminal term rev-terms)
1260 (cons term rev-terms)
1261 (cons (list term optype prec) rev-terms/prec))))))
1263 (lalr-error "invalid operator precedence specification: " term)))
1266 (check-terminal term rev-terms)
1268 (cons term rev-terms)
1269 (cons (list term 'none 0) rev-terms/prec)
1272 ;; --- check the grammar rules
1273 (let loop2 ((lst grammar) (rev-nonterm-defs '()))
1275 (let ((def (car lst)))
1276 (if (not (pair? def))
1277 (lalr-error "Nonterminal definition must be a non-empty list" '())
1278 (let ((nonterm (car def)))
1279 (cond ((not (valid-nonterminal? nonterm))
1280 (lalr-error "Invalid nonterminal:" nonterm))
1281 ((or (member nonterm rev-terms)
1282 (assoc nonterm rev-nonterm-defs))
1283 (lalr-error "Nonterminal previously defined:" nonterm))
1286 (cons def rev-nonterm-defs)))))))
1287 (let* ((terms (cons eoi (cons 'error (reverse rev-terms))))
1288 (terms/prec (cons '(eoi none 0) (cons '(error none 0) (reverse rev-terms/prec))))
1289 (nonterm-defs (reverse rev-nonterm-defs))
1290 (nonterms (cons '*start* (map car nonterm-defs))))
1291 (if (= (length nonterms) 1)
1292 (lalr-error "Grammar must contain at least one nonterminal" '())
1293 (let loop-defs ((defs (cons `(*start* (,(cadr nonterms) ,eoi) : $1)
1298 (let* ((nonterm-def (car defs))
1299 (compiled-def (rewrite-nonterm-def
1303 (loop-defs (cdr defs)
1304 (+ ruleno (length compiled-def))
1305 (cons compiled-def comp-defs)))
1307 (let ((compiled-nonterm-defs (reverse comp-defs)))
1311 (map (lambda (x) (cons (caaar x) (map cdar x)))
1312 compiled-nonterm-defs)
1313 (apply append compiled-nonterm-defs))))))))))))))
1316 (define (rewrite-nonterm-def nonterm-def ruleno terms nonterms)
1318 (define No-NT (length nonterms))
1321 (let ((PosInNT (pos-in-list x nonterms)))
1324 (let ((PosInT (pos-in-list x terms)))
1327 (lalr-error "undefined symbol : " x))))))
1329 (define (process-prec-directive rhs ruleno)
1333 (let ((first (car l))
1336 ((or (member first terms) (member first nonterms))
1337 (cons first (loop rest)))
1339 (eq? (car first) 'prec:))
1340 (if (and (pair? (cdr first))
1341 (null? (cddr first))
1342 (member (cadr first) terms))
1345 (add-rule-precedence! ruleno (pos-in-list (cadr first) terms))
1347 (lalr-error "prec: directive should be at end of rule: " rhs))
1348 (lalr-error "Invalid prec: directive: " first)))
1350 (lalr-error "Invalid terminal or nonterminal: " first)))))))
1352 (define (check-error-production rhs)
1353 (let loop ((rhs rhs))
1356 (if (and (eq? (car rhs) 'error)
1357 (or (null? (cdr rhs))
1358 (not (member (cadr rhs) terms))
1359 (not (null? (cddr rhs)))))
1360 (lalr-error "Invalid 'error' production. A single terminal symbol must follow the 'error' token.:" rhs))
1361 (loop (cdr rhs))))))
1364 (if (not (pair? (cdr nonterm-def)))
1365 (lalr-error "At least one production needed for nonterminal:" (car nonterm-def))
1366 (let ((name (symbol->string (car nonterm-def))))
1367 (let loop1 ((lst (cdr nonterm-def))
1369 (rev-productions-and-actions '()))
1370 (if (not (pair? lst))
1371 (reverse rev-productions-and-actions)
1372 (let* ((rhs (process-prec-directive (car lst) (+ ruleno i -1)))
1374 (prod (map encode (cons (car nonterm-def) rhs))))
1375 ;; -- check for undefined tokens
1376 (for-each (lambda (x)
1377 (if (not (or (member x terms) (member x nonterms)))
1378 (lalr-error "Invalid terminal or nonterminal:" x)))
1380 ;; -- check 'error' productions
1381 (check-error-production rhs)
1383 (if (and (pair? rest)
1388 (cons (cons prod (cadr rest))
1389 rev-productions-and-actions))
1390 (let* ((rhs-length (length rhs))
1393 (cons (list 'quote (string->symbol
1397 (number->string i))))
1399 (if (> j rhs-length)
1401 (cons (string->symbol
1404 (number->string j)))
1405 (loop-j (+ j 1)))))))))
1408 (cons (cons prod action)
1409 rev-productions-and-actions))))))))))
1411 (define (valid-nonterminal? x)
1414 (define (valid-terminal? x)
1417 ;; ----------------------------------------------------------------------
1419 ;; ----------------------------------------------------------------------
1420 (define (pos-in-list x lst)
1421 (let loop ((lst lst) (i 0))
1422 (cond ((not (pair? lst)) #f)
1423 ((equal? (car lst) x) i)
1424 (else (loop (cdr lst) (+ i 1))))))
1426 (define (sunion lst1 lst2) ; union of sorted lists
1427 (let loop ((L1 lst1)
1429 (cond ((null? L1) L2)
1432 (let ((x (car L1)) (y (car L2)))
1435 (cons y (loop L1 (cdr L2))))
1437 (cons x (loop (cdr L1) L2)))
1442 (define (sinsert elem lst)
1443 (let loop ((l1 lst))
1450 (cons x (loop (cdr l1))))
1454 (define (lalr-filter p lst)
1458 (let ((x (car l)) (y (cdr l)))
1463 ;; ----------------------------------------------------------------------
1464 ;; Debugging tools ...
1465 ;; ----------------------------------------------------------------------
1466 (define the-terminals #f) ; names of terminal symbols
1467 (define the-nonterminals #f) ; non-terminals
1469 (define (print-item item-no)
1470 (let loop ((i item-no))
1471 (let ((v (vector-ref ritem i)))
1475 (nt (vector-ref rlhs rlno)))
1476 (display (vector-ref the-nonterminals nt)) (display " --> ")
1477 (let loop ((i (vector-ref rrhs rlno)))
1478 (let ((v (vector-ref ritem i)))
1483 (display (get-symbol v))
1492 (define (get-symbol n)
1494 (vector-ref the-terminals (- n nvars))
1495 (vector-ref the-nonterminals n)))
1498 (define (print-states)
1499 (define (print-action act)
1502 (display " : Error"))
1504 (display " : Accept input"))
1506 (display " : reduce using rule ")
1509 (display " : shift and goto state ")
1514 (define (print-actions acts)
1515 (let loop ((l acts))
1518 (let ((sym (caar l))
1523 (display "default action"))
1526 (display (get-symbol (+ sym nvars)))
1531 (if (not action-table)
1533 (display "No generated parser available!")
1537 (display "State table") (newline)
1538 (display "-----------") (newline) (newline)
1540 (let loop ((l first-state))
1543 (let* ((core (car l))
1544 (i (core-number core))
1545 (items (core-items core))
1546 (actions (vector-ref action-table i)))
1547 (display "state ") (display i) (newline)
1549 (for-each (lambda (x) (display " ") (print-item x))
1552 (print-actions actions)
1554 (loop (cdr l))))))))
1558 ;; ----------------------------------------------------------------------
1560 (define build-goto-table
1567 (let loop ((l (shift-shifts shifts)))
1570 (let* ((state (car l))
1571 (symbol (vector-ref acces-symbol state)))
1572 (if (< symbol nvars)
1573 (cons `(,symbol . ,state)
1577 (vector->list shift-table)))))
1580 (define build-reduction-table
1581 (lambda (gram/actions)
1586 (let ((act (cdr p)))
1587 `(lambda ,(if (eq? driver-name 'lr-driver)
1588 '(___stack ___sp ___goto-table ___push yypushback)
1589 '(___sp ___goto-table ___push))
1590 ,(let* ((nt (caar p)) (rhs (cdar p)) (n (length rhs)))
1592 (let loop ((i 1) (l rhs))
1594 (let ((rest (cdr l)))
1601 ,(if (eq? driver-name 'lr-driver)
1602 `(vector-ref ___stack (- ___sp ,(- (* i 2) 1)))
1603 `(list-ref ___sp ,(+ (* (- i 1) 2) 1))))
1604 (loop (+ i 1) rest)))
1609 `(___push ,n ,nt ,(cdr p) ,@(if (eq? driver-name 'lr-driver) '() '(___sp)))))))))
1617 (define *valid-options*
1622 (= (length option) 2)
1623 (string? (cadr option)))))
1627 (= (length option) 3)
1628 (symbol? (cadr option))
1629 (string? (caddr option)))))
1633 (= (length option) 2)
1634 (integer? (cadr option))
1635 (>= (cadr option) 0))))
1640 (= (length option) 2)
1641 (symbol? (cadr option))
1642 (memq (cadr option) '(lr glr)))))))
1645 (define (validate-options options)
1648 (let ((p (assoc (car option) *valid-options*)))
1650 (not ((cdr p) option)))
1651 (lalr-error "Invalid option:" option))))
1655 (define (output-parser! options code)
1656 (let ((option (assq 'output: options)))
1658 (let ((parser-name (cadr option))
1659 (file-name (caddr option)))
1660 (with-output-to-file file-name
1662 (pprint `(define ,parser-name ,code))
1666 (define (output-table! options)
1667 (let ((option (assq 'out-table: options)))
1669 (let ((file-name (cadr option)))
1670 (with-output-to-file file-name print-states)))))
1673 (define (set-expected-conflicts! options)
1674 (let ((option (assq 'expect: options)))
1675 (set! expected-conflicts (if option (cadr option) 0))))
1677 (define (set-driver-name! options)
1678 (let ((option (assq 'driver: options)))
1680 (let ((driver-type (cadr option)))
1681 (set! driver-name (if (eq? driver-type 'glr) 'glr-driver 'lr-driver))))))
1686 (define (extract-arguments lst proc)
1687 (let loop ((options '())
1692 (let ((p (car lst)))
1695 (lalr-keyword? (car p))
1696 (assq (car p) *valid-options*))
1697 (loop (cons p options) tokens rules (cdr lst)))
1699 (proc options p (cdr lst)))))
1700 (lalr-error "Malformed lalr-parser form" lst))))
1703 (define (build-driver options tokens rules)
1704 (validate-options options)
1705 (set-expected-conflicts! options)
1706 (set-driver-name! options)
1707 (let* ((gram/actions (gen-tables! tokens rules))
1708 (code `(,driver-name ',action-table ,(build-goto-table) ,(build-reduction-table gram/actions))))
1710 (output-table! options)
1711 (output-parser! options code)
1714 (extract-arguments arguments build-driver))
1720 ;;;; Implementation of the lr-driver
1734 (usual-integrations)
1741 ;;;; Source location utilities
1745 ;; This function assumes that src-location-1 and src-location-2 are source-locations
1746 ;; Returns #f if they are not locations for the same input
1747 (define (combine-locations src-location-1 src-location-2)
1748 (let ((offset-1 (source-location-offset src-location-1))
1749 (offset-2 (source-location-offset src-location-2))
1750 (length-1 (source-location-length src-location-1))
1751 (length-2 (source-location-length src-location-2)))
1753 (cond ((not (equal? (source-location-input src-location-1)
1754 (source-location-input src-location-2)))
1756 ((or (not (number? offset-1)) (not (number? offset-2))
1757 (not (number? length-1)) (not (number? length-2))
1758 (< offset-1 0) (< offset-2 0)
1759 (< length-1 0) (< length-2 0))
1760 (make-source-location (source-location-input src-location-1)
1761 (source-location-line src-location-1)
1762 (source-location-column src-location-1)
1764 ((<= offset-1 offset-2)
1765 (make-source-location (source-location-input src-location-1)
1766 (source-location-line src-location-1)
1767 (source-location-column src-location-1)
1769 (- (+ offset-2 length-2) offset-1)))
1771 (make-source-location (source-location-input src-location-1)
1772 (source-location-line src-location-1)
1773 (source-location-column src-location-1)
1775 (- (+ offset-1 length-1) offset-2))))))
1783 (define *max-stack-size* 500)
1785 (define (lr-driver action-table goto-table reduction-table)
1786 (define ___atable action-table)
1787 (define ___gtable goto-table)
1788 (define ___rtable reduction-table)
1790 (define ___lexerp #f)
1791 (define ___errorp #f)
1793 (define ___stack #f)
1796 (define ___curr-input #f)
1797 (define ___reuse-input #f)
1799 (define ___input #f)
1800 (define (___consume)
1801 (set! ___input (if ___reuse-input ___curr-input (___lexerp)))
1802 (set! ___reuse-input #f)
1803 (set! ___curr-input ___input))
1805 (define (___pushback)
1806 (set! ___reuse-input #t))
1808 (define (___initstack)
1809 (set! ___stack (make-vector *max-stack-size* 0))
1812 (define (___growstack)
1813 (let ((new-stack (make-vector (* 2 (vector-length ___stack)) 0)))
1814 (let loop ((i (- (vector-length ___stack) 1)))
1817 (vector-set! new-stack i (vector-ref ___stack i))
1819 (set! ___stack new-stack)))
1821 (define (___checkstack)
1822 (if (>= ___sp (vector-length ___stack))
1825 (define (___push delta new-category lvalue)
1826 (set! ___sp (- ___sp (* delta 2)))
1827 (let* ((state (vector-ref ___stack ___sp))
1828 (new-state (cdr (assoc new-category (vector-ref ___gtable state)))))
1829 (set! ___sp (+ ___sp 2))
1831 (vector-set! ___stack ___sp new-state)
1832 (vector-set! ___stack (- ___sp 1) lvalue)))
1834 (define (___reduce st)
1835 ((vector-ref ___rtable st) ___stack ___sp ___gtable ___push ___pushback))
1837 (define (___shift token attribute)
1838 (set! ___sp (+ ___sp 2))
1840 (vector-set! ___stack (- ___sp 1) attribute)
1841 (vector-set! ___stack ___sp token))
1843 (define (___action x l)
1844 (let ((y (assoc x l)))
1845 (if y (cadr y) (cadar l))))
1847 (define (___recover tok)
1848 (let find-state ((sp ___sp))
1851 (let* ((state (vector-ref ___stack sp))
1852 (act (assoc 'error (vector-ref ___atable state))))
1856 (___sync (cadr act) tok))
1857 (find-state (- sp 2)))))))
1859 (define (___sync state tok)
1860 (let ((sync-set (map car (cdr (vector-ref ___atable state)))))
1861 (set! ___sp (+ ___sp 4))
1863 (vector-set! ___stack (- ___sp 3) #f)
1864 (vector-set! ___stack (- ___sp 2) state)
1866 (let ((i (___category ___input)))
1869 (if (memq i sync-set)
1870 (let ((act (assoc i (vector-ref ___atable state))))
1871 (vector-set! ___stack (- ___sp 1) #f)
1872 (vector-set! ___stack ___sp (cadr act)))
1877 (define (___category tok)
1878 (if (lexical-token? tok)
1879 (lexical-token-category tok)
1882 (define (___value tok)
1883 (if (lexical-token? tok)
1884 (lexical-token-value tok)
1890 (let* ((state (vector-ref ___stack ___sp))
1891 (i (___category ___input))
1892 (attr (___value ___input))
1893 (act (___action i (vector-ref ___atable state))))
1895 (cond ((not (symbol? i))
1896 (___errorp "Syntax error: invalid token: " ___input)
1899 ;; Input succesfully parsed
1901 (vector-ref ___stack 1))
1903 ;; Syntax error in input
1907 (___errorp "Syntax error: unexpected end of input")
1910 (___errorp "Syntax error: unexpected token : " ___input)
1916 (set! ___input '*eoi*)))
1919 ;; Shift current token on top of the stack
1922 (set! ___input (if (eq? i '*eoi*) '*eoi* #f))
1925 ;; Reduce by rule (- act)
1930 ;; no lookahead, so check if there is a default action
1931 ;; that does not require the lookahead
1932 (let* ((state (vector-ref ___stack ___sp))
1933 (acts (vector-ref ___atable state))
1934 (defact (if (pair? acts) (cadar acts) #f)))
1935 (if (and (= 1 (length acts)) (< defact 0))
1936 (___reduce (- defact))
1941 (lambda (lexerp errorp)
1942 (set! ___errorp errorp)
1943 (set! ___lexerp lexerp)
1949 ;;;; Simple-minded GLR-driver
1953 (define (glr-driver action-table goto-table reduction-table)
1954 (define ___atable action-table)
1955 (define ___gtable goto-table)
1956 (define ___rtable reduction-table)
1958 (define ___lexerp #f)
1959 (define ___errorp #f)
1961 ;; -- Input handling
1964 (define (initialize-lexer lexer)
1965 (set! ___lexerp lexer)
1968 (set! *input* (___lexerp)))
1970 (define (token-category tok)
1971 (if (lexical-token? tok)
1972 (lexical-token-category tok)
1975 (define (token-attribute tok)
1976 (if (lexical-token? tok)
1977 (lexical-token-value tok)
1980 ;; -- Processes (stacks) handling
1982 (define *processes* '())
1984 (define (initialize-processes)
1985 (set! *processes* '()))
1986 (define (add-process process)
1987 (set! *processes* (cons process *processes*)))
1988 (define (get-processes)
1989 (reverse *processes*))
1991 (define (for-all-processes proc)
1992 (let ((processes (get-processes)))
1993 (initialize-processes)
1994 (for-each proc processes)))
1997 (define *parses* '())
1998 (define (get-parses)
2000 (define (initialize-parses)
2001 (set! *parses* '()))
2002 (define (add-parse parse)
2003 (set! *parses* (cons parse *parses*)))
2006 (define (push delta new-category lvalue stack)
2007 (let* ((stack (drop stack (* delta 2)))
2009 (new-state (cdr (assv new-category (vector-ref ___gtable state)))))
2010 (cons new-state (cons lvalue stack))))
2012 (define (reduce state stack)
2013 ((vector-ref ___rtable state) stack ___gtable push))
2015 (define (shift state symbol stack)
2016 (cons state (cons symbol stack)))
2018 (define (get-actions token action-list)
2019 (let ((pair (assoc token action-list)))
2022 (cdar action-list)))) ;; get the default action
2028 (let ((symbol (token-category *input*))
2029 (attr (token-attribute *input*)))
2032 (let loop ((stacks (list process)) (active-stacks '()))
2033 (cond ((pair? stacks)
2034 (let* ((stack (car stacks))
2035 (state (car stack)))
2036 (let actions-loop ((actions (get-actions symbol (vector-ref ___atable state)))
2037 (active-stacks active-stacks))
2039 (let ((action (car actions))
2040 (other-actions (cdr actions)))
2041 (cond ((eq? action '*error*)
2042 (actions-loop other-actions active-stacks))
2043 ((eq? action 'accept)
2044 (add-parse (car (take-right stack 2)))
2045 (actions-loop other-actions active-stacks))
2047 (let ((new-stack (shift action attr stack)))
2048 (add-process new-stack))
2049 (actions-loop other-actions active-stacks))
2051 (let ((new-stack (reduce (- action) stack)))
2052 (actions-loop other-actions (cons new-stack active-stacks))))))
2053 (loop (cdr stacks) active-stacks)))))
2054 ((pair? active-stacks)
2055 (loop (reverse active-stacks) '())))))))
2056 (if (pair? (get-processes))
2060 (lambda (lexerp errorp)
2061 (set! ___errorp errorp)
2062 (initialize-lexer lexerp)
2063 (initialize-processes)
2071 (cond ((and (> n 0) (pair? l))
2072 (drop (cdr l) (- n 1)))
2076 (define (take-right l n)
2077 (drop l (- (length l) n)))