ikarus/lab/lalr.scm

;;;
;;;; An Efficient and Portable LALR(1) Parser Generator for Scheme
;;;
;;
;; @created   "Mon Jan 22 15:42:32 1996"
;; @modified  "Thu Feb 10 20:14:46 2005"
;; @author    "Dominique Boucher"
;; @version   "2.1.0"
;; @copyright "Dominique Boucher"
;; Copyright (C) 1984, 1989, 1990 Free Software Foundation, Inc.
;;   (for the Bison source code translated in Scheme)
;; Copyright (C) 1996-2003 Dominique Boucher
;;   (for the translation in Scheme)
;;
;;;
;;;; --
;;;; Introduction
;;;
;; This file contains yet another LALR(1) parser generator written in
;; Scheme. In contrast to other such parser generators, this one
;; implements a more efficient algorithm for computing the lookahead sets.
;; The algorithm is the same as used in Bison (GNU yacc) and is described
;; in the following paper:
;; 
;; @a "Efficient Computation of LALR(1) Look-Ahead Set", F. DeRemer and
;; T. Pennello, TOPLAS, vol. 4, no. 4, october 1982.
;; 
;; As a consequence, it is not written in a fully functional style.
;; In fact, much of the code is a direct translation from C to Scheme
;; of the Bison sources.
;; 
;; Dominique Boucher -- NuEcho Inc.
;; 
;; Send questions, comments or suggestions to
;; @email boucherd@iro.umontreal.ca
;;
;;;
;;;;   Portability
;;;
;; The program has been successfully tested on a number of Scheme
;; interpreters and compilers, including Gambit v3.0, MzScheme v103.5 and v200+,
;; SISC 1.5, Chicken, Kawa 1.7, and Guile 1.6.4.
;; 
;; It should be portable to any Scheme interpreter or compiler supporting
;; low-level, non-hygienic macros <20> la @c define-macro. If you port
;; @c lalr-scm to a new Scheme system and you want this port to be
;; included in the next releases, please send a request at:
;; @email boucherd@iro.umontreal.ca
;;
;;;
;;;;   Getting the distribution
;;;
;; The distribution can be obtained
;; @href ("http://www.iro.umontreal.ca/~boucherd/soft/lalr-2.0.taz"
;; "here").
;; 
;;;
;;;;   Installing the parser generator
;;;
;; To configure the parser generater under Unix or cygwin, simply type
;; @verbatim
;;    % make *scheme-system*
;; @endverbatim
;; where @a *scheme-system* is one of
;; @list
;; @item @c gambit
;; @item @c plt-scheme (v103 and v200)
;; @item @c sisc
;; @item @c chicken
;; @item @c bigloo
;; @item @c kawa
;; @item @c guile
;; @item @c stklos
;; @endlist
;; The exact list of supported Scheme systems may differ from this list.
;; Typing @c make without any argument will list all supported systems.
;; 
;; The configuration will generate a file @c lalr.scm containing the
;; code for the parser generator.
;;
;;;
;;;;   Acknowledgments
;;;
;; I would like to thank the following people for their contributions to this software:
;; @list
;; @item Scott G. Miller for the port to SISC
;; @item Rouben Rostamian for testing the port to Guile
;; @item Felix L. Winkelmann for the port to Chicken
;; @item Erick Gallesio for the port to STklos
;; @endlist
;;
;;;
;;;; --
;;;; Defining a parser
;;;
;; The file @c lalr.scm declares a macro called @link lalr-parser :
;; @verbatim
;;    (lalr-parser [options] tokens rules ...)
;; @endverbatim
;; To use this macro, you must first load @c lalr.scm in your Scheme
;; system using either @c load or the @c include special form in
;; Gambit-C.
;; 
;; This macro, when given appropriate arguments, generates an LALR(1)
;; syntax analyzer.  The macro accepts at least two arguments. The first
;; is a list of symbols which represent the terminal symbols of the
;; grammar. The remaining arguments are the grammar production rules. See
;; section @ref format for further details.
;;;
;;;; --
;;;; Running the parser
;;;
;; The parser generated by the @code lalr-parser macro is a function that
;; takes two parameters. The first parameter is a lexical analyzer while
;; the second is an error procedure.
;; 
;; The lexical analyzer is zero-argument function (a thunk)
;; invoked each time the parser needs to look-ahead in the token stream.
;; A token is usually a pair whose @c car is the symbol corresponding to
;; the token (the same symbol as used in the grammar definition). The
;; @c cdr of the pair is the semantic value associated with the token. For
;; example, a string token would have the @c car set to @c ('string)
;; while the @c cdr is set to the string value @c "hello".
;; 
;; Once the end of file is encountered, the lexical analyzer must always
;; return the symbol @c ('*eoi*) each time it is invoked.
;; 
;; The error procedure must be a function that accepts at least two
;; parameters.
;;;
;;;; --
;;;; The grammar format
;;;
;; The grammar is specified by first giving the list of terminals and the
;; list of non-terminal definitions. Each non-terminal definition
;; is a list where the first element is the non-terminal and the other
;; elements are the right-hand sides (lists of grammar symbols). In
;; addition to this, each rhs can be followed by a semantic action.
;; 
;; For example, consider the following (yacc) grammar for a very simple
;; expression language:
;; @verbatim
;;   e : e '+' t
;;     | e '-' t
;;     | t
;;     ;
;;   t : t '*' f
;;     : t '/' f
;;     | f
;;     ;
;;   f : ID
;;     ;
;; @endverbatim
;; The same grammar, written for the scheme parser generator, would look
;; like this (with semantic actions)
;; @verbatim
;; (define expr-parser
;;   (lalr-parser
;;    ; Terminal symbols
;;    (ID + - * /)
;;    ; Productions
;;    (e (e + t)    : (+ $1 $3)
;;       (e - t)    : (- $1 $3)
;;       (t)        : $1)
;;    (t (t * f)    : (* $1 $3)
;;       (t / f)    : (/ $1 $3)
;;       (f)        : $1)
;;    (f (ID)       : $1)))
;; @endverbatim
;; In semantic actions, the symbol @c $n refers to the synthesized
;; attribute value of the nth symbol in the production. The value
;; associated with the non-terminal on the left is the result of
;; evaluating the semantic action (it defaults to @c #f).
;; 
;;;
;;;;   Operator precedence and associativity
;;;
;; The above grammar implicitly handles operator precedences. It is also
;; possible to explicitly assign precedences and associativity to
;; terminal symbols and productions @a "<22> la" Yacc. Here is a modified
;; (and augmented) version of the grammar:
;; @verbatim
;; (define expr-parser
;;  (lalr-parser
;;   ; Terminal symbols
;;   (ID
;;    (left: + -)
;;    (left: * /)
;;    (nonassoc: uminus))
;;   (e (e + e)              : (+ $1 $3)
;;      (e - e)              : (- $1 $3)
;;      (e * e)              : (* $1 $3)
;;      (e / e)              : (/ $1 $3)
;;      (- e (prec: uminus)) : (- $2)
;;      (ID)                 : $1)))
;; @endverbatim
;; The @c left: directive is used to specify a set of left-associative
;; operators of the same precedence level, the @c right: directive for
;; right-associative operators, and @c nonassoc: for operators that
;; are not associative. Note the use of the (apparently) useless
;; terminal @c uminus. It is only defined in order to assign to the
;; penultimate rule a precedence level higher than that of @c * and
;; @c /. The @c prec: directive can only appear as the last element of a
;; rule. Finally, note that precedence levels are incremented from
;; left to right, i.e. the precedence level of @c + and @c - is less
;; than the precedence level of @c * and @c / since the formers appear
;; first in the list of terminal symbols (token definitions).
;; 
;;;
;;;;   Options
;;;
;; The following options are available.
;; @list
;; @item (@c output: @a name @a filename) - copies the parser to the given
;;   file. The parser is given the name @c name.
;; @item (@c out-tables: @a filename)  - outputs the parsing tables in
;;   @a filename in a more readable format
;; @item (@c expect: @a n) - don't warn about conflits if there are
;;   @a n or less conflicts.
;; @endlist
;;
;;;
;;;; --
;;;; A final note on conflict resolution
;;;
;; Conflicts in the grammar are handled in a conventional way.
;; In the absence of precedence directives,
;; Shift/Reduce conflicts are resolved by shifting, and Reduce/Reduce
;; conflicts are resolved by choosing the rule listed first in the
;; grammar definition.
;; 
;; You can print the states of the generated parser by evaluating
;; @c (print-states). The format of the output is similar to the one
;; produced by bison when given the -v command-line option.
;; 
;;;
;;;; --
;;;; Redistribution
;;;
;; @c lalr.scm is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; 
;; @c lalr.scm is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;; 
;; You should have received a copy of the GNU General Public License
;; along with @c lalr.scm; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.


; ---------- SYSTEM DEPENDENT SECTION -----------------

(library (lalr)
  (export lalr-parser)
  (import (rnrs) (rnrs r5rs) (rnrs mutable-pairs))


(define (lalr-error string . args) 
  (apply error 'lalr string args))

(define lalr-keyword? symbol?)

(define (pprint x)
  (write x)
  (newline))
; ---------- END OF SYSTEM DEPENDENT SECTION ------------

; - Macros pour la gestion des vecteurs de bits


(define (set-bit v b)
  (let ((x (quotient b (fixnum-width)))
	(y (expt 2 (remainder b (fixnum-width)))))
    (vector-set! v x (bitwise-ior (vector-ref v x) y))))

(define (bit-union v1 v2 n)
  (do ((i 0 (+ i 1)))
      ((= i n))
     (vector-set! v1 i (bitwise-ior (vector-ref v1 i) 
				   (vector-ref v2 i)))))

; - Macro pour les structures de donnees

(define (new-core)              (make-vector 4 0))
(define (set-core-number! c n)  (vector-set! c 0 n))
(define (set-core-acc-sym! c s) (vector-set! c 1 s))
(define (set-core-nitems! c n)  (vector-set! c 2 n))
(define (set-core-items! c i)   (vector-set! c 3 i))
(define (core-number c)         (vector-ref c 0))
(define (core-acc-sym c)        (vector-ref c 1))
(define (core-nitems c)         (vector-ref c 2))
(define (core-items c)          (vector-ref c 3))

(define (new-shift)              (make-vector 3 0))
(define (set-shift-number! c x)  (vector-set! c 0 x))
(define (set-shift-nshifts! c x) (vector-set! c 1 x))
(define (set-shift-shifts! c x)  (vector-set! c 2 x))
(define (shift-number s)         (vector-ref s 0))
(define (shift-nshifts s)        (vector-ref s 1))
(define (shift-shifts s)         (vector-ref s 2))

(define (new-red)                (make-vector 3 0))
(define (set-red-number! c x)    (vector-set! c 0 x))
(define (set-red-nreds! c x)     (vector-set! c 1 x))
(define (set-red-rules! c x)     (vector-set! c 2 x))
(define (red-number c)           (vector-ref c 0))
(define (red-nreds c)            (vector-ref c 1))
(define (red-rules c)            (vector-ref c 2))



(define (new-set nelem)
  (make-vector nelem 0))


; in R6RS
;(define (vector-map f v)
;  (let ((vm-n (- (vector-length v) 1)))
;    (let loop ((vm-low 0) (vm-high vm-n))
;      (if (= vm-low vm-high)
;	  (vector-set! v vm-low (f (vector-ref v vm-low) vm-low))
;	  (let ((vm-middle (quotient (+ vm-low vm-high) 2)))
;	    (loop vm-low vm-middle)
;	    (loop (+ vm-middle 1) vm-high))))))


;; - Constantes
(define STATE-TABLE-SIZE 1009)


;; - Tableaux 
(define rrhs         #f)
(define rlhs         #f)
(define ritem        #f)
(define nullable     #f)
(define derives      #f)
(define fderives     #f)
(define firsts       #f)
(define kernel-base  #f)
(define kernel-end   #f)
(define shift-symbol #f)
(define shift-set    #f)
(define red-set      #f)
(define state-table  #f)
(define acces-symbol #f)
(define reduction-table #f)
(define shift-table  #f)
(define consistent   #f)
(define lookaheads   #f)
(define LA           #f)
(define LAruleno     #f)
(define lookback     #f)
(define goto-map     #f)
(define from-state   #f)
(define to-state     #f)
(define includes     #f)
(define F            #f)
(define action-table #f)

;; - Variables
(define nitems          #f)
(define nrules          #f)
(define nvars           #f)
(define nterms          #f)
(define nsyms           #f)
(define nstates         #f)
(define first-state     #f)
(define last-state      #f)
(define final-state     #f)
(define first-shift     #f)
(define last-shift      #f)
(define first-reduction #f)
(define last-reduction  #f)
(define nshifts         #f)
(define maxrhs          #f)
(define ngotos          #f)
(define token-set-size  #f)

(define (gen-tables! tokens gram )
  (initialize-all)
  (rewrite-grammar 
   tokens
   gram
   (lambda (terms terms/prec vars gram gram/actions)
     (set! the-terminals/prec (list->vector terms/prec))
     (set! the-terminals (list->vector terms))
     (set! the-nonterminals (list->vector vars))
     (set! nterms (length terms))
     (set! nvars  (length vars))
     (set! nsyms  (+ nterms nvars))
     (let ((no-of-rules (length gram/actions))
	   (no-of-items (let loop ((l gram/actions) (count 0))
			  (if (null? l) 
			      count
			      (loop (cdr l) (+ count (length (caar l))))))))
       (pack-grammar no-of-rules no-of-items gram)
       (set-derives)
       (set-nullable)
       (generate-states)
       (lalr)
       (build-tables)
       (compact-action-table terms)
       gram/actions))))


(define (initialize-all)
  (set! rrhs         #f)
  (set! rlhs         #f)
  (set! ritem        #f)
  (set! nullable     #f)
  (set! derives      #f)
  (set! fderives     #f)
  (set! firsts       #f)
  (set! kernel-base  #f)
  (set! kernel-end   #f)
  (set! shift-symbol #f)
  (set! shift-set    #f)
  (set! red-set      #f)
  (set! state-table  (make-vector STATE-TABLE-SIZE '()))
  (set! acces-symbol #f)
  (set! reduction-table #f)
  (set! shift-table  #f)
  (set! consistent   #f)
  (set! lookaheads   #f)
  (set! LA           #f)
  (set! LAruleno     #f)
  (set! lookback     #f)
  (set! goto-map     #f)
  (set! from-state   #f)
  (set! to-state     #f)
  (set! includes     #f)
  (set! F            #f)
  (set! action-table #f)
  (set! nstates         #f)
  (set! first-state     #f)
  (set! last-state      #f)
  (set! final-state     #f)
  (set! first-shift     #f)
  (set! last-shift      #f)
  (set! first-reduction #f)
  (set! last-reduction  #f)
  (set! nshifts         #f)
  (set! maxrhs          #f)
  (set! ngotos          #f)
  (set! token-set-size  #f)
  (set! rule-precedences '()))


(define (pack-grammar no-of-rules no-of-items gram)
  (set! nrules (+  no-of-rules 1))
  (set! nitems no-of-items)
  (set! rlhs (make-vector nrules #f))
  (set! rrhs (make-vector nrules #f))
  (set! ritem (make-vector (+ 1 nitems) #f))

  (let loop ((p gram) (item-no 0) (rule-no 1))
	(if (not (null? p))
	(let ((nt (caar p)))
	  (let loop2 ((prods (cdar p)) (it-no2 item-no) (rl-no2 rule-no))
		(if (null? prods)
		(loop (cdr p) it-no2 rl-no2)
		(begin
		  (vector-set! rlhs rl-no2 nt)
		  (vector-set! rrhs rl-no2 it-no2)
		  (let loop3 ((rhs (car prods)) (it-no3 it-no2))
			(if (null? rhs)
			(begin
			  (vector-set! ritem it-no3 (- rl-no2))
			  (loop2 (cdr prods) (+ it-no3 1) (+ rl-no2 1)))
			(begin
			  (vector-set! ritem it-no3 (car rhs))
			  (loop3 (cdr rhs) (+ it-no3 1))))))))))))


; Fonction set-derives
; --------------------
(define (set-derives)
  (define delts (make-vector (+ nrules 1) 0))
  (define dset  (make-vector nvars -1))

  (let loop ((i 1) (j 0))		; i = 0
    (if (< i nrules)
	(let ((lhs (vector-ref rlhs i)))
	  (if (>= lhs 0)
	      (begin
		(vector-set! delts j (cons i (vector-ref dset lhs)))
		(vector-set! dset lhs j)
		(loop (+ i 1) (+ j 1)))
	      (loop (+ i 1) j)))))
  
  (set! derives (make-vector nvars 0))
  
  (let loop ((i 0))
    (if (< i nvars)
	(let ((q (let loop2 ((j (vector-ref dset i)) (s '()))
		   (if (< j 0)
		       s
		       (let ((x (vector-ref delts j)))
			 (loop2 (cdr x) (cons (car x) s)))))))
	  (vector-set! derives i q)
	  (loop (+ i 1))))))



(define (set-nullable)
  (set! nullable (make-vector nvars #f))
  (let ((squeue (make-vector nvars #f))
	(rcount (make-vector (+ nrules 1) 0))
	(rsets  (make-vector nvars #f))
	(relts  (make-vector (+ nitems nvars 1) #f)))
    (let loop ((r 0) (s2 0) (p 0))
      (let ((*r (vector-ref ritem r)))
	(if *r
	    (if (< *r 0)
		(let ((symbol (vector-ref rlhs (- *r))))
		  (if (and (>= symbol 0)
			   (not (vector-ref nullable symbol)))
		      (begin
			(vector-set! nullable symbol #t)
			(vector-set! squeue s2 symbol)
			(loop (+ r 1) (+ s2 1) p))))
		(let loop2 ((r1 r) (any-tokens #f))
		  (let* ((symbol (vector-ref ritem r1)))
		    (if (> symbol 0)
			(loop2 (+ r1 1) (or any-tokens (>= symbol nvars)))
			(if (not any-tokens)
			    (let ((ruleno (- symbol)))
			      (let loop3 ((r2 r) (p2 p))
				(let ((symbol (vector-ref ritem r2)))
				  (if (> symbol 0)
				      (begin
					(vector-set! rcount ruleno
						     (+ (vector-ref rcount ruleno) 1))
					(vector-set! relts p2
						     (cons (vector-ref rsets symbol)
							   ruleno))
					(vector-set! rsets symbol p2)
					(loop3 (+ r2 1) (+ p2 1)))
				      (loop (+ r2 1) s2 p2)))))
			    (loop (+ r1 1) s2 p))))))
	    (let loop ((s1 0) (s3 s2))
	      (if (< s1 s3)
		  (let loop2 ((p (vector-ref rsets (vector-ref squeue s1))) (s4 s3))
		    (if p 
			(let* ((x (vector-ref relts p))
			       (ruleno (cdr x))
			       (y (- (vector-ref rcount ruleno) 1)))
			  (vector-set! rcount ruleno y)
			  (if (= y 0)
			      (let ((symbol (vector-ref rlhs ruleno)))
				(if (and (>= symbol 0)
					 (not (vector-ref nullable symbol)))
				    (begin
				      (vector-set! nullable symbol #t)
				      (vector-set! squeue s4 symbol)
				      (loop2 (car x) (+ s4 1)))
				    (loop2 (car x) s4)))
			      (loop2 (car x) s4))))
		    (loop (+ s1 1) s4)))))))))
		  


; Fonction set-firsts qui calcule un tableau de taille
; nvars et qui donne, pour chaque non-terminal X, une liste des
; non-terminaux pouvant apparaitre au debut d'une derivation a
; partir de X.

(define (set-firsts)
  (set! firsts (make-vector nvars '()))
  
  ;; -- initialization
  (let loop ((i 0))
    (if (< i nvars)
	(let loop2 ((sp (vector-ref derives i)))
	  (if (null? sp)
	      (loop (+ i 1))
	      (let ((sym (vector-ref ritem (vector-ref rrhs (car sp)))))
		(if (< -1 sym nvars)
		    (vector-set! firsts i (sinsert sym (vector-ref firsts i))))
		(loop2 (cdr sp)))))))

  ;; -- reflexive and transitive closure
  (let loop ((continue #t))
    (if continue
	(let loop2 ((i 0) (cont #f))
	  (if (>= i nvars)
	      (loop cont)
	      (let* ((x (vector-ref firsts i))
		     (y (let loop3 ((l x) (z x))
			  (if (null? l)
			      z
			      (loop3 (cdr l)
				     (sunion (vector-ref firsts (car l)) z))))))
		(if (equal? x y)
		    (loop2 (+ i 1) cont)
		    (begin
		      (vector-set! firsts i y)
		      (loop2 (+ i 1) #t))))))))
  
  (let loop ((i 0))
    (if (< i nvars)
	(begin
	  (vector-set! firsts i (sinsert i (vector-ref firsts i)))
	  (loop (+ i 1))))))




; Fonction set-fderives qui calcule un tableau de taille
; nvars et qui donne, pour chaque non-terminal, une liste des regles pouvant
; etre derivees a partir de ce non-terminal. (se sert de firsts)

(define (set-fderives)
  (set! fderives (make-vector nvars #f))

  (set-firsts)

  (let loop ((i 0))
    (if (< i nvars)
	(let ((x (let loop2 ((l (vector-ref firsts i)) (fd '()))
		   (if (null? l) 
		       fd
		       (loop2 (cdr l) 
			      (sunion (vector-ref derives (car l)) fd))))))
	  (vector-set! fderives i x)
	  (loop (+ i 1))))))


; Fonction calculant la fermeture d'un ensemble d'items LR0
; ou core est une liste d'items

(define (closure core)
  ;; Initialization
  (define ruleset (make-vector nrules #f))

  (let loop ((csp core))
    (if (not (null? csp))
	(let ((sym (vector-ref ritem (car csp))))
	  (if (< -1 sym nvars)
	      (let loop2 ((dsp (vector-ref fderives sym)))
		(if (not (null? dsp))
		    (begin
		      (vector-set! ruleset (car dsp) #t)
		      (loop2 (cdr dsp))))))
	  (loop (cdr csp)))))

  (let loop ((ruleno 1) (csp core) (itemsetv '())) ; ruleno = 0
    (if (< ruleno nrules)
	(if (vector-ref ruleset ruleno)
	    (let ((itemno (vector-ref rrhs ruleno)))
	      (let loop2 ((c csp) (itemsetv2 itemsetv))
		(if (and (pair? c)
			 (< (car c) itemno))
		    (loop2 (cdr c) (cons (car c) itemsetv2))
		    (loop (+ ruleno 1) c (cons itemno itemsetv2)))))
	    (loop (+ ruleno 1) csp itemsetv))
	(let loop2 ((c csp) (itemsetv2 itemsetv))
	  (if (pair? c)
	      (loop2 (cdr c) (cons (car c) itemsetv2))
	      (reverse itemsetv2))))))



(define (allocate-item-sets)
  (set! kernel-base (make-vector nsyms 0))
  (set! kernel-end  (make-vector nsyms #f)))


(define (allocate-storage)
  (allocate-item-sets)
  (set! red-set (make-vector (+ nrules 1) 0)))

; --


(define (initialize-states)
  (let ((p (new-core)))
    (set-core-number! p 0)
    (set-core-acc-sym! p #f)
    (set-core-nitems! p 1)
    (set-core-items! p '(0))

    (set! first-state (list p))
    (set! last-state first-state)
    (set! nstates 1)))



(define (generate-states)
  (allocate-storage)
  (set-fderives)
  (initialize-states)
  (let loop ((this-state first-state))
    (if (pair? this-state)
	(let* ((x (car this-state))
	       (is (closure (core-items x))))
	  (save-reductions x is)
	  (new-itemsets is)
	  (append-states)
	  (if (> nshifts 0)
	      (save-shifts x))
	  (loop (cdr this-state))))))


; Fonction calculant les symboles sur lesquels il faut "shifter" 
; et regroupe les items en fonction de ces symboles

(define (new-itemsets itemset)
  ;; - Initialization
  (set! shift-symbol '())
  (let loop ((i 0))
    (if (< i nsyms)
	(begin
	  (vector-set! kernel-end i '())
	  (loop (+ i 1)))))

  (let loop ((isp itemset))
    (if (pair? isp)
	(let* ((i (car isp))
	       (sym (vector-ref ritem i)))
	  (if (>= sym 0)
	      (begin
		(set! shift-symbol (sinsert sym shift-symbol))
		(let ((x (vector-ref kernel-end sym)))
		  (if (null? x)
		      (begin
			(vector-set! kernel-base sym (cons (+ i 1) x))
			(vector-set! kernel-end sym (vector-ref kernel-base sym)))
		      (begin
			(set-cdr! x (list (+ i 1)))
			(vector-set! kernel-end sym (cdr x)))))))
	  (loop (cdr isp)))))

  (set! nshifts (length shift-symbol)))



(define (get-state sym)
  (let* ((isp  (vector-ref kernel-base sym))
	 (n    (length isp))
	 (key  (let loop ((isp1 isp) (k 0))
		 (if (null? isp1)
		     (modulo k STATE-TABLE-SIZE)
		     (loop (cdr isp1) (+ k (car isp1))))))
	 (sp   (vector-ref state-table key)))
    (if (null? sp)
	(let ((x (new-state sym)))
	  (vector-set! state-table key (list x))
	  (core-number x))
	(let loop ((sp1 sp))
	  (if (and (= n (core-nitems (car sp1)))
		   (let loop2 ((i1 isp) (t (core-items (car sp1)))) 
		     (if (and (pair? i1) 
			      (= (car i1)
				 (car t)))
			 (loop2 (cdr i1) (cdr t))
			 (null? i1))))
	      (core-number (car sp1))
	      (if (null? (cdr sp1))
		  (let ((x (new-state sym)))
		    (set-cdr! sp1 (list x))
		    (core-number x))
		  (loop (cdr sp1))))))))


(define (new-state sym)
  (let* ((isp  (vector-ref kernel-base sym))
	 (n    (length isp))
	 (p    (new-core)))
    (set-core-number! p nstates)
    (set-core-acc-sym! p sym)
    (if (= sym nvars) (set! final-state nstates))
    (set-core-nitems! p n)
    (set-core-items! p isp)
    (set-cdr! last-state (list p))
    (set! last-state (cdr last-state))
    (set! nstates (+ nstates 1))
    p))


; --

(define (append-states)
  (set! shift-set
	(let loop ((l (reverse shift-symbol)))
	  (if (null? l)
	      '()
	      (cons (get-state (car l)) (loop (cdr l)))))))

; --

(define (save-shifts core)
  (let ((p (new-shift)))
	(set-shift-number! p (core-number core))
	(set-shift-nshifts! p nshifts)
	(set-shift-shifts! p shift-set)
	(if last-shift
	(begin
	  (set-cdr! last-shift (list p))
	  (set! last-shift (cdr last-shift)))
	(begin
	  (set! first-shift (list p))
	  (set! last-shift first-shift)))))

(define (save-reductions core itemset)
  (let ((rs (let loop ((l itemset))
	      (if (null? l)
		  '()
		  (let ((item (vector-ref ritem (car l))))
		    (if (< item 0)
			(cons (- item) (loop (cdr l)))
			(loop (cdr l))))))))
    (if (pair? rs)
	(let ((p (new-red)))
	  (set-red-number! p (core-number core))
	  (set-red-nreds!  p (length rs))
	  (set-red-rules!  p rs)
	  (if last-reduction
	      (begin
		(set-cdr! last-reduction (list p))
		(set! last-reduction (cdr last-reduction)))
	      (begin
		(set! first-reduction (list p))
		(set! last-reduction first-reduction)))))))


; --

(define (lalr)
  (set! token-set-size (+ 1 (quotient nterms (fixnum-width))))
  (set-accessing-symbol)
  (set-shift-table)
  (set-reduction-table)
  (set-max-rhs)
  (initialize-LA)
  (set-goto-map)
  (initialize-F)
  (build-relations)
  (digraph includes)
  (compute-lookaheads))

(define (set-accessing-symbol)
  (set! acces-symbol (make-vector nstates #f))
  (let loop ((l first-state))
    (if (pair? l)
	(let ((x (car l)))
	  (vector-set! acces-symbol (core-number x) (core-acc-sym x))
	  (loop (cdr l))))))

(define (set-shift-table)
  (set! shift-table (make-vector nstates #f))
  (let loop ((l first-shift))
    (if (pair? l)
	(let ((x (car l)))
	  (vector-set! shift-table (shift-number x) x)
	  (loop (cdr l))))))

(define (set-reduction-table)
  (set! reduction-table (make-vector nstates #f))
  (let loop ((l first-reduction))
    (if (pair? l)
	(let ((x (car l)))
	  (vector-set! reduction-table (red-number x) x)
	  (loop (cdr l))))))

(define (set-max-rhs)
  (let loop ((p 0) (curmax 0) (length 0))
    (let ((x (vector-ref ritem p)))
      (if x
	  (if (>= x 0)
	      (loop (+ p 1) curmax (+ length 1))
	      (loop (+ p 1) (max curmax length) 0))
	  (set! maxrhs curmax)))))

(define (initialize-LA)
  (define (last l)
    (if (null? (cdr l))
	(car l)
	(last (cdr l))))

  (set! consistent (make-vector nstates #f))
  (set! lookaheads (make-vector (+ nstates 1) #f))

  (let loop ((count 0) (i 0))
    (if (< i nstates)
	(begin
	  (vector-set! lookaheads i count)
	  (let ((rp (vector-ref reduction-table i))
		(sp (vector-ref shift-table i)))
	    (if (and rp
		     (or (> (red-nreds rp) 1)
			 (and sp
			      (not
			       (< (vector-ref acces-symbol
					      (last (shift-shifts sp)))
				  nvars)))))
		(loop (+ count (red-nreds rp)) (+ i 1))
		(begin
		  (vector-set! consistent i #t)
		  (loop count (+ i 1))))))

	(begin
	  (vector-set! lookaheads nstates count)
	  (let ((c (max count 1)))
	    (set! LA (make-vector c #f))
	    (do ((j 0 (+ j 1))) ((= j c)) (vector-set! LA j (new-set token-set-size)))
	    (set! LAruleno (make-vector c -1))
	    (set! lookback (make-vector c #f)))
	  (let loop ((i 0) (np 0))
	    (if (< i nstates)
		(if (vector-ref consistent i)
		    (loop (+ i 1) np)
		    (let ((rp (vector-ref reduction-table i)))
		      (if rp
			  (let loop2 ((j (red-rules rp)) (np2 np))
			    (if (null? j)
				(loop (+ i 1) np2)
				(begin
				  (vector-set! LAruleno np2 (car j))
				  (loop2 (cdr j) (+ np2 1)))))
			  (loop (+ i 1) np))))))))))


(define (set-goto-map)
  (set! goto-map (make-vector (+ nvars 1) 0))
  (let ((temp-map (make-vector (+ nvars 1) 0)))
    (let loop ((ng 0) (sp first-shift))
      (if (pair? sp)
	  (let loop2 ((i (reverse (shift-shifts (car sp)))) (ng2 ng))
	    (if (pair? i)
		(let ((symbol (vector-ref acces-symbol (car i))))
		  (if (< symbol nvars)
		      (begin
			(vector-set! goto-map symbol 
				     (+ 1 (vector-ref goto-map symbol)))
			(loop2 (cdr i) (+ ng2 1)))
		      (loop2 (cdr i) ng2)))
		(loop ng2 (cdr sp))))

	  (let loop ((k 0) (i 0))
	    (if (< i nvars)
		(begin
		  (vector-set! temp-map i k)
		  (loop (+ k (vector-ref goto-map i)) (+ i 1)))

		(begin
		  (do ((i 0 (+ i 1)))
		      ((>= i nvars))
		    (vector-set! goto-map i (vector-ref temp-map i)))

		  (set! ngotos ng)
		  (vector-set! goto-map nvars ngotos)
		  (vector-set! temp-map nvars ngotos)
		  (set! from-state (make-vector ngotos #f))
		  (set! to-state (make-vector ngotos #f))
		  
		  (do ((sp first-shift (cdr sp)))
		      ((null? sp))
		    (let* ((x (car sp))
			   (state1 (shift-number x)))
		      (do ((i (shift-shifts x) (cdr i)))
			  ((null? i))
			(let* ((state2 (car i))
			       (symbol (vector-ref acces-symbol state2)))
			  (if (< symbol nvars)
			      (let ((k (vector-ref temp-map symbol)))
				(vector-set! temp-map symbol (+ k 1))
				(vector-set! from-state k state1)
				(vector-set! to-state k state2))))))))))))))


(define (map-goto state symbol)
  (let loop ((low (vector-ref goto-map symbol))
	     (high (- (vector-ref goto-map (+ symbol 1)) 1)))
    (if (> low high)
	(begin
	  (display (list "Error in map-goto" state symbol)) (newline)
	  0)
	(let* ((middle (quotient (+ low high) 2))
	       (s (vector-ref from-state middle)))
	  (cond
	   ((= s state)
	    middle)
	   ((< s state)
	    (loop (+ middle 1) high))
	   (else
	    (loop low (- middle 1))))))))


(define (initialize-F)
  (set! F (make-vector ngotos #f))
  (do ((i 0 (+ i 1))) ((= i ngotos)) (vector-set! F i (new-set token-set-size)))

  (let ((reads (make-vector ngotos #f)))

    (let loop ((i 0) (rowp 0))
      (if (< i ngotos)
	  (let* ((rowf (vector-ref F rowp))
		 (stateno (vector-ref to-state i))
		 (sp (vector-ref shift-table stateno)))
	    (if sp
		(let loop2 ((j (shift-shifts sp)) (edges '()))
		  (if (pair? j)
		      (let ((symbol (vector-ref acces-symbol (car j))))
			(if (< symbol nvars)
			    (if (vector-ref nullable symbol)
				(loop2 (cdr j) (cons (map-goto stateno symbol) 
						     edges))
				(loop2 (cdr j) edges))
			    (begin
			      (set-bit rowf (- symbol nvars))
			      (loop2 (cdr j) edges))))
		      (if (pair? edges)
			  (vector-set! reads i (reverse edges))))))
	      (loop (+ i 1) (+ rowp 1)))))
    (digraph reads)))

(define (add-lookback-edge stateno ruleno gotono)
  (let ((k (vector-ref lookaheads (+ stateno 1))))
    (let loop ((found #f) (i (vector-ref lookaheads stateno)))
      (if (and (not found) (< i k))
	  (if (= (vector-ref LAruleno i) ruleno)
	      (loop #t i)
	      (loop found (+ i 1)))

	  (if (not found)
	      (begin (display "Error in add-lookback-edge : ")
		     (display (list stateno ruleno gotono)) (newline))
	      (vector-set! lookback i
			   (cons gotono (vector-ref lookback i))))))))


(define (transpose r-arg n)
  (let ((new-end (make-vector n #f))
	(new-R  (make-vector n #f)))
    (do ((i 0 (+ i 1))) 
	((= i n))
      (let ((x (list 'bidon)))
	(vector-set! new-R i x)
	(vector-set! new-end i x)))
    (do ((i 0 (+ i 1)))
	((= i n))
      (let ((sp (vector-ref r-arg i)))
	(if (pair? sp)
	    (let loop ((sp2 sp))
	      (if (pair? sp2)
		  (let* ((x (car sp2))
			 (y (vector-ref new-end x)))
		    (set-cdr! y (cons i (cdr y)))
		    (vector-set! new-end x (cdr y))
		    (loop (cdr sp2))))))))
    (do ((i 0 (+ i 1)))
	((= i n))
      (vector-set! new-R i (cdr (vector-ref new-R i))))
    
    new-R))



(define (build-relations)

  (define (get-state stateno symbol)
    (let loop ((j (shift-shifts (vector-ref shift-table stateno)))
	       (stno stateno))
      (if (null? j)
	  stno
	  (let ((st2 (car j)))
	    (if (= (vector-ref acces-symbol st2) symbol)
		st2
		(loop (cdr j) st2))))))

  (set! includes (make-vector ngotos #f))
  (do ((i 0 (+ i 1)))
      ((= i ngotos))
    (let ((state1 (vector-ref from-state i))
	  (symbol1 (vector-ref acces-symbol (vector-ref to-state i))))
      (let loop ((rulep (vector-ref derives symbol1))
		 (edges '()))
	(if (pair? rulep)
	    (let ((*rulep (car rulep)))
	      (let loop2 ((rp (vector-ref rrhs *rulep))
			  (stateno state1)
			  (states (list state1)))
		(let ((*rp (vector-ref ritem rp)))
		  (if (> *rp 0)
		      (let ((st (get-state stateno *rp)))
			(loop2 (+ rp 1) st (cons st states)))
		      (begin

			(if (not (vector-ref consistent stateno))
			    (add-lookback-edge stateno *rulep i))
			
			(let loop2 ((done #f) 
				    (stp (cdr states))
				    (rp2 (- rp 1))
				    (edgp edges))
			  (if (not done)
			      (let ((*rp (vector-ref ritem rp2)))
				(if (< -1 *rp nvars)
				  (loop2 (not (vector-ref nullable *rp))
					 (cdr stp)
					 (- rp2 1)
					 (cons (map-goto (car stp) *rp) edgp))
				  (loop2 #t stp rp2 edgp)))

			      (loop (cdr rulep) edgp))))))))
	    (vector-set! includes i edges)))))
  (set! includes (transpose includes ngotos)))
			


(define (compute-lookaheads)
  (let ((n (vector-ref lookaheads nstates)))
    (let loop ((i 0))
      (if (< i n)
	  (let loop2 ((sp (vector-ref lookback i)))
	    (if (pair? sp)
		(let ((LA-i (vector-ref LA i))
		      (F-j  (vector-ref F (car sp))))
		  (bit-union LA-i F-j token-set-size)
		  (loop2 (cdr sp)))
		(loop (+ i 1))))))))



(define (digraph relation)
  (define infinity (+ ngotos 2))
  (define INDEX (make-vector (+ ngotos 1) 0))
  (define VERTICES (make-vector (+ ngotos 1) 0))
  (define top 0)
  (define R relation)

  (define (traverse i)
    (set! top (+ 1 top))
    (vector-set! VERTICES top i)
    (let ((height top))
      (vector-set! INDEX i height)
      (let ((rp (vector-ref R i)))
	(if (pair? rp)
	    (let loop ((rp2 rp))
	      (if (pair? rp2)
		  (let ((j (car rp2)))
		    (if (= 0 (vector-ref INDEX j))
			(traverse j))
		    (if (> (vector-ref INDEX i) 
			   (vector-ref INDEX j))
			(vector-set! INDEX i (vector-ref INDEX j)))
		    (let ((F-i (vector-ref F i))
			  (F-j (vector-ref F j)))
		      (bit-union F-i F-j token-set-size))
		    (loop (cdr rp2))))))
	(if (= (vector-ref INDEX i) height)
	    (let loop ()
	      (let ((j (vector-ref VERTICES top)))
		(set! top (- top 1))
		(vector-set! INDEX j infinity)
		(if (not (= i j))
		    (begin
		      (bit-union (vector-ref F i) 
				 (vector-ref F j)
				 token-set-size)
		      (loop)))))))))

  (let loop ((i 0))
    (if (< i ngotos)
	(begin
	  (if (and (= 0 (vector-ref INDEX i))
		   (pair? (vector-ref R i)))
	      (traverse i))
	  (loop (+ i 1))))))


; ----------------------------------------------------------------------
; operator precedence management
; ----------------------------------------------------------------------

; a vector of precedence descriptors where each element
; is of the form (terminal type precedence)
(define the-terminals/prec #f)		; terminal symbols with precedence 
; the precedence is an integer >= 0
(define (get-symbol-precedence sym)
  (caddr (vector-ref the-terminals/prec sym)))
; the operator type is either 'none, 'left, 'right, or 'nonassoc
(define (get-symbol-assoc sym)
  (cadr (vector-ref the-terminals/prec sym)))

(define rule-precedences '())
(define (add-rule-precedence! rule sym)
  (set! rule-precedences
	(cons (cons rule sym) rule-precedences)))

(define (get-rule-precedence ruleno)
  (cond
   ((assq ruleno rule-precedences) 
    => (lambda (p) 
	 (get-symbol-precedence (cdr p))))
   (else
    ;; process the rule symbols from left to right
    (let loop ((i    (vector-ref rrhs ruleno))
	       (prec 0))
      (let ((item (vector-ref ritem i)))
	;; end of rule
	(if (< item 0)
	    prec
	    (let ((i1 (+ i 1)))
	      (if (>= item nvars)
		  ;; it's a terminal symbol
		  (loop i1 (get-symbol-precedence (- item nvars)))
		  (loop i1 prec)))))))))

; ----------------------------------------------------------------------
; Build the various tables
; ----------------------------------------------------------------------

(define expected-conflicts 0)

(define (build-tables)
  
  (define (resolve-conflict sym rule)
    (let ((sym-prec   (get-symbol-precedence sym))
	  (sym-assoc  (get-symbol-assoc sym))
	  (rule-prec  (get-rule-precedence rule)))
      (cond
       ((> sym-prec rule-prec)     'shift)
       ((< sym-prec rule-prec)     'reduce)
       ((eq? sym-assoc 'left)      'reduce)
       ((eq? sym-assoc 'right)     'shift)
       (else                       'none))))
 
  (define conflict-messages '())
  
  (define (add-conflict-message . l)
    (set! conflict-messages (cons l conflict-messages)))
  
  (define (log-conflicts)
    (if (> (length conflict-messages) expected-conflicts)
	(for-each
	 (lambda (message)
	   (for-each display message)
	   (newline))
	 conflict-messages)))
  
  ;; --- Add an action to the action table
  (define (add-action St Sym Act)
    (let* ((x (vector-ref action-table St))
	   (y (assv Sym x)))
      (if y
	  (if (not (= Act (cdr y)))
	      ;; -- there is a conflict 
	      (begin
		(if (and (<= (cdr y) 0)
			 (<= Act 0))
		    ;; --- reduce/reduce conflict
		    (begin
		      (add-conflict-message
		       "%% Reduce/Reduce conflict (reduce " (- Act)
		       ", reduce " (- (cdr y))
		       ") on " (get-symbol (+ Sym nvars))
		       " in state " St)
		      (set-cdr! y (max (cdr y) Act)))
		    ;; --- shift/reduce conflict
		    ;; can we resolve the conflict using precedences?
		    (case (resolve-conflict Sym (- (cdr y)))
		      ;; -- shift
		      ((shift)
		       (set-cdr! y Act))
		      ;; -- reduce
		      ((reduce)
		       #f)		; well, nothing to do...
		      ;; -- signal a conflict!
		      (else
		       (add-conflict-message
			"%% Shift/Reduce conflict (shift " Act
			", reduce " (- (cdr y))
			") on " (get-symbol (+ Sym nvars))
			" in state " St)
		       (set-cdr! y Act))))))
	  
	  (vector-set! action-table St (cons (cons Sym Act) x)))))
	
  (set! action-table (make-vector nstates '()))

  (do ((i 0 (+ i 1)))  ; i = state
      ((= i nstates))
    (let ((red (vector-ref reduction-table i)))
      (if (and red (>= (red-nreds red) 1))
	  (if (and (= (red-nreds red) 1) (vector-ref consistent i))
	      (add-action i 'default (- (car (red-rules red))))
	      (let ((k (vector-ref lookaheads (+ i 1))))
		(let loop ((j (vector-ref lookaheads i)))
		  (if (< j k)
		      (let ((rule (- (vector-ref LAruleno j)))
			    (lav  (vector-ref LA j)))
			(let loop2 ((token 0) (x (vector-ref lav 0)) (y 1) (z 0))
			  (if (< token nterms)
			      (begin
				(let ((in-la-set? (modulo x 2)))
				  (if (= in-la-set? 1)
				      (add-action i token rule)))
				(if (= y (fixnum-width))
				    (loop2 (+ token 1) 
					   (vector-ref lav (+ z 1))
					   1
					   (+ z 1))
				    (loop2 (+ token 1) (quotient x 2) (+ y 1) z)))))
			(loop (+ j 1)))))))))

    (let ((shiftp (vector-ref shift-table i)))
      (if shiftp
	  (let loop ((k (shift-shifts shiftp)))
	    (if (pair? k)
		(let* ((state (car k))
		       (symbol (vector-ref acces-symbol state)))
		  (if (>= symbol nvars)
		      (add-action i (- symbol nvars) state))
		  (loop (cdr k))))))))

  (add-action final-state 0 'accept)
  (log-conflicts))

(define (compact-action-table terms)
  (define (most-common-action acts)
    (let ((accums '()))
      (let loop ((l acts))
	(if (pair? l)
	    (let* ((x (cdar l))
		   (y (assv x accums)))
	      (if (and (number? x) (< x 0))
		  (if y
		      (set-cdr! y (+ 1 (cdr y)))
		      (set! accums (cons `(,x . 1) accums))))
	      (loop (cdr l)))))

      (let loop ((l accums) (max 0) (sym #f))
	(if (null? l)
	    sym
	    (let ((x (car l)))
	      (if (> (cdr x) max)
		  (loop (cdr l) (cdr x) (car x))
		  (loop (cdr l) max sym)))))))
  
  (define (translate-terms acts)
    (map (lambda (act) 
	   (cons (list-ref terms (car act))
		 (cdr act)))
	 acts))

  (do ((i 0 (+ i 1)))
      ((= i nstates))
    (let ((acts (vector-ref action-table i)))
      (if (vector? (vector-ref reduction-table i))
	  (let ((act (most-common-action acts)))
	    (vector-set! action-table i
			 (cons `(*default* . ,(if act act '*error*))
			       (translate-terms
				(lalr-filter (lambda (x) 
					  (not (eq? (cdr x) act)))
					acts)))))
	  (vector-set! action-table i 
		       (cons `(*default* . *error*) 
			     (translate-terms acts)))))))



; --

(define (rewrite-grammar tokens grammar k) 

  (define eoi '*eoi*)
  
  (define (check-terminal term terms)
    (cond 
     ((not (valid-terminal? term))
      (lalr-error "invalid terminal: " term))
     ((member term terms)
      (lalr-error "duplicate definition of terminal: " term))))
  
  (define (prec->type prec)
    (cdr (assq prec '((left:     . left) 
		      (right:    . right)
		      (nonassoc: . nonassoc)))))

  (cond
   ;; --- a few error conditions
   ((not (list? tokens))
    (lalr-error "Invalid token list: " tokens))
   ((not (pair? grammar))
    (lalr-error "Grammar definition must have a non-empty list of productions" '()))
   
   (else
    ;; --- check the terminals
    (let loop1 ((lst            tokens)
		(rev-terms      '())
		(rev-terms/prec '())
		(prec-level     0))
      (if (pair? lst)
	  (let ((term (car lst)))
	    (cond
	     ((pair? term)
	      (if (and (memq (car term) '(left: right: nonassoc:))
		       (not (null? (cdr term))))
		  (let ((prec    (+ prec-level 1))
			(optype  (prec->type (car term))))
		    (let loop-toks ((l             (cdr term))
				    (rev-terms      rev-terms)
				    (rev-terms/prec rev-terms/prec))
		      (if (null? l)
			  (loop1 (cdr lst) rev-terms rev-terms/prec prec)
			  (let ((term (car l)))
			    (check-terminal term rev-terms)
			    (loop-toks 
			     (cdr l)
			     (cons term rev-terms)
			     (cons (list term optype prec) rev-terms/prec))))))
		  
		  (lalr-error "invalid operator precedence specification: " term)))
	      
	     (else
	      (check-terminal term rev-terms)
	      (loop1 (cdr lst) 
		     (cons term rev-terms)
		     (cons (list term 'none 0) rev-terms/prec)
		     prec-level))))
	  
	  ;; --- check the grammar rules
	  (let loop2 ((lst grammar) (rev-nonterm-defs '()))
	    (if (pair? lst)
		(let ((def (car lst)))
		  (if (not (pair? def))
		      (lalr-error "Nonterminal definition must be a non-empty list" '())
		      (let ((nonterm (car def)))
			(cond ((not (valid-nonterminal? nonterm))
			       (lalr-error "Invalid nonterminal:" nonterm))
			      ((or (member nonterm rev-terms)
				   (assoc nonterm rev-nonterm-defs))
			       (lalr-error "Nonterminal previously defined:" nonterm))
			      (else
			       (loop2 (cdr lst)
				      (cons def rev-nonterm-defs)))))))
		(let* ((terms        (cons eoi            (cons 'error          (reverse rev-terms))))
		       (terms/prec   (cons '(eoi none 0)  (cons '(error none 0) (reverse rev-terms/prec))))
		       (nonterm-defs (reverse rev-nonterm-defs))
		       (nonterms     (cons '*start* (map car nonterm-defs))))
		  (if (= (length nonterms) 1)
		      (lalr-error "Grammar must contain at least one nonterminal" '())
		      (let loop-defs ((defs      (cons `(*start* (,(cadr nonterms) ,eoi) : $1)
						       nonterm-defs))
				      (ruleno    0)
				      (comp-defs '()))
			(if (pair? defs)
			    (let* ((nonterm-def  (car defs))
				   (compiled-def (rewrite-nonterm-def 
						  nonterm-def 
						  ruleno
						  terms nonterms)))
			      (loop-defs (cdr defs)
					 (+ ruleno (length compiled-def))
					 (cons compiled-def comp-defs)))

			    (let ((compiled-nonterm-defs (reverse comp-defs)))
			      (k terms
				 terms/prec
				 nonterms
				 (map (lambda (x) (cons (caaar x) (map cdar x)))
				      compiled-nonterm-defs)
				 (apply append compiled-nonterm-defs))))))))))))))


(define (rewrite-nonterm-def nonterm-def ruleno terms nonterms)

  (define No-NT (length nonterms))

  (define (encode x) 
    (let ((PosInNT (pos-in-list x nonterms)))
      (if PosInNT
	  PosInNT
	  (let ((PosInT (pos-in-list x terms)))
	    (if PosInT
		(+ No-NT PosInT)
		(lalr-error "undefined symbol : " x))))))
  
  (define (process-prec-directive rhs ruleno)
    (let loop ((l rhs))
      (if (null? l) 
	  '()
	  (let ((first (car l))
		(rest  (cdr l)))
	    (cond
	     ((or (member first terms) (member first nonterms))
	      (cons first (loop rest)))
	     ((and (pair? first)
		   (eq? (car first) 'prec:))
	      (if (and (pair? (cdr first))
                       (null? (cddr first))
		       (member (cadr first) terms))
		  (if (null? rest)
		      (begin
			(add-rule-precedence! ruleno (pos-in-list (cadr first) terms))
			(loop rest))
		      (lalr-error "prec: directive should be at end of rule: " rhs))
		  (lalr-error "Invalid prec: directive: " first)))
	     (else
	      (lalr-error "Invalid terminal or nonterminal: " first)))))))
	

  (if (not (pair? (cdr nonterm-def)))
      (lalr-error "At least one production needed for nonterminal:" (car nonterm-def))
      (let ((name (symbol->string (car nonterm-def))))
	(let loop1 ((lst (cdr nonterm-def))
		    (i 1)
		    (rev-productions-and-actions '()))
	  (if (not (pair? lst))
	      (reverse rev-productions-and-actions)
	      (let* ((rhs  (process-prec-directive (car lst) (+ ruleno i -1)))
		     (rest (cdr lst))
		     (prod (map encode (cons (car nonterm-def) rhs))))
		;; -- check for undefined tokens
		(for-each (lambda (x)
			    (if (not (or (member x terms) (member x nonterms)))
				(lalr-error "Invalid terminal or nonterminal:" x)))
			  rhs)
		;; -- check 'error' productions
		(if (member 'error rhs)
		    (if (or (not (= 2 (length rhs)))
			    (not (equal? (car rhs) 'error))
			    (not (member (cadr rhs) terms)))
			(lalr-error "Invalid 'error' production:" rhs)))
		(if (and (pair? rest)
			 (eq? (car rest) ':)
			 (pair? (cdr rest)))
		    (loop1 (cddr rest)
			   (+ i 1)
			   (cons (cons prod (cadr rest)) 
				 rev-productions-and-actions))
		    (let* ((rhs-length (length rhs))
			   (action
			    (cons 'vector
				 (cons (list 'quote (string->symbol
						     (string-append
						      name
						      "-"
						      (number->string i))))
				       (let loop-j ((j 1))
					 (if (> j rhs-length)
					     '()
					     (cons (string->symbol
						    (string-append
						     "$"
						     (number->string j)))
						   (loop-j (+ j 1)))))))))
		      (loop1 rest
			     (+ i 1)
			     (cons (cons prod action) 
				   rev-productions-and-actions))))))))))

(define (valid-nonterminal? x)
  (symbol? x))

(define (valid-terminal? x)
  (symbol? x))              ; DB 

; ----------------------------------------------------------------------
; Miscellaneous
; ----------------------------------------------------------------------
(define (pos-in-list x lst)
  (let loop ((lst lst) (i 0))
    (cond ((not (pair? lst))    #f)
	  ((equal? (car lst) x) i)
	  (else                 (loop (cdr lst) (+ i 1))))))

(define (sunion lst1 lst2)		; union of sorted lists
  (let loop ((L1 lst1)
	     (L2 lst2))
    (cond ((null? L1)    L2)
	  ((null? L2)    L1)
	  (else 
	   (let ((x (car L1)) (y (car L2)))
	     (cond
	      ((> x y)
	       (cons y (loop L1 (cdr L2))))
	      ((< x y)
	       (cons x (loop (cdr L1) L2)))
	      (else
	       (loop (cdr L1) L2))
	      ))))))

(define (sinsert elem lst)
  (let loop ((l1 lst))
    (if (null? l1) 
	(cons elem l1)
	(let ((x (car l1)))
	  (cond ((< elem x)
		 (cons elem l1))
		((> elem x)
		 (cons x (loop (cdr l1))))
		(else 
		 l1))))))

(define (lalr-filter p lst)
  (let loop ((l lst))
    (if (null? l)
	'()
	(let ((x (car l)) (y (cdr l)))
	(if (p x)
	    (cons x (loop y))
	    (loop y))))))

; ----------------------------------------------------------------------
; Debugging tools ...
; ----------------------------------------------------------------------
(define the-terminals #f)		; names of terminal symbols
(define the-nonterminals #f)		; non-terminals

(define (print-item item-no)
  (let loop ((i item-no))
    (let ((v (vector-ref ritem i)))
      (if (>= v 0)
	  (loop (+ i 1))
	  (let* ((rlno    (- v))
		 (nt      (vector-ref rlhs rlno)))
	    (display (vector-ref the-nonterminals nt)) (display " --> ")
	    (let loop ((i (vector-ref rrhs rlno)))
	      (let ((v (vector-ref ritem i)))
		(if (= i item-no)
		    (display ". "))
		(if (>= v 0)
		    (begin
		      (display (get-symbol v))
		      (display " ")
		      (loop (+ i 1)))
		    (begin 
		      (display "   (rule ")
		      (display (- v))
		      (display ")")
		      (newline))))))))))
  
(define (get-symbol n)
  (if (>= n nvars)
      (vector-ref the-terminals (- n nvars))
      (vector-ref the-nonterminals n)))

  
(define (print-states)
  (define (print-action act)
    (cond
     ((eq? act '*error*)
      (display " : Error"))
     ((eq? act 'accept)
      (display " : Accept input"))
     ((< act 0)
      (display " : reduce using rule ")
      (display (- act)))
     (else
      (display " : shift and goto state ")
      (display act)))
    (newline)
    #t)
  
  (define (print-actions acts)
    (let loop ((l acts))
      (if (null? l)
	  #t
	  (let ((sym (caar l))
		(act (cdar l)))
	    (display "   ")
	    (cond
	     ((eq? sym 'default)
	      (display "default action"))
	     (else
	      (if (number? sym)
		  (display (get-symbol (+ sym nvars)))
		  (display sym))))
	    (print-action act)
	    (loop (cdr l))))))
  
  (if (not action-table)
      (begin
	(display "No generated parser available!")
	(newline)
	#f)
      (begin
	(display "State table") (newline)
	(display "-----------") (newline) (newline)
  
	(let loop ((l first-state))
	  (if (null? l)
	      #t
	      (let* ((core  (car l))
		     (i     (core-number core))
		     (items (core-items core))
		     (actions (vector-ref action-table i)))
		(display "state ") (display i) (newline)
		(newline)
		(for-each (lambda (x) (display "   ") (print-item x))
			  items)
		(newline)
		(print-actions actions)
		(newline)
		(loop (cdr l))))))))


	  
; ----------------------------------------------------------------------

(define build-goto-table
  (lambda ()
    `(vector
      ,@(map
	 (lambda (shifts)
	   (list 'quote
		 (if shifts
		     (let loop ((l (shift-shifts shifts)))
		       (if (null? l)
			   '()
			   (let* ((state  (car l))
				  (symbol (vector-ref acces-symbol state)))
			     (if (< symbol nvars)
				 (cons `(,symbol . ,state)
				       (loop (cdr l)))
				 (loop (cdr l))))))
		     '())))
	 (vector->list shift-table)))))


(define build-reduction-table
  (lambda (gram/actions)
    `(vector
      '()
      ,@(map
	 (lambda (p)
	   (let ((act (cdr p)))
	     `(lambda (___stack ___sp ___goto-table ___k)
		,(let* ((nt (caar p)) (rhs (cdar p)) (n (length rhs)))
		   `(let* (,@(if act
				 (let loop ((i 1) (l rhs))
				   (if (pair? l)
				       (let ((rest (cdr l)))
					 (cons 
					  `(,(string->symbol
					      (string-append
					       "$"
					       (number->string 
						(+ (- n i) 1))))
					    (vector-ref ___stack (- ___sp ,(- (* i 2) 1))))
					  (loop (+ i 1) rest)))
				       '()))
				 '()))
		      ,(if (= nt 0)
			   '$1
			   `(___push ___stack (- ___sp ,(* 2 n)) 
				  ,nt ___goto-table ,(cdr p) ___k)))))))

	 gram/actions))))


; Options

(define *valid-options*
  (list 
   (cons 'out-table:
	 (lambda (option)
	   (and (list? option)
		(= (length option) 2)
		(string? (cadr option)))))
   (cons 'output:
	 (lambda (option)
	   (and (list? option)
		(= (length option) 3)
		(symbol? (cadr option))
		(string? (caddr option)))))
   (cons 'expect:
	 (lambda (option)
	   (and (list? option)
		(= (length option) 2)
		(integer? (cadr option))
		(>= (cadr option) 0))))))








  

; -- arguments

(define (extract-arguments lst proc)
  (let loop ((options '())
             (tokens  '())
             (rules   '())
             (lst     lst))
    (if (pair? lst)
        (let ((p (car lst)))
          (cond
           ((and (pair? p) 
                 (lalr-keyword? (car p))
                 (assq (car p) *valid-options*))
            (loop (cons p options) tokens rules (cdr lst)))
           (else
            (proc options p (cdr lst)))))
        (lalr-error "Malformed lalr-parser form" lst))))

(define (validate-options options)
  (for-each
   (lambda (option)
     (let ((p (assoc (car option) *valid-options*)))
       (if (or (not p)
               (not ((cdr p) option)))
           (lalr-error "Invalid option:" option))))
   options))

(define (output-parser! options code)
  (let ((option (assq 'output: options)))
    (if option
        (let ((parser-name (cadr option))
              (file-name   (caddr option)))
          (with-output-to-file file-name
            (lambda ()
              (pprint `(define ,parser-name ,code))
              (newline)))))))

(define (output-table! options)
  (let ((option (assq 'out-table: options)))
    (if option
        (let ((file-name (cadr option)))
          (with-output-to-file file-name print-states)))))

(define (set-expected-conflicts! options)
  (let ((option (assq 'expect: options)))
    (set! expected-conflicts (if option (cadr option) 0))))


(define (make-lalr-parser arguments)
  (extract-arguments arguments
    (lambda (options tokens rules)
      (validate-options options)
      (set-expected-conflicts! options)
      (let* ((gram/actions (gen-tables! tokens rules))
	     (code
	      `(letrec ((___max-stack-size 500)

			(___atable         ',action-table)
			(___gtable         ,(build-goto-table))
			(___grow-stack     (lambda (stack)
					     ;; make a new stack twice as big as the original
					     (let ((new-stack (make-vector (* 2 (vector-length stack)) #f)))
					       ;; then copy the elements...
					       (let loop ((i (- (vector-length stack) 1)))
						 (if (< i 0)
						     new-stack
						     (begin
						       (vector-set! new-stack i (vector-ref stack i))
						       (loop (- i 1))))))))
	      
			(___push           (lambda (stack sp new-cat goto-table lval k)
					     (let* ((state     (vector-ref stack sp))
						    (new-state (cdr (assq new-cat (vector-ref goto-table state))))
						    (new-sp    (+ sp 2))
						    (stack     (if (< new-sp (vector-length stack))
								   stack
								   (___grow-stack stack))))
					       (vector-set! stack new-sp new-state)
					       (vector-set! stack (- new-sp 1) lval)
					       (k stack new-sp))))

			(___action         (lambda (x l)
					     (let ((y (assq x l)))
					       (if y (cdr y) (cdar l)))))
			
			(___recover        (lambda (stack sp tok lexerp k)
					     ;; -- find a state with a transition on the
					     ;; -- 'error' token
					     (let find-state ((sp sp))
					       (if (< sp 0)
						   (k stack sp)
						   (let* ((state (vector-ref stack sp))
							  (act   (assq 'error (vector-ref ___atable state))))
						     (if act
							 (___sync stack sp (cdr act) tok lexerp k)
							 (find-state (- sp 2))))))))
			
			(___sync          (lambda (stack sp state tok lexerp k)
					    ;; -- synchronize with the token following the
					    ;; -- 'error' token
					    (let ((sync-set  (map car (cdr (vector-ref ___atable state))))
						  (stack     (if (< (+ sp 4) (vector-length stack))
								 stack
								 (___grow-stack stack))))
					      (vector-set! stack (+ sp 1) #f)
					      (vector-set! stack (+ sp 2) state)
					      (let skip ((tok tok))
						(let ((i (if (pair? tok) (car tok) tok)))
						  (if (eq? i '*eoi*)
						      (k stack -1)
						      (if (memq i sync-set)
							  (let ((act (assq i (vector-ref ___atable state))))
							    (vector-set! stack (+ sp 3) #f)
							    (vector-set! stack (+ sp 4) (cdr act))
							    (k stack (+ sp 4)))
							  (skip (lexerp)))))))))
	      
			(___rtable         ,(build-reduction-table gram/actions)))

		 (lambda (lexerp errorp)

		   (let ((stack (make-vector ___max-stack-size 0)))
		     (let loop ((stack stack) (sp 0) (input #f))
		       (if input
			   (let* ((state (vector-ref stack sp))
				  (i     (if (pair? input) (car input) input))
				  (attr  (if (pair? input) (cdr input) #f))
				  (act   (___action i (vector-ref ___atable state))))

			     (cond
			      ((not (symbol? i))
			       (errorp "PARSE ERROR: invalid token: " i)
			       #f)
			      
			      ;; Input succesfully parsed
			      ((eq? act 'accept)
			       (vector-ref stack 1))
		  
			      ;; Syntax error in input
			      ((eq? act '*error*)
			       (if (eq? i '*eoi*)
				   (begin
				     (errorp "PARSE ERROR : unexpected end of input ")
				     #f)
				   (begin
				     (errorp "PARSE ERROR : unexpected token : " i)
				     (___recover
				      stack sp i lexerp
				      (lambda (stack sp)
					(if (>= sp 0)
					    (loop stack sp #f)
					    (loop stack sp '*eoi*)))))))
		  
			      ;; Shift current token on top of the stack
			      ((>= act 0)
			       (let ((stack (if (< (+ sp 2) (vector-length stack))
						stack
						(___grow-stack stack))))
				 (vector-set! stack (+ sp 1) attr)
				 (vector-set! stack (+ sp 2) act)
				 (loop stack (+ sp 2) (if (eq? i '*eoi*) '*eoi* #f))))

			      ;; Reduce by rule (- act)
			      (else
			       ((vector-ref ___rtable (- act))
				stack sp ___gtable
				(lambda (stack sp)
				  (loop stack sp input))))))
			   
			   ;; no lookahead, so check if there is a default action
			   ;; that does not require the lookahead
			   (let* ((state  (vector-ref stack sp))
				  (acts   (vector-ref ___atable state))
				  (defact (if (pair? acts) (cdar acts) #f)))
			     (if (and (= 1 (length acts))
				      (< defact 0))
				 ((vector-ref ___rtable (- defact))
				  stack sp ___gtable
				  (lambda (stack sp)
				    (loop stack sp input)))
				 (loop stack sp (lexerp)))))))))))
				 
	(output-table! options)
	(output-parser! options code)
	code))))

(define-syntax lalr-parser
  (lambda (x)
    (syntax-case x ()
      [(ctxt . arguments) 
       #'(let-syntax ([foo (lambda (x)
                             (syntax-case x ()
                               [(_ ctxt)
                                (datum->syntax #'ctxt 
                                  (make-lalr-parser
                                    'arguments))]))])
           (foo ctxt))])))

)