1 ;; ---------------------------------------------------------------------- ;;
2 ;; FICHIER : lalr.scm ;;
3 ;; DATE DE CREATION : Mon Jan 22 15:42:32 1996 ;;
4 ;; DERNIERE MODIFICATION : Mon Jun 3 10:24:43 1996 ;;
5 ;; ---------------------------------------------------------------------- ;;
6 ;; Copyright (C) 1984, 1989, 1990 Free Software Foundation, Inc. ;;
7 ;; (for the Bison source code translated in Scheme) ;;
8 ;; Copyright (C) 1996 Dominique Boucher ;;
9 ;; (for the translation in Scheme) ;;
10 ;; ---------------------------------------------------------------------- ;;
11 ;; An efficient Scheme LALR(1) Parser Generator -- lalr.scm ;;
12 ;; ---------------------------------------------------------------------- ;;
13 ;; This file contains yet another LALR(1) parser generator written in ;;
14 ;; Scheme. In contrast to other such parser generators, this one ;;
15 ;; implements a more efficient algorithm for computing the lookahead sets.;;
16 ;; The algorithm is the same as used in Bison (GNU yacc) and is described ;;
17 ;; in the following paper: ;;
19 ;; "Efficient Computation of LALR(1) Look-Ahead Set", F. DeRemer and ;;
20 ;; T. Pennello, TOPLAS, vol. 4, no. 4, october 1982. ;;
22 ;; As a consequence, it is not written in a fully functional style. ;;
23 ;; The program has been successfully tested on several Scheme ;;
24 ;; interpreters and compilers, including scm4d3, Gambit v2.2, and ;;
25 ;; MIT-Scheme 7.2.0 (microcode 11.127, runtime 14.160). ;;
26 ;; ---------------------------------------------------------------------- ;;
27 ;; HOW TO USE THE PROGRAM ;;
29 ;; To generate a parser for a given grammar, the latter must be first ;;
30 ;; written down in scheme. The next section will describe the syntax ;;
31 ;; of the grammar. Now suppose your grammar is defined like this: ;;
33 ;; (define my-grammar { grammar }) ;;
35 ;; All you need to do is evaluate the expression: ;;
37 ;; (gen-lalr1 my-grammar "file" [prefix]) ;;
39 ;; where "file" is the name of the file (a string) that will contain the ;;
40 ;; tables for LR-parsing. The last argument must be supplied if you want ;;
41 ;; multiple parsers coexist in the same application. It must be a symbol, ;;
42 ;; otherwise it will be ignored. ;;
44 ;; To run the parser, you must first load the LR parsing driver(also part ;;
45 ;; of this distribution): ;;
47 ;; (load "lr-dvr.scm") ;;
49 ;; The interface to the generated parser will be the function ;;
51 ;; ([prefix-]parse lexer errorp) ;;
53 ;; where lexer is the name of the scanner feeding the parser with pairs ;;
54 ;; (token . lval) and errorp is the name of a user-defined error ;;
55 ;; function (the standard error function can be used as well). ;;
58 ;; Here are some notes about the lexer and the error function: ;;
60 ;; - the tokens (which are the first components of the pairs returned ;;
61 ;; by the lexer) must agree with the tokens defined in the grammar. ;;
63 ;; - when the lexer wants to signal the end of the input, it must ;;
64 ;; return the pair '(0) each time it's invoked. ;;
66 ;; - the error function must accept two parameters (the standard error ;;
67 ;; function accepts a variable number of parameters, so it accepts ;;
70 ;; ---------------------------------------------------------------------- ;;
71 ;; THE GRAMMAR FORMAT ;;
73 ;; The grammar is specified by first giving the list of terminals and the ;;
74 ;; list of non-terminal definitions. Each non-terminal definition ;;
75 ;; is a list where the first element is the non-terminal and the other ;;
76 ;; elements are the right-hand sides (lists of grammar symbols). In ;;
77 ;; addition to this, each rhs can be followed by a semantic action. ;;
78 ;; By convention, use strings for tokens and atoms for non-terminals. ;;
80 ;; For example, consider the following (yacc) grammar: ;;
93 ;; The same grammar, written for the scheme parser generator, would look ;;
94 ;; like this (with semantic actions) ;;
96 ;; (define my-grammar ;;
98 ;; ; Terminal symbols ;;
101 ;; (e (e ADD t) : (+ $1 $3) ;;
104 ;; (t (t MULT f) : (* $1 $3) ;;
110 ;; In semantic actions, the symbol $<n> refers to the synthesized ;;
111 ;; attribute value of the nth symbol in the production. The value ;;
112 ;; associated with the non-terminal on the left is the result of ;;
113 ;; evaluating the semantic action (it defaults to #f). ;;
115 ;; If you evaluate ;;
117 ;; (gen-lalr1 my-grammar "foo.scm" 'my) ;;
119 ;; then the generated parser will be named 'my-parser'. ;;
121 ;; NOTE ON CONFLICT RESOLUTION ;;
123 ;; Conflicts in the grammar are handled in a conventional way. ;;
124 ;; Shift/Reduce conflicts are resolved by shifting, and Reduce/Reduce ;;
125 ;; conflicts are resolved by choosing the rule listed first in the ;;
126 ;; grammar definition. ;;
128 ;; You can print the states of the generated parser by evaluating ;;
129 ;; `(print-states)'. The format of the output is similar to the one ;;
130 ;; produced by bison when given the -v command-line option. ;;
131 ;; ---------------------------------------------------------------------- ;;
132 ;; lalr.scm is free software; you can redistribute it and/or modify ;;
133 ;; it under the terms of the GNU General Public License as published by ;;
134 ;; the Free Software Foundation; either version 2, or (at your option) ;;
135 ;; any later version. ;;
137 ;; lalr.scm is distributed in the hope that it will be useful, ;;
138 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;
139 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;
140 ;; GNU General Public License for more details. ;;
142 ;; You should have received a copy of the GNU General Public License ;;
143 ;; along with lalr.scm; see the file COPYING. If not, write to ;;
144 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;
146 ;; Dominique Boucher -- Universite de Montreal ;;
148 ;; Send questions, comments or suggestions to boucherd@iro.umontreal.ca ;;
149 ;; ---------------------------------------------------------------------- ;;
151 ;; 1998/08/16: Tanaka Akira <akr@jaist.ac.jp> transplants generating code from Scheme to Emacs-Lisp.
153 ;;; ---------- SYSTEM DEPENDENT SECTION -----------------
157 (defmacro def-macro (args body)
158 `(defmacro ,(car args) ,(cdr args) ,body))
160 (def-macro (BITS-PER-WORD) 24)
161 (def-macro (logical-or x . y) `(logior ,x ,@y))
164 ;; -------- MIT-Scheme
166 (declare (usual-integrations))
168 (define-macro (def-macro form . body)
169 `(DEFINE-MACRO ,form (LET () ,@body)))
171 (def-macro (BITS-PER-WORD) 24)
172 (def-macro (logical-or x . y) `(fix:or ,x ,@y))
184 (define-macro (def-macro form . body)
185 `(DEFINE-MACRO ,form (LET () ,@body)))
187 (def-macro (BITS-PER-WORD) 28)
188 (def-macro (logical-or x . y) `(,(string->symbol "##logior") ,x ,@y))
194 (define-macro (def-macro form . body)
195 `(DEFINE-MACRO ,form (LET () ,@body)))
196 (def-macro (BITS-PER-WORD) 16)
197 (def-macro (logical-or x . y) `(bit-or ,x ,@y))
200 ;;; ---------- END OF SYSTEM DEPENDENT SECTION ------------
202 ;; - Macros pour la gestion des vecteurs de bits
204 (def-macro (set-bit v b)
205 `(let ((x (quotient ,b (BITS-PER-WORD)))
206 (y (expt 2 (remainder ,b (BITS-PER-WORD)))))
207 (vector-set! ,v x (logical-or (vector-ref ,v x) y))))
209 (def-macro (bit-union v1 v2 n)
212 (vector-set! ,v1 i (logical-or (vector-ref ,v1 i)
213 (vector-ref ,v2 i)))))
215 ;; - Macro pour les structures de donnees
217 (def-macro (new-core) `(make-vector 4 0))
218 (def-macro (set-core-number! c n) `(vector-set! ,c 0 ,n))
219 (def-macro (set-core-acc-sym! c s) `(vector-set! ,c 1 ,s))
220 (def-macro (set-core-nitems! c n) `(vector-set! ,c 2 ,n))
221 (def-macro (set-core-items! c i) `(vector-set! ,c 3 ,i))
222 (def-macro (core-number c) `(vector-ref ,c 0))
223 (def-macro (core-acc-sym c) `(vector-ref ,c 1))
224 (def-macro (core-nitems c) `(vector-ref ,c 2))
225 (def-macro (core-items c) `(vector-ref ,c 3))
227 (def-macro (new-shift) `(make-vector 3 0))
228 (def-macro (set-shift-number! c x) `(vector-set! ,c 0 ,x))
229 (def-macro (set-shift-nshifts! c x) `(vector-set! ,c 1 ,x))
230 (def-macro (set-shift-shifts! c x) `(vector-set! ,c 2 ,x))
231 (def-macro (shift-number s) `(vector-ref ,s 0))
232 (def-macro (shift-nshifts s) `(vector-ref ,s 1))
233 (def-macro (shift-shifts s) `(vector-ref ,s 2))
235 (def-macro (new-red) `(make-vector 3 0))
236 (def-macro (set-red-number! c x) `(vector-set! ,c 0 ,x))
237 (def-macro (set-red-nreds! c x) `(vector-set! ,c 1 ,x))
238 (def-macro (set-red-rules! c x) `(vector-set! ,c 2 ,x))
239 (def-macro (red-number c) `(vector-ref ,c 0))
240 (def-macro (red-nreds c) `(vector-ref ,c 1))
241 (def-macro (red-rules c) `(vector-ref ,c 2))
245 (def-macro (new-set nelem)
246 `(make-vector ,nelem 0))
249 (def-macro (vector-map f v)
250 `(let ((vm-n (- (vector-length ,v) 1)))
251 (let loop ((vm-low 0) (vm-high vm-n))
252 (if (= vm-low vm-high)
253 (vector-set! ,v vm-low (,f (vector-ref ,v vm-low) vm-low))
254 (let ((vm-middle (quotient (+ vm-low vm-high) 2)))
255 (loop vm-low vm-middle)
256 (loop (+ vm-middle 1) vm-high))))))
260 (define STATE-TABLE-SIZE 1009)
271 (define kernel-base #f)
272 (define kernel-end #f)
273 (define shift-symbol #f)
274 (define shift-set #f)
276 (define state-table #f)
277 (define acces-symbol #f)
278 (define reduction-table #f)
279 (define shift-table #f)
280 (define consistent #f)
281 (define lookaheads #f)
286 (define from-state #f)
290 (define action-table #f)
299 (define first-state #f)
300 (define last-state #f)
301 (define final-state #f)
302 (define first-shift #f)
303 (define last-shift #f)
304 (define first-reduction #f)
305 (define last-reduction #f)
309 (define token-set-size #f)
311 (define (gen-larl1 gram output-file header footer . opt)
312 (define (conv-rule-right rr)
315 (cons (reverse (car rr))
318 (conv-rule-right (cdddr rr)))))))
324 (cons (car elt) (conv-rule-right (cdr elt)))))
331 (define (gen-lalr1 gram output-file header footer . opt)
335 (lambda (terms vars gram gram/actions)
336 (set! the-terminals (list->vector terms))
337 (set! the-nonterminals (list->vector vars))
338 (set! nterms (length terms))
339 (set! nvars (length vars))
340 (set! nsyms (+ nterms nvars))
341 (let ((no-of-rules (length gram/actions))
342 (no-of-items (let loop ((l gram/actions) (count 0))
345 (loop (cdr l) (+ count (length (caar l))))))))
346 (pack-grammar no-of-rules no-of-items gram)
352 (compact-action-table)
353 (let* ((parser-name (if (and (pair? opt) (symbol? (car opt))) (car opt) #f))
354 (prefix (if parser-name
356 (symbol->string parser-name)
359 (parser-prefix (if parser-name
360 (string-append (symbol->string parser-name) "-")
362 (with-output-to-file output-file
364 (display "; *** Header ***")
366 (output-header header parser-prefix)
367 (display "; *** Token Definitions ***")
369 (output-token-defs terms prefix)
370 (display "; *** Action Table ***")
372 (output-action-table prefix)
373 (display "; *** Goto Table ***")
375 (output-goto-table prefix)
376 (display "; *** Reduction Table ***")
378 (output-reduction-table gram/actions prefix)
379 (display "; *** Parser Definition ***")
381 (output-parser-def parser-prefix prefix)
382 (display "; *** Footer ***")
384 (output-footer footer)
388 (define (initialize-all)
396 (set! kernel-base #f)
398 (set! shift-symbol #f)
401 (set! state-table (make-vector STATE-TABLE-SIZE '()))
402 (set! acces-symbol #f)
403 (set! reduction-table #f)
404 (set! shift-table #f)
415 (set! action-table #f)
417 (set! first-state #f)
419 (set! final-state #f)
420 (set! first-shift #f)
422 (set! first-reduction #f)
423 (set! last-reduction #f)
427 (set! token-set-size #f))
430 (define (pack-grammar no-of-rules no-of-items gram)
431 (set! nrules (+ no-of-rules 1))
432 (set! nitems no-of-items)
433 (set! rlhs (make-vector nrules #f))
434 (set! rrhs (make-vector nrules #f))
435 (set! ritem (make-vector (+ 1 nitems) #f))
437 (let loop ((p gram) (item-no 0) (rule-no 1))
440 (let loop2 ((prods (cdar p)) (it-no2 item-no) (rl-no2 rule-no))
442 (loop (cdr p) it-no2 rl-no2)
444 (vector-set! rlhs rl-no2 nt)
445 (vector-set! rrhs rl-no2 it-no2)
446 (let loop3 ((rhs (car prods)) (it-no3 it-no2))
449 (vector-set! ritem it-no3 (- rl-no2))
450 (loop2 (cdr prods) (+ it-no3 1) (+ rl-no2 1)))
452 (vector-set! ritem it-no3 (car rhs))
453 (loop3 (cdr rhs) (+ it-no3 1))))))))))))
456 ;; Fonction set-derives
457 ;; --------------------
458 (define (set-derives)
459 (define delts (make-vector (+ nrules 1) 0))
460 (define dset (make-vector nvars -1))
462 (let loop ((i 1) (j 0)) ; i = 0
464 (let ((lhs (vector-ref rlhs i)))
467 (vector-set! delts j (cons i (vector-ref dset lhs)))
468 (vector-set! dset lhs j)
469 (loop (+ i 1) (+ j 1)))
472 (set! derives (make-vector nvars 0))
476 (let ((q (let loop2 ((j (vector-ref dset i)) (s '()))
479 (let ((x (vector-ref delts j)))
480 (loop2 (cdr x) (cons (car x) s)))))))
481 (vector-set! derives i q)
486 (define (set-nullable)
487 (set! nullable (make-vector nvars #f))
488 (let ((squeue (make-vector nvars #f))
489 (rcount (make-vector (+ nrules 1) 0))
490 (rsets (make-vector nvars #f))
491 (relts (make-vector (+ nitems nvars 1) #f)))
492 (let loop ((r 0) (s2 0) (p 0))
493 (let ((*r (vector-ref ritem r)))
496 (let ((symbol (vector-ref rlhs (- *r))))
497 (if (and (>= symbol 0)
498 (not (vector-ref nullable symbol)))
500 (vector-set! nullable symbol #t)
501 (vector-set! squeue s2 symbol)
502 (loop (+ r 1) (+ s2 1) p))))
503 (let loop2 ((r1 r) (any-tokens #f))
504 (let* ((symbol (vector-ref ritem r1)))
506 (loop2 (+ r1 1) (or any-tokens (>= symbol nvars)))
508 (let ((ruleno (- symbol)))
509 (let loop3 ((r2 r) (p2 p))
510 (let ((symbol (vector-ref ritem r2)))
513 (vector-set! rcount ruleno
514 (+ (vector-ref rcount ruleno) 1))
515 (vector-set! relts p2
516 (cons (vector-ref rsets symbol)
518 (vector-set! rsets symbol p2)
519 (loop3 (+ r2 1) (+ p2 1)))
520 (loop (+ r2 1) s2 p2)))))
521 (loop (+ r1 1) s2 p))))))
522 (let loop ((s1 0) (s3 s2))
524 (let loop2 ((p (vector-ref rsets (vector-ref squeue s1))) (s4 s3))
526 (let* ((x (vector-ref relts p))
528 (y (- (vector-ref rcount ruleno) 1)))
529 (vector-set! rcount ruleno y)
531 (let ((symbol (vector-ref rlhs ruleno)))
532 (if (and (>= symbol 0)
533 (not (vector-ref nullable symbol)))
535 (vector-set! nullable symbol #t)
536 (vector-set! squeue s4 symbol)
537 (loop2 (car x) (+ s4 1)))
539 (loop2 (car x) s4))))
540 (loop (+ s1 1) s4)))))))))
544 ; Fonction set-firsts qui calcule un tableau de taille
545 ; nvars et qui donne, pour chaque non-terminal X, une liste des
546 ; non-terminaux pouvant apparaitre au debut d'une derivation a
550 (set! firsts (make-vector nvars '()))
555 (let loop2 ((sp (vector-ref derives i)))
558 (let ((sym (vector-ref ritem (vector-ref rrhs (car sp)))))
560 (vector-set! firsts i (sinsert sym (vector-ref firsts i))))
561 (loop2 (cdr sp)))))))
563 ;; -- reflexive and transitive closure
564 (let loop ((continue #t))
566 (let loop2 ((i 0) (cont #f))
569 (let* ((x (vector-ref firsts i))
570 (y (let loop3 ((l x) (z x))
574 (sunion (vector-ref firsts (car l)) z))))))
578 (vector-set! firsts i y)
579 (loop2 (+ i 1) #t))))))))
584 (vector-set! firsts i (sinsert i (vector-ref firsts i)))
590 ; Fonction set-fderives qui calcule un tableau de taille
591 ; nvars et qui donne, pour chaque non-terminal, une liste des regles pouvant
592 ; etre derivees a partir de ce non-terminal. (se sert de firsts)
594 (define (set-fderives)
595 (set! fderives (make-vector nvars #f))
601 (let ((x (let loop2 ((l (vector-ref firsts i)) (fd '()))
605 (sunion (vector-ref derives (car l)) fd))))))
606 (vector-set! fderives i x)
610 ; Fonction calculant la fermeture d'un ensemble d'items LR0
611 ; ou core est une liste d'items
613 (define (closure core)
615 (define ruleset (make-vector nrules #f))
617 (let loop ((csp core))
618 (if (not (null? csp))
619 (let ((sym (vector-ref ritem (car csp))))
621 (let loop2 ((dsp (vector-ref fderives sym)))
622 (if (not (null? dsp))
624 (vector-set! ruleset (car dsp) #t)
625 (loop2 (cdr dsp))))))
628 (let loop ((ruleno 1) (csp core) (itemsetv '())) ; ruleno = 0
629 (if (< ruleno nrules)
630 (if (vector-ref ruleset ruleno)
631 (let ((itemno (vector-ref rrhs ruleno)))
632 (let loop2 ((c csp) (itemsetv2 itemsetv))
635 (loop2 (cdr c) (cons (car c) itemsetv2))
636 (loop (+ ruleno 1) c (cons itemno itemsetv2)))))
637 (loop (+ ruleno 1) csp itemsetv))
638 (let loop2 ((c csp) (itemsetv2 itemsetv))
640 (loop2 (cdr c) (cons (car c) itemsetv2))
641 (reverse itemsetv2))))))
645 (define (allocate-item-sets)
646 (set! kernel-base (make-vector nsyms 0))
647 (set! kernel-end (make-vector nsyms #f)))
650 (define (allocate-storage)
652 (set! red-set (make-vector (+ nrules 1) 0)))
657 (define (initialize-states)
658 (let ((p (new-core)))
659 (set-core-number! p 0)
660 (set-core-acc-sym! p #f)
661 (set-core-nitems! p 1)
662 (set-core-items! p '(0))
664 (set! first-state (list p))
665 (set! last-state first-state)
670 (define (generate-states)
674 (let loop ((this-state first-state))
675 (if (pair? this-state)
676 (let* ((x (car this-state))
677 (is (closure (core-items x))))
678 (save-reductions x is)
683 (loop (cdr this-state))))))
686 ;; Fonction calculant les symboles sur lesquels il faut "shifter"
687 ;; et regroupe les items en fonction de ces symboles
689 (define (new-itemsets itemset)
691 (set! shift-symbol '())
695 (vector-set! kernel-end i '())
698 (let loop ((isp itemset))
701 (sym (vector-ref ritem i)))
704 (set! shift-symbol (sinsert sym shift-symbol))
705 (let ((x (vector-ref kernel-end sym)))
708 (vector-set! kernel-base sym (cons (+ i 1) x))
709 (vector-set! kernel-end sym (vector-ref kernel-base sym)))
711 (set-cdr! x (list (+ i 1)))
712 (vector-set! kernel-end sym (cdr x)))))))
715 (set! nshifts (length shift-symbol)))
719 (define (get-state sym)
720 (let* ((isp (vector-ref kernel-base sym))
722 (key (let loop ((isp1 isp) (k 0))
724 (modulo k STATE-TABLE-SIZE)
725 (loop (cdr isp1) (+ k (car isp1))))))
726 (sp (vector-ref state-table key)))
728 (let ((x (new-state sym)))
729 (vector-set! state-table key (list x))
732 (if (and (= n (core-nitems (car sp1)))
733 (let loop2 ((i1 isp) (t (core-items (car sp1))))
737 (loop2 (cdr i1) (cdr t))
739 (core-number (car sp1))
740 (if (null? (cdr sp1))
741 (let ((x (new-state sym)))
742 (set-cdr! sp1 (list x))
744 (loop (cdr sp1))))))))
747 (define (new-state sym)
748 (let* ((isp (vector-ref kernel-base sym))
751 (set-core-number! p nstates)
752 (set-core-acc-sym! p sym)
753 (if (= sym nvars) (set! final-state nstates))
754 (set-core-nitems! p n)
755 (set-core-items! p isp)
756 (set-cdr! last-state (list p))
757 (set! last-state (cdr last-state))
758 (set! nstates (+ nstates 1))
764 (define (append-states)
766 (let loop ((l (reverse shift-symbol)))
769 (cons (get-state (car l)) (loop (cdr l)))))))
773 (define (save-shifts core)
774 (let ((p (new-shift)))
775 (set-shift-number! p (core-number core))
776 (set-shift-nshifts! p nshifts)
777 (set-shift-shifts! p shift-set)
780 (set-cdr! last-shift (list p))
781 (set! last-shift (cdr last-shift)))
783 (set! first-shift (list p))
784 (set! last-shift first-shift)))))
786 (define (save-reductions core itemset)
787 (let ((rs (let loop ((l itemset))
790 (let ((item (vector-ref ritem (car l))))
792 (cons (- item) (loop (cdr l)))
796 (set-red-number! p (core-number core))
797 (set-red-nreds! p (length rs))
798 (set-red-rules! p rs)
801 (set-cdr! last-reduction (list p))
802 (set! last-reduction (cdr last-reduction)))
804 (set! first-reduction (list p))
805 (set! last-reduction first-reduction)))))))
811 (set! token-set-size (+ 1 (quotient nterms (BITS-PER-WORD))))
812 (set-accessing-symbol)
814 (set-reduction-table)
821 (compute-lookaheads))
823 (define (set-accessing-symbol)
824 (set! acces-symbol (make-vector nstates #f))
825 (let loop ((l first-state))
828 (vector-set! acces-symbol (core-number x) (core-acc-sym x))
831 (define (set-shift-table)
832 (set! shift-table (make-vector nstates #f))
833 (let loop ((l first-shift))
836 (vector-set! shift-table (shift-number x) x)
839 (define (set-reduction-table)
840 (set! reduction-table (make-vector nstates #f))
841 (let loop ((l first-reduction))
844 (vector-set! reduction-table (red-number x) x)
847 (define (set-max-rhs)
848 (let loop ((p 0) (curmax 0) (length 0))
849 (let ((x (vector-ref ritem p)))
852 (loop (+ p 1) curmax (+ length 1))
853 (loop (+ p 1) (max curmax length) 0))
854 (set! maxrhs curmax)))))
856 (define (initialize-LA)
862 (set! consistent (make-vector nstates #f))
863 (set! lookaheads (make-vector (+ nstates 1) #f))
865 (let loop ((count 0) (i 0))
868 (vector-set! lookaheads i count)
869 (let ((rp (vector-ref reduction-table i))
870 (sp (vector-ref shift-table i)))
872 (or (> (red-nreds rp) 1)
875 (< (vector-ref acces-symbol
876 (last (shift-shifts sp)))
878 (loop (+ count (red-nreds rp)) (+ i 1))
880 (vector-set! consistent i #t)
881 (loop count (+ i 1))))))
884 (vector-set! lookaheads nstates count)
885 (let ((c (max count 1)))
886 (set! LA (make-vector c #f))
887 (do ((j 0 (+ j 1))) ((= j c)) (vector-set! LA j (new-set token-set-size)))
888 (set! LAruleno (make-vector c -1))
889 (set! lookback (make-vector c #f)))
890 (let loop ((i 0) (np 0))
892 (if (vector-ref consistent i)
894 (let ((rp (vector-ref reduction-table i)))
896 (let loop2 ((j (red-rules rp)) (np2 np))
900 (vector-set! LAruleno np2 (car j))
901 (loop2 (cdr j) (+ np2 1)))))
902 (loop (+ i 1) np))))))))))
905 (define (set-goto-map)
906 (set! goto-map (make-vector (+ nvars 1) 0))
907 (let ((temp-map (make-vector (+ nvars 1) 0)))
908 (let loop ((ng 0) (sp first-shift))
910 (let loop2 ((i (reverse (shift-shifts (car sp)))) (ng2 ng))
912 (let ((symbol (vector-ref acces-symbol (car i))))
915 (vector-set! goto-map symbol
916 (+ 1 (vector-ref goto-map symbol)))
917 (loop2 (cdr i) (+ ng2 1)))
918 (loop2 (cdr i) ng2)))
919 (loop ng2 (cdr sp))))
921 (let loop ((k 0) (i 0))
924 (vector-set! temp-map i k)
925 (loop (+ k (vector-ref goto-map i)) (+ i 1)))
930 (vector-set! goto-map i (vector-ref temp-map i)))
933 (vector-set! goto-map nvars ngotos)
934 (vector-set! temp-map nvars ngotos)
935 (set! from-state (make-vector ngotos #f))
936 (set! to-state (make-vector ngotos #f))
938 (do ((sp first-shift (cdr sp)))
941 (state1 (shift-number x)))
942 (do ((i (shift-shifts x) (cdr i)))
944 (let* ((state2 (car i))
945 (symbol (vector-ref acces-symbol state2)))
947 (let ((k (vector-ref temp-map symbol)))
948 (vector-set! temp-map symbol (+ k 1))
949 (vector-set! from-state k state1)
950 (vector-set! to-state k state2))))))))))))))
953 (define (map-goto state symbol)
954 (let loop ((low (vector-ref goto-map symbol))
955 (high (- (vector-ref goto-map (+ symbol 1)) 1)))
958 (display (list "Error in map-goto" state symbol)) (newline)
960 (let* ((middle (quotient (+ low high) 2))
961 (s (vector-ref from-state middle)))
966 (loop (+ middle 1) high))
968 (loop low (- middle 1))))))))
971 (define (initialize-F)
972 (set! F (make-vector ngotos #f))
973 (do ((i 0 (+ i 1))) ((= i ngotos)) (vector-set! F i (new-set token-set-size)))
975 (let ((reads (make-vector ngotos #f)))
977 (let loop ((i 0) (rowp 0))
979 (let* ((rowf (vector-ref F rowp))
980 (stateno (vector-ref to-state i))
981 (sp (vector-ref shift-table stateno)))
983 (let loop2 ((j (shift-shifts sp)) (edges '()))
985 (let ((symbol (vector-ref acces-symbol (car j))))
987 (if (vector-ref nullable symbol)
988 (loop2 (cdr j) (cons (map-goto stateno symbol)
990 (loop2 (cdr j) edges))
992 (set-bit rowf (- symbol nvars))
993 (loop2 (cdr j) edges))))
995 (vector-set! reads i (reverse edges))))))
996 (loop (+ i 1) (+ rowp 1)))))
999 (define (add-lookback-edge stateno ruleno gotono)
1000 (let ((k (vector-ref lookaheads (+ stateno 1))))
1001 (let loop ((found #f) (i (vector-ref lookaheads stateno)))
1002 (if (and (not found) (< i k))
1003 (if (= (vector-ref LAruleno i) ruleno)
1005 (loop found (+ i 1)))
1008 (begin (display "Error in add-lookback-edge : ")
1009 (display (list stateno ruleno gotono)) (newline))
1010 (vector-set! lookback i
1011 (cons gotono (vector-ref lookback i))))))))
1014 (define (transpose r-arg n)
1015 (let ((new-end (make-vector n #f))
1016 (new-R (make-vector n #f)))
1019 (let ((x (list 'bidon)))
1020 (vector-set! new-R i x)
1021 (vector-set! new-end i x)))
1024 (let ((sp (vector-ref r-arg i)))
1026 (let loop ((sp2 sp))
1028 (let* ((x (car sp2))
1029 (y (vector-ref new-end x)))
1030 (set-cdr! y (cons i (cdr y)))
1031 (vector-set! new-end x (cdr y))
1032 (loop (cdr sp2))))))))
1035 (vector-set! new-R i (cdr (vector-ref new-R i))))
1041 (define (build-relations)
1043 (define (get-state stateno symbol)
1044 (let loop ((j (shift-shifts (vector-ref shift-table stateno)))
1048 (let ((st2 (car j)))
1049 (if (= (vector-ref acces-symbol st2) symbol)
1051 (loop (cdr j) st2))))))
1053 (set! includes (make-vector ngotos #f))
1056 (let ((state1 (vector-ref from-state i))
1057 (symbol1 (vector-ref acces-symbol (vector-ref to-state i))))
1058 (let loop ((rulep (vector-ref derives symbol1))
1061 (let ((*rulep (car rulep)))
1062 (let loop2 ((rp (vector-ref rrhs *rulep))
1064 (states (list state1)))
1065 (let ((*rp (vector-ref ritem rp)))
1067 (let ((st (get-state stateno *rp)))
1068 (loop2 (+ rp 1) st (cons st states)))
1071 (if (not (vector-ref consistent stateno))
1072 (add-lookback-edge stateno *rulep i))
1074 (let loop2 ((done #f)
1079 (let ((*rp (vector-ref ritem rp2)))
1080 (if (< -1 *rp nvars)
1081 (loop2 (not (vector-ref nullable *rp))
1084 (cons (map-goto (car stp) *rp) edgp))
1085 (loop2 #t stp rp2 edgp)))
1087 (loop (cdr rulep) edgp))))))))
1088 (vector-set! includes i edges)))))
1089 (set! includes (transpose includes ngotos)))
1093 (define (compute-lookaheads)
1094 (let ((n (vector-ref lookaheads nstates)))
1097 (let loop2 ((sp (vector-ref lookback i)))
1099 (let ((LA-i (vector-ref LA i))
1100 (F-j (vector-ref F (car sp))))
1101 (bit-union LA-i F-j token-set-size)
1103 (loop (+ i 1))))))))
1107 (define (digraph relation)
1108 (define infinity (+ ngotos 2))
1109 (define INDEX (make-vector (+ ngotos 1) 0))
1110 (define VERTICES (make-vector (+ ngotos 1) 0))
1114 (define (traverse i)
1115 (set! top (+ 1 top))
1116 (vector-set! VERTICES top i)
1118 (vector-set! INDEX i height)
1119 (let ((rp (vector-ref R i)))
1121 (let loop ((rp2 rp))
1123 (let ((j (car rp2)))
1124 (if (= 0 (vector-ref INDEX j))
1126 (if (> (vector-ref INDEX i)
1127 (vector-ref INDEX j))
1128 (vector-set! INDEX i (vector-ref INDEX j)))
1129 (let ((F-i (vector-ref F i))
1130 (F-j (vector-ref F j)))
1131 (bit-union F-i F-j token-set-size))
1132 (loop (cdr rp2))))))
1133 (if (= (vector-ref INDEX i) height)
1135 (let ((j (vector-ref VERTICES top)))
1136 (set! top (- top 1))
1137 (vector-set! INDEX j infinity)
1140 (bit-union (vector-ref F i)
1148 (if (and (= 0 (vector-ref INDEX i))
1149 (pair? (vector-ref R i)))
1156 (define (build-tables)
1157 (define (add-action St Sym Act)
1158 (let* ((x (vector-ref ACTION-TABLE St))
1161 (if (not (= Act (cdr y)))
1162 ;; -- there is a conflict
1164 (if (and (<= (cdr y) 0)
1167 (display "%% Reduce/Reduce conflict ")
1168 (display "(reduce ") (display (- Act))
1169 (display ", reduce ") (display (- (cdr y)))
1170 (display ") on ") (print-symbol (+ Sym nvars))
1171 (display " in state ") (display St)
1173 (set-cdr! y (max (cdr y) Act)))
1175 (display "%% Shift/Reduce conflict ")
1176 (display "(shift ") (display Act)
1177 (display ", reduce ") (display (- (cdr y)))
1178 (display ") on ") (print-symbol (+ Sym nvars))
1179 (display " in state ") (display St)
1181 (set-cdr! y Act)))))
1182 (vector-set! ACTION-TABLE St
1183 (cons (cons Sym Act) x)))))
1185 (set! action-table (make-vector nstates '()))
1187 (do ((i 0 (+ i 1))) ; i = state
1189 (let ((red (vector-ref reduction-table i)))
1190 (if (and red (>= (red-nreds red) 1))
1191 (if (and (= (red-nreds red) 1) (vector-ref consistent i))
1192 (add-action i 'default (- (car (red-rules red))))
1193 (let ((k (vector-ref lookaheads (+ i 1))))
1194 (let loop ((j (vector-ref lookaheads i)))
1196 (let ((rule (- (vector-ref LAruleno j)))
1197 (lav (vector-ref LA j)))
1198 (let loop2 ((token 0) (x (vector-ref lav 0)) (y 1) (z 0))
1199 (if (< token nterms)
1201 (let ((in-la-set? (modulo x 2)))
1202 (if (= in-la-set? 1)
1203 (add-action i token rule)))
1204 (if (= y (BITS-PER-WORD))
1206 (vector-ref lav (+ z 1))
1209 (loop2 (+ token 1) (quotient x 2) (+ y 1) z)))))
1210 (loop (+ j 1)))))))))
1212 (let ((shiftp (vector-ref shift-table i)))
1214 (let loop ((k (shift-shifts shiftp)))
1216 (let* ((state (car k))
1217 (symbol (vector-ref acces-symbol state)))
1218 (if (>= symbol nvars)
1219 (add-action i (- symbol nvars) state))
1220 (loop (cdr k))))))))
1222 (add-action final-state 0 'accept))
1224 (define (compact-action-table)
1225 (define (most-common-action acts)
1227 (let loop ((l acts))
1230 (y (assv x accums)))
1231 (if (and (number? x) (< x 0))
1233 (set-cdr! y (+ 1 (cdr y)))
1234 (set! accums (cons `(,x . 1) accums))))
1237 (let loop ((l accums) (max 0) (sym #f))
1242 (loop (cdr l) (cdr x) (car x))
1243 (loop (cdr l) max sym)))))))
1247 (let ((acts (vector-ref action-table i)))
1248 (if (vector? (vector-ref reduction-table i))
1249 (let ((act (most-common-action acts)))
1250 (vector-set! action-table i
1251 (cons `(default . ,(if act act 'error))
1253 (not (eq? (cdr x) act)))
1255 (vector-set! action-table i
1256 (cons `(default . *error*) acts))))))
1259 (define (output-action-table prefix)
1260 (display "(defconst ") (display prefix) (display "action-table") (newline)
1261 (display " [") (newline)
1265 (write (vector-ref action-table i))
1267 (display " ])") (newline)
1270 (define (output-goto-table prefix)
1271 (display "(defconst ") (display prefix) (display "goto-table") (newline)
1272 (display " [") (newline)
1276 (let ((shifts (vector-ref shift-table i)))
1280 (let loop ((l (shift-shifts shifts)))
1283 (let* ((state (car l))
1284 (symbol (vector-ref acces-symbol state)))
1285 (if (< symbol nvars)
1286 (display `(,symbol . ,state)))
1290 (display " ])") (newline)
1293 (define (output-reduction-table gram/actions prefix)
1294 (display "(defconst ") (display prefix) (display "reduction-table") (newline)
1295 (display " (vector") (newline)
1296 (display " '()") (newline)
1299 (let ((act (cdr p)))
1300 (display " (lambda (stack sp goto-table $look)") (newline)
1301 (let* ((nt (caar p)) (rhs (cdar p)) (n (length rhs)))
1302 (display " (let* (")
1304 (let loop ((i 1) (l rhs))
1306 (let ((rest (cdr l)))
1307 (if (> i 1) (begin (newline) (display " ")))
1308 (display "($") (display (+ (- n i) 1)) (display " ")
1309 (display "(aref stack (- sp ")
1310 (display (- (* i 2) 1))
1312 (loop (+ i 1) rest)))))
1317 (display "(accept $1)")
1319 (display "(lr-push stack (- sp ")
1323 (display " goto-table ")
1326 (display "))") (newline))))
1328 (display " ))") (newline)
1331 (define (output-header header parser-prefix)
1333 (display "(require 'lr-driver)") (newline)
1336 (define (output-footer footer)
1337 (display footer) (newline)
1340 (define (output-parser-def parser-prefix prefix)
1341 (display "(defun ") (display parser-prefix) (display "parse") (display "(scanner errorhandler)") (newline)
1342 (display " (lr-parse scanner errorhandler ") (newline)
1343 (display " ") (display prefix) (display "action-table") (newline)
1344 (display " ") (display prefix) (display "goto-table") (newline)
1345 (display " ") (display prefix) (display "reduction-table") (newline)
1346 (display " ") (display prefix) (display "token-defs))") (newline)
1349 (define (output-token-defs terms prefix)
1350 (let loop ((i 0) (l terms))
1353 (display "(defconst ") (display prefix)
1359 (loop (+ i 1) (cdr l)))))
1361 (display "(defconst ") (display prefix) (display "token-defs") (newline)
1362 (display " (list ") (newline)
1363 (let loop ((i 0) (l terms))
1368 (display " \"") (display (car l)) (display "\")")
1370 (loop (+ i 1) (cdr l)))))
1371 (display " ))") (newline)
1376 (define (rewrite-grammar grammar proc)
1380 (if (not (pair? grammar))
1381 (error "Grammar definition must be a non-empty list")
1382 (let loop1 ((lst grammar) (rev-terms '()))
1383 (if (and (pair? lst) (not (pair? (car lst)))) ; definition d'un terminal?
1384 (let ((term (car lst)))
1385 (cond ((not (valid-terminal? term))
1386 (error "Invalid terminal:" term))
1387 ((member term rev-terms)
1388 (error "Terminal previously defined:" term))
1390 (loop1 (cdr lst) (cons term rev-terms)))))
1391 (let loop2 ((lst lst) (rev-nonterm-defs '()))
1393 (let ((def (car lst)))
1394 (if (not (pair? def))
1395 (error "Nonterminal definition must be a non-empty list")
1396 (let ((nonterm (car def)))
1397 (cond ((not (valid-nonterminal? nonterm))
1398 (error "Invalid nonterminal:" nonterm))
1399 ((or (member nonterm rev-terms)
1400 (assoc nonterm rev-nonterm-defs))
1401 (error "Nonterminal previously defined:" nonterm))
1404 (cons def rev-nonterm-defs)))))))
1405 (let* ((terms (cons eoi (reverse rev-terms)))
1406 (nonterm-defs (reverse rev-nonterm-defs))
1407 (nonterms (cons '*start* (map car nonterm-defs))))
1408 (if (= (length nonterms) 1)
1409 (error "Grammar must contain at least one nonterminal")
1410 (let ((compiled-nonterminals
1411 (map (lambda (nonterm-def)
1412 (rewrite-nonterm-def nonterm-def
1415 (cons `(*start* (,(cadr nonterms) ,eoi) : $1)
1419 (map (lambda (x) (cons (caaar x) (map cdar x)))
1420 compiled-nonterminals)
1421 (apply append compiled-nonterminals)))))))))))
1424 (define (rewrite-nonterm-def nonterm-def terms nonterms)
1426 (define No-NT (length nonterms))
1429 (let ((PosInNT (pos-in-list x nonterms)))
1432 (let ((PosInT (pos-in-list x terms)))
1435 (error "undefined symbol : " x))))))
1437 (if (not (pair? (cdr nonterm-def)))
1438 (error "At least one production needed for nonterminal" (car nonterm-def))
1439 (let ((name (symbol->string (car nonterm-def))))
1440 (let loop1 ((lst (cdr nonterm-def))
1442 (rev-productions-and-actions '()))
1443 (if (not (pair? lst))
1444 (reverse rev-productions-and-actions)
1445 (let* ((rhs (car lst))
1447 (prod (map encode (cons (car nonterm-def) rhs))))
1448 (for-each (lambda (x)
1449 (if (not (or (member x terms) (member x nonterms)))
1450 (error "Invalid terminal or nonterminal" x)))
1452 (if (and (pair? rest)
1457 (cons (cons prod (cadr rest))
1458 rev-productions-and-actions))
1459 (let* ((rhs-length (length rhs))
1462 (cons (list 'QUOTE (string->symbol
1466 (number->string i))))
1468 (if (> j rhs-length)
1470 (cons (string->symbol
1473 (number->string j)))
1474 (loop-j (+ j 1)))))))))
1477 (cons (cons prod action)
1478 rev-productions-and-actions))))))))))
1480 (define (valid-nonterminal? x)
1483 (define (valid-terminal? x)
1486 ;; ---------------------------------------------------------------------- ;;
1488 ;; ---------------------------------------------------------------------- ;;
1489 (define (pos-in-list x lst)
1490 (let loop ((lst lst) (i 0))
1491 (cond ((not (pair? lst)) #f)
1492 ((equal? (car lst) x) i)
1493 (else (loop (cdr lst) (+ i 1))))))
1495 (define (sunion lst1 lst2) ; union of sorted lists
1496 (let loop ((L1 lst1)
1498 (cond ((null? L1) L2)
1501 (let ((x (car L1)) (y (car L2)))
1504 (cons y (loop L1 (cdr L2))))
1506 (cons x (loop (cdr L1) L2)))
1511 (define (sinsert elem lst)
1512 (let loop ((l1 lst))
1519 (cons x (loop (cdr l1))))
1523 (define (filter p lst)
1527 (let ((x (car l)) (y (cdr l)))
1532 ;; ---------------------------------------------------------------------- ;;
1533 ;; Debugging tools ... ;;
1534 ;; ---------------------------------------------------------------------- ;;
1535 (define the-terminals #f)
1536 (define the-nonterminals #f)
1538 (define (print-item item-no)
1539 (let loop ((i item-no))
1540 (let ((v (vector-ref ritem i)))
1544 (nt (vector-ref rlhs rlno)))
1545 (display (vector-ref the-nonterminals nt)) (display " --> ")
1546 (let loop ((i (vector-ref rrhs rlno)))
1547 (let ((v (vector-ref ritem i)))
1561 (define (print-symbol n)
1562 (display (if (>= n nvars)
1563 (vector-ref the-terminals (- n nvars))
1564 (vector-ref the-nonterminals n))))
1566 (define (print-states)
1567 (define (print-action act)
1570 (display " : Error"))
1572 (display " : Accept input"))
1574 (display " : reduce using rule ")
1577 (display " : shift and goto state ")
1582 (define (print-actions acts)
1583 (let loop ((l acts))
1586 (let ((sym (caar l))
1591 (display "default action"))
1593 (print-symbol (+ sym nvars))))
1597 (if (not action-table)
1599 (display "No generated parser available!")
1603 (display "State table") (newline)
1604 (display "-----------") (newline) (newline)
1606 (let loop ((l first-state))
1609 (let* ((core (car l))
1610 (i (core-number core))
1611 (items (core-items core))
1612 (actions (vector-ref action-table i)))
1613 (display "state ") (display i) (newline)
1615 (for-each (lambda (x) (display " ") (print-item x))
1618 (print-actions actions)
1620 (loop (cdr l))))))))