diff --git a/lab/lalr-example-calc.scm b/lab/lalr-example-calc.scm
new file mode 100755
index 0000000..77de0d9
--- /dev/null
+++ b/lab/lalr-example-calc.scm
@@ -0,0 +1,203 @@
+;;;
+;;;; Simple calculator in Scheme
+;;;
+;;
+;; @created   "Tue Jan  6 12:47:23 2004"
+;; @modified  "Mon Oct 25 11:07:24 2004"
+;; @author    "Dominique Boucher"
+;; @copyright "Dominique Boucher"
+;;
+;; Simple arithmetic calculator. 
+;; 
+;;   This program illustrates the use of the lalr-scm parser generator
+;; for Scheme. It is NOT robust, since calling a function with 
+;; the wrong number of arguments may generate an error that will
+;; cause the calculator to crash.
+
+
+;;;
+;;;;   The LALR(1) parser
+;;;
+
+
+(import (rnrs) (rnrs mutable-pairs) (lalr))
+
+(define calc-parser
+  (lalr-parser
+   
+   ;; --- Options 
+   ;; output a parser, called calc-parser, in a separate file - calc.yy.scm, 
+   ;(output:    calc-parser "calc.yy.scm")
+   ;; output the LALR table to calc.out
+   ;(out-table: "calc.out")
+   ;; there should be no conflict
+   (expect:    0)
+   
+   ;; --- token definitions
+   (ID NUM = LPAREN RPAREN NEWLINE COMMA
+    (left: + -)
+    (left: * /)
+    (nonassoc: uminus))
+   
+   (lines    (lines line) : (display-result $2)
+	     (line)       : (display-result $1))
+	   
+
+   ;; --- rules
+   (line     (assign NEWLINE)        : $1
+	     (expr   NEWLINE)        : $1
+	     (error  NEWLINE)        : #f)
+   
+   (assign   (ID = expr)             : (add-binding $1 $3))
+   
+   (expr     (expr + expr)           : (+ $1 $3)
+	     (expr - expr)           : (- $1 $3)
+	     (expr * expr)           : (* $1 $3)
+	     (expr / expr)           : (/ $1 $3)
+	     (- expr (prec: uminus)) : (- $2)
+	     (ID)                    : (get-binding $1)
+	     (ID LPAREN args RPAREN) : (invoke-proc $1 $3)
+	     (NUM)                   : $1
+	     (LPAREN expr RPAREN)    : $2)
+    
+   (args     ()                      : '()
+	     (expr arg-rest)         : (cons $1 $2))
+   
+   (arg-rest (COMMA expr arg-rest)   : (cons $2 $3)
+	     ()                      : '())))
+
+
+(define (display-result v)
+  (if v
+      (begin
+	(display "==> ")
+	(display v)
+	(newline))))
+
+
+;;;
+;;;;   The lexer
+;;;
+
+
+(define (make-lexer errorp)
+  (lambda ()
+    (letrec ((skip-spaces
+	      (lambda ()
+		(let loop ((c (peek-char)))
+		  (if (and (not (eof-object? c))
+			   (or (char=? c #\space) (char=? c #\tab)))
+		      (begin
+			(read-char)
+			(loop (peek-char)))))))   
+	     (read-number 
+	      (lambda (l)
+		(let ((c (peek-char)))
+		  (if (char-numeric? c)
+		      (read-number (cons (read-char) l))
+		      (string->number (apply string (reverse l)))))))
+	     (read-id
+	      (lambda (l)
+		(let ((c (peek-char)))
+		  (if (char-alphabetic? c)
+		      (read-id (cons (read-char) l))
+		      (string->symbol (apply string (reverse l))))))))
+
+      ;; -- skip spaces
+      (skip-spaces)
+      ;; -- read the next token
+      (let loop ((c (read-char)))
+	(cond
+	 ((eof-object? c)      '*eoi*)
+	 ((char=? c #\newline) 'NEWLINE)
+	 ((char=? c #\+)       '+)
+	 ((char=? c #\-)       '-)
+	 ((char=? c #\*)       '*)
+	 ((char=? c #\/)       '/)
+	 ((char=? c #\=)       '=)
+	 ((char=? c #\,)       'COMMA)
+	 ((char=? c #\()       'LPAREN)
+	 ((char=? c #\))       'RPAREN)
+	 ((char-numeric? c)    (cons 'NUM (read-number (list c))))
+	 ((char-alphabetic? c) (cons 'ID  (read-id (list c))))
+	 (else                 
+	  (errorp "PARSE ERROR : illegal character: " c)
+	  (skip-spaces)
+	  (loop (read-char))))))))
+
+
+(define (read-line)
+  (let loop ((c (read-char)))
+    (if (and (not (eof-object? c))
+	     (not (char=? c #\newline)))
+	(loop (read-char)))))
+
+
+;;;
+;;;;   Environment management
+;;;
+
+
+(define *env* (list (cons '$$ 0)))
+
+
+(define (init-bindings)
+  (set-cdr! *env* '())
+  (add-binding 'cos cos)
+  (add-binding 'sin sin)
+  (add-binding 'tan tan)
+  (add-binding 'expt expt)
+  (add-binding 'sqrt sqrt))
+
+
+(define (add-binding var val)
+  (set! *env* (cons (cons var val) *env*))
+  val)
+
+
+(define (get-binding var)
+  (let ((p (assq var *env*)))
+    (if p 
+	(cdr p)
+	0)))
+
+
+(define (invoke-proc proc-name args)
+  (let ((proc (get-binding proc-name)))
+    (if (procedure? proc)
+	(apply proc args)
+	(begin
+	  (display "ERROR: invalid procedure:")
+	  (display proc-name)
+	  (newline)
+	  0))))
+
+
+;;;
+;;;;   The main program
+;;;
+
+
+(define calc
+  (lambda ()
+    (call-with-current-continuation
+     (lambda (k)
+       (display "********************************") (newline)
+       (display "*  Mini calculator in Scheme   *") (newline)
+       (display "*                              *") (newline)
+       (display "* Enter expressions followed   *") (newline)
+       (display "* by [RETURN] or 'quit()' to   *") (newline)
+       (display "* exit.                        *") (newline)
+       (display "********************************") (newline)
+       (init-bindings)
+       (add-binding 'quit k)
+       (letrec ((errorp
+		 (lambda args
+		   (for-each display args) (newline)))
+		(start
+		 (lambda ()
+		   (calc-parser (make-lexer errorp) errorp))))
+	 (start))))))
+
+(calc)
+
diff --git a/lab/lalr.scm b/lab/lalr.scm
new file mode 100644
index 0000000..cc21950
--- /dev/null
+++ b/lab/lalr.scm
@@ -0,0 +1,1989 @@
+;;;
+;;;; 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 à 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 "à 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))])))
+
+)
diff --git a/lab/objc/hello-cocoa.ss b/lab/objc/hello-cocoa.ss
new file mode 100755
index 0000000..b9d8b49
--- /dev/null
+++ b/lab/objc/hello-cocoa.ss
@@ -0,0 +1,47 @@
+#!/usr/bin/env ikarus --r6rs-script
+;;; vim:syntax=scheme
+(import (ikarus) (objc))
+
+(define-framework Cocoa)
+(define-class NSAutoreleasePool)
+(define-class NSWindow)
+(define-class NSApplication)
+(define-object NSApp Cocoa)
+
+
+(define pool [$ [$ NSAutoreleasePool alloc] init])
+[$ NSApplication sharedApplication]
+
+(define NSBorderlessWindowMask         #b000000000)
+(define NSTitledWindowMask             #b000000001)
+(define NSClosableWindowMask           #b000000010)
+(define NSMiniaturizableWindowMask     #b000000100)
+(define NSResizableWindowMask          #b000001000)
+(define NSTexturedBackgroundWindowMask #b100000000)
+
+(define NSBackingStoreRetained     0)
+(define NSBackingStoreNonretained  1)
+(define NSBackingStoreBuffered     2)
+
+(define style 
+  (bitwise-ior 
+    NSClosableWindowMask 
+    NSResizableWindowMask
+    NSTexturedBackgroundWindowMask
+    NSTitledWindowMask
+    NSMiniaturizableWindowMask))
+
+(define backing NSBackingStoreBuffered)
+
+(define win [$ [$ NSWindow alloc]
+               initWithContentRect: '#(#(50 50) #(600 400))
+               styleMask: style
+               backing: backing
+               defer: #f])
+
+[$ win makeKeyAndOrderFront: win]
+
+[$ NSApp run]
+[$ pool release]
+
+
diff --git a/lab/objc/objc.ss b/lab/objc/objc.ss
new file mode 100644
index 0000000..b3a7e5b
--- /dev/null
+++ b/lab/objc/objc.ss
@@ -0,0 +1,454 @@
+
+(library (objc)
+  (export 
+    define-framework
+    define-class
+    define-object
+    $)
+  (import 
+    (ikarus)
+    (ikarus system $foreign)
+    (except (ypsilon-compat) format)
+    )
+
+(define ptrsize 4)
+
+
+
+ 
+(define objc 
+  (load-shared-object "libobjc.A.dylib"))
+(define Cocoa 
+  (load-shared-object "/System/Library/Frameworks/Cocoa.framework/Cocoa"))
+
+
+(define-syntax define-function
+  (syntax-rules ()
+    ((_ ret name args)
+     (define name 
+       (c-function objc "Objective C Binding" ret __stdcall name args)))))
+
+
+(define-function int objc_getClassList (void* int))
+(define-function void* objc_getClass (char*))
+(define-function void* sel_registerName (char*))
+(define-function void* sel_getUid (char*))
+(define-function void* class_getInstanceMethod (void* void*))
+(define-function void* class_getClassMethod (void* void*))
+(define-function void* class_nextMethodList (void* void*))
+
+
+
+(define-record-type class (fields ptr))
+(define-record-type object (fields ptr))
+(define-record-type lazy-object (fields ptr))
+(define-record-type selector (fields ptr))
+(define-record-type method (fields ptr))
+
+(define (pointer-ref addr offset)
+  (assert (pointer? addr))
+  (integer->pointer (pointer-ref-long addr offset)))
+
+(define (char*len x)
+  (let f ([i 0])
+    (cond
+      [(zero? (pointer-ref-uchar x i)) i]
+      [else (f (+ i 1))])))
+
+(define (char*->bv x)
+  (let ([n (char*len x)])
+    (let ([bv (make-bytevector n)])
+      (let f ([i 0])
+        (cond
+          [(= i n) bv]
+          [else
+           (bytevector-u8-set! bv i (pointer-ref-uchar x i))
+           (f (+ i 1))])))))
+
+(define (char*->string x)
+  (utf8->string (char*->bv x)))
+
+(define-syntax check
+  (syntax-rules ()
+    [(_ who pred expr)
+     (let ([t expr])
+       (unless (pred t)
+         (die who (format "not a ~a" 'pred) t)))]))
+
+(define (class-name x)
+  (check 'class-name class? x)
+  (char*->string (pointer-ref (class-ptr x) (* ptrsize 2))))
+
+(define (method-types x)
+  (check 'method-types method? x)
+  (char*->string (pointer-ref (method-ptr x) (* ptrsize 1))))
+
+(define (method-pointer x)
+  (check 'method-pointer method? x)
+  (pointer-ref (method-ptr x) (* ptrsize 2)))
+
+
+(define (method-selector x)
+  (check 'method-selector method? x)
+  (make-selector (pointer-ref (method-ptr x) (* ptrsize 0))))
+
+(define (method-name x)
+  (check 'method-name method? x)
+  (string-append 
+    (selector-name (method-selector x))
+    "  "
+    (method-types x)))
+
+
+
+(define CLS_METHOD_ARRAY #x100)
+
+
+(define (class-is? x what)
+  (define alist
+    '([method-array      #x100]
+      [no-method-array  #x4000]))
+  (check 'class-info class? x)
+  (let ([mask
+          (cond
+            [(assq what alist) => cadr]
+            [else (error 'class-is? "invalid what" what)])])
+    (= mask (bitwise-and mask (pointer-ref-long (class-ptr x) (* ptrsize 4))))))
+
+(define (class-methods x)
+  (define (methods x)
+    (let ([n (pointer-ref-int x ptrsize)]
+          [array (integer->pointer (+ (pointer->integer x) (* 2 ptrsize)))])
+      (let f ([i 0])
+        (if (= i n)
+            '()
+            (let ([m (make-method 
+                       (integer->pointer 
+                         (+ (pointer->integer array)
+                            (* 3 ptrsize i))))])
+              (cons m (f (+ i 1))))))))
+  (check 'class-methods class? x)
+  (when (class-is? x 'method-array)
+    (error 'class-methods "BUG: not yet for method arrays"))
+  (let ([iterator (malloc ptrsize)])
+    (pointer-set-long iterator 0 0)
+    (let f ()
+      (let ([methodlist (class_nextMethodList (class-ptr x) iterator)])
+        (cond
+          [(nil? methodlist)
+           (free iterator) 
+           '()]
+          [else
+           (let ([ls (methods methodlist)])
+             (append ls (f)))])))))
+
+
+(define (get-class-list)
+  (let ([n (objc_getClassList (integer->pointer 0) 0)])
+    (if (= n 0)
+        '()
+        (let ([buffer (malloc (* ptrsize n))])
+          (let ([n (objc_getClassList buffer n)])
+            (let f ([i 0] [ac '()])
+              (if (= i n) 
+                  (begin (free buffer) ac)
+                  (f (+ i 1) 
+                     (cons 
+                       (make-class 
+                         (integer->pointer
+                           (pointer-ref-long buffer (* ptrsize i))))
+                       ac)))))))))
+
+(define (nil? x)
+  (zero? (pointer->integer x)))
+
+(define (get-class name)
+  (check 'lookup-class string? name)
+  (let ([v (objc_getClass name)])
+    (cond
+      [(nil? v) #f]
+      [else (make-class v)])))
+
+(define (get-selector name)
+  (check 'lookup-selector string? name)
+  (let ([v (sel_registerName name)])
+    (cond
+      [(nil? v) #f]
+      [else (make-selector v)])))
+
+(define (selector-name x)
+  (check 'selector-name selector? x)
+  (char*->string (selector-ptr x)))
+
+(define (get-class-method class selector)
+  (check 'get-class-method class? class)
+  (check 'get-class-method selector? selector)
+  (let ([v (class_getClassMethod 
+             (class-ptr class)
+             (selector-ptr selector))])
+    (cond
+      [(nil? v) #f]
+      [else (make-method v)])))
+
+(define (get-instance-method x selector)
+  (check 'get-instance-method object? x)
+  (check 'get-instance-method selector? selector)
+  (let ([class (pointer-ref (object-ptr x) 0)])
+    (let ([v (class_getInstanceMethod 
+               class
+               (selector-ptr selector))])
+    (cond
+      [(nil? v) #f]
+      [else (make-method v)]))))
+
+
+(define-syntax define-class 
+  (syntax-rules ()
+    [(_ name) 
+     (define name 
+       (or (get-class (symbol->string 'name))
+           (error 'define-class "undefined class" 'name)))]))
+
+(define-syntax define-selector 
+  (syntax-rules ()
+    [(_ name) 
+     (define name 
+       (or (get-selector (symbol->string 'name))
+           (error 'define-selector "undefined selector" 'name)))]))
+
+(define-syntax define-class-method
+  (syntax-rules ()
+    [(_ name class selector)
+     (define name 
+       (or (get-class-method class selector)
+           (error 'define-class-method 
+                  "class method not implemented"
+                  'name)))]))
+
+
+(define-class NSObject)
+(define-class NSString)
+(define-class NSAutoreleasePool)
+(define-class NSWindow)
+(define-selector alloc)
+(define-selector allocWithZone:)
+(define-selector init)
+
+(define-class-method NSObject:alloc NSObject alloc)
+(define-class-method NSObject:allocWithZone: NSObject allocWithZone:)
+(define-class-method NSAutoreleasePool:alloc NSAutoreleasePool alloc)
+
+
+(define (class-info x)
+  `([name: ,(class-name x)]
+    [methods: 
+      ,(list-sort string<?
+         (map method-name (class-methods x)))]))
+
+
+(define-syntax define-framework
+  (lambda (x)
+    (syntax-case x ()
+      [(_ name) (identifier? #'name)
+       (let ([str (symbol->string (syntax->datum #'name))])
+         (with-syntax ([framework-name
+                        (string-append str ".framework/" str)])
+           #'(define name 
+               (load-shared-object framework-name))))])))
+
+(define (load-object lib name)
+  (let ([ptr 
+         (or (dlsym (library-pointer lib) (symbol->string name))
+             (error 'load-object "cannot find symbol" name))])
+    (make-lazy-object ptr)))
+
+(define-syntax define-object
+  (lambda (x)
+    (syntax-case x ()
+      [(_ name lib)
+       #'(define name (load-object lib 'name))])))
+
+(define (symbol->selector x)
+  (or (get-selector (symbol->string x))
+      (error 'symbol->selector "undefined selector" x)))
+
+
+(define (make-signature str)
+  (define who 'make-signature)
+  (let ([n (string-length str)])
+    (define (scan i c)
+      (cond
+        [(= i n) (error who "cannot find " c)]
+        [(char=? c (string-ref str i)) (+ i 1)]
+        [else (scan (+ i 1) c)]))
+    (define (parse i)
+      (cond
+        [(= i n) (error who "unterminated string")]
+        [else
+         (let ([c (string-ref str i)])
+           (case c
+             [(#\@) (values 'object (+ i 1))]
+             [(#\:) (values 'selector (+ i 1))]
+             [(#\v) (values 'void (+ i 1))]
+             [(#\f) (values 'float (+ i 1))]
+             [(#\i) (values 'int (+ i 1))]
+             [(#\I) (values 'uint (+ i 1))]
+             [(#\c) (values 'char (+ i 1))]
+             [(#\{) ;;; struct
+              (let ([i (scan (+ i 1) #\=)])
+                (let-values ([(i ls)
+                              (let f ([i i])
+                                (let-values ([(x i) (parse i)])
+                                  (cond
+                                    [(>= i n) (error who "runaway")]
+                                    [(char=? (string-ref str i) #\})
+                                     (values (+ i 1) (list x))]
+                                    [else
+                                     (let-values ([(i ls) (f i)])
+                                       (values i (cons x ls)))])))])
+                  (values (list->vector ls) i)))]
+             [(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+              (values 'skip (+ i 1))]
+             [else (error who "invalid char" c str)]))]))
+    (define (cons/skip x y)
+      (if (eq? x 'skip) y (cons x y)))
+    (let f ([i 0])
+      (cond
+        [(= i n) '()]
+        [else 
+         (let-values ([(x i) (parse i)])
+           (cons/skip x (f i)))]))))
+
+
+(define (objc-type->ikarus-type x)
+  (cond
+    [(vector? x) 
+     (vector-map objc-type->ikarus-type x)]
+    [else
+     (case x 
+       [(selector) 'pointer]
+       [(object)   'pointer]
+       [(void)     'void]
+       [(float)    'float]
+       [(uint)     'uint32]
+       [(int)      'sint32]
+       [(char)     'sint8]
+       [else (error 'objc-type->ikarus-type "invalid type" x)])]))
+
+
+
+(define (convert-incoming t x)
+  (case t
+    [(object) (make-object x)]
+    [(void)   (void)]
+    [else (error 'convert-incoming "invalid type" t)]))
+
+(define (convert-outgoing t x)
+  (cond
+    [(vector? t)
+     (cond
+       [(vector? x)
+        (unless (= (vector-length x) (vector-length t))
+          (error 'convert-outgoing "length mismatch" x t))
+        (vector-map convert-outgoing t x)]
+       [else (error 'convert-output "not a vector" x)])]
+    [else
+     (case t
+       [(selector)
+        (cond
+          [(selector? x) (selector-ptr x)]
+          [else (error 'convert-output "not a selector" x)])]
+       [(object) 
+        (cond
+          [(object? x) (object-ptr x)]
+          [(lazy-object? x) 
+           (pointer-ref (lazy-object-ptr x) 0)]
+          [(class? x) (class-ptr x)]
+          [else (error 'convert-output "cannot convert to object" x)])]
+       [(float) 
+        (cond
+          [(number? x) (inexact x)]
+          [else (error 'convert-output "cannot convert to float" x)])]
+       [(uint int char)
+        (cond
+          [(or (fixnum? x) (bignum? x)) x]
+          [(boolean? x) (if x 1 0)]
+          [else (error 'convert-output "cannot convert to int" x)])]
+       [else (error 'convert-outgoing "invalid type" t)])]))
+
+
+(define (call-with-sig sig mptr args)
+  (let ([rtype (car sig)] [argtypes (cdr sig)])
+    (unless (= (length args) (length argtypes))
+      (error 'call-with-sig "incorrect number of args" args argtypes))
+    (let ([ffi (make-ffi 
+                 (objc-type->ikarus-type rtype)
+                 (map objc-type->ikarus-type argtypes))])
+      (let ([proc (ffi mptr)])
+        (convert-incoming rtype 
+          (apply proc (map convert-outgoing argtypes args)))))))
+
+(define (send-message x method-name . args)
+  (let ([selector (symbol->selector method-name)])
+    (let ([method 
+           (cond
+             [(class? x) (get-class-method x selector)]
+             [(object? x) (get-instance-method x selector)]
+             [(lazy-object? x)
+              (get-instance-method 
+                (make-object (pointer-ref (lazy-object-ptr x) 0))
+                selector)]
+             [else (error 'send-message "not an object" x)])])
+      (unless method
+        (error 'send-message "undefined method" method-name))
+      (let ([sig (make-signature (method-types method))]
+            [mptr (method-pointer method)])
+        (call-with-sig sig mptr (cons* x selector args))))))
+
+(define-syntax $
+  (lambda (x)
+    (define (process-rest ls)
+      (syntax-case ls ()
+        [() (values "" '())]
+        [(kwd val . rest) (identifier? #'kwd)
+         (let-values ([(sel args) (process-rest #'rest)])
+           (values 
+             (string-append 
+               (symbol->string (syntax->datum #'kwd))
+               sel)
+             (cons #'val args)))]))
+    (define (process-args ls)
+      (let-values ([(sel args) (process-rest ls)])
+        (cons (datum->syntax #'here (string->symbol sel)) args)))
+    (syntax-case x ()
+      [(_ receiver kwd)
+       (identifier? #'kwd)
+       #'(send-message receiver 'kwd)]
+      [(_ receiver kwd/arg* ...)
+       (identifier? #'kwd)
+       (with-syntax ([(sel-name arg* ...)
+                      (process-args #'(kwd/arg* ...))])
+         #'(send-message receiver 'sel-name arg* ...))])))
+
+
+         
+
+;(printf "Classes: ~s\n" 
+;  (list-sort string<? (map class-name (get-class-list))))
+;
+;(printf "NSObject=~s\n" NSObject)
+;(printf "alloc=~s\n" alloc)
+;(printf "init=~s\n" init)
+;(printf "NSObject:alloc=~s\n" NSObject:alloc)
+;(printf "NSObject:allocWithZone=~s\n" NSObject:allocWithZone:)
+;(printf "types alloc=~s\n" (method-types NSObject:alloc))
+;(printf "types alloc=~s\n" (method-types NSAutoreleasePool:alloc))
+;(printf "types allocWithZone=~s\n" (method-types NSObject:allocWithZone:))
+;(for-each
+;  (lambda (x)
+;    (pretty-print (class-info x)))
+;  (list NSObject NSString NSAutoreleasePool NSWindow))
+
+
+
+) ; library
diff --git a/lab/test-ffi.ss b/lab/test-ffi.ss
index 0ebcabf..91f81aa 100644
--- a/lab/test-ffi.ss
+++ b/lab/test-ffi.ss
@@ -93,8 +93,11 @@
 (check = (test_D_DDD S_add_D_DDD 12.0 13.0 14.0) (+ 12.0 13.0 14.0))
 
 
+(define RectArea 
+  ((make-ffi 'float '(#(#(float float) #(float float))))
+   (dlsym self "test_area_F_R")))
 
-
+(check = (RectArea '#(#(0.0 0.0) #(10.0 10.0))) 100.0)
 
 
 
diff --git a/lib/ypsilon-compat.ikarus.ss b/lib/ypsilon-compat.ikarus.ss
index dbbbb71..d9fe5f6 100644
--- a/lib/ypsilon-compat.ikarus.ss
+++ b/lib/ypsilon-compat.ikarus.ss
@@ -2,7 +2,7 @@
 (library (ypsilon-compat)
   (export on-windows on-darwin on-linux on-freebsd on-posix
           load-shared-object c-argument c-function 
-          microsecond usleep
+          microsecond usleep library-pointer
           (rename (ypsilon:format format)))
   (import 
     (ikarus system $foreign)
@@ -19,8 +19,9 @@
     (cond
       [(eq? what #t) 
        (apply printf str args)]
-      [else 
-       (apply format str args)]))
+      [(eq? what #f) 
+       (apply format str args)]
+      [else (error 'ypsion:format "invalid what" what)]))
 
 
   (define (architecture-feature what)
@@ -148,7 +149,10 @@
          (define (name* . args) (error 'name* "not implemented"))
          ...)]))
 
-  (todo check-void* )
+  (define (check-void* who x)
+    (cond
+      [(pointer? x) x]
+      [else (die who "not a void*" x)]))
 
   (define-syntax convert-arg
     (lambda (x)
@@ -235,7 +239,7 @@
     (unless (library? lib) (die who "not a library" lib))
     (or (dlsym (library-pointer lib) (symbol->string name))
       (error who 
-        (format #f "cannot find object ~a in library ~a" 
+        (format "cannot find object ~a in library ~a" 
                 name (library-name lib)))))
 
 
diff --git a/scheme/ikarus.pointers.ss b/scheme/ikarus.pointers.ss
index 70a4181..686b78e 100644
--- a/scheme/ikarus.pointers.ss
+++ b/scheme/ikarus.pointers.ss
@@ -124,20 +124,23 @@
   (define (ffi-prep-cif rtype argtypes)
     (define who 'ffi-prep-cif)
     (define (convert x)
-      (case x 
-        [(void)       1]
-        [(uint8)      2]
-        [(sint8)      3]
-        [(uint16)     4]
-        [(sint16)     5]
-        [(uint32)     6]
-        [(sint32)     7]
-        [(uint64)     8]
-        [(sint64)     9]
-        [(float)     10]
-        [(double)    11]
-        [(pointer)   12]
-        [else (die who "invalid type" x)]))
+      (cond
+        [(vector? x) (vector-map convert x)]
+        [else
+         (case x 
+           [(void)       1]
+           [(uint8)      2]
+           [(sint8)      3]
+           [(uint16)     4]
+           [(sint16)     5]
+           [(uint32)     6]
+           [(sint32)     7]
+           [(uint64)     8]
+           [(sint64)     9]
+           [(float)     10]
+           [(double)    11]
+           [(pointer)   12]
+           [else (die who "invalid type" x)])]))
     (unless (list? argtypes)
       (die who "arg types is not a list" argtypes))
     (let ([argtypes-n (vector-map convert (list->vector argtypes))]
diff --git a/scheme/last-revision b/scheme/last-revision
index 9e8e0f4..6e2eace 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1612
+1613
diff --git a/src/ikarus-ffi.c b/src/ikarus-ffi.c
index 26dab76..61afda1 100644
--- a/src/ikarus-ffi.c
+++ b/src/ikarus-ffi.c
@@ -19,61 +19,121 @@ alloc(size_t n, int m) {
   return x;
 }
 
+static ffi_type* scheme_to_ffi_type_cast(ikptr nptr);
 
 static ffi_type* 
-scheme_to_ffi_type_cast(int n){
-  switch (n & 0xF) {
-    case  1: return &ffi_type_void;
-    case  2: return &ffi_type_uint8;
-    case  3: return &ffi_type_sint8;
-    case  4: return &ffi_type_uint16;
-    case  5: return &ffi_type_sint16;
-    case  6: return &ffi_type_uint32;
-    case  7: return &ffi_type_sint32;
-    case  8: return &ffi_type_uint64;
-    case  9: return &ffi_type_sint64;
-    case 10: return &ffi_type_float;
-    case 11: return &ffi_type_double;
-    case 12: return &ffi_type_pointer;
-    default: 
-      fprintf(stderr, "INVALID ARG %d", n);
-      exit(-1);
+scheme_to_ffi_record_type_cast(ikptr vec){
+  ikptr lenptr = ref(vec, -vector_tag);
+  if (! is_fixnum(lenptr)) {
+    fprintf(stderr, "NOT A VECTOR 0x%016lx\n", vec);
+    exit(-1);
+  }
+  long n = unfix(lenptr);
+  ffi_type* t = alloc(sizeof(ffi_type), 1);
+  ffi_type** ts = alloc(sizeof(ffi_type*), n+1);
+  t->size = 0;
+  t->alignment = 0;
+  t->type = FFI_TYPE_STRUCT;
+  t->elements = ts;
+  long i;
+  for(i=0; i<n; i++){
+    ts[i] = scheme_to_ffi_type_cast(ref(vec, off_vector_data + i*wordsize)); 
+  }
+  ts[n] = 0;
+  return t;
+}
+
+static ffi_type* 
+scheme_to_ffi_type_cast(ikptr nptr){
+  if (tagof(nptr) == vector_tag) {
+    return scheme_to_ffi_record_type_cast(nptr);
+  } else if (is_fixnum(nptr)) {
+    long n = unfix(nptr);
+    switch (n & 0xF) {
+      case  1: return &ffi_type_void;
+      case  2: return &ffi_type_uint8;
+      case  3: return &ffi_type_sint8;
+      case  4: return &ffi_type_uint16;
+      case  5: return &ffi_type_sint16;
+      case  6: return &ffi_type_uint32;
+      case  7: return &ffi_type_sint32;
+      case  8: return &ffi_type_uint64;
+      case  9: return &ffi_type_sint64;
+      case 10: return &ffi_type_float;
+      case 11: return &ffi_type_double;
+      case 12: return &ffi_type_pointer;
+      default: 
+        fprintf(stderr, "INVALID ARG %ld", n);
+        exit(-1);
+    }
+  } else {
+    fprintf(stderr, "INVALID ARG %ld", nptr);
+    exit(-1);
   }
 }
 
 static void* 
-alloc_room_for_type(int n){
-  ffi_type* t = scheme_to_ffi_type_cast(n);
+alloc_room_for_type(ffi_type* t){
   return alloc(t->size, 1);
 }
 
 extern long extract_num(ikptr x);
 
+static void scheme_to_ffi_value_cast(ffi_type*, ikptr, ikptr, void*);
+
 static void
-scheme_to_ffi_value_cast(int n, ikptr p, void* r) {
-  switch (n & 0xF) {
-    case  1: {  return; }
-    case  2: // ffi_type_uint8;
-    case  3:
-     { *((char*)r) = extract_num(p); return; }
-    case  4: // ffi_type_uint16;
-    case  5: 
-     { *((short*)r) = extract_num(p); return; }
-    case  6: //  ffi_type_uint32;
-    case  7: 
-     { *((int*)r) = extract_num(p); return; }
-    case  8: // ffi_type_uint64;
-    case  9: 
-     { *((long*)r) = extract_num(p); return; }
-    case 10: //return &ffi_type_float;
-     { *((float*)r) = flonum_data(p); return; }
-    case 11: //return &ffi_type_double;
-     { *((double*)r) = flonum_data(p); return; }
-    case 12: //return &ffi_type_pointer;
-     { *((void**)r) = (void*)ref(p, off_pointer_data); return; }
-    default: 
-      fprintf(stderr, "INVALID ARG %d", n);
-      exit(-1);
+scheme_to_ffi_record_value_cast(ffi_type* t, ikptr nptr, ikptr p, void* r) {
+  if (t->type != FFI_TYPE_STRUCT) {
+    fprintf(stderr, "not a struct type\n");
+    exit(-1);
+  }
+  ffi_type** ts = t->elements;
+  char* buf = r;
+  ikptr lenptr = ref(nptr, off_vector_length);
+  int n = unfix(lenptr);
+  int i;
+  for(i=0; i<n; i++) {
+    ffi_type* at = ts[i];
+    ikptr argt = ref(nptr, off_vector_data + i*wordsize);
+    ikptr arg = ref(p, off_vector_data + i*wordsize);
+    scheme_to_ffi_value_cast(at, argt, arg, buf);
+    buf += at->size;
+  }
+}
+
+static void
+scheme_to_ffi_value_cast(ffi_type* t, ikptr nptr, ikptr p, void* r) {
+  if (tagof(nptr) == vector_tag) {
+    scheme_to_ffi_record_value_cast(t, nptr, p, r);
+  } else if (is_fixnum(nptr)) {
+    long n = unfix(nptr);
+    switch (n & 0xF) {
+      case  1: {  return; }
+      case  2: // ffi_type_uint8;
+      case  3:
+       { *((char*)r) = extract_num(p); return; }
+      case  4: // ffi_type_uint16;
+      case  5: 
+       { *((short*)r) = extract_num(p); return; }
+      case  6: //  ffi_type_uint32;
+      case  7: 
+       { *((int*)r) = extract_num(p); return; }
+      case  8: // ffi_type_uint64;
+      case  9: 
+       { *((long*)r) = extract_num(p); return; }
+      case 10: //return &ffi_type_float;
+       { *((float*)r) = flonum_data(p); return; }
+      case 11: //return &ffi_type_double;
+       { *((double*)r) = flonum_data(p); return; }
+      case 12: //return &ffi_type_pointer;
+       { *((void**)r) = (void*)ref(p, off_pointer_data); return; }
+      default: 
+        fprintf(stderr, "INVALID ARG %ld", n);
+        exit(-1);
+    }
+  } else {
+    fprintf(stderr, "INVALID TYPE  0x%016lx\n", nptr);
+    exit(-1);
   }
 }
 
@@ -112,10 +172,10 @@ ikrt_ffi_prep_cif(ikptr rtptr, ikptr argstptr, ikpcb* pcb) {
   int i;
   for(i=0; i<nargs; i++){
     ikptr argt = ref(argstptr, off_vector_data + i*wordsize);
-    argtypes[i] = scheme_to_ffi_type_cast(unfix(argt));
+    argtypes[i] = scheme_to_ffi_type_cast(argt);
   }
   argtypes[nargs] = NULL;
-  ffi_type* rtype = scheme_to_ffi_type_cast(unfix(rtptr));
+  ffi_type* rtype = scheme_to_ffi_type_cast(rtptr);
   ffi_status s = ffi_prep_cif(cif, abi, nargs, rtype, argtypes);
   if (s == FFI_OK) {
     ikptr r = ik_safe_alloc(pcb, pointer_size);
@@ -266,14 +326,15 @@ ikrt_ffi_call(ikptr data, ikptr argsvec, ikpcb* pcb)  {
   void** avalues = alloc(sizeof(void*), n+1);
   int i;
   for(i=0; i<n; i++){
-    ikptr t = ref(typevec, off_vector_data + i * wordsize);
+    ffi_type* t = cif->arg_types[i];
+    ikptr at = ref(typevec, off_vector_data + i * wordsize);
     ikptr v = ref(argsvec, off_vector_data + i * wordsize);
-    void* p = alloc_room_for_type(unfix(t));
+    void* p = alloc_room_for_type(t);
     avalues[i] = p;
-    scheme_to_ffi_value_cast(unfix(t), v, p);
+    scheme_to_ffi_value_cast(t, at, v, p);
   }
   avalues[n] = NULL;
-  void* rvalue = alloc_room_for_type(unfix(rtype));
+  void* rvalue = alloc_room_for_type(cif->rtype);
   ffi_call(cif, fn, rvalue, avalues);
   ikptr val = ffi_to_scheme_value_cast(unfix(rtype), rvalue, pcb);
   for(i=0; i<n; i++){
@@ -351,7 +412,7 @@ generic_callback(ffi_cif *cif, void *ret, void **args, void *user_data){
 #ifdef DEBUG_FFI
   fprintf(stderr, "and back with rv=0x%016lx!\n", rv);
 #endif
-  scheme_to_ffi_value_cast(unfix(rtype_conv), rv, ret);
+  scheme_to_ffi_value_cast(cif->rtype, rtype_conv, rv, ret);
   return;
 }
 
@@ -432,6 +493,21 @@ int add_I_III(int n0, int n1, int n2) {
 
 
 
+struct Point{
+  float x;
+  float y;
+};
+
+struct Rect{
+  struct Point tl;
+  struct Point br;
+};
+
+float test_area_F_R(struct Rect r) {
+  float dx = r.br.x - r.tl.x;
+  float dy = r.br.y - r.tl.y;
+  return dx * dy;
+}
 
 double test_D_D (double(*f)(double), double n0) {
   return f(n0);