From 7efd05778cddec0293e0d48199f3aeee2aad6178 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès
Date: Fri, 18 Jan 2008 12:36:59 +0100
Subject: Add SILex, for simplicity.

---
 src/guile/silex/silex.scm | 6651 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 6651 insertions(+)
 create mode 100644 src/guile/silex/silex.scm

(limited to 'src/guile/silex/silex.scm')

diff --git a/src/guile/silex/silex.scm b/src/guile/silex/silex.scm
new file mode 100644
index 0000000..3d95d35
--- /dev/null
+++ b/src/guile/silex/silex.scm
@@ -0,0 +1,6651 @@
+; SILex - Scheme Implementation of Lex
+; SILex 1.0
+; Copyright (C) 2001  Danny Dube'
+; 
+; This program 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
+; of the License, or (at your option) any later version.
+; 
+; This program 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 this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+
+; Module util.scm.
+
+;
+; Quelques definitions de constantes
+;
+
+(define eof-tok              0)
+(define hblank-tok           1)
+(define vblank-tok           2)
+(define pipe-tok             3)
+(define question-tok         4)
+(define plus-tok             5)
+(define star-tok             6)
+(define lpar-tok             7)
+(define rpar-tok             8)
+(define dot-tok              9)
+(define lbrack-tok          10)
+(define lbrack-rbrack-tok   11)
+(define lbrack-caret-tok    12)
+(define lbrack-minus-tok    13)
+(define subst-tok           14)
+(define power-tok           15)
+(define doublequote-tok     16)
+(define char-tok            17)
+(define caret-tok           18)
+(define dollar-tok          19)
+(define <<EOF>>-tok         20)
+(define <<ERROR>>-tok       21)
+(define percent-percent-tok 22)
+(define id-tok              23)
+(define rbrack-tok          24)
+(define minus-tok           25)
+(define illegal-tok         26)
+; Tokens agreges
+(define class-tok           27)
+(define string-tok          28)
+
+(define number-of-tokens 29)
+
+(define newline-ch   (char->integer #\newline))
+(define tab-ch       (char->integer #\	))
+(define dollar-ch    (char->integer #\$))
+(define minus-ch     (char->integer #\-))
+(define rbrack-ch    (char->integer #\]))
+(define caret-ch     (char->integer #\^))
+
+(define dot-class (list (cons 'inf- (- newline-ch 1))
+			(cons (+ newline-ch 1) 'inf+)))
+
+(define default-action
+  (string-append "        (yycontinue)" (string #\newline)))
+(define default-<<EOF>>-action
+  (string-append "       '(0)" (string #\newline)))
+(define default-<<ERROR>>-action
+  (string-append "       (begin"
+		 (string #\newline)
+		 "         (display \"Error: Invalid token.\")"
+		 (string #\newline)
+		 "         (newline)"
+		 (string #\newline)
+		 "         'error)"
+		 (string #\newline)))
+
+
+
+
+;
+; Fabrication de tables de dispatch
+;
+
+(define make-dispatch-table
+  (lambda (size alist default)
+    (let ((v (make-vector size default)))
+      (let loop ((alist alist))
+	(if (null? alist)
+	    v
+	    (begin
+	      (vector-set! v (caar alist) (cdar alist))
+	      (loop (cdr alist))))))))
+
+
+
+
+;
+; Fonctions de manipulation des tokens
+;
+
+(define make-tok
+  (lambda (tok-type lexeme line column . attr)
+    (cond ((null? attr)
+	   (vector tok-type line column lexeme))
+	  ((null? (cdr attr))
+	   (vector tok-type line column lexeme (car attr)))
+	  (else
+	   (vector tok-type line column lexeme (car attr) (cadr attr))))))
+
+(define get-tok-type     (lambda (tok) (vector-ref tok 0)))
+(define get-tok-line     (lambda (tok) (vector-ref tok 1)))
+(define get-tok-column   (lambda (tok) (vector-ref tok 2)))
+(define get-tok-lexeme   (lambda (tok) (vector-ref tok 3)))
+(define get-tok-attr     (lambda (tok) (vector-ref tok 4)))
+(define get-tok-2nd-attr (lambda (tok) (vector-ref tok 5)))
+
+
+
+
+;
+; Fonctions de manipulations des regles
+;
+
+(define make-rule
+  (lambda (line eof? error? bol? eol? regexp action)
+    (vector line eof? error? bol? eol? regexp action #f)))
+
+(define get-rule-line    (lambda (rule) (vector-ref rule 0)))
+(define get-rule-eof?    (lambda (rule) (vector-ref rule 1)))
+(define get-rule-error?  (lambda (rule) (vector-ref rule 2)))
+(define get-rule-bol?    (lambda (rule) (vector-ref rule 3)))
+(define get-rule-eol?    (lambda (rule) (vector-ref rule 4)))
+(define get-rule-regexp  (lambda (rule) (vector-ref rule 5)))
+(define get-rule-action  (lambda (rule) (vector-ref rule 6)))
+(define get-rule-yytext? (lambda (rule) (vector-ref rule 7)))
+
+(define set-rule-regexp  (lambda (rule regexp)  (vector-set! rule 5 regexp)))
+(define set-rule-action  (lambda (rule action)  (vector-set! rule 6 action)))
+(define set-rule-yytext? (lambda (rule yytext?) (vector-set! rule 7 yytext?)))
+
+
+
+
+;
+; Noeuds des regexp
+;
+
+(define epsilon-re  0)
+(define or-re       1)
+(define conc-re     2)
+(define star-re     3)
+(define plus-re     4)
+(define question-re 5)
+(define class-re    6)
+(define char-re     7)
+
+(define make-re
+  (lambda (re-type . lattr)
+    (cond ((null? lattr)
+	   (vector re-type))
+	  ((null? (cdr lattr))
+	   (vector re-type (car lattr)))
+	  ((null? (cddr lattr))
+	   (vector re-type (car lattr) (cadr lattr))))))
+
+(define get-re-type  (lambda (re) (vector-ref re 0)))
+(define get-re-attr1 (lambda (re) (vector-ref re 1)))
+(define get-re-attr2 (lambda (re) (vector-ref re 2)))
+
+
+
+
+;
+; Fonctions de manipulation des ensembles d'etats
+;
+
+; Intersection de deux ensembles d'etats
+(define ss-inter
+  (lambda (ss1 ss2)
+    (cond ((null? ss1)
+	   '())
+	  ((null? ss2)
+	   '())
+	  (else
+	   (let ((t1 (car ss1))
+		 (t2 (car ss2)))
+	     (cond ((< t1 t2)
+		    (ss-inter (cdr ss1) ss2))
+		   ((= t1 t2)
+		    (cons t1 (ss-inter (cdr ss1) (cdr ss2))))
+		   (else
+		    (ss-inter ss1 (cdr ss2)))))))))
+
+; Difference entre deux ensembles d'etats
+(define ss-diff
+  (lambda (ss1 ss2)
+    (cond ((null? ss1)
+	   '())
+	  ((null? ss2)
+	   ss1)
+	  (else
+	   (let ((t1 (car ss1))
+		 (t2 (car ss2)))
+	     (cond ((< t1 t2)
+		    (cons t1 (ss-diff (cdr ss1) ss2)))
+		   ((= t1 t2)
+		    (ss-diff (cdr ss1) (cdr ss2)))
+		   (else
+		    (ss-diff ss1 (cdr ss2)))))))))
+
+; Union de deux ensembles d'etats
+(define ss-union
+  (lambda (ss1 ss2)
+    (cond ((null? ss1)
+	   ss2)
+	  ((null? ss2)
+	   ss1)
+	  (else
+	   (let ((t1 (car ss1))
+		 (t2 (car ss2)))
+	     (cond ((< t1 t2)
+		    (cons t1 (ss-union (cdr ss1) ss2)))
+		   ((= t1 t2)
+		    (cons t1 (ss-union (cdr ss1) (cdr ss2))))
+		   (else
+		    (cons t2 (ss-union ss1 (cdr ss2))))))))))
+
+; Decoupage de deux ensembles d'etats
+(define ss-sep
+  (lambda (ss1 ss2)
+    (let loop ((ss1 ss1) (ss2 ss2) (l '()) (c '()) (r '()))
+      (if (null? ss1)
+	  (if (null? ss2)
+	      (vector (reverse l) (reverse c) (reverse r))
+	      (loop ss1 (cdr ss2) l c (cons (car ss2) r)))
+	  (if (null? ss2)
+	      (loop (cdr ss1) ss2 (cons (car ss1) l) c r)
+	      (let ((t1 (car ss1))
+		    (t2 (car ss2)))
+		(cond ((< t1 t2)
+		       (loop (cdr ss1) ss2 (cons t1 l) c r))
+		      ((= t1 t2)
+		       (loop (cdr ss1) (cdr ss2) l (cons t1 c) r))
+		      (else
+		       (loop ss1 (cdr ss2) l c (cons t2 r))))))))))
+
+
+
+
+;
+; Fonctions de manipulation des classes de caracteres
+;
+
+; Comparaisons de bornes d'intervalles
+(define class-= eqv?)
+
+(define class-<=
+  (lambda (b1 b2)
+    (cond ((eq? b1 'inf-) #t)
+	  ((eq? b2 'inf+) #t)
+	  ((eq? b1 'inf+) #f)
+	  ((eq? b2 'inf-) #f)
+	  (else (<= b1 b2)))))
+
+(define class->=
+  (lambda (b1 b2)
+    (cond ((eq? b1 'inf+) #t)
+	  ((eq? b2 'inf-) #t)
+	  ((eq? b1 'inf-) #f)
+	  ((eq? b2 'inf+) #f)
+	  (else (>= b1 b2)))))
+
+(define class-<
+  (lambda (b1 b2)
+    (cond ((eq? b1 'inf+) #f)
+	  ((eq? b2 'inf-) #f)
+	  ((eq? b1 'inf-) #t)
+	  ((eq? b2 'inf+) #t)
+	  (else (< b1 b2)))))
+
+(define class->
+  (lambda (b1 b2)
+    (cond ((eq? b1 'inf-) #f)
+	  ((eq? b2 'inf+) #f)
+	  ((eq? b1 'inf+) #t)
+	  ((eq? b2 'inf-) #t)
+	  (else (> b1 b2)))))
+
+; Complementation d'une classe
+(define class-compl
+  (lambda (c)
+    (let loop ((c c) (start 'inf-))
+      (if (null? c)
+	  (list (cons start 'inf+))
+	  (let* ((r (car c))
+		 (rstart (car r))
+		 (rend (cdr r)))
+	    (if (class-< start rstart)
+		(cons (cons start (- rstart 1))
+		      (loop c rstart))
+		(if (class-< rend 'inf+)
+		    (loop (cdr c) (+ rend 1))
+		    '())))))))
+
+; Union de deux classes de caracteres
+(define class-union
+  (lambda (c1 c2)
+    (let loop ((c1 c1) (c2 c2) (u '()))
+      (if (null? c1)
+	  (if (null? c2)
+	      (reverse u)
+	      (loop c1 (cdr c2) (cons (car c2) u)))
+	  (if (null? c2)
+	      (loop (cdr c1) c2 (cons (car c1) u))
+	      (let* ((r1 (car c1))
+		     (r2 (car c2))
+		     (r1start (car r1))
+		     (r1end (cdr r1))
+		     (r2start (car r2))
+		     (r2end (cdr r2)))
+		(if (class-<= r1start r2start)
+		    (cond ((class-= r1end 'inf+)
+			   (loop c1 (cdr c2) u))
+			  ((class-< (+ r1end 1) r2start)
+			   (loop (cdr c1) c2 (cons r1 u)))
+			  ((class-<= r1end r2end)
+			   (loop (cdr c1)
+				 (cons (cons r1start r2end) (cdr c2))
+				 u))
+			  (else
+			   (loop c1 (cdr c2) u)))
+		    (cond ((class-= r2end 'inf+)
+			   (loop (cdr c1) c2 u))
+			  ((class-> r1start (+ r2end 1))
+			   (loop c1 (cdr c2) (cons r2 u)))
+			  ((class->= r1end r2end)
+			   (loop (cons (cons r2start r1end) (cdr c1))
+				 (cdr c2)
+				 u))
+			  (else
+			   (loop (cdr c1) c2 u))))))))))
+
+; Decoupage de deux classes de caracteres
+(define class-sep
+  (lambda (c1 c2)
+    (let loop ((c1 c1) (c2 c2) (l '()) (c '()) (r '()))
+      (if (null? c1)
+	  (if (null? c2)
+	      (vector (reverse l) (reverse c) (reverse r))
+	      (loop c1 (cdr c2) l c (cons (car c2) r)))
+	  (if (null? c2)
+	      (loop (cdr c1) c2 (cons (car c1) l) c r)
+	      (let* ((r1 (car c1))
+		     (r2 (car c2))
+		     (r1start (car r1))
+		     (r1end (cdr r1))
+		     (r2start (car r2))
+		     (r2end (cdr r2)))
+		(cond ((class-< r1start r2start)
+		       (if (class-< r1end r2start)
+			   (loop (cdr c1) c2 (cons r1 l) c r)
+			   (loop (cons (cons r2start r1end) (cdr c1)) c2
+				 (cons (cons r1start (- r2start 1)) l) c r)))
+		      ((class-> r1start r2start)
+		       (if (class-> r1start r2end)
+			   (loop c1 (cdr c2) l c (cons r2 r))
+			   (loop c1 (cons (cons r1start r2end) (cdr c2))
+				 l c (cons (cons r2start (- r1start 1)) r))))
+		      (else
+		       (cond ((class-< r1end r2end)
+			      (loop (cdr c1)
+				    (cons (cons (+ r1end 1) r2end) (cdr c2))
+				    l (cons r1 c) r))
+			     ((class-= r1end r2end)
+			      (loop (cdr c1) (cdr c2) l (cons r1 c) r))
+			     (else
+			      (loop (cons (cons (+ r2end 1) r1end) (cdr c1))
+				    (cdr c2)
+				    l (cons r2 c) r)))))))))))
+
+; Transformer une classe (finie) de caracteres en une liste de ...
+(define class->char-list
+  (lambda (c)
+    (let loop1 ((c c))
+      (if (null? c)
+	  '()
+	  (let* ((r (car c))
+		 (rend (cdr r))
+		 (tail (loop1 (cdr c))))
+	    (let loop2 ((rstart (car r)))
+	      (if (<= rstart rend)
+		  (cons (integer->char rstart) (loop2 (+ rstart 1)))
+		  tail)))))))
+
+; Transformer une classe de caracteres en une liste poss. compl.
+; 1er element = #t -> classe complementee
+(define class->tagged-char-list
+  (lambda (c)
+    (let* ((finite? (or (null? c) (number? (caar c))))
+	   (c2 (if finite? c (class-compl c)))
+	   (c-l (class->char-list c2)))
+      (cons (not finite?) c-l))))
+
+
+
+
+;
+; Fonction digraph
+;
+
+; Fonction "digraph".
+; Etant donne un graphe dirige dont les noeuds comportent une valeur,
+; calcule pour chaque noeud la "somme" des valeurs contenues dans le
+; noeud lui-meme et ceux atteignables a partir de celui-ci.  La "somme"
+; consiste a appliquer un operateur commutatif et associatif aux valeurs
+; lorsqu'elles sont additionnees.
+; L'entree consiste en un vecteur de voisinages externes, un autre de
+; valeurs initiales et d'un operateur.
+; La sortie est un vecteur de valeurs finales.
+(define digraph
+  (lambda (arcs init op)
+    (let* ((nbnodes (vector-length arcs))
+	   (infinity nbnodes)
+	   (prio (make-vector nbnodes -1))
+	   (stack (make-vector nbnodes #f))
+	   (sp 0)
+	   (final (make-vector nbnodes #f)))
+      (letrec ((store-final
+		(lambda (self-sp value)
+		  (let loop ()
+		    (if (> sp self-sp)
+			(let ((voisin (vector-ref stack (- sp 1))))
+			  (vector-set! prio voisin infinity)
+			  (set! sp (- sp 1))
+			  (vector-set! final voisin value)
+			  (loop))))))
+	       (visit-node
+		(lambda (n)
+		  (let ((self-sp sp))
+		    (vector-set! prio n self-sp)
+		    (vector-set! stack sp n)
+		    (set! sp (+ sp 1))
+		    (vector-set! final n (vector-ref init n))
+		    (let loop ((vois (vector-ref arcs n)))
+		      (if (pair? vois)
+			  (let* ((v (car vois))
+				 (vprio (vector-ref prio v)))
+			    (if (= vprio -1)
+				(visit-node v))
+			    (vector-set! prio n (min (vector-ref prio n)
+						     (vector-ref prio v)))
+			    (vector-set! final n (op (vector-ref final n)
+						     (vector-ref final v)))
+			    (loop (cdr vois)))))
+		    (if (= (vector-ref prio n) self-sp)
+			(store-final self-sp (vector-ref final n)))))))
+	(let loop ((n 0))
+	  (if (< n nbnodes)
+	      (begin
+		(if (= (vector-ref prio n) -1)
+		    (visit-node n))
+		(loop (+ n 1)))))
+	final))))
+
+
+
+
+;
+; Fonction de tri
+;
+
+(define merge-sort-merge
+  (lambda (l1 l2 cmp-<=)
+    (cond ((null? l1)
+	   l2)
+	  ((null? l2)
+	   l1)
+	  (else
+	   (let ((h1 (car l1))
+		 (h2 (car l2)))
+	     (if (cmp-<= h1 h2)
+		 (cons h1 (merge-sort-merge (cdr l1) l2 cmp-<=))
+		 (cons h2 (merge-sort-merge l1 (cdr l2) cmp-<=))))))))
+
+(define merge-sort
+  (lambda (l cmp-<=)
+    (if (null? l)
+	l
+	(let loop1 ((ll (map list l)))
+	  (if (null? (cdr ll))
+	      (car ll)
+	      (loop1
+	       (let loop2 ((ll ll))
+		 (cond ((null? ll)
+			ll)
+		       ((null? (cdr ll))
+			ll)
+		       (else
+			(cons (merge-sort-merge (car ll) (cadr ll) cmp-<=)
+			      (loop2 (cddr ll))))))))))))
+
+; Module action.l.scm.
+
+(define action-tables
+  (vector
+   'all
+   (lambda (yycontinue yygetc yyungetc)
+     (lambda (yytext yyline yycolumn yyoffset)
+          (make-tok eof-tok    yytext yyline yycolumn)
+       ))
+   (lambda (yycontinue yygetc yyungetc)
+     (lambda (yytext yyline yycolumn yyoffset)
+       (begin
+         (display "Error: Invalid token.")
+         (newline)
+         'error)
+       ))
+   (vector
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+          (make-tok hblank-tok yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+          (make-tok vblank-tok yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+          (make-tok char-tok   yytext yyline yycolumn)
+        )))
+   'tagged-chars-lists
+   0
+   0
+   '#((((#f #\	 #\space) . 4)
+       ((#f #\;) . 3)
+       ((#f #\newline) . 2)
+       ((#t #\	 #\newline #\space #\;) . 1))
+      (((#t #\newline) . 1))
+      ()
+      (((#t #\newline) . 3))
+      (((#f #\	 #\space) . 4)
+       ((#f #\;) . 3)
+       ((#t #\	 #\newline #\space #\;) . 1)))
+   '#((#f . #f) (2 . 2) (1 . 1) (0 . 0) (0 . 0))))
+
+; Module class.l.scm.
+
+(define class-tables
+  (vector
+   'all
+   (lambda (yycontinue yygetc yyungetc)
+     (lambda (yytext yyline yycolumn yyoffset)
+              (make-tok eof-tok    yytext yyline yycolumn)
+       ))
+   (lambda (yycontinue yygetc yyungetc)
+     (lambda (yytext yyline yycolumn yyoffset)
+       (begin
+         (display "Error: Invalid token.")
+         (newline)
+         'error)
+       ))
+   (vector
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+              (make-tok rbrack-tok yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+              (make-tok minus-tok  yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+              (parse-spec-char     yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+              (parse-digits-char   yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+              (parse-digits-char   yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+              (parse-quoted-char   yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+              (parse-ordinary-char yytext yyline yycolumn)
+        )))
+   'tagged-chars-lists
+   0
+   0
+   '#((((#f #\]) . 4) ((#f #\-) . 3) ((#f #\\) . 2) ((#t #\- #\\ #\]) . 1))
+      ()
+      (((#f #\n) . 8)
+       ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 7)
+       ((#f #\-) . 6)
+       ((#t #\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\n) . 5))
+      ()
+      ()
+      ()
+      (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 9))
+      (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 10))
+      ()
+      (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 9))
+      (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 10)))
+   '#((#f . #f) (6 . 6)   (6 . 6)   (1 . 1)   (0 . 0)   (5 . 5)   (5 . 5)
+      (3 . 3)   (2 . 2)   (4 . 4)   (3 . 3))))
+
+; Module macro.l.scm.
+
+(define macro-tables
+  (vector
+   'all
+   (lambda (yycontinue yygetc yyungetc)
+     (lambda (yytext yyline yycolumn yyoffset)
+         (make-tok eof-tok             yytext yyline yycolumn)
+       ))
+   (lambda (yycontinue yygetc yyungetc)
+     (lambda (yytext yyline yycolumn yyoffset)
+       (begin
+         (display "Error: Invalid token.")
+         (newline)
+         'error)
+       ))
+   (vector
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+         (make-tok hblank-tok          yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+         (make-tok vblank-tok          yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+         (make-tok percent-percent-tok yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+         (parse-id                     yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+         (make-tok illegal-tok         yytext yyline yycolumn)
+        )))
+   'tagged-chars-lists
+   0
+   0
+   '#((((#f #\	 #\space) . 8)
+       ((#f #\;) . 7)
+       ((#f #\newline) . 6)
+       ((#f #\%) . 5)
+       ((#f  #\! #\$ #\& #\* #\/ #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E
+         #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U
+         #\V #\W #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i
+         #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y
+         #\z #\~)
+        .
+        4)
+       ((#f #\+ #\-) . 3)
+       ((#f #\.) . 2)
+       ((#t        #\	       #\newline #\space   #\!       #\$
+         #\%       #\&       #\*       #\+       #\-       #\.
+         #\/       #\:       #\;       #\<       #\=       #\>
+         #\?       #\A       #\B       #\C       #\D       #\E
+         #\F       #\G       #\H       #\I       #\J       #\K
+         #\L       #\M       #\N       #\O       #\P       #\Q
+         #\R       #\S       #\T       #\U       #\V       #\W
+         #\X       #\Y       #\Z       #\^       #\_       #\a
+         #\b       #\c       #\d       #\e       #\f       #\g
+         #\h       #\i       #\j       #\k       #\l       #\m
+         #\n       #\o       #\p       #\q       #\r       #\s
+         #\t       #\u       #\v       #\w       #\x       #\y
+         #\z       #\~)
+        .
+        1))
+      ()
+      (((#f #\.) . 9))
+      ()
+      (((#f  #\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
+         #\6 #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G
+         #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W
+         #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k
+         #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
+        .
+        10))
+      (((#f #\%) . 11)
+       ((#f  #\! #\$ #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5 #\6
+         #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G #\H
+         #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X
+         #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l
+         #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
+        .
+        10))
+      ()
+      (((#t #\newline) . 12))
+      ()
+      (((#f #\.) . 13))
+      (((#f  #\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
+         #\6 #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G
+         #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W
+         #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k
+         #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
+        .
+        10))
+      (((#f  #\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
+         #\6 #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G
+         #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W
+         #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k
+         #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
+        .
+        10))
+      (((#t #\newline) . 12))
+      ())
+   '#((#f . #f) (4 . 4)   (4 . 4)   (3 . 3)   (3 . 3)   (3 . 3)   (1 . 1)
+      (0 . 0)   (0 . 0)   (#f . #f) (3 . 3)   (2 . 2)   (0 . 0)   (3 . 3))))
+
+; Module regexp.l.scm.
+
+(define regexp-tables
+  (vector
+   'all
+   (lambda (yycontinue yygetc yyungetc)
+     (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok eof-tok           yytext yyline yycolumn)
+       ))
+   (lambda (yycontinue yygetc yyungetc)
+     (lambda (yytext yyline yycolumn yyoffset)
+       (begin
+         (display "Error: Invalid token.")
+         (newline)
+         'error)
+       ))
+   (vector
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok hblank-tok        yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok vblank-tok        yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok pipe-tok          yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok question-tok      yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok plus-tok          yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok star-tok          yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok lpar-tok          yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok rpar-tok          yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok dot-tok           yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok lbrack-tok        yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok lbrack-rbrack-tok yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok lbrack-caret-tok  yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok lbrack-minus-tok  yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (parse-id-ref               yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (parse-power-m              yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (parse-power-m-inf          yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (parse-power-m-n            yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok illegal-tok       yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok doublequote-tok   yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (parse-spec-char            yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (parse-digits-char          yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (parse-digits-char          yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (parse-quoted-char          yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok caret-tok         yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok dollar-tok        yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (parse-ordinary-char        yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok <<EOF>>-tok       yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+                          (make-tok <<ERROR>>-tok     yytext yyline yycolumn)
+        )))
+   'tagged-chars-lists
+   0
+   0
+   '#((((#f #\	 #\space) . 18)
+       ((#f #\;) . 17)
+       ((#f #\newline) . 16)
+       ((#f #\|) . 15)
+       ((#f #\?) . 14)
+       ((#f #\+) . 13)
+       ((#f #\*) . 12)
+       ((#f #\() . 11)
+       ((#f #\)) . 10)
+       ((#f #\.) . 9)
+       ((#f #\[) . 8)
+       ((#f #\{) . 7)
+       ((#f #\") . 6)
+       ((#f #\\) . 5)
+       ((#f #\^) . 4)
+       ((#f #\$) . 3)
+       ((#t        #\	       #\newline #\space   #\"       #\$
+         #\(       #\)       #\*       #\+       #\.       #\;
+         #\<       #\?       #\[       #\\       #\^       #\{
+         #\|)
+        .
+        2)
+       ((#f #\<) . 1))
+      (((#f #\<) . 19))
+      ()
+      ()
+      ()
+      (((#f #\n) . 23)
+       ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 22)
+       ((#f #\-) . 21)
+       ((#t #\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\n) . 20))
+      ()
+      (((#f  #\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\A #\B #\C #\D
+         #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T
+         #\U #\V #\W #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h
+         #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x
+         #\y #\z #\~)
+        .
+        27)
+       ((#f #\+ #\-) . 26)
+       ((#f #\.) . 25)
+       ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 24))
+      (((#f #\]) . 30) ((#f #\^) . 29) ((#f #\-) . 28))
+      ()
+      ()
+      ()
+      ()
+      ()
+      ()
+      ()
+      ()
+      (((#t #\newline) . 31))
+      ()
+      (((#f #\E) . 32))
+      ()
+      (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 33))
+      (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 34))
+      ()
+      (((#f #\}) . 36)
+       ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 24)
+       ((#f #\,) . 35))
+      (((#f #\.) . 37))
+      (((#f #\}) . 38))
+      (((#f #\}) . 38)
+       ((#f  #\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
+         #\6 #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G
+         #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W
+         #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k
+         #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
+        .
+        27))
+      ()
+      ()
+      ()
+      (((#t #\newline) . 31))
+      (((#f #\O) . 40) ((#f #\R) . 39))
+      (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 33))
+      (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 34))
+      (((#f #\}) . 42) ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 41))
+      ()
+      (((#f #\.) . 26))
+      ()
+      (((#f #\R) . 43))
+      (((#f #\F) . 44))
+      (((#f #\}) . 45) ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 41))
+      ()
+      (((#f #\O) . 46))
+      (((#f #\>) . 47))
+      ()
+      (((#f #\R) . 48))
+      (((#f #\>) . 49))
+      (((#f #\>) . 50))
+      ()
+      (((#f #\>) . 51))
+      ())
+   '#((#f . #f) (25 . 25) (25 . 25) (24 . 24) (23 . 23) (25 . 25) (18 . 18)
+      (17 . 17) (9 . 9)   (8 . 8)   (7 . 7)   (6 . 6)   (5 . 5)   (4 . 4)
+      (3 . 3)   (2 . 2)   (1 . 1)   (0 . 0)   (0 . 0)   (#f . #f) (22 . 22)
+      (22 . 22) (20 . 20) (19 . 19) (#f . #f) (#f . #f) (#f . #f) (#f . #f)
+      (12 . 12) (11 . 11) (10 . 10) (0 . 0)   (#f . #f) (21 . 21) (20 . 20)
+      (#f . #f) (14 . 14) (#f . #f) (13 . 13) (#f . #f) (#f . #f) (#f . #f)
+      (15 . 15) (#f . #f) (#f . #f) (16 . 16) (#f . #f) (#f . #f) (#f . #f)
+      (26 . 26) (#f . #f) (27 . 27))))
+
+; Module string.l.scm.
+
+(define string-tables
+  (vector
+   'all
+   (lambda (yycontinue yygetc yyungetc)
+     (lambda (yytext yyline yycolumn yyoffset)
+              (make-tok eof-tok         yytext yyline yycolumn)
+       ))
+   (lambda (yycontinue yygetc yyungetc)
+     (lambda (yytext yyline yycolumn yyoffset)
+       (begin
+         (display "Error: Invalid token.")
+         (newline)
+         'error)
+       ))
+   (vector
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+              (make-tok doublequote-tok yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+              (parse-spec-char          yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+              (parse-digits-char        yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+              (parse-digits-char        yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+              (parse-quoted-char        yytext yyline yycolumn)
+        ))
+    #t
+    (lambda (yycontinue yygetc yyungetc)
+      (lambda (yytext yyline yycolumn yyoffset)
+              (parse-ordinary-char      yytext yyline yycolumn)
+        )))
+   'tagged-chars-lists
+   0
+   0
+   '#((((#f #\") . 3) ((#f #\\) . 2) ((#t #\" #\\) . 1))
+      ()
+      (((#f #\n) . 7)
+       ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 6)
+       ((#f #\-) . 5)
+       ((#t #\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\n) . 4))
+      ()
+      ()
+      (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 8))
+      (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 9))
+      ()
+      (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 8))
+      (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 9)))
+   '#((#f . #f) (5 . 5)   (5 . 5)   (0 . 0)   (4 . 4)   (4 . 4)   (2 . 2)
+      (1 . 1)   (3 . 3)   (2 . 2))))
+
+; Module multilex.scm.
+
+;
+; Gestion des Input Systems
+; Fonctions a utiliser par l'usager:
+;   lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc,
+;   lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
+;
+
+; Taille initiale par defaut du buffer d'entree
+(define lexer-init-buffer-len 1024)
+
+; Numero du caractere newline
+(define lexer-integer-newline (char->integer #\newline))
+
+; Constructeur d'IS brut
+(define lexer-raw-IS-maker
+  (lambda (buffer read-ptr input-f counters)
+    (let ((input-f          input-f)                ; Entree reelle
+	  (buffer           buffer)                 ; Buffer
+	  (buflen           (string-length buffer))
+	  (read-ptr         read-ptr)
+	  (start-ptr        1)                      ; Marque de debut de lexeme
+	  (start-line       1)
+	  (start-column     1)
+	  (start-offset     0)
+	  (end-ptr          1)                      ; Marque de fin de lexeme
+	  (point-ptr        1)                      ; Le point
+	  (user-ptr         1)                      ; Marque de l'usager
+	  (user-line        1)
+	  (user-column      1)
+	  (user-offset      0)
+	  (user-up-to-date? #t))                    ; Concerne la colonne seul.
+      (letrec
+	  ((start-go-to-end-none         ; Fonctions de depl. des marques
+	    (lambda ()
+	      (set! start-ptr end-ptr)))
+	   (start-go-to-end-line
+	    (lambda ()
+	      (let loop ((ptr start-ptr) (line start-line))
+		(if (= ptr end-ptr)
+		    (begin
+		      (set! start-ptr ptr)
+		      (set! start-line line))
+		    (if (char=? (string-ref buffer ptr) #\newline)
+			(loop (+ ptr 1) (+ line 1))
+			(loop (+ ptr 1) line))))))
+	   (start-go-to-end-all
+	    (lambda ()
+	      (set! start-offset (+ start-offset (- end-ptr start-ptr)))
+	      (let loop ((ptr start-ptr)
+			 (line start-line)
+			 (column start-column))
+		(if (= ptr end-ptr)
+		    (begin
+		      (set! start-ptr ptr)
+		      (set! start-line line)
+		      (set! start-column column))
+		    (if (char=? (string-ref buffer ptr) #\newline)
+			(loop (+ ptr 1) (+ line 1) 1)
+			(loop (+ ptr 1) line (+ column 1)))))))
+	   (start-go-to-user-none
+	    (lambda ()
+	      (set! start-ptr user-ptr)))
+	   (start-go-to-user-line
+	    (lambda ()
+	      (set! start-ptr user-ptr)
+	      (set! start-line user-line)))
+	   (start-go-to-user-all
+	    (lambda ()
+	      (set! start-line user-line)
+	      (set! start-offset user-offset)
+	      (if user-up-to-date?
+		  (begin
+		    (set! start-ptr user-ptr)
+		    (set! start-column user-column))
+		  (let loop ((ptr start-ptr) (column start-column))
+		    (if (= ptr user-ptr)
+			(begin
+			  (set! start-ptr ptr)
+			  (set! start-column column))
+			(if (char=? (string-ref buffer ptr) #\newline)
+			    (loop (+ ptr 1) 1)
+			    (loop (+ ptr 1) (+ column 1))))))))
+	   (end-go-to-point
+	    (lambda ()
+	      (set! end-ptr point-ptr)))
+	   (point-go-to-start
+	    (lambda ()
+	      (set! point-ptr start-ptr)))
+	   (user-go-to-start-none
+	    (lambda ()
+	      (set! user-ptr start-ptr)))
+	   (user-go-to-start-line
+	    (lambda ()
+	      (set! user-ptr start-ptr)
+	      (set! user-line start-line)))
+	   (user-go-to-start-all
+	    (lambda ()
+	      (set! user-ptr start-ptr)
+	      (set! user-line start-line)
+	      (set! user-column start-column)
+	      (set! user-offset start-offset)
+	      (set! user-up-to-date? #t)))
+	   (init-lexeme-none             ; Debute un nouveau lexeme
+	    (lambda ()
+	      (if (< start-ptr user-ptr)
+		  (start-go-to-user-none))
+	      (point-go-to-start)))
+	   (init-lexeme-line
+	    (lambda ()
+	      (if (< start-ptr user-ptr)
+		  (start-go-to-user-line))
+	      (point-go-to-start)))
+	   (init-lexeme-all
+	    (lambda ()
+	      (if (< start-ptr user-ptr)
+		  (start-go-to-user-all))
+	      (point-go-to-start)))
+	   (get-start-line               ; Obtention des stats du debut du lxm
+	    (lambda ()
+	      start-line))
+	   (get-start-column
+	    (lambda ()
+	      start-column))
+	   (get-start-offset
+	    (lambda ()
+	      start-offset))
+	   (peek-left-context            ; Obtention de caracteres (#f si EOF)
+	    (lambda ()
+	      (char->integer (string-ref buffer (- start-ptr 1)))))
+	   (peek-char
+	    (lambda ()
+	      (if (< point-ptr read-ptr)
+		  (char->integer (string-ref buffer point-ptr))
+		  (let ((c (input-f)))
+		    (if (char? c)
+			(begin
+			  (if (= read-ptr buflen)
+			      (reorganize-buffer))
+			  (string-set! buffer point-ptr c)
+			  (set! read-ptr (+ point-ptr 1))
+			  (char->integer c))
+			(begin
+			  (set! input-f (lambda () 'eof))
+			  #f))))))
+	   (read-char
+	    (lambda ()
+	      (if (< point-ptr read-ptr)
+		  (let ((c (string-ref buffer point-ptr)))
+		    (set! point-ptr (+ point-ptr 1))
+		    (char->integer c))
+		  (let ((c (input-f)))
+		    (if (char? c)
+			(begin
+			  (if (= read-ptr buflen)
+			      (reorganize-buffer))
+			  (string-set! buffer point-ptr c)
+			  (set! read-ptr (+ point-ptr 1))
+			  (set! point-ptr read-ptr)
+			  (char->integer c))
+			(begin
+			  (set! input-f (lambda () 'eof))
+			  #f))))))
+	   (get-start-end-text           ; Obtention du lexeme
+	    (lambda ()
+	      (substring buffer start-ptr end-ptr)))
+	   (get-user-line-line           ; Fonctions pour l'usager
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-line))
+	      user-line))
+	   (get-user-line-all
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-all))
+	      user-line))
+	   (get-user-column-all
+	    (lambda ()
+	      (cond ((< user-ptr start-ptr)
+		     (user-go-to-start-all)
+		     user-column)
+		    (user-up-to-date?
+		     user-column)
+		    (else
+		     (let loop ((ptr start-ptr) (column start-column))
+		       (if (= ptr user-ptr)
+			   (begin
+			     (set! user-column column)
+			     (set! user-up-to-date? #t)
+			     column)
+			   (if (char=? (string-ref buffer ptr) #\newline)
+			       (loop (+ ptr 1) 1)
+			       (loop (+ ptr 1) (+ column 1)))))))))
+	   (get-user-offset-all
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-all))
+	      user-offset))
+	   (user-getc-none
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-none))
+	      (if (< user-ptr read-ptr)
+		  (let ((c (string-ref buffer user-ptr)))
+		    (set! user-ptr (+ user-ptr 1))
+		    c)
+		  (let ((c (input-f)))
+		    (if (char? c)
+			(begin
+			  (if (= read-ptr buflen)
+			      (reorganize-buffer))
+			  (string-set! buffer user-ptr c)
+			  (set! read-ptr (+ read-ptr 1))
+			  (set! user-ptr read-ptr)
+			  c)
+			(begin
+			  (set! input-f (lambda () 'eof))
+			  'eof))))))
+	   (user-getc-line
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-line))
+	      (if (< user-ptr read-ptr)
+		  (let ((c (string-ref buffer user-ptr)))
+		    (set! user-ptr (+ user-ptr 1))
+		    (if (char=? c #\newline)
+			(set! user-line (+ user-line 1)))
+		    c)
+		  (let ((c (input-f)))
+		    (if (char? c)
+			(begin
+			  (if (= read-ptr buflen)
+			      (reorganize-buffer))
+			  (string-set! buffer user-ptr c)
+			  (set! read-ptr (+ read-ptr 1))
+			  (set! user-ptr read-ptr)
+			  (if (char=? c #\newline)
+			      (set! user-line (+ user-line 1)))
+			  c)
+			(begin
+			  (set! input-f (lambda () 'eof))
+			  'eof))))))
+	   (user-getc-all
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-all))
+	      (if (< user-ptr read-ptr)
+		  (let ((c (string-ref buffer user-ptr)))
+		    (set! user-ptr (+ user-ptr 1))
+		    (if (char=? c #\newline)
+			(begin
+			  (set! user-line (+ user-line 1))
+			  (set! user-column 1))
+			(set! user-column (+ user-column 1)))
+		    (set! user-offset (+ user-offset 1))
+		    c)
+		  (let ((c (input-f)))
+		    (if (char? c)
+			(begin
+			  (if (= read-ptr buflen)
+			      (reorganize-buffer))
+			  (string-set! buffer user-ptr c)
+			  (set! read-ptr (+ read-ptr 1))
+			  (set! user-ptr read-ptr)
+			  (if (char=? c #\newline)
+			      (begin
+				(set! user-line (+ user-line 1))
+				(set! user-column 1))
+			      (set! user-column (+ user-column 1)))
+			  (set! user-offset (+ user-offset 1))
+			  c)
+			(begin
+			  (set! input-f (lambda () 'eof))
+			  'eof))))))
+	   (user-ungetc-none
+	    (lambda ()
+	      (if (> user-ptr start-ptr)
+		  (set! user-ptr (- user-ptr 1)))))
+	   (user-ungetc-line
+	    (lambda ()
+	      (if (> user-ptr start-ptr)
+		  (begin
+		    (set! user-ptr (- user-ptr 1))
+		    (let ((c (string-ref buffer user-ptr)))
+		      (if (char=? c #\newline)
+			  (set! user-line (- user-line 1))))))))
+	   (user-ungetc-all
+	    (lambda ()
+	      (if (> user-ptr start-ptr)
+		  (begin
+		    (set! user-ptr (- user-ptr 1))
+		    (let ((c (string-ref buffer user-ptr)))
+		      (if (char=? c #\newline)
+			  (begin
+			    (set! user-line (- user-line 1))
+			    (set! user-up-to-date? #f))
+			  (set! user-column (- user-column 1)))
+		      (set! user-offset (- user-offset 1)))))))
+	   (reorganize-buffer            ; Decaler ou agrandir le buffer
+	    (lambda ()
+	      (if (< (* 2 start-ptr) buflen)
+		  (let* ((newlen (* 2 buflen))
+			 (newbuf (make-string newlen))
+			 (delta (- start-ptr 1)))
+		    (let loop ((from (- start-ptr 1)))
+		      (if (< from buflen)
+			  (begin
+			    (string-set! newbuf
+					 (- from delta)
+					 (string-ref buffer from))
+			    (loop (+ from 1)))))
+		    (set! buffer    newbuf)
+		    (set! buflen    newlen)
+		    (set! read-ptr  (- read-ptr delta))
+		    (set! start-ptr (- start-ptr delta))
+		    (set! end-ptr   (- end-ptr delta))
+		    (set! point-ptr (- point-ptr delta))
+		    (set! user-ptr  (- user-ptr delta)))
+		  (let ((delta (- start-ptr 1)))
+		    (let loop ((from (- start-ptr 1)))
+		      (if (< from buflen)
+			  (begin
+			    (string-set! buffer
+					 (- from delta)
+					 (string-ref buffer from))
+			    (loop (+ from 1)))))
+		    (set! read-ptr  (- read-ptr delta))
+		    (set! start-ptr (- start-ptr delta))
+		    (set! end-ptr   (- end-ptr delta))
+		    (set! point-ptr (- point-ptr delta))
+		    (set! user-ptr  (- user-ptr delta)))))))
+	(list (cons 'start-go-to-end
+		    (cond ((eq? counters 'none) start-go-to-end-none)
+			  ((eq? counters 'line) start-go-to-end-line)
+			  ((eq? counters 'all ) start-go-to-end-all)))
+	      (cons 'end-go-to-point
+		    end-go-to-point)
+	      (cons 'init-lexeme
+		    (cond ((eq? counters 'none) init-lexeme-none)
+			  ((eq? counters 'line) init-lexeme-line)
+			  ((eq? counters 'all ) init-lexeme-all)))
+	      (cons 'get-start-line
+		    get-start-line)
+	      (cons 'get-start-column
+		    get-start-column)
+	      (cons 'get-start-offset
+		    get-start-offset)
+	      (cons 'peek-left-context
+		    peek-left-context)
+	      (cons 'peek-char
+		    peek-char)
+	      (cons 'read-char
+		    read-char)
+	      (cons 'get-start-end-text
+		    get-start-end-text)
+	      (cons 'get-user-line
+		    (cond ((eq? counters 'none) #f)
+			  ((eq? counters 'line) get-user-line-line)
+			  ((eq? counters 'all ) get-user-line-all)))
+	      (cons 'get-user-column
+		    (cond ((eq? counters 'none) #f)
+			  ((eq? counters 'line) #f)
+			  ((eq? counters 'all ) get-user-column-all)))
+	      (cons 'get-user-offset
+		    (cond ((eq? counters 'none) #f)
+			  ((eq? counters 'line) #f)
+			  ((eq? counters 'all ) get-user-offset-all)))
+	      (cons 'user-getc
+		    (cond ((eq? counters 'none) user-getc-none)
+			  ((eq? counters 'line) user-getc-line)
+			  ((eq? counters 'all ) user-getc-all)))
+	      (cons 'user-ungetc
+		    (cond ((eq? counters 'none) user-ungetc-none)
+			  ((eq? counters 'line) user-ungetc-line)
+			  ((eq? counters 'all ) user-ungetc-all))))))))
+
+; Construit un Input System
+; Le premier parametre doit etre parmi "port", "procedure" ou "string"
+; Prend un parametre facultatif qui doit etre parmi
+; "none", "line" ou "all"
+(define lexer-make-IS
+  (lambda (input-type input . largs)
+    (let ((counters-type (cond ((null? largs)
+				'line)
+			       ((memq (car largs) '(none line all))
+				(car largs))
+			       (else
+				'line))))
+      (cond ((and (eq? input-type 'port) (input-port? input))
+	     (let* ((buffer   (make-string lexer-init-buffer-len #\newline))
+		    (read-ptr 1)
+		    (input-f  (lambda () (read-char input))))
+	       (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+	    ((and (eq? input-type 'procedure) (procedure? input))
+	     (let* ((buffer   (make-string lexer-init-buffer-len #\newline))
+		    (read-ptr 1)
+		    (input-f  input))
+	       (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+	    ((and (eq? input-type 'string) (string? input))
+	     (let* ((buffer   (string-append (string #\newline) input))
+		    (read-ptr (string-length buffer))
+		    (input-f  (lambda () 'eof)))
+	       (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+	    (else
+	     (let* ((buffer   (string #\newline))
+		    (read-ptr 1)
+		    (input-f  (lambda () 'eof)))
+	       (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))))))
+
+; Les fonctions:
+;   lexer-get-func-getc, lexer-get-func-ungetc,
+;   lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
+(define lexer-get-func-getc
+  (lambda (IS) (cdr (assq 'user-getc IS))))
+(define lexer-get-func-ungetc
+  (lambda (IS) (cdr (assq 'user-ungetc IS))))
+(define lexer-get-func-line
+  (lambda (IS) (cdr (assq 'get-user-line IS))))
+(define lexer-get-func-column
+  (lambda (IS) (cdr (assq 'get-user-column IS))))
+(define lexer-get-func-offset
+  (lambda (IS) (cdr (assq 'get-user-offset IS))))
+
+;
+; Gestion des lexers
+;
+
+; Fabrication de lexer a partir d'arbres de decision
+(define lexer-make-tree-lexer
+  (lambda (tables IS)
+    (letrec
+	(; Contenu de la table
+	 (counters-type        (vector-ref tables 0))
+	 (<<EOF>>-pre-action   (vector-ref tables 1))
+	 (<<ERROR>>-pre-action (vector-ref tables 2))
+	 (rules-pre-actions    (vector-ref tables 3))
+	 (table-nl-start       (vector-ref tables 5))
+	 (table-no-nl-start    (vector-ref tables 6))
+	 (trees-v              (vector-ref tables 7))
+	 (acc-v                (vector-ref tables 8))
+
+	 ; Contenu du IS
+	 (IS-start-go-to-end    (cdr (assq 'start-go-to-end IS)))
+	 (IS-end-go-to-point    (cdr (assq 'end-go-to-point IS)))
+	 (IS-init-lexeme        (cdr (assq 'init-lexeme IS)))
+	 (IS-get-start-line     (cdr (assq 'get-start-line IS)))
+	 (IS-get-start-column   (cdr (assq 'get-start-column IS)))
+	 (IS-get-start-offset   (cdr (assq 'get-start-offset IS)))
+	 (IS-peek-left-context  (cdr (assq 'peek-left-context IS)))
+	 (IS-peek-char          (cdr (assq 'peek-char IS)))
+	 (IS-read-char          (cdr (assq 'read-char IS)))
+	 (IS-get-start-end-text (cdr (assq 'get-start-end-text IS)))
+	 (IS-get-user-line      (cdr (assq 'get-user-line IS)))
+	 (IS-get-user-column    (cdr (assq 'get-user-column IS)))
+	 (IS-get-user-offset    (cdr (assq 'get-user-offset IS)))
+	 (IS-user-getc          (cdr (assq 'user-getc IS)))
+	 (IS-user-ungetc        (cdr (assq 'user-ungetc IS)))
+
+	 ; Resultats
+	 (<<EOF>>-action   #f)
+	 (<<ERROR>>-action #f)
+	 (rules-actions    #f)
+	 (states           #f)
+	 (final-lexer      #f)
+
+	 ; Gestion des hooks
+	 (hook-list '())
+	 (add-hook
+	  (lambda (thunk)
+	    (set! hook-list (cons thunk hook-list))))
+	 (apply-hooks
+	  (lambda ()
+	    (let loop ((l hook-list))
+	      (if (pair? l)
+		  (begin
+		    ((car l))
+		    (loop (cdr l)))))))
+
+	 ; Preparation des actions
+	 (set-action-statics
+	  (lambda (pre-action)
+	    (pre-action final-lexer IS-user-getc IS-user-ungetc)))
+	 (prepare-special-action-none
+	  (lambda (pre-action)
+	    (let ((action #f))
+	      (let ((result
+		     (lambda ()
+		       (action "")))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-special-action-line
+	  (lambda (pre-action)
+	    (let ((action #f))
+	      (let ((result
+		     (lambda (yyline)
+		       (action "" yyline)))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-special-action-all
+	  (lambda (pre-action)
+	    (let ((action #f))
+	      (let ((result
+		     (lambda (yyline yycolumn yyoffset)
+		       (action "" yyline yycolumn yyoffset)))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-special-action
+	  (lambda (pre-action)
+	    (cond ((eq? counters-type 'none)
+		   (prepare-special-action-none pre-action))
+		  ((eq? counters-type 'line)
+		   (prepare-special-action-line pre-action))
+		  ((eq? counters-type 'all)
+		   (prepare-special-action-all  pre-action)))))
+	 (prepare-action-yytext-none
+	  (lambda (pre-action)
+	    (let ((get-start-end-text IS-get-start-end-text)
+		  (start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda ()
+		       (let ((yytext (get-start-end-text)))
+			 (start-go-to-end)
+			 (action yytext))))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-yytext-line
+	  (lambda (pre-action)
+	    (let ((get-start-end-text IS-get-start-end-text)
+		  (start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda (yyline)
+		       (let ((yytext (get-start-end-text)))
+			 (start-go-to-end)
+			 (action yytext yyline))))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-yytext-all
+	  (lambda (pre-action)
+	    (let ((get-start-end-text IS-get-start-end-text)
+		  (start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda (yyline yycolumn yyoffset)
+		       (let ((yytext (get-start-end-text)))
+			 (start-go-to-end)
+			 (action yytext yyline yycolumn yyoffset))))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-yytext
+	  (lambda (pre-action)
+	    (cond ((eq? counters-type 'none)
+		   (prepare-action-yytext-none pre-action))
+		  ((eq? counters-type 'line)
+		   (prepare-action-yytext-line pre-action))
+		  ((eq? counters-type 'all)
+		   (prepare-action-yytext-all  pre-action)))))
+	 (prepare-action-no-yytext-none
+	  (lambda (pre-action)
+	    (let ((start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda ()
+		       (start-go-to-end)
+		       (action)))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-no-yytext-line
+	  (lambda (pre-action)
+	    (let ((start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda (yyline)
+		       (start-go-to-end)
+		       (action yyline)))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-no-yytext-all
+	  (lambda (pre-action)
+	    (let ((start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda (yyline yycolumn yyoffset)
+		       (start-go-to-end)
+		       (action yyline yycolumn yyoffset)))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-no-yytext
+	  (lambda (pre-action)
+	    (cond ((eq? counters-type 'none)
+		   (prepare-action-no-yytext-none pre-action))
+		  ((eq? counters-type 'line)
+		   (prepare-action-no-yytext-line pre-action))
+		  ((eq? counters-type 'all)
+		   (prepare-action-no-yytext-all  pre-action)))))
+
+	 ; Fabrique les fonctions de dispatch
+	 (prepare-dispatch-err
+	  (lambda (leaf)
+	    (lambda (c)
+	      #f)))
+	 (prepare-dispatch-number
+	  (lambda (leaf)
+	    (let ((state-function #f))
+	      (let ((result
+		     (lambda (c)
+		       state-function))
+		    (hook
+		     (lambda ()
+		       (set! state-function (vector-ref states leaf)))))
+		(add-hook hook)
+		result))))
+	 (prepare-dispatch-leaf
+	  (lambda (leaf)
+	    (if (eq? leaf 'err)
+		(prepare-dispatch-err leaf)
+		(prepare-dispatch-number leaf))))
+	 (prepare-dispatch-<
+	  (lambda (tree)
+	    (let ((left-tree  (list-ref tree 1))
+		  (right-tree (list-ref tree 2)))
+	      (let ((bound      (list-ref tree 0))
+		    (left-func  (prepare-dispatch-tree left-tree))
+		    (right-func (prepare-dispatch-tree right-tree)))
+		(lambda (c)
+		  (if (< c bound)
+		      (left-func c)
+		      (right-func c)))))))
+	 (prepare-dispatch-=
+	  (lambda (tree)
+	    (let ((left-tree  (list-ref tree 2))
+		  (right-tree (list-ref tree 3)))
+	      (let ((bound      (list-ref tree 1))
+		    (left-func  (prepare-dispatch-tree left-tree))
+		    (right-func (prepare-dispatch-tree right-tree)))
+		(lambda (c)
+		  (if (= c bound)
+		      (left-func c)
+		      (right-func c)))))))
+	 (prepare-dispatch-tree
+	  (lambda (tree)
+	    (cond ((not (pair? tree))
+		   (prepare-dispatch-leaf tree))
+		  ((eq? (car tree) '=)
+		   (prepare-dispatch-= tree))
+		  (else
+		   (prepare-dispatch-< tree)))))
+	 (prepare-dispatch
+	  (lambda (tree)
+	    (let ((dicho-func (prepare-dispatch-tree tree)))
+	      (lambda (c)
+		(and c (dicho-func c))))))
+
+	 ; Fabrique les fonctions de transition (read & go) et (abort)
+	 (prepare-read-n-go
+	  (lambda (tree)
+	    (let ((dispatch-func (prepare-dispatch tree))
+		  (read-char     IS-read-char))
+	      (lambda ()
+		(dispatch-func (read-char))))))
+	 (prepare-abort
+	  (lambda (tree)
+	    (lambda ()
+	      #f)))
+	 (prepare-transition
+	  (lambda (tree)
+	    (if (eq? tree 'err)
+		(prepare-abort     tree)
+		(prepare-read-n-go tree))))
+
+	 ; Fabrique les fonctions d'etats ([set-end] & trans)
+	 (prepare-state-no-acc
+	   (lambda (s r1 r2)
+	     (let ((trans-func (prepare-transition (vector-ref trees-v s))))
+	       (lambda (action)
+		 (let ((next-state (trans-func)))
+		   (if next-state
+		       (next-state action)
+		       action))))))
+	 (prepare-state-yes-no
+	  (lambda (s r1 r2)
+	    (let ((peek-char       IS-peek-char)
+		  (end-go-to-point IS-end-go-to-point)
+		  (new-action1     #f)
+		  (trans-func (prepare-transition (vector-ref trees-v s))))
+	      (let ((result
+		     (lambda (action)
+		       (let* ((c (peek-char))
+			      (new-action
+			       (if (or (not c) (= c lexer-integer-newline))
+				   (begin
+				     (end-go-to-point)
+				     new-action1)
+				   action))
+			      (next-state (trans-func)))
+			 (if next-state
+			     (next-state new-action)
+			     new-action))))
+		    (hook
+		     (lambda ()
+		       (set! new-action1 (vector-ref rules-actions r1)))))
+		(add-hook hook)
+		result))))
+	 (prepare-state-diff-acc
+	  (lambda (s r1 r2)
+	    (let ((end-go-to-point IS-end-go-to-point)
+		  (peek-char       IS-peek-char)
+		  (new-action1     #f)
+		  (new-action2     #f)
+		  (trans-func (prepare-transition (vector-ref trees-v s))))
+	      (let ((result
+		     (lambda (action)
+		       (end-go-to-point)
+		       (let* ((c (peek-char))
+			      (new-action
+			       (if (or (not c) (= c lexer-integer-newline))
+				   new-action1
+				   new-action2))
+			      (next-state (trans-func)))
+			 (if next-state
+			     (next-state new-action)
+			     new-action))))
+		    (hook
+		     (lambda ()
+		       (set! new-action1 (vector-ref rules-actions r1))
+		       (set! new-action2 (vector-ref rules-actions r2)))))
+		(add-hook hook)
+		result))))
+	 (prepare-state-same-acc
+	  (lambda (s r1 r2)
+	    (let ((end-go-to-point IS-end-go-to-point)
+		  (trans-func (prepare-transition (vector-ref trees-v s)))
+		  (new-action #f))
+	      (let ((result
+		     (lambda (action)
+		       (end-go-to-point)
+		       (let ((next-state (trans-func)))
+			 (if next-state
+			     (next-state new-action)
+			     new-action))))
+		    (hook
+		     (lambda ()
+		       (set! new-action (vector-ref rules-actions r1)))))
+		(add-hook hook)
+		result))))
+	 (prepare-state
+	  (lambda (s)
+	    (let* ((acc (vector-ref acc-v s))
+		   (r1 (car acc))
+		   (r2 (cdr acc)))
+	      (cond ((not r1)  (prepare-state-no-acc   s r1 r2))
+		    ((not r2)  (prepare-state-yes-no   s r1 r2))
+		    ((< r1 r2) (prepare-state-diff-acc s r1 r2))
+		    (else      (prepare-state-same-acc s r1 r2))))))
+
+	 ; Fabrique la fonction de lancement du lexage a l'etat de depart
+	 (prepare-start-same
+	  (lambda (s1 s2)
+	    (let ((peek-char    IS-peek-char)
+		  (eof-action   #f)
+		  (start-state  #f)
+		  (error-action #f))
+	      (let ((result
+		     (lambda ()
+		       (if (not (peek-char))
+			   eof-action
+			   (start-state error-action))))
+		    (hook
+		     (lambda ()
+		       (set! eof-action   <<EOF>>-action)
+		       (set! start-state  (vector-ref states s1))
+		       (set! error-action <<ERROR>>-action))))
+		(add-hook hook)
+		result))))
+	 (prepare-start-diff
+	  (lambda (s1 s2)
+	    (let ((peek-char         IS-peek-char)
+		  (eof-action        #f)
+		  (peek-left-context IS-peek-left-context)
+		  (start-state1      #f)
+		  (start-state2      #f)
+		  (error-action      #f))
+	      (let ((result
+		     (lambda ()
+		       (cond ((not (peek-char))
+			      eof-action)
+			     ((= (peek-left-context) lexer-integer-newline)
+			      (start-state1 error-action))
+			     (else
+			      (start-state2 error-action)))))
+		    (hook
+		     (lambda ()
+		       (set! eof-action <<EOF>>-action)
+		       (set! start-state1 (vector-ref states s1))
+		       (set! start-state2 (vector-ref states s2))
+		       (set! error-action <<ERROR>>-action))))
+		(add-hook hook)
+		result))))
+	 (prepare-start
+	  (lambda ()
+	    (let ((s1 table-nl-start)
+		  (s2 table-no-nl-start))
+	      (if (= s1 s2)
+		  (prepare-start-same s1 s2)
+		  (prepare-start-diff s1 s2)))))
+
+	 ; Fabrique la fonction principale
+	 (prepare-lexer-none
+	  (lambda ()
+	    (let ((init-lexeme IS-init-lexeme)
+		  (start-func  (prepare-start)))
+	      (lambda ()
+		(init-lexeme)
+		((start-func))))))
+	 (prepare-lexer-line
+	  (lambda ()
+	    (let ((init-lexeme    IS-init-lexeme)
+		  (get-start-line IS-get-start-line)
+		  (start-func     (prepare-start)))
+	      (lambda ()
+		(init-lexeme)
+		(let ((yyline (get-start-line)))
+		  ((start-func) yyline))))))
+	 (prepare-lexer-all
+	  (lambda ()
+	    (let ((init-lexeme      IS-init-lexeme)
+		  (get-start-line   IS-get-start-line)
+		  (get-start-column IS-get-start-column)
+		  (get-start-offset IS-get-start-offset)
+		  (start-func       (prepare-start)))
+	      (lambda ()
+		(init-lexeme)
+		(let ((yyline   (get-start-line))
+		      (yycolumn (get-start-column))
+		      (yyoffset (get-start-offset)))
+		  ((start-func) yyline yycolumn yyoffset))))))
+	 (prepare-lexer
+	  (lambda ()
+	    (cond ((eq? counters-type 'none) (prepare-lexer-none))
+		  ((eq? counters-type 'line) (prepare-lexer-line))
+		  ((eq? counters-type 'all)  (prepare-lexer-all))))))
+
+      ; Calculer la valeur de <<EOF>>-action et de <<ERROR>>-action
+      (set! <<EOF>>-action   (prepare-special-action <<EOF>>-pre-action))
+      (set! <<ERROR>>-action (prepare-special-action <<ERROR>>-pre-action))
+
+      ; Calculer la valeur de rules-actions
+      (let* ((len (quotient (vector-length rules-pre-actions) 2))
+	     (v (make-vector len)))
+	(let loop ((r (- len 1)))
+	  (if (< r 0)
+	      (set! rules-actions v)
+	      (let* ((yytext? (vector-ref rules-pre-actions (* 2 r)))
+		     (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1)))
+		     (action (if yytext?
+				 (prepare-action-yytext    pre-action)
+				 (prepare-action-no-yytext pre-action))))
+		(vector-set! v r action)
+		(loop (- r 1))))))
+
+      ; Calculer la valeur de states
+      (let* ((len (vector-length trees-v))
+	     (v (make-vector len)))
+	(let loop ((s (- len 1)))
+	  (if (< s 0)
+	      (set! states v)
+	      (begin
+		(vector-set! v s (prepare-state s))
+		(loop (- s 1))))))
+
+      ; Calculer la valeur de final-lexer
+      (set! final-lexer (prepare-lexer))
+
+      ; Executer les hooks
+      (apply-hooks)
+
+      ; Resultat
+      final-lexer)))
+
+; Fabrication de lexer a partir de listes de caracteres taggees
+(define lexer-make-char-lexer
+  (let* ((char->class
+	  (lambda (c)
+	    (let ((n (char->integer c)))
+	      (list (cons n n)))))
+	 (merge-sort
+	  (lambda (l combine zero-elt)
+	    (if (null? l)
+		zero-elt
+		(let loop1 ((l l))
+		  (if (null? (cdr l))
+		      (car l)
+		      (loop1
+		       (let loop2 ((l l))
+			 (cond ((null? l)
+				l)
+			       ((null? (cdr l))
+				l)
+			       (else
+				(cons (combine (car l) (cadr l))
+				      (loop2 (cddr l))))))))))))
+	 (finite-class-union
+	  (lambda (c1 c2)
+	    (let loop ((c1 c1) (c2 c2) (u '()))
+	      (if (null? c1)
+		  (if (null? c2)
+		      (reverse u)
+		      (loop c1 (cdr c2) (cons (car c2) u)))
+		  (if (null? c2)
+		      (loop (cdr c1) c2 (cons (car c1) u))
+		      (let* ((r1 (car c1))
+			     (r2 (car c2))
+			     (r1start (car r1))
+			     (r1end (cdr r1))
+			     (r2start (car r2))
+			     (r2end (cdr r2)))
+			(if (<= r1start r2start)
+			    (cond ((< (+ r1end 1) r2start)
+				   (loop (cdr c1) c2 (cons r1 u)))
+				  ((<= r1end r2end)
+				   (loop (cdr c1)
+					 (cons (cons r1start r2end) (cdr c2))
+					 u))
+				  (else
+				   (loop c1 (cdr c2) u)))
+			    (cond ((> r1start (+ r2end 1))
+				   (loop c1 (cdr c2) (cons r2 u)))
+				  ((>= r1end r2end)
+				   (loop (cons (cons r2start r1end) (cdr c1))
+					 (cdr c2)
+					 u))
+				  (else
+				   (loop (cdr c1) c2 u))))))))))
+	 (char-list->class
+	  (lambda (cl)
+	    (let ((classes (map char->class cl)))
+	      (merge-sort classes finite-class-union '()))))
+	 (class-<
+	  (lambda (b1 b2)
+	    (cond ((eq? b1 'inf+) #f)
+		  ((eq? b2 'inf-) #f)
+		  ((eq? b1 'inf-) #t)
+		  ((eq? b2 'inf+) #t)
+		  (else (< b1 b2)))))
+	 (finite-class-compl
+	  (lambda (c)
+	    (let loop ((c c) (start 'inf-))
+	      (if (null? c)
+		  (list (cons start 'inf+))
+		  (let* ((r (car c))
+			 (rstart (car r))
+			 (rend (cdr r)))
+		    (if (class-< start rstart)
+			(cons (cons start (- rstart 1))
+			      (loop c rstart))
+			(loop (cdr c) (+ rend 1))))))))
+	 (tagged-chars->class
+	  (lambda (tcl)
+	    (let* ((inverse? (car tcl))
+		   (cl (cdr tcl))
+		   (class-tmp (char-list->class cl)))
+	      (if inverse? (finite-class-compl class-tmp) class-tmp))))
+	 (charc->arc
+	  (lambda (charc)
+	    (let* ((tcl (car charc))
+		   (dest (cdr charc))
+		   (class (tagged-chars->class tcl)))
+	      (cons class dest))))
+	 (arc->sharcs
+	  (lambda (arc)
+	    (let* ((range-l (car arc))
+		   (dest (cdr arc))
+		   (op (lambda (range) (cons range dest))))
+	      (map op range-l))))
+	 (class-<=
+	  (lambda (b1 b2)
+	    (cond ((eq? b1 'inf-) #t)
+		  ((eq? b2 'inf+) #t)
+		  ((eq? b1 'inf+) #f)
+		  ((eq? b2 'inf-) #f)
+		  (else (<= b1 b2)))))
+	 (sharc-<=
+	  (lambda (sharc1 sharc2)
+	    (class-<= (caar sharc1) (caar sharc2))))
+	 (merge-sharcs
+	  (lambda (l1 l2)
+	    (let loop ((l1 l1) (l2 l2))
+	      (cond ((null? l1)
+		     l2)
+		    ((null? l2)
+		     l1)
+		    (else
+		     (let ((sharc1 (car l1))
+			   (sharc2 (car l2)))
+		       (if (sharc-<= sharc1 sharc2)
+			   (cons sharc1 (loop (cdr l1) l2))
+			   (cons sharc2 (loop l1 (cdr l2))))))))))
+	 (class-= eqv?)
+	 (fill-error
+	  (lambda (sharcs)
+	    (let loop ((sharcs sharcs) (start 'inf-))
+	      (cond ((class-= start 'inf+)
+		     '())
+		    ((null? sharcs)
+		     (cons (cons (cons start 'inf+) 'err)
+			   (loop sharcs 'inf+)))
+		    (else
+		     (let* ((sharc (car sharcs))
+			    (h (caar sharc))
+			    (t (cdar sharc)))
+		       (if (class-< start h)
+			   (cons (cons (cons start (- h 1)) 'err)
+				 (loop sharcs h))
+			   (cons sharc (loop (cdr sharcs)
+					     (if (class-= t 'inf+)
+						 'inf+
+						 (+ t 1)))))))))))
+	 (charcs->tree
+	  (lambda (charcs)
+	    (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc))))
+		   (sharcs-l (map op charcs))
+		   (sorted-sharcs (merge-sort sharcs-l merge-sharcs '()))
+		   (full-sharcs (fill-error sorted-sharcs))
+		   (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
+		   (table (list->vector (map op full-sharcs))))
+	      (let loop ((left 0) (right (- (vector-length table) 1)))
+		(if (= left right)
+		    (cdr (vector-ref table left))
+		    (let ((mid (quotient (+ left right 1) 2)))
+		      (if (and (= (+ left 2) right)
+			       (= (+ (car (vector-ref table mid)) 1)
+				  (car (vector-ref table right)))
+			       (eqv? (cdr (vector-ref table left))
+				     (cdr (vector-ref table right))))
+			  (list '=
+				(car (vector-ref table mid))
+				(cdr (vector-ref table mid))
+				(cdr (vector-ref table left)))
+			  (list (car (vector-ref table mid))
+				(loop left (- mid 1))
+				(loop mid right))))))))))
+    (lambda (tables IS)
+      (let ((counters         (vector-ref tables 0))
+	    (<<EOF>>-action   (vector-ref tables 1))
+	    (<<ERROR>>-action (vector-ref tables 2))
+	    (rules-actions    (vector-ref tables 3))
+	    (nl-start         (vector-ref tables 5))
+	    (no-nl-start      (vector-ref tables 6))
+	    (charcs-v         (vector-ref tables 7))
+	    (acc-v            (vector-ref tables 8)))
+	(let* ((len (vector-length charcs-v))
+	       (v (make-vector len)))
+	  (let loop ((i (- len 1)))
+	    (if (>= i 0)
+		(begin
+		  (vector-set! v i (charcs->tree (vector-ref charcs-v i)))
+		  (loop (- i 1)))
+		(lexer-make-tree-lexer
+		 (vector counters
+			 <<EOF>>-action
+			 <<ERROR>>-action
+			 rules-actions
+			 'decision-trees
+			 nl-start
+			 no-nl-start
+			 v
+			 acc-v)
+		 IS))))))))
+
+; Fabrication d'un lexer a partir de code pre-genere
+(define lexer-make-code-lexer
+  (lambda (tables IS)
+    (let ((<<EOF>>-pre-action   (vector-ref tables 1))
+	  (<<ERROR>>-pre-action (vector-ref tables 2))
+	  (rules-pre-action     (vector-ref tables 3))
+	  (code                 (vector-ref tables 5)))
+      (code <<EOF>>-pre-action <<ERROR>>-pre-action rules-pre-action IS))))
+
+(define lexer-make-lexer
+  (lambda (tables IS)
+    (let ((automaton-type (vector-ref tables 4)))
+      (cond ((eq? automaton-type 'decision-trees)
+	     (lexer-make-tree-lexer tables IS))
+	    ((eq? automaton-type 'tagged-chars-lists)
+	     (lexer-make-char-lexer tables IS))
+	    ((eq? automaton-type 'code)
+	     (lexer-make-code-lexer tables IS))))))
+
+; Module lexparser.scm.
+
+;
+; Fonctions auxilliaires du lexer
+;
+
+(define parse-spec-char
+  (lambda (lexeme line column)
+    (make-tok char-tok lexeme line column newline-ch)))
+
+(define parse-digits-char
+  (lambda (lexeme line column)
+    (let* ((num (substring lexeme 1 (string-length lexeme)))
+	   (n (string->number num)))
+      (make-tok char-tok lexeme line column n))))
+
+(define parse-quoted-char
+  (lambda (lexeme line column)
+    (let ((c (string-ref lexeme 1)))
+      (make-tok char-tok lexeme line column (char->integer c)))))
+
+(define parse-ordinary-char
+  (lambda (lexeme line column)
+    (let ((c (string-ref lexeme 0)))
+      (make-tok char-tok lexeme line column (char->integer c)))))
+
+(define string-downcase
+  (lambda (s)
+    (let* ((l (string->list s))
+	   (ld (map char-downcase l)))
+      (list->string ld))))
+
+(define extract-id
+  (lambda (s)
+    (let ((len (string-length s)))
+      (substring s 1 (- len 1)))))
+
+(define parse-id
+  (lambda (lexeme line column)
+    (make-tok id-tok lexeme line column (string-downcase lexeme) lexeme)))
+
+(define parse-id-ref
+  (lambda (lexeme line column)
+    (let* ((orig-name (extract-id lexeme))
+	   (name (string-downcase orig-name)))
+    (make-tok subst-tok lexeme line column name orig-name))))
+
+(define parse-power-m
+  (lambda (lexeme line column)
+    (let* ((len (string-length lexeme))
+	   (substr (substring lexeme 1 (- len 1)))
+	   (m (string->number substr))
+	   (range (cons m m)))
+      (make-tok power-tok lexeme line column range))))
+
+(define parse-power-m-inf
+  (lambda (lexeme line column)
+    (let* ((len (string-length lexeme))
+	   (substr (substring lexeme 1 (- len 2)))
+	   (m (string->number substr))
+	   (range (cons m 'inf)))
+      (make-tok power-tok lexeme line column range))))
+
+(define parse-power-m-n
+  (lambda (lexeme line column)
+    (let ((len (string-length lexeme)))
+      (let loop ((comma 2))
+	(if (char=? (string-ref lexeme comma) #\,)
+	    (let* ((sub1 (substring lexeme 1 comma))
+		   (sub2 (substring lexeme (+ comma 1) (- len 1)))
+		   (m (string->number sub1))
+		   (n (string->number sub2))
+		   (range (cons m n)))
+	      (make-tok power-tok lexeme line column range))
+	    (loop (+ comma 1)))))))
+
+
+
+
+;
+; Lexer generique
+;
+
+(define lexer-raw #f)
+(define lexer-stack '())
+
+(define lexer-alist #f)
+
+(define lexer-buffer #f)
+(define lexer-buffer-empty? #t)
+
+(define lexer-history '())
+(define lexer-history-interp #f)
+
+(define init-lexer
+  (lambda (port)
+    (let* ((IS (lexer-make-IS 'port port 'all))
+	   (action-lexer (lexer-make-lexer action-tables IS))
+	   (class-lexer  (lexer-make-lexer class-tables  IS))
+	   (macro-lexer  (lexer-make-lexer macro-tables  IS))
+	   (regexp-lexer (lexer-make-lexer regexp-tables IS))
+	   (string-lexer (lexer-make-lexer string-tables IS)))
+      (set! lexer-raw #f)
+      (set! lexer-stack '())
+      (set! lexer-alist
+	    (list (cons 'action action-lexer)
+		  (cons 'class  class-lexer)
+		  (cons 'macro  macro-lexer)
+		  (cons 'regexp regexp-lexer)
+		  (cons 'string string-lexer)))
+      (set! lexer-buffer-empty? #t)
+      (set! lexer-history '()))))
+
+; Lexer brut
+; S'assurer qu'il n'y a pas de risque de changer de
+; lexer quand le buffer est rempli
+(define push-lexer
+  (lambda (name)
+    (set! lexer-stack (cons lexer-raw lexer-stack))
+    (set! lexer-raw (cdr (assq name lexer-alist)))))
+
+(define pop-lexer
+  (lambda ()
+    (set! lexer-raw (car lexer-stack))
+    (set! lexer-stack (cdr lexer-stack))))
+
+; Traite le "unget" (capacite du unget: 1)
+(define lexer2
+  (lambda ()
+    (if lexer-buffer-empty?
+	(lexer-raw)
+	(begin
+	  (set! lexer-buffer-empty? #t)
+	  lexer-buffer))))
+
+(define lexer2-unget
+  (lambda (tok)
+    (set! lexer-buffer tok)
+    (set! lexer-buffer-empty? #f)))
+
+; Traite l'historique
+(define lexer
+  (lambda ()
+    (let* ((tok (lexer2))
+	   (tok-lexeme (get-tok-lexeme tok))
+	   (hist-lexeme (if lexer-history-interp
+			    (blank-translate tok-lexeme)
+			    tok-lexeme)))
+      (set! lexer-history (cons hist-lexeme lexer-history))
+      tok)))
+
+(define lexer-unget
+  (lambda (tok)
+    (set! lexer-history (cdr lexer-history))
+    (lexer2-unget tok)))
+
+(define lexer-set-blank-history
+  (lambda (b)
+    (set! lexer-history-interp b)))
+
+(define blank-translate
+  (lambda (s)
+    (let ((ss (string-copy s)))
+      (let loop ((i (- (string-length ss) 1)))
+	(cond ((< i 0)
+	       ss)
+	      ((char=? (string-ref ss i) (integer->char tab-ch))
+	       (loop (- i 1)))
+	      ((char=? (string-ref ss i) #\newline)
+	       (loop (- i 1)))
+	      (else
+	       (string-set! ss i #\space)
+	       (loop (- i 1))))))))
+
+(define lexer-get-history
+  (lambda ()
+    (let* ((rightlist (reverse lexer-history))
+	   (str (apply string-append rightlist))
+	   (strlen (string-length str))
+	   (str2 (if (and (> strlen 0)
+			  (char=? (string-ref str (- strlen 1)) #\newline))
+		     str
+		     (string-append str (string #\newline)))))
+      (set! lexer-history '())
+      str2)))
+
+
+
+
+;
+; Traitement des listes de tokens
+;
+
+(define de-anchor-tokens
+  (let ((not-anchor-toks (make-dispatch-table number-of-tokens
+					      (list (cons caret-tok     #f)
+						    (cons dollar-tok    #f)
+						    (cons <<EOF>>-tok   #f)
+						    (cons <<ERROR>>-tok #f))
+					      #t)))
+    (lambda (tok-list)
+      (if (null? tok-list)
+	  '()
+	  (let* ((tok (car tok-list))
+		 (tok-type (get-tok-type tok))
+		 (toks (cdr tok-list))
+		 (new-toks (de-anchor-tokens toks)))
+	    (cond ((vector-ref not-anchor-toks tok-type)
+		   (cons tok new-toks))
+		  ((or (= tok-type caret-tok) (= tok-type dollar-tok))
+		   (let* ((line (get-tok-line tok))
+			  (column (get-tok-column tok))
+			  (attr (if (= tok-type caret-tok) caret-ch dollar-ch))
+			  (new-tok (make-tok char-tok "" line column attr)))
+		     (cons new-tok new-toks)))
+		  ((= tok-type <<EOF>>-tok)
+		   (lex-error (get-tok-line tok)
+			      (get-tok-column tok)
+			      "the <<EOF>> anchor must be used alone"
+			      " and only after %%."))
+		  ((= tok-type <<ERROR>>-tok)
+		   (lex-error (get-tok-line tok)
+			      (get-tok-column tok)
+			      "the <<ERROR>> anchor must be used alone"
+			      " and only after %%."))))))))
+
+(define strip-end
+  (lambda (l)
+    (if (null? (cdr l))
+	'()
+	(cons (car l) (strip-end (cdr l))))))
+
+(define extract-anchors
+  (lambda (tok-list)
+    (let* ((tok1 (car tok-list))
+	   (line (get-tok-line tok1))
+	   (tok1-type (get-tok-type tok1)))
+      (cond ((and (= tok1-type <<EOF>>-tok) (null? (cdr tok-list)))
+	     (make-rule line #t #f #f #f '() #f))
+	    ((and (= tok1-type <<ERROR>>-tok) (null? (cdr tok-list)))
+	     (make-rule line #f #t #f #f '() #f))
+	    (else
+	     (let* ((bol? (= tok1-type caret-tok))
+		    (tok-list2 (if bol? (cdr tok-list) tok-list)))
+	       (if (null? tok-list2)
+		   (make-rule line #f #f bol? #f tok-list2 #f)
+		   (let* ((len (length tok-list2))
+			  (tok2 (list-ref tok-list2 (- len 1)))
+			  (tok2-type (get-tok-type tok2))
+			  (eol? (= tok2-type dollar-tok))
+			  (tok-list3 (if eol?
+					 (strip-end tok-list2)
+					 tok-list2)))
+		     (make-rule line #f #f bol? eol? tok-list3 #f)))))))))
+
+(define char-list->conc
+  (lambda (char-list)
+    (if (null? char-list)
+	(make-re epsilon-re)
+	(let loop ((cl char-list))
+	  (let* ((c (car cl))
+		 (cl2 (cdr cl)))
+	    (if (null? cl2)
+		(make-re char-re c)
+		(make-re conc-re (make-re char-re c) (loop cl2))))))))
+
+(define parse-tokens-atom
+  (let ((action-table
+	 (make-dispatch-table
+	  number-of-tokens
+	  (list (cons lpar-tok
+		      (lambda (tok tok-list macros)
+			(parse-tokens-sub tok-list macros)))
+		(cons dot-tok
+		      (lambda (tok tok-list macros)
+			(cons (make-re class-re dot-class) (cdr tok-list))))
+		(cons subst-tok
+		      (lambda (tok tok-list macros)
+			(let* ((name (get-tok-attr tok))
+			       (ass (assoc name macros)))
+			  (if ass
+			      (cons (cdr ass) (cdr tok-list))
+			      (lex-error (get-tok-line tok)
+					 (get-tok-column tok)
+					 "unknown macro \""
+					 (get-tok-2nd-attr tok)
+					 "\".")))))
+		(cons char-tok
+		      (lambda (tok tok-list macros)
+			(let ((c (get-tok-attr tok)))
+			  (cons (make-re char-re c) (cdr tok-list)))))
+		(cons class-tok
+		      (lambda (tok tok-list macros)
+			(let ((class (get-tok-attr tok)))
+			  (cons (make-re class-re class) (cdr tok-list)))))
+		(cons string-tok
+		      (lambda (tok tok-list macros)
+			(let* ((char-list (get-tok-attr tok))
+			       (re (char-list->conc char-list)))
+			  (cons re (cdr tok-list))))))
+	  (lambda (tok tok-list macros)
+	    (lex-error (get-tok-line tok)
+		       (get-tok-column tok)
+		       "syntax error in regular expression.")))))
+    (lambda (tok-list macros)
+      (let* ((tok (car tok-list))
+	     (tok-type (get-tok-type tok))
+	     (action (vector-ref action-table tok-type)))
+	(action tok tok-list macros)))))
+
+(define check-power-tok
+  (lambda (tok)
+    (let* ((range (get-tok-attr tok))
+	   (start (car range))
+	   (end (cdr range)))
+      (if (or (eq? 'inf end) (<= start end))
+	  range
+	  (lex-error (get-tok-line tok)
+		     (get-tok-column tok)
+		     "incorrect power specification.")))))
+
+(define power->star-plus
+  (lambda (re range)
+    (power->star-plus-rec re (car range) (cdr range))))
+
+(define power->star-plus-rec
+  (lambda (re start end)
+    (cond ((eq? end 'inf)
+	   (cond ((= start 0)
+		  (make-re star-re re))
+		 ((= start 1)
+		  (make-re plus-re re))
+		 (else
+		  (make-re conc-re
+			   re
+			   (power->star-plus-rec re (- start 1) 'inf)))))
+	  ((= start 0)
+	   (cond ((= end 0)
+		  (make-re epsilon-re))
+		 ((= end 1)
+		  (make-re question-re re))
+		 (else
+		  (make-re question-re
+			   (power->star-plus-rec re 1 end)))))
+	  ((= start 1)
+	   (if (= end 1)
+	       re
+	       (make-re conc-re re (power->star-plus-rec re 0 (- end 1)))))
+	  (else
+	   (make-re conc-re
+		    re
+		    (power->star-plus-rec re (- start 1) (- end 1)))))))
+
+(define parse-tokens-fact
+  (let ((not-op-toks (make-dispatch-table number-of-tokens
+					  (list (cons question-tok #f)
+						(cons plus-tok     #f)
+						(cons star-tok     #f)
+						(cons power-tok    #f))
+					  #t)))
+    (lambda (tok-list macros)
+      (let* ((result (parse-tokens-atom tok-list macros))
+	     (re (car result))
+	     (tok-list2 (cdr result)))
+	(let loop ((re re) (tok-list3 tok-list2))
+	  (let* ((tok (car tok-list3))
+		 (tok-type (get-tok-type tok)))
+	    (cond ((vector-ref not-op-toks tok-type)
+		   (cons re tok-list3))
+		  ((= tok-type question-tok)
+		   (loop (make-re question-re re) (cdr tok-list3)))
+		  ((= tok-type plus-tok)
+		   (loop (make-re plus-re re) (cdr tok-list3)))
+		  ((= tok-type star-tok)
+		   (loop (make-re star-re re) (cdr tok-list3)))
+		  ((= tok-type power-tok)
+		   (loop (power->star-plus re (check-power-tok tok))
+			 (cdr tok-list3))))))))))
+
+(define parse-tokens-conc
+  (lambda (tok-list macros)
+    (let* ((result1 (parse-tokens-fact tok-list macros))
+	   (re1 (car result1))
+	   (tok-list2 (cdr result1))
+	   (tok (car tok-list2))
+	   (tok-type (get-tok-type tok)))
+      (cond ((or (= tok-type pipe-tok)
+		 (= tok-type rpar-tok))
+	     result1)
+	    (else ; Autres facteurs
+	     (let* ((result2 (parse-tokens-conc tok-list2 macros))
+		    (re2 (car result2))
+		    (tok-list3 (cdr result2)))
+	       (cons (make-re conc-re re1 re2) tok-list3)))))))
+
+(define parse-tokens-or
+  (lambda (tok-list macros)
+    (let* ((result1 (parse-tokens-conc tok-list macros))
+	   (re1 (car result1))
+	   (tok-list2 (cdr result1))
+	   (tok (car tok-list2))
+	   (tok-type (get-tok-type tok)))
+      (cond ((= tok-type pipe-tok)
+	     (let* ((tok-list3 (cdr tok-list2))
+		    (result2 (parse-tokens-or tok-list3 macros))
+		    (re2 (car result2))
+		    (tok-list4 (cdr result2)))
+	       (cons (make-re or-re re1 re2) tok-list4)))
+	    (else ; rpar-tok
+	     result1)))))
+
+(define parse-tokens-sub
+  (lambda (tok-list macros)
+    (let* ((tok-list2 (cdr tok-list)) ; Manger le lpar-tok
+	   (result (parse-tokens-or tok-list2 macros))
+	   (re (car result))
+	   (tok-list3 (cdr result))
+	   (tok-list4 (cdr tok-list3))) ; Manger le rpar-tok
+      (cons re tok-list4))))
+
+(define parse-tokens-match
+  (lambda (tok-list line)
+    (let loop ((tl tok-list) (count 0))
+      (if (null? tl)
+	  (if (> count 0)
+	      (lex-error line
+			 #f
+			 "mismatched parentheses."))
+	  (let* ((tok (car tl))
+		 (tok-type (get-tok-type tok)))
+	    (cond ((= tok-type lpar-tok)
+		   (loop (cdr tl) (+ count 1)))
+		  ((= tok-type rpar-tok)
+		   (if (zero? count)
+		       (lex-error line
+				  #f
+				  "mismatched parentheses."))
+		   (loop (cdr tl) (- count 1)))
+		  (else
+		   (loop (cdr tl) count))))))))
+
+; Ne traite pas les anchors
+(define parse-tokens
+  (lambda (tok-list macros)
+    (if (null? tok-list)
+	(make-re epsilon-re)
+	(let ((line (get-tok-line (car tok-list))))
+	  (parse-tokens-match tok-list line)
+	  (let* ((begin-par (make-tok lpar-tok "" line 1))
+		 (end-par (make-tok rpar-tok "" line 1)))
+	    (let* ((tok-list2 (append (list begin-par)
+				      tok-list
+				      (list end-par)))
+		   (result (parse-tokens-sub tok-list2 macros)))
+	      (car result))))))) ; (cdr result) == () obligatoirement
+
+(define tokens->regexp
+  (lambda (tok-list macros)
+    (let ((tok-list2 (de-anchor-tokens tok-list)))
+      (parse-tokens tok-list2 macros))))
+
+(define tokens->rule
+  (lambda (tok-list macros)
+    (let* ((rule (extract-anchors tok-list))
+	   (tok-list2 (get-rule-regexp rule))
+	   (tok-list3 (de-anchor-tokens tok-list2))
+	   (re (parse-tokens tok-list3 macros)))
+      (set-rule-regexp rule re)
+      rule)))
+
+; Retourne une paire: <<EOF>>-action et vecteur des regles ordinaires
+(define adapt-rules
+  (lambda (rules)
+    (let loop ((r rules) (revr '()) (<<EOF>>-action #f) (<<ERROR>>-action #f))
+      (if (null? r)
+	  (cons (or <<EOF>>-action default-<<EOF>>-action)
+		(cons (or <<ERROR>>-action default-<<ERROR>>-action)
+		      (list->vector (reverse revr))))
+	  (let ((r1 (car r)))
+	    (cond ((get-rule-eof? r1)
+		   (if <<EOF>>-action
+		       (lex-error (get-rule-line r1)
+				  #f
+				  "the <<EOF>> anchor can be "
+				  "used at most once.")
+		       (loop (cdr r)
+			     revr
+			     (get-rule-action r1)
+			     <<ERROR>>-action)))
+		  ((get-rule-error? r1)
+		   (if <<ERROR>>-action
+		       (lex-error (get-rule-line r1)
+				  #f
+				  "the <<ERROR>> anchor can be "
+				  "used at most once.")
+		       (loop (cdr r)
+			     revr
+			     <<EOF>>-action
+			     (get-rule-action r1))))
+		  (else
+		   (loop (cdr r)
+			 (cons r1 revr)
+			 <<EOF>>-action
+			 <<ERROR>>-action))))))))
+
+
+
+
+;
+; Analyseur de fichier lex
+;
+
+(define parse-hv-blanks
+  (lambda ()
+    (let* ((tok (lexer))
+	   (tok-type (get-tok-type tok)))
+      (if (or (= tok-type hblank-tok)
+	      (= tok-type vblank-tok))
+	  (parse-hv-blanks)
+	  (lexer-unget tok)))))
+
+(define parse-class-range
+  (lambda ()
+    (let* ((tok (lexer))
+	   (tok-type (get-tok-type tok)))
+      (cond ((= tok-type char-tok)
+	     (let* ((c (get-tok-attr tok))
+		    (tok2 (lexer))
+		    (tok2-type (get-tok-type tok2)))
+	       (if (not (= tok2-type minus-tok))
+		   (begin
+		     (lexer-unget tok2)
+		     (cons c c))
+		   (let* ((tok3 (lexer))
+			  (tok3-type (get-tok-type tok3)))
+		     (cond ((= tok3-type char-tok)
+			    (let ((c2 (get-tok-attr tok3)))
+			      (if (> c c2)
+				  (lex-error (get-tok-line tok3)
+					     (get-tok-column tok3)
+					     "bad range specification in "
+					     "character class;"
+					     #\newline
+					     "the start character is "
+					     "higher than the end one.")
+				  (cons c c2))))
+		           ((or (= tok3-type rbrack-tok)
+				(= tok3-type minus-tok))
+			    (lex-error (get-tok-line tok3)
+				       (get-tok-column tok3)
+				       "bad range specification in "
+				       "character class; a specification"
+				       #\newline
+				       "like \"-x\", \"x--\" or \"x-]\" has "
+				       "been used."))
+			   ((= tok3-type eof-tok)
+			    (lex-error (get-tok-line tok3)
+				       #f
+				       "eof of file found while parsing "
+				       "a character class.")))))))
+	    ((= tok-type minus-tok)
+	     (lex-error (get-tok-line tok)
+			(get-tok-column tok)
+			"bad range specification in character class; a "
+			"specification"
+			#\newline
+			"like \"-x\", \"x--\" or \"x-]\" has been used."))
+            ((= tok-type rbrack-tok)
+	     #f)
+	    ((= tok-type eof-tok)
+	     (lex-error (get-tok-line tok)
+			#f
+			"eof of file found while parsing "
+			"a character class."))))))
+
+(define parse-class
+  (lambda (initial-class negative-class? line column)
+    (push-lexer 'class)
+    (let loop ((class initial-class))
+      (let ((new-range (parse-class-range)))
+	(if new-range
+	    (loop (class-union (list new-range) class))
+	    (let ((class (if negative-class?
+			     (class-compl class)
+			     class)))
+	      (pop-lexer)
+	      (make-tok class-tok "" line column class)))))))
+
+(define parse-string
+  (lambda (line column)
+    (push-lexer 'string)
+    (let ((char-list (let loop ()
+		       (let* ((tok (lexer))
+			      (tok-type (get-tok-type tok)))
+			 (cond ((= tok-type char-tok)
+				(cons (get-tok-attr tok) (loop)))
+			       ((= tok-type doublequote-tok)
+				(pop-lexer)
+				'())
+			       (else ; eof-tok
+				(lex-error (get-tok-line tok)
+					   #f
+					   "end of file found while "
+					   "parsing a string.")))))))
+      (make-tok string-tok "" line column char-list))))
+
+(define parse-regexp
+  (let* ((end-action
+	  (lambda (tok loop)
+	    (lexer-unget tok)
+	    (pop-lexer)
+	    (lexer-set-blank-history #f)
+	    `()))
+	 (action-table
+	  (make-dispatch-table
+	   number-of-tokens
+	   (list (cons eof-tok end-action)
+		 (cons hblank-tok end-action)
+		 (cons vblank-tok end-action)
+		 (cons lbrack-tok
+		       (lambda (tok loop)
+			 (let ((tok1 (parse-class (list)
+						  #f
+						  (get-tok-line tok)
+						  (get-tok-column tok))))
+			   (cons tok1 (loop)))))
+		 (cons lbrack-rbrack-tok
+		       (lambda (tok loop)
+			 (let ((tok1 (parse-class
+				      (list (cons rbrack-ch rbrack-ch))
+				      #f
+				      (get-tok-line tok)
+				      (get-tok-column tok))))
+			   (cons tok1 (loop)))))
+		 (cons lbrack-caret-tok
+		       (lambda (tok loop)
+			 (let ((tok1 (parse-class (list)
+						  #t
+						  (get-tok-line tok)
+						  (get-tok-column tok))))
+			   (cons tok1 (loop)))))
+		 (cons lbrack-minus-tok
+		       (lambda (tok loop)
+			 (let ((tok1 (parse-class
+				      (list (cons minus-ch minus-ch))
+				      #f
+				      (get-tok-line tok)
+				      (get-tok-column tok))))
+			   (cons tok1 (loop)))))
+		 (cons doublequote-tok
+		       (lambda (tok loop)
+			 (let ((tok1 (parse-string (get-tok-line tok)
+						   (get-tok-column tok))))
+			   (cons tok1 (loop)))))
+		 (cons illegal-tok
+		       (lambda (tok loop)
+			 (lex-error (get-tok-line tok)
+				    (get-tok-column tok)
+				    "syntax error in macro reference."))))
+	   (lambda (tok loop)
+	     (cons tok (loop))))))
+    (lambda ()
+      (push-lexer 'regexp)
+      (lexer-set-blank-history #t)
+      (parse-hv-blanks)
+      (let loop ()
+	(let* ((tok (lexer))
+	       (tok-type (get-tok-type tok))
+	       (action (vector-ref action-table tok-type)))
+	  (action tok loop))))))
+
+(define parse-ws1-regexp  ; Exige un blanc entre le nom et la RE d'une macro
+  (lambda ()
+    (let* ((tok (lexer))
+	   (tok-type (get-tok-type tok)))
+      (cond ((or (= tok-type hblank-tok) (= tok-type vblank-tok))
+	     (parse-regexp))
+	    (else  ; percent-percent-tok, id-tok ou illegal-tok
+	     (lex-error (get-tok-line tok)
+			(get-tok-column tok)
+			"white space expected."))))))
+
+(define parse-macro
+  (lambda (macros)
+    (push-lexer 'macro)
+    (parse-hv-blanks)
+    (let* ((tok (lexer))
+	   (tok-type (get-tok-type tok)))
+      (cond ((= tok-type id-tok)
+	     (let* ((name (get-tok-attr tok))
+		    (ass (assoc name macros)))
+	       (if ass
+		   (lex-error (get-tok-line tok)
+			      (get-tok-column tok)
+			      "the macro \""
+			      (get-tok-2nd-attr tok)
+			      "\" has already been defined.")
+		   (let* ((tok-list (parse-ws1-regexp))
+			  (regexp (tokens->regexp tok-list macros)))
+		     (pop-lexer)
+		     (cons name regexp)))))
+            ((= tok-type percent-percent-tok)
+	     (pop-lexer)
+	     #f)
+	    ((= tok-type illegal-tok)
+	     (lex-error (get-tok-line tok)
+			(get-tok-column tok)
+			"macro name expected."))
+	    ((= tok-type eof-tok)
+	     (lex-error (get-tok-line tok)
+			#f
+			"end of file found before %%."))))))
+
+(define parse-macros
+  (lambda ()
+    (let loop ((macros '()))
+      (let ((macro (parse-macro macros)))
+	(if macro
+	    (loop (cons macro macros))
+	    macros)))))
+
+(define parse-action-end
+  (lambda (<<EOF>>-action? <<ERROR>>-action? action?)
+    (let ((act (lexer-get-history)))
+      (cond (action?
+	     act)
+	    (<<EOF>>-action?
+	     (string-append act default-<<EOF>>-action))
+	    (<<ERROR>>-action?
+	     (string-append act default-<<ERROR>>-action))
+	    (else
+	     (string-append act default-action))))))
+
+(define parse-action
+  (lambda (<<EOF>>-action? <<ERROR>>-action?)
+    (push-lexer 'action)
+    (let loop ((action? #f))
+      (let* ((tok (lexer))
+	     (tok-type (get-tok-type tok)))
+	(cond ((= tok-type char-tok)
+	       (loop #t))
+	      ((= tok-type hblank-tok)
+	       (loop action?))
+	      ((= tok-type vblank-tok)
+	       (push-lexer 'regexp)
+	       (let* ((tok (lexer))
+		      (tok-type (get-tok-type tok))
+		      (bidon (lexer-unget tok)))
+		 (pop-lexer)
+		 (if (or (= tok-type hblank-tok)
+			 (= tok-type vblank-tok))
+		     (loop action?)
+		     (begin
+		       (pop-lexer)
+		       (parse-action-end <<EOF>>-action?
+					 <<ERROR>>-action?
+					 action?)))))
+	      (else ; eof-tok
+	       (lexer-unget tok)
+	       (pop-lexer)
+	       (parse-action-end <<EOF>>-action?
+				 <<ERROR>>-action?
+				 action?)))))))
+
+(define parse-rule
+  (lambda (macros)
+    (let ((tok-list (parse-regexp)))
+      (if (null? tok-list)
+	  #f
+	  (let* ((rule (tokens->rule tok-list macros))
+		 (action
+		  (parse-action (get-rule-eof? rule) (get-rule-error? rule))))
+	    (set-rule-action rule action)
+	    rule)))))
+
+(define parse-rules
+  (lambda (macros)
+    (parse-action #f #f)
+    (let loop ()
+      (let ((rule (parse-rule macros)))
+	(if rule
+	    (cons rule (loop))
+	    '())))))
+
+(define parser
+  (lambda (filename)
+    (let* ((port (open-input-file filename))
+	   (port-open? #t))
+      (lex-unwind-protect (lambda ()
+			    (if port-open?
+				(close-input-port port))))
+      (init-lexer port)
+      (let* ((macros (parse-macros))
+	     (rules (parse-rules macros)))
+	(close-input-port port)
+	(set! port-open? #f)
+	(adapt-rules rules)))))
+
+; Module re2nfa.scm.
+
+; Le vecteur d'etats contient la table de transition du nfa.
+; Chaque entree contient les arcs partant de l'etat correspondant.
+; Les arcs sont stockes dans une liste.
+; Chaque arc est une paire (class . destination).
+; Les caracteres d'une classe sont enumeres par ranges.
+; Les ranges sont donnes dans une liste,
+;   chaque element etant une paire (debut . fin).
+; Le symbole eps peut remplacer une classe.
+; L'acceptation est decrite par une paire (acc-if-eol . acc-if-no-eol).
+
+; Quelques variables globales
+(define r2n-counter 0)
+(define r2n-v-arcs '#(#f))
+(define r2n-v-acc '#(#f))
+(define r2n-v-len 1)
+
+; Initialisation des variables globales
+(define r2n-init
+  (lambda ()
+    (set! r2n-counter 0)
+    (set! r2n-v-arcs (vector '()))
+    (set! r2n-v-acc (vector #f))
+    (set! r2n-v-len 1)))
+
+; Agrandissement des vecteurs
+(define r2n-extend-v
+  (lambda ()
+    (let* ((new-len (* 2 r2n-v-len))
+	   (new-v-arcs (make-vector new-len '()))
+	   (new-v-acc (make-vector new-len #f)))
+      (let loop ((i 0))
+	(if (< i r2n-v-len)
+	    (begin
+	      (vector-set! new-v-arcs i (vector-ref r2n-v-arcs i))
+	      (vector-set! new-v-acc i (vector-ref r2n-v-acc i))
+	      (loop (+ i 1)))))
+      (set! r2n-v-arcs new-v-arcs)
+      (set! r2n-v-acc new-v-acc)
+      (set! r2n-v-len new-len))))
+
+; Finalisation des vecteurs
+(define r2n-finalize-v
+  (lambda ()
+    (let* ((new-v-arcs (make-vector r2n-counter))
+	   (new-v-acc (make-vector r2n-counter)))
+      (let loop ((i 0))
+	(if (< i r2n-counter)
+	    (begin
+	      (vector-set! new-v-arcs i (vector-ref r2n-v-arcs i))
+	      (vector-set! new-v-acc i (vector-ref r2n-v-acc i))
+	      (loop (+ i 1)))))
+      (set! r2n-v-arcs new-v-arcs)
+      (set! r2n-v-acc new-v-acc)
+      (set! r2n-v-len r2n-counter))))
+
+; Creation d'etat
+(define r2n-get-state
+  (lambda (acc)
+    (if (= r2n-counter r2n-v-len)
+	(r2n-extend-v))
+    (let ((state r2n-counter))
+      (set! r2n-counter (+ r2n-counter 1))
+      (vector-set! r2n-v-acc state (or acc (cons #f #f)))
+      state)))
+
+; Ajout d'un arc
+(define r2n-add-arc
+  (lambda (start chars end)
+    (vector-set! r2n-v-arcs
+		 start
+		 (cons (cons chars end) (vector-ref r2n-v-arcs start)))))
+
+; Construction de l'automate a partir des regexp
+(define r2n-build-epsilon
+  (lambda (re start end)
+    (r2n-add-arc start 'eps end)))
+
+(define r2n-build-or
+  (lambda (re start end)
+    (let ((re1 (get-re-attr1 re))
+	  (re2 (get-re-attr2 re)))
+      (r2n-build-re re1 start end)
+      (r2n-build-re re2 start end))))
+
+(define r2n-build-conc
+  (lambda (re start end)
+    (let* ((re1 (get-re-attr1 re))
+	   (re2 (get-re-attr2 re))
+	   (inter (r2n-get-state #f)))
+      (r2n-build-re re1 start inter)
+      (r2n-build-re re2 inter end))))
+
+(define r2n-build-star
+  (lambda (re start end)
+    (let* ((re1 (get-re-attr1 re))
+	   (inter1 (r2n-get-state #f))
+	   (inter2 (r2n-get-state #f)))
+      (r2n-add-arc start 'eps inter1)
+      (r2n-add-arc inter1 'eps inter2)
+      (r2n-add-arc inter2 'eps end)
+      (r2n-build-re re1 inter2 inter1))))
+
+(define r2n-build-plus
+  (lambda (re start end)
+    (let* ((re1 (get-re-attr1 re))
+	   (inter1 (r2n-get-state #f))
+	   (inter2 (r2n-get-state #f)))
+      (r2n-add-arc start 'eps inter1)
+      (r2n-add-arc inter2 'eps inter1)
+      (r2n-add-arc inter2 'eps end)
+      (r2n-build-re re1 inter1 inter2))))
+
+(define r2n-build-question
+  (lambda (re start end)
+    (let ((re1 (get-re-attr1 re)))
+      (r2n-add-arc start 'eps end)
+      (r2n-build-re re1 start end))))
+
+(define r2n-build-class
+  (lambda (re start end)
+    (let ((class (get-re-attr1 re)))
+      (r2n-add-arc start class end))))
+
+(define r2n-build-char
+  (lambda (re start end)
+    (let* ((c (get-re-attr1 re))
+	   (class (list (cons c c))))
+      (r2n-add-arc start class end))))
+
+(define r2n-build-re
+  (let ((sub-function-v (vector r2n-build-epsilon
+				r2n-build-or
+				r2n-build-conc
+				r2n-build-star
+				r2n-build-plus
+				r2n-build-question
+				r2n-build-class
+				r2n-build-char)))
+    (lambda (re start end)
+      (let* ((re-type (get-re-type re))
+	     (sub-f (vector-ref sub-function-v re-type)))
+	(sub-f re start end)))))
+
+; Construction de l'automate relatif a une regle
+(define r2n-build-rule
+  (lambda (rule ruleno nl-start no-nl-start)
+    (let* ((re (get-rule-regexp rule))
+	   (bol? (get-rule-bol? rule))
+	   (eol? (get-rule-eol? rule))
+	   (rule-start (r2n-get-state #f))
+	   (rule-end (r2n-get-state (if eol?
+					(cons ruleno #f)
+					(cons ruleno ruleno)))))
+      (r2n-build-re re rule-start rule-end)
+      (r2n-add-arc nl-start 'eps rule-start)
+      (if (not bol?)
+	  (r2n-add-arc no-nl-start 'eps rule-start)))))
+
+; Construction de l'automate complet
+(define re2nfa
+  (lambda (rules)
+    (let ((nb-of-rules (vector-length rules)))
+      (r2n-init)
+      (let* ((nl-start (r2n-get-state #f))
+	     (no-nl-start (r2n-get-state #f)))
+	(let loop ((i 0))
+	  (if (< i nb-of-rules)
+	      (begin
+		(r2n-build-rule (vector-ref rules i)
+				i
+				nl-start
+				no-nl-start)
+		(loop (+ i 1)))))
+	(r2n-finalize-v)
+	(let ((v-arcs r2n-v-arcs)
+	      (v-acc r2n-v-acc))
+	  (r2n-init)
+	  (list nl-start no-nl-start v-arcs v-acc))))))
+
+; Module noeps.scm.
+
+; Fonction "merge" qui elimine les repetitions
+(define noeps-merge-1
+  (lambda (l1 l2)
+    (cond ((null? l1)
+	   l2)
+	  ((null? l2)
+	   l1)
+	  (else
+	   (let ((t1 (car l1))
+		 (t2 (car l2)))
+	     (cond ((< t1 t2)
+		    (cons t1 (noeps-merge-1 (cdr l1) l2)))
+		   ((= t1 t2)
+		    (cons t1 (noeps-merge-1 (cdr l1) (cdr l2))))
+		   (else
+		    (cons t2 (noeps-merge-1 l1 (cdr l2))))))))))
+
+; Fabrication des voisinages externes
+(define noeps-mkvois
+  (lambda (trans-v)
+    (let* ((nbnodes (vector-length trans-v))
+	   (arcs (make-vector nbnodes '())))
+      (let loop1 ((n 0))
+	(if (< n nbnodes)
+	    (begin
+	      (let loop2 ((trans (vector-ref trans-v n)) (ends '()))
+		(if (null? trans)
+		    (vector-set! arcs n ends)
+		    (let* ((tran (car trans))
+			   (class (car tran))
+			   (end (cdr tran)))
+		      (loop2 (cdr trans) (if (eq? class 'eps)
+					     (noeps-merge-1 ends (list end))
+					     ends)))))
+	      (loop1 (+ n 1)))))
+      arcs)))
+
+; Fabrication des valeurs initiales
+(define noeps-mkinit
+  (lambda (trans-v)
+    (let* ((nbnodes (vector-length trans-v))
+	   (init (make-vector nbnodes)))
+      (let loop ((n 0))
+	(if (< n nbnodes)
+	    (begin
+	      (vector-set! init n (list n))
+	      (loop (+ n 1)))))
+      init)))
+
+; Traduction d'une liste d'arcs
+(define noeps-trad-arcs
+  (lambda (trans dict)
+    (let loop ((trans trans))
+      (if (null? trans)
+	  '()
+	  (let* ((tran (car trans))
+		 (class (car tran))
+		 (end (cdr tran)))
+	    (if (eq? class 'eps)
+		(loop (cdr trans))
+		(let* ((new-end (vector-ref dict end))
+		       (new-tran (cons class new-end)))
+		  (cons new-tran (loop (cdr trans))))))))))
+
+; Elimination des transitions eps
+(define noeps
+  (lambda (nl-start no-nl-start arcs acc)
+    (let* ((digraph-arcs (noeps-mkvois arcs))
+	   (digraph-init (noeps-mkinit arcs))
+	   (dict (digraph digraph-arcs digraph-init noeps-merge-1))
+	   (new-nl-start (vector-ref dict nl-start))
+	   (new-no-nl-start (vector-ref dict no-nl-start)))
+      (let loop ((i (- (vector-length arcs) 1)))
+	(if (>= i 0)
+	    (begin
+	      (vector-set! arcs i (noeps-trad-arcs (vector-ref arcs i) dict))
+	      (loop (- i 1)))))
+      (list new-nl-start new-no-nl-start arcs acc))))
+
+; Module sweep.scm.
+
+; Preparer les arcs pour digraph
+(define sweep-mkarcs
+  (lambda (trans-v)
+    (let* ((nbnodes (vector-length trans-v))
+	   (arcs-v (make-vector nbnodes '())))
+      (let loop1 ((n 0))
+	(if (< n nbnodes)
+	    (let loop2 ((trans (vector-ref trans-v n)) (arcs '()))
+	      (if (null? trans)
+		  (begin
+		    (vector-set! arcs-v n arcs)
+		    (loop1 (+ n 1)))
+		  (loop2 (cdr trans) (noeps-merge-1 (cdar trans) arcs))))
+	    arcs-v)))))
+
+; Preparer l'operateur pour digraph
+(define sweep-op
+  (let ((acc-min (lambda (rule1 rule2)
+		   (cond ((not rule1)
+			  rule2)
+			 ((not rule2)
+			  rule1)
+			 (else
+			  (min rule1 rule2))))))
+    (lambda (acc1 acc2)
+      (cons (acc-min (car acc1) (car acc2))
+	    (acc-min (cdr acc1) (cdr acc2))))))
+
+; Renumerotation des etats (#f pour etat a eliminer)
+; Retourne (new-nbnodes . dict)
+(define sweep-renum
+  (lambda (dist-acc-v)
+    (let* ((nbnodes (vector-length dist-acc-v))
+	   (dict (make-vector nbnodes)))
+      (let loop ((n 0) (new-n 0))
+	(if (< n nbnodes)
+	    (let* ((acc (vector-ref dist-acc-v n))
+		   (dead? (equal? acc '(#f . #f))))
+	      (if dead?
+		  (begin
+		    (vector-set! dict n #f)
+		    (loop (+ n 1) new-n))
+		  (begin
+		    (vector-set! dict n new-n)
+		    (loop (+ n 1) (+ new-n 1)))))
+	    (cons new-n dict))))))
+
+; Elimination des etats inutiles d'une liste d'etats
+(define sweep-list
+  (lambda (ss dict)
+    (if (null? ss)
+	'()
+	(let* ((olds (car ss))
+	       (news (vector-ref dict olds)))
+	  (if news
+	      (cons news (sweep-list (cdr ss) dict))
+	      (sweep-list (cdr ss) dict))))))
+
+; Elimination des etats inutiles d'une liste d'arcs
+(define sweep-arcs
+  (lambda (arcs dict)
+    (if (null? arcs)
+	'()
+	(let* ((arc (car arcs))
+	       (class (car arc))
+	       (ss (cdr arc))
+	       (new-ss (sweep-list ss dict)))
+	  (if (null? new-ss)
+	      (sweep-arcs (cdr arcs) dict)
+	      (cons (cons class new-ss) (sweep-arcs (cdr arcs) dict)))))))
+
+; Elimination des etats inutiles dans toutes les transitions
+(define sweep-all-arcs
+  (lambda (arcs-v dict)
+    (let loop ((n (- (vector-length arcs-v) 1)))
+      (if (>= n 0)
+	  (begin
+	    (vector-set! arcs-v n (sweep-arcs (vector-ref arcs-v n) dict))
+	    (loop (- n 1)))
+	  arcs-v))))
+
+; Elimination des etats inutiles dans un vecteur
+(define sweep-states
+  (lambda (v new-nbnodes dict)
+    (let ((nbnodes (vector-length v))
+	  (new-v (make-vector new-nbnodes)))
+      (let loop ((n 0))
+	(if (< n nbnodes)
+	    (let ((new-n (vector-ref dict n)))
+	      (if new-n
+		  (vector-set! new-v new-n (vector-ref v n)))
+	      (loop (+ n 1)))
+	    new-v)))))
+
+; Elimination des etats inutiles
+(define sweep
+  (lambda (nl-start no-nl-start arcs-v acc-v)
+    (let* ((digraph-arcs (sweep-mkarcs arcs-v))
+	   (digraph-init acc-v)
+	   (digraph-op sweep-op)
+	   (dist-acc-v (digraph digraph-arcs digraph-init digraph-op))
+	   (result (sweep-renum dist-acc-v))
+	   (new-nbnodes (car result))
+	   (dict (cdr result))
+	   (new-nl-start (sweep-list nl-start dict))
+	   (new-no-nl-start (sweep-list no-nl-start dict))
+	   (new-arcs-v (sweep-states (sweep-all-arcs arcs-v dict)
+				     new-nbnodes
+				     dict))
+	   (new-acc-v (sweep-states acc-v new-nbnodes dict)))
+      (list new-nl-start new-no-nl-start new-arcs-v new-acc-v))))
+
+; Module nfa2dfa.scm.
+
+; Recoupement de deux arcs
+(define n2d-2arcs
+  (lambda (arc1 arc2)
+    (let* ((class1 (car arc1))
+	   (ss1 (cdr arc1))
+	   (class2 (car arc2))
+	   (ss2 (cdr arc2))
+	   (result (class-sep class1 class2))
+	   (classl (vector-ref result 0))
+	   (classc (vector-ref result 1))
+	   (classr (vector-ref result 2))
+	   (ssl ss1)
+	   (ssc (ss-union ss1 ss2))
+	   (ssr ss2))
+      (vector (if (or (null? classl) (null? ssl)) #f (cons classl ssl))
+	      (if (or (null? classc) (null? ssc)) #f (cons classc ssc))
+	      (if (or (null? classr) (null? ssr)) #f (cons classr ssr))))))
+
+; Insertion d'un arc dans une liste d'arcs a classes distinctes
+(define n2d-insert-arc
+  (lambda (new-arc arcs)
+    (if (null? arcs)
+	(list new-arc)
+	(let* ((arc (car arcs))
+	       (others (cdr arcs))
+	       (result (n2d-2arcs new-arc arc))
+	       (arcl (vector-ref result 0))
+	       (arcc (vector-ref result 1))
+	       (arcr (vector-ref result 2))
+	       (list-arcc (if arcc (list arcc) '()))
+	       (list-arcr (if arcr (list arcr) '())))
+	  (if arcl
+	      (append list-arcc list-arcr (n2d-insert-arc arcl others))
+	      (append list-arcc list-arcr others))))))
+
+; Regroupement des arcs qui aboutissent au meme sous-ensemble d'etats
+(define n2d-factorize-arcs
+  (lambda (arcs)
+    (if (null? arcs)
+	'()
+	(let* ((arc (car arcs))
+	       (arc-ss (cdr arc))
+	       (others-no-fact (cdr arcs))
+	       (others (n2d-factorize-arcs others-no-fact)))
+	  (let loop ((o others))
+	    (if (null? o)
+		(list arc)
+		(let* ((o1 (car o))
+		       (o1-ss (cdr o1)))
+		  (if (equal? o1-ss arc-ss)
+		      (let* ((arc-class (car arc))
+			     (o1-class (car o1))
+			     (new-class (class-union arc-class o1-class))
+			     (new-arc (cons new-class arc-ss)))
+			(cons new-arc (cdr o)))
+		      (cons o1 (loop (cdr o)))))))))))
+
+; Transformer une liste d'arcs quelconques en des arcs a classes distinctes
+(define n2d-distinguish-arcs
+  (lambda (arcs)
+    (let loop ((arcs arcs) (n-arcs '()))
+      (if (null? arcs)
+	  n-arcs
+	  (loop (cdr arcs) (n2d-insert-arc (car arcs) n-arcs))))))
+
+; Transformer une liste d'arcs quelconques en des arcs a classes et a
+; destinations distinctes
+(define n2d-normalize-arcs
+  (lambda (arcs)
+    (n2d-factorize-arcs (n2d-distinguish-arcs arcs))))
+
+; Factoriser des arcs a destination unique (~deterministes)
+(define n2d-factorize-darcs
+  (lambda (arcs)
+    (if (null? arcs)
+	'()
+	(let* ((arc (car arcs))
+	       (arc-end (cdr arc))
+	       (other-arcs (cdr arcs))
+	       (farcs (n2d-factorize-darcs other-arcs)))
+	  (let loop ((farcs farcs))
+	    (if (null? farcs)
+		(list arc)
+		(let* ((farc (car farcs))
+		       (farc-end (cdr farc)))
+		  (if (= farc-end arc-end)
+		      (let* ((arc-class (car arc))
+			     (farc-class (car farc))
+			     (new-class (class-union farc-class arc-class))
+			     (new-arc (cons new-class arc-end)))
+			(cons new-arc (cdr farcs)))
+		      (cons farc (loop (cdr farcs)))))))))))
+
+; Normaliser un vecteur de listes d'arcs
+(define n2d-normalize-arcs-v
+  (lambda (arcs-v)
+    (let* ((nbnodes (vector-length arcs-v))
+	   (new-v (make-vector nbnodes)))
+      (let loop ((n 0))
+	(if (= n nbnodes)
+	    new-v
+	    (begin
+	      (vector-set! new-v n (n2d-normalize-arcs (vector-ref arcs-v n)))
+	      (loop (+ n 1))))))))
+
+; Inserer un arc dans une liste d'arcs a classes distinctes en separant
+; les arcs contenant une partie de la classe du nouvel arc des autres arcs
+; Retourne: (oui . non)
+(define n2d-ins-sep-arc
+  (lambda (new-arc arcs)
+    (if (null? arcs)
+	(cons (list new-arc) '())
+	(let* ((arc (car arcs))
+	       (others (cdr arcs))
+	       (result (n2d-2arcs new-arc arc))
+	       (arcl (vector-ref result 0))
+	       (arcc (vector-ref result 1))
+	       (arcr (vector-ref result 2))
+	       (l-arcc (if arcc (list arcc) '()))
+	       (l-arcr (if arcr (list arcr) '()))
+	       (result (if arcl
+			   (n2d-ins-sep-arc arcl others)
+			   (cons '() others)))
+	       (oui-arcs (car result))
+	       (non-arcs (cdr result)))
+	  (cons (append l-arcc oui-arcs) (append l-arcr non-arcs))))))
+
+; Combiner deux listes d'arcs a classes distinctes
+; Ne tente pas de combiner les arcs qui ont nec. des classes disjointes
+; Conjecture: les arcs crees ont leurs classes disjointes
+; Note: envisager de rajouter un "n2d-factorize-arcs" !!!!!!!!!!!!
+(define n2d-combine-arcs
+  (lambda (arcs1 arcs2)
+    (let loop ((arcs1 arcs1) (arcs2 arcs2) (dist-arcs2 '()))
+      (if (null? arcs1)
+	  (append arcs2 dist-arcs2)
+	  (let* ((arc (car arcs1))
+		 (result (n2d-ins-sep-arc arc arcs2))
+		 (oui-arcs (car result))
+		 (non-arcs (cdr result)))
+	    (loop (cdr arcs1) non-arcs (append oui-arcs dist-arcs2)))))))
+
+; ; 
+; ; Section temporaire: vieille facon de generer le dfa
+; ; Dictionnaire d'etat det.  Recherche lineaire.  Creation naive
+; ; des arcs d'un ensemble d'etats.
+; ; 
+; 
+; ; Quelques variables globales
+; (define n2d-state-dict '#(#f))
+; (define n2d-state-len 1)
+; (define n2d-state-count 0)
+; 
+; ; Fonctions de gestion des entrees du dictionnaire
+; (define make-dentry (lambda (ss) (vector ss #f #f)))
+; 
+; (define get-dentry-ss    (lambda (dentry) (vector-ref dentry 0)))
+; (define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
+; (define get-dentry-acc   (lambda (dentry) (vector-ref dentry 2)))
+; 
+; (define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
+; (define set-dentry-acc   (lambda (dentry acc)  (vector-set! dentry 2 acc)))
+; 
+; ; Initialisation des variables globales
+; (define n2d-init-glob-vars
+;   (lambda ()
+;     (set! n2d-state-dict (vector #f))
+;     (set! n2d-state-len 1)
+;     (set! n2d-state-count 0)))
+; 
+; ; Extension du dictionnaire
+; (define n2d-extend-dict
+;   (lambda ()
+;     (let* ((new-len (* 2 n2d-state-len))
+; 	   (v (make-vector new-len #f)))
+;       (let loop ((n 0))
+; 	(if (= n n2d-state-count)
+; 	    (begin
+; 	      (set! n2d-state-dict v)
+; 	      (set! n2d-state-len new-len))
+; 	    (begin
+; 	      (vector-set! v n (vector-ref n2d-state-dict n))
+; 	      (loop (+ n 1))))))))
+; 
+; ; Ajout d'un etat
+; (define n2d-add-state
+;   (lambda (ss)
+;     (let* ((s n2d-state-count)
+; 	   (dentry (make-dentry ss)))
+;       (if (= n2d-state-count n2d-state-len)
+; 	  (n2d-extend-dict))
+;       (vector-set! n2d-state-dict s dentry)
+;       (set! n2d-state-count (+ n2d-state-count 1))
+;       s)))
+; 
+; ; Recherche d'un etat
+; (define n2d-search-state
+;   (lambda (ss)
+;     (let loop ((n 0))
+;       (if (= n n2d-state-count)
+; 	  (n2d-add-state ss)
+; 	  (let* ((dentry (vector-ref n2d-state-dict n))
+; 		 (dentry-ss (get-dentry-ss dentry)))
+; 	    (if (equal? dentry-ss ss)
+; 		n
+; 		(loop (+ n 1))))))))
+; 
+; ; Transformer un arc non-det. en un arc det.
+; (define n2d-translate-arc
+;   (lambda (arc)
+;     (let* ((class (car arc))
+; 	   (ss (cdr arc))
+; 	   (s (n2d-search-state ss)))
+;       (cons class s))))
+; 
+; ; Transformer une liste d'arcs non-det. en ...
+; (define n2d-translate-arcs
+;   (lambda (arcs)
+;     (map n2d-translate-arc arcs)))
+; 
+; ; Trouver le minimum de deux acceptants
+; (define n2d-acc-min2
+;   (let ((acc-min (lambda (rule1 rule2)
+; 		   (cond ((not rule1)
+; 			  rule2)
+; 			 ((not rule2)
+; 			  rule1)
+; 			 (else
+; 			  (min rule1 rule2))))))
+;     (lambda (acc1 acc2)
+;       (cons (acc-min (car acc1) (car acc2))
+; 	    (acc-min (cdr acc1) (cdr acc2))))))
+; 
+; ; Trouver le minimum de plusieurs acceptants
+; (define n2d-acc-mins
+;   (lambda (accs)
+;     (if (null? accs)
+; 	(cons #f #f)
+; 	(n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
+; 
+; ; Fabriquer les vecteurs d'arcs et d'acceptance
+; (define n2d-extract-vs
+;   (lambda ()
+;     (let* ((arcs-v (make-vector n2d-state-count))
+; 	   (acc-v (make-vector n2d-state-count)))
+;       (let loop ((n 0))
+; 	(if (= n n2d-state-count)
+; 	    (cons arcs-v acc-v)
+; 	    (begin
+; 	      (vector-set! arcs-v n (get-dentry-darcs
+; 				     (vector-ref n2d-state-dict n)))
+; 	      (vector-set! acc-v n (get-dentry-acc
+; 				    (vector-ref n2d-state-dict n)))
+; 	      (loop (+ n 1))))))))
+; 
+; ; Effectuer la transformation de l'automate de non-det. a det.
+; (define nfa2dfa
+;   (lambda (nl-start no-nl-start arcs-v acc-v)
+;     (n2d-init-glob-vars)
+;     (let* ((nl-d (n2d-search-state nl-start))
+; 	   (no-nl-d (n2d-search-state no-nl-start)))
+;       (let loop ((n 0))
+; 	(if (< n n2d-state-count)
+; 	    (let* ((dentry (vector-ref n2d-state-dict n))
+; 		   (ss (get-dentry-ss dentry))
+; 		   (arcss (map (lambda (s) (vector-ref arcs-v s)) ss))
+; 		   (arcs (apply append arcss))
+; 		   (dist-arcs (n2d-distinguish-arcs arcs))
+; 		   (darcs (n2d-translate-arcs dist-arcs))
+; 		   (fact-darcs (n2d-factorize-darcs darcs))
+; 		   (accs (map (lambda (s) (vector-ref acc-v s)) ss))
+; 		   (acc (n2d-acc-mins accs)))
+; 	      (set-dentry-darcs dentry fact-darcs)
+; 	      (set-dentry-acc   dentry acc)
+; 	      (loop (+ n 1)))))
+;       (let* ((result (n2d-extract-vs))
+; 	     (new-arcs-v (car result))
+; 	     (new-acc-v (cdr result)))
+; 	(n2d-init-glob-vars)
+; 	(list nl-d no-nl-d new-arcs-v new-acc-v)))))
+
+; ; 
+; ; Section temporaire: vieille facon de generer le dfa
+; ; Dictionnaire d'etat det.  Recherche lineaire.  Creation des
+; ; arcs d'un ensemble d'etats en combinant des ensembles d'arcs a
+; ; classes distinctes.
+; ; 
+; 
+; ; Quelques variables globales
+; (define n2d-state-dict '#(#f))
+; (define n2d-state-len 1)
+; (define n2d-state-count 0)
+; 
+; ; Fonctions de gestion des entrees du dictionnaire
+; (define make-dentry (lambda (ss) (vector ss #f #f)))
+; 
+; (define get-dentry-ss    (lambda (dentry) (vector-ref dentry 0)))
+; (define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
+; (define get-dentry-acc   (lambda (dentry) (vector-ref dentry 2)))
+; 
+; (define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
+; (define set-dentry-acc   (lambda (dentry acc)  (vector-set! dentry 2 acc)))
+; 
+; ; Initialisation des variables globales
+; (define n2d-init-glob-vars
+;   (lambda ()
+;     (set! n2d-state-dict (vector #f))
+;     (set! n2d-state-len 1)
+;     (set! n2d-state-count 0)))
+; 
+; ; Extension du dictionnaire
+; (define n2d-extend-dict
+;   (lambda ()
+;     (let* ((new-len (* 2 n2d-state-len))
+; 	   (v (make-vector new-len #f)))
+;       (let loop ((n 0))
+; 	(if (= n n2d-state-count)
+; 	    (begin
+; 	      (set! n2d-state-dict v)
+; 	      (set! n2d-state-len new-len))
+; 	    (begin
+; 	      (vector-set! v n (vector-ref n2d-state-dict n))
+; 	      (loop (+ n 1))))))))
+; 
+; ; Ajout d'un etat
+; (define n2d-add-state
+;   (lambda (ss)
+;     (let* ((s n2d-state-count)
+; 	   (dentry (make-dentry ss)))
+;       (if (= n2d-state-count n2d-state-len)
+; 	  (n2d-extend-dict))
+;       (vector-set! n2d-state-dict s dentry)
+;       (set! n2d-state-count (+ n2d-state-count 1))
+;       s)))
+; 
+; ; Recherche d'un etat
+; (define n2d-search-state
+;   (lambda (ss)
+;     (let loop ((n 0))
+;       (if (= n n2d-state-count)
+; 	  (n2d-add-state ss)
+; 	  (let* ((dentry (vector-ref n2d-state-dict n))
+; 		 (dentry-ss (get-dentry-ss dentry)))
+; 	    (if (equal? dentry-ss ss)
+; 		n
+; 		(loop (+ n 1))))))))
+; 
+; ; Combiner des listes d'arcs a classes dictinctes
+; (define n2d-combine-arcs-l
+;   (lambda (arcs-l)
+;     (if (null? arcs-l)
+; 	'()
+; 	(let* ((arcs (car arcs-l))
+; 	       (other-arcs-l (cdr arcs-l))
+; 	       (other-arcs (n2d-combine-arcs-l other-arcs-l)))
+; 	  (n2d-combine-arcs arcs other-arcs)))))
+; 
+; ; Transformer un arc non-det. en un arc det.
+; (define n2d-translate-arc
+;   (lambda (arc)
+;     (let* ((class (car arc))
+; 	   (ss (cdr arc))
+; 	   (s (n2d-search-state ss)))
+;       (cons class s))))
+; 
+; ; Transformer une liste d'arcs non-det. en ...
+; (define n2d-translate-arcs
+;   (lambda (arcs)
+;     (map n2d-translate-arc arcs)))
+; 
+; ; Trouver le minimum de deux acceptants
+; (define n2d-acc-min2
+;   (let ((acc-min (lambda (rule1 rule2)
+; 		   (cond ((not rule1)
+; 			  rule2)
+; 			 ((not rule2)
+; 			  rule1)
+; 			 (else
+; 			  (min rule1 rule2))))))
+;     (lambda (acc1 acc2)
+;       (cons (acc-min (car acc1) (car acc2))
+; 	    (acc-min (cdr acc1) (cdr acc2))))))
+; 
+; ; Trouver le minimum de plusieurs acceptants
+; (define n2d-acc-mins
+;   (lambda (accs)
+;     (if (null? accs)
+; 	(cons #f #f)
+; 	(n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
+; 
+; ; Fabriquer les vecteurs d'arcs et d'acceptance
+; (define n2d-extract-vs
+;   (lambda ()
+;     (let* ((arcs-v (make-vector n2d-state-count))
+; 	   (acc-v (make-vector n2d-state-count)))
+;       (let loop ((n 0))
+; 	(if (= n n2d-state-count)
+; 	    (cons arcs-v acc-v)
+; 	    (begin
+; 	      (vector-set! arcs-v n (get-dentry-darcs
+; 				     (vector-ref n2d-state-dict n)))
+; 	      (vector-set! acc-v n (get-dentry-acc
+; 				    (vector-ref n2d-state-dict n)))
+; 	      (loop (+ n 1))))))))
+; 
+; ; Effectuer la transformation de l'automate de non-det. a det.
+; (define nfa2dfa
+;   (lambda (nl-start no-nl-start arcs-v acc-v)
+;     (n2d-init-glob-vars)
+;     (let* ((nl-d (n2d-search-state nl-start))
+; 	   (no-nl-d (n2d-search-state no-nl-start))
+; 	   (norm-arcs-v (n2d-normalize-arcs-v arcs-v)))
+;       (let loop ((n 0))
+; 	(if (< n n2d-state-count)
+; 	    (let* ((dentry (vector-ref n2d-state-dict n))
+; 		   (ss (get-dentry-ss dentry))
+; 		   (arcs-l (map (lambda (s) (vector-ref norm-arcs-v s)) ss))
+; 		   (arcs (n2d-combine-arcs-l arcs-l))
+; 		   (darcs (n2d-translate-arcs arcs))
+; 		   (fact-darcs (n2d-factorize-darcs darcs))
+; 		   (accs (map (lambda (s) (vector-ref acc-v s)) ss))
+; 		   (acc (n2d-acc-mins accs)))
+; 	      (set-dentry-darcs dentry fact-darcs)
+; 	      (set-dentry-acc   dentry acc)
+; 	      (loop (+ n 1)))))
+;       (let* ((result (n2d-extract-vs))
+; 	     (new-arcs-v (car result))
+; 	     (new-acc-v (cdr result)))
+; 	(n2d-init-glob-vars)
+; 	(list nl-d no-nl-d new-arcs-v new-acc-v)))))
+
+; ; 
+; ; Section temporaire: vieille facon de generer le dfa
+; ; Dictionnaire d'etat det.  Arbre de recherche.  Creation des
+; ; arcs d'un ensemble d'etats en combinant des ensembles d'arcs a
+; ; classes distinctes.
+; ; 
+; 
+; ; Quelques variables globales
+; (define n2d-state-dict '#(#f))
+; (define n2d-state-len 1)
+; (define n2d-state-count 0)
+; (define n2d-state-tree '#(#f ()))
+; 
+; ; Fonctions de gestion des entrees du dictionnaire
+; (define make-dentry (lambda (ss) (vector ss #f #f)))
+; 
+; (define get-dentry-ss    (lambda (dentry) (vector-ref dentry 0)))
+; (define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
+; (define get-dentry-acc   (lambda (dentry) (vector-ref dentry 2)))
+; 
+; (define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
+; (define set-dentry-acc   (lambda (dentry acc)  (vector-set! dentry 2 acc)))
+; 
+; ; Fonctions de gestion de l'arbre de recherche
+; (define make-snode (lambda () (vector #f '())))
+; 
+; (define get-snode-dstate   (lambda (snode) (vector-ref snode 0)))
+; (define get-snode-children (lambda (snode) (vector-ref snode 1)))
+; 
+; (define set-snode-dstate
+;   (lambda (snode dstate)   (vector-set! snode 0 dstate)))
+; (define set-snode-children
+;   (lambda (snode children) (vector-set! snode 1 children)))
+; 
+; ; Initialisation des variables globales
+; (define n2d-init-glob-vars
+;   (lambda ()
+;     (set! n2d-state-dict (vector #f))
+;     (set! n2d-state-len 1)
+;     (set! n2d-state-count 0)
+;     (set! n2d-state-tree (make-snode))))
+; 
+; ; Extension du dictionnaire
+; (define n2d-extend-dict
+;   (lambda ()
+;     (let* ((new-len (* 2 n2d-state-len))
+; 	   (v (make-vector new-len #f)))
+;       (let loop ((n 0))
+; 	(if (= n n2d-state-count)
+; 	    (begin
+; 	      (set! n2d-state-dict v)
+; 	      (set! n2d-state-len new-len))
+; 	    (begin
+; 	      (vector-set! v n (vector-ref n2d-state-dict n))
+; 	      (loop (+ n 1))))))))
+; 
+; ; Ajout d'un etat
+; (define n2d-add-state
+;   (lambda (ss)
+;     (let* ((s n2d-state-count)
+; 	   (dentry (make-dentry ss)))
+;       (if (= n2d-state-count n2d-state-len)
+; 	  (n2d-extend-dict))
+;       (vector-set! n2d-state-dict s dentry)
+;       (set! n2d-state-count (+ n2d-state-count 1))
+;       s)))
+; 
+; ; Recherche d'un etat
+; (define n2d-search-state
+;   (lambda (ss)
+;     (let loop ((s-l ss) (snode n2d-state-tree))
+;       (if (null? s-l)
+; 	  (or (get-snode-dstate snode)
+; 	      (let ((s (n2d-add-state ss)))
+; 		(set-snode-dstate snode s)
+; 		s))
+; 	  (let* ((next-s (car s-l))
+; 		 (alist (get-snode-children snode))
+; 		 (ass (or (assv next-s alist)
+; 			  (let ((ass (cons next-s (make-snode))))
+; 			    (set-snode-children snode (cons ass alist))
+; 			    ass))))
+; 	    (loop (cdr s-l) (cdr ass)))))))
+; 
+; ; Combiner des listes d'arcs a classes dictinctes
+; (define n2d-combine-arcs-l
+;   (lambda (arcs-l)
+;     (if (null? arcs-l)
+; 	'()
+; 	(let* ((arcs (car arcs-l))
+; 	       (other-arcs-l (cdr arcs-l))
+; 	       (other-arcs (n2d-combine-arcs-l other-arcs-l)))
+; 	  (n2d-combine-arcs arcs other-arcs)))))
+; 
+; ; Transformer un arc non-det. en un arc det.
+; (define n2d-translate-arc
+;   (lambda (arc)
+;     (let* ((class (car arc))
+; 	   (ss (cdr arc))
+; 	   (s (n2d-search-state ss)))
+;       (cons class s))))
+; 
+; ; Transformer une liste d'arcs non-det. en ...
+; (define n2d-translate-arcs
+;   (lambda (arcs)
+;     (map n2d-translate-arc arcs)))
+; 
+; ; Trouver le minimum de deux acceptants
+; (define n2d-acc-min2
+;   (let ((acc-min (lambda (rule1 rule2)
+; 		   (cond ((not rule1)
+; 			  rule2)
+; 			 ((not rule2)
+; 			  rule1)
+; 			 (else
+; 			  (min rule1 rule2))))))
+;     (lambda (acc1 acc2)
+;       (cons (acc-min (car acc1) (car acc2))
+; 	    (acc-min (cdr acc1) (cdr acc2))))))
+; 
+; ; Trouver le minimum de plusieurs acceptants
+; (define n2d-acc-mins
+;   (lambda (accs)
+;     (if (null? accs)
+; 	(cons #f #f)
+; 	(n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
+; 
+; ; Fabriquer les vecteurs d'arcs et d'acceptance
+; (define n2d-extract-vs
+;   (lambda ()
+;     (let* ((arcs-v (make-vector n2d-state-count))
+; 	   (acc-v (make-vector n2d-state-count)))
+;       (let loop ((n 0))
+; 	(if (= n n2d-state-count)
+; 	    (cons arcs-v acc-v)
+; 	    (begin
+; 	      (vector-set! arcs-v n (get-dentry-darcs
+; 				     (vector-ref n2d-state-dict n)))
+; 	      (vector-set! acc-v n (get-dentry-acc
+; 				    (vector-ref n2d-state-dict n)))
+; 	      (loop (+ n 1))))))))
+; 
+; ; Effectuer la transformation de l'automate de non-det. a det.
+; (define nfa2dfa
+;   (lambda (nl-start no-nl-start arcs-v acc-v)
+;     (n2d-init-glob-vars)
+;     (let* ((nl-d (n2d-search-state nl-start))
+; 	   (no-nl-d (n2d-search-state no-nl-start))
+; 	   (norm-arcs-v (n2d-normalize-arcs-v arcs-v)))
+;       (let loop ((n 0))
+; 	(if (< n n2d-state-count)
+; 	    (let* ((dentry (vector-ref n2d-state-dict n))
+; 		   (ss (get-dentry-ss dentry))
+; 		   (arcs-l (map (lambda (s) (vector-ref norm-arcs-v s)) ss))
+; 		   (arcs (n2d-combine-arcs-l arcs-l))
+; 		   (darcs (n2d-translate-arcs arcs))
+; 		   (fact-darcs (n2d-factorize-darcs darcs))
+; 		   (accs (map (lambda (s) (vector-ref acc-v s)) ss))
+; 		   (acc (n2d-acc-mins accs)))
+; 	      (set-dentry-darcs dentry fact-darcs)
+; 	      (set-dentry-acc   dentry acc)
+; 	      (loop (+ n 1)))))
+;       (let* ((result (n2d-extract-vs))
+; 	     (new-arcs-v (car result))
+; 	     (new-acc-v (cdr result)))
+; 	(n2d-init-glob-vars)
+; 	(list nl-d no-nl-d new-arcs-v new-acc-v)))))
+
+; 
+; Section temporaire: vieille facon de generer le dfa
+; Dictionnaire d'etat det.  Table de hashage.  Creation des
+; arcs d'un ensemble d'etats en combinant des ensembles d'arcs a
+; classes distinctes.
+; 
+
+; Quelques variables globales
+(define n2d-state-dict '#(#f))
+(define n2d-state-len 1)
+(define n2d-state-count 0)
+(define n2d-state-hash '#())
+
+; Fonctions de gestion des entrees du dictionnaire
+(define make-dentry (lambda (ss) (vector ss #f #f)))
+
+(define get-dentry-ss    (lambda (dentry) (vector-ref dentry 0)))
+(define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
+(define get-dentry-acc   (lambda (dentry) (vector-ref dentry 2)))
+
+(define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
+(define set-dentry-acc   (lambda (dentry acc)  (vector-set! dentry 2 acc)))
+
+; Initialisation des variables globales
+(define n2d-init-glob-vars
+  (lambda (hash-len)
+    (set! n2d-state-dict (vector #f))
+    (set! n2d-state-len 1)
+    (set! n2d-state-count 0)
+    (set! n2d-state-hash (make-vector hash-len '()))))
+
+; Extension du dictionnaire
+(define n2d-extend-dict
+  (lambda ()
+    (let* ((new-len (* 2 n2d-state-len))
+	   (v (make-vector new-len #f)))
+      (let loop ((n 0))
+	(if (= n n2d-state-count)
+	    (begin
+	      (set! n2d-state-dict v)
+	      (set! n2d-state-len new-len))
+	    (begin
+	      (vector-set! v n (vector-ref n2d-state-dict n))
+	      (loop (+ n 1))))))))
+
+; Ajout d'un etat
+(define n2d-add-state
+  (lambda (ss)
+    (let* ((s n2d-state-count)
+	   (dentry (make-dentry ss)))
+      (if (= n2d-state-count n2d-state-len)
+	  (n2d-extend-dict))
+      (vector-set! n2d-state-dict s dentry)
+      (set! n2d-state-count (+ n2d-state-count 1))
+      s)))
+
+; Recherche d'un etat
+(define n2d-search-state
+  (lambda (ss)
+    (let* ((hash-no (if (null? ss) 0 (car ss)))
+	   (alist (vector-ref n2d-state-hash hash-no))
+	   (ass (assoc ss alist)))
+      (if ass
+	  (cdr ass)
+	  (let* ((s (n2d-add-state ss))
+		 (new-ass (cons ss s)))
+	    (vector-set! n2d-state-hash hash-no (cons new-ass alist))
+	    s)))))
+
+; Combiner des listes d'arcs a classes dictinctes
+(define n2d-combine-arcs-l
+  (lambda (arcs-l)
+    (if (null? arcs-l)
+	'()
+	(let* ((arcs (car arcs-l))
+	       (other-arcs-l (cdr arcs-l))
+	       (other-arcs (n2d-combine-arcs-l other-arcs-l)))
+	  (n2d-combine-arcs arcs other-arcs)))))
+
+; Transformer un arc non-det. en un arc det.
+(define n2d-translate-arc
+  (lambda (arc)
+    (let* ((class (car arc))
+	   (ss (cdr arc))
+	   (s (n2d-search-state ss)))
+      (cons class s))))
+
+; Transformer une liste d'arcs non-det. en ...
+(define n2d-translate-arcs
+  (lambda (arcs)
+    (map n2d-translate-arc arcs)))
+
+; Trouver le minimum de deux acceptants
+(define n2d-acc-min2
+  (let ((acc-min (lambda (rule1 rule2)
+		   (cond ((not rule1)
+			  rule2)
+			 ((not rule2)
+			  rule1)
+			 (else
+			  (min rule1 rule2))))))
+    (lambda (acc1 acc2)
+      (cons (acc-min (car acc1) (car acc2))
+	    (acc-min (cdr acc1) (cdr acc2))))))
+
+; Trouver le minimum de plusieurs acceptants
+(define n2d-acc-mins
+  (lambda (accs)
+    (if (null? accs)
+	(cons #f #f)
+	(n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
+
+; Fabriquer les vecteurs d'arcs et d'acceptance
+(define n2d-extract-vs
+  (lambda ()
+    (let* ((arcs-v (make-vector n2d-state-count))
+	   (acc-v (make-vector n2d-state-count)))
+      (let loop ((n 0))
+	(if (= n n2d-state-count)
+	    (cons arcs-v acc-v)
+	    (begin
+	      (vector-set! arcs-v n (get-dentry-darcs
+				     (vector-ref n2d-state-dict n)))
+	      (vector-set! acc-v n (get-dentry-acc
+				    (vector-ref n2d-state-dict n)))
+	      (loop (+ n 1))))))))
+
+; Effectuer la transformation de l'automate de non-det. a det.
+(define nfa2dfa
+  (lambda (nl-start no-nl-start arcs-v acc-v)
+    (n2d-init-glob-vars (vector-length arcs-v))
+    (let* ((nl-d (n2d-search-state nl-start))
+	   (no-nl-d (n2d-search-state no-nl-start))
+	   (norm-arcs-v (n2d-normalize-arcs-v arcs-v)))
+      (let loop ((n 0))
+	(if (< n n2d-state-count)
+	    (let* ((dentry (vector-ref n2d-state-dict n))
+		   (ss (get-dentry-ss dentry))
+		   (arcs-l (map (lambda (s) (vector-ref norm-arcs-v s)) ss))
+		   (arcs (n2d-combine-arcs-l arcs-l))
+		   (darcs (n2d-translate-arcs arcs))
+		   (fact-darcs (n2d-factorize-darcs darcs))
+		   (accs (map (lambda (s) (vector-ref acc-v s)) ss))
+		   (acc (n2d-acc-mins accs)))
+	      (set-dentry-darcs dentry fact-darcs)
+	      (set-dentry-acc   dentry acc)
+	      (loop (+ n 1)))))
+      (let* ((result (n2d-extract-vs))
+	     (new-arcs-v (car result))
+	     (new-acc-v (cdr result)))
+	(n2d-init-glob-vars 0)
+	(list nl-d no-nl-d new-arcs-v new-acc-v)))))
+
+; Module prep.scm.
+
+;
+; Divers pre-traitements avant l'ecriture des tables
+;
+
+; Passe d'un arc multi-range a une liste d'arcs mono-range
+(define prep-arc->sharcs
+  (lambda (arc)
+    (let* ((range-l (car arc))
+	   (dest (cdr arc))
+	   (op (lambda (range) (cons range dest))))
+      (map op range-l))))
+
+; Compare des arcs courts selon leur premier caractere
+(define prep-sharc-<=
+  (lambda (sharc1 sharc2)
+    (class-<= (caar sharc1) (caar sharc2))))
+
+; Remplit les trous parmi les sharcs avec des arcs "erreur"
+(define prep-fill-error
+  (lambda (sharcs)
+    (let loop ((sharcs sharcs) (start 'inf-))
+      (cond ((class-= start 'inf+)
+	     '())
+	    ((null? sharcs)
+	     (cons (cons (cons start 'inf+) 'err) (loop sharcs 'inf+)))
+	    (else
+	     (let* ((sharc (car sharcs))
+		    (h (caar sharc))
+		    (t (cdar sharc)))
+	       (if (class-< start h)
+		   (cons (cons (cons start (- h 1)) 'err) (loop sharcs h))
+		   (cons sharc (loop (cdr sharcs)
+				     (if (class-= t 'inf+)
+					 'inf+
+					 (+ t 1)))))))))))
+
+; ; Passe d'une liste d'arcs a un arbre de decision
+; ; 1ere methode: seulement des comparaisons <
+; (define prep-arcs->tree
+;   (lambda (arcs)
+;     (let* ((sharcs-l (map prep-arc->sharcs arcs))
+; 	   (sharcs (apply append sharcs-l))
+; 	   (sorted-with-holes (merge-sort sharcs prep-sharc-<=))
+; 	   (sorted (prep-fill-error sorted-with-holes))
+; 	   (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
+; 	   (table (list->vector (map op sorted))))
+;       (let loop ((left 0) (right (- (vector-length table) 1)))
+; 	(if (= left right)
+; 	    (cdr (vector-ref table left))
+; 	    (let ((mid (quotient (+ left right 1) 2)))
+; 	      (list (car (vector-ref table mid))
+; 		    (loop left (- mid 1))
+; 		    (loop mid right))))))))
+
+; Passe d'une liste d'arcs a un arbre de decision
+; 2eme methode: permettre des comparaisons = quand ca adonne
+(define prep-arcs->tree
+  (lambda (arcs)
+    (let* ((sharcs-l (map prep-arc->sharcs arcs))
+	   (sharcs (apply append sharcs-l))
+	   (sorted-with-holes (merge-sort sharcs prep-sharc-<=))
+	   (sorted (prep-fill-error sorted-with-holes))
+	   (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
+	   (table (list->vector (map op sorted))))
+      (let loop ((left 0) (right (- (vector-length table) 1)))
+	(if (= left right)
+	    (cdr (vector-ref table left))
+	    (let ((mid (quotient (+ left right 1) 2)))
+	      (if (and (= (+ left 2) right)
+		       (= (+ (car (vector-ref table mid)) 1)
+			  (car (vector-ref table right)))
+		       (eqv? (cdr (vector-ref table left))
+			     (cdr (vector-ref table right))))
+		  (list '=
+			(car (vector-ref table mid))
+			(cdr (vector-ref table mid))
+			(cdr (vector-ref table left)))
+		  (list (car (vector-ref table mid))
+			(loop left (- mid 1))
+			(loop mid right)))))))))
+
+; Determine si une action a besoin de calculer yytext
+(define prep-detect-yytext
+  (lambda (s)
+    (let loop1 ((i (- (string-length s) 6)))
+      (cond ((< i 0)
+	     #f)
+	    ((char-ci=? (string-ref s i) #\y)
+	     (let loop2 ((j 5))
+	       (cond ((= j 0)
+		      #t)
+		     ((char-ci=? (string-ref s (+ i j))
+				 (string-ref "yytext" j))
+		      (loop2 (- j 1)))
+		     (else
+		      (loop1 (- i 1))))))
+	    (else
+	     (loop1 (- i 1)))))))
+
+; Note dans une regle si son action a besoin de yytext
+(define prep-set-rule-yytext?
+  (lambda (rule)
+    (let ((action (get-rule-action rule)))
+      (set-rule-yytext? rule (prep-detect-yytext action)))))
+
+; Note dans toutes les regles si leurs actions ont besoin de yytext
+(define prep-set-rules-yytext?
+  (lambda (rules)
+    (let loop ((n (- (vector-length rules) 1)))
+      (if (>= n 0)
+	  (begin
+	    (prep-set-rule-yytext? (vector-ref rules n))
+	    (loop (- n 1)))))))
+
+; Module output.scm.
+
+;
+; Nettoie les actions en enlevant les lignes blanches avant et apres
+;
+
+(define out-split-in-lines
+  (lambda (s)
+    (let ((len (string-length s)))
+      (let loop ((i 0) (start 0))
+	(cond ((= i len)
+	       '())
+	      ((char=? (string-ref s i) #\newline)
+	       (cons (substring s start (+ i 1))
+		     (loop (+ i 1) (+ i 1))))
+	      (else
+	       (loop (+ i 1) start)))))))
+
+(define out-empty-line?
+  (lambda (s)
+    (let ((len (- (string-length s) 1)))
+      (let loop ((i 0))
+	(cond ((= i len)
+	       #t)
+	      ((char-whitespace? (string-ref s i))
+	       (loop (+ i 1)))
+	      (else
+	       #f))))))
+
+; Enleve les lignes vides dans une liste avant et apres l'action
+(define out-remove-empty-lines
+  (lambda (lines)
+    (let loop ((lines lines) (top? #t))
+      (if (null? lines)
+	  '()
+	  (let ((line (car lines)))
+	    (cond ((not (out-empty-line? line))
+		   (cons line (loop (cdr lines) #f)))
+		  (top?
+		   (loop (cdr lines) #t))
+		  (else
+		   (let ((rest (loop (cdr lines) #f)))
+		     (if (null? rest)
+			 '()
+			 (cons line rest))))))))))
+
+; Enleve les lignes vides avant et apres l'action
+(define out-clean-action
+  (lambda (s)
+    (let* ((lines (out-split-in-lines s))
+	   (clean-lines (out-remove-empty-lines lines)))
+      (apply string-append clean-lines))))
+
+
+
+
+;
+; Pretty-printer pour les booleens, la liste vide, les nombres,
+; les symboles, les caracteres, les chaines, les listes et les vecteurs
+;
+
+; Colonne limite pour le pretty-printer (a ne pas atteindre)
+(define out-max-col 76)
+
+(define out-flatten-list
+  (lambda (ll)
+    (let loop ((ll ll) (part-out '()))
+      (if (null? ll)
+	  part-out
+	  (let* ((new-part-out (loop (cdr ll) part-out))
+		 (head (car ll)))
+	    (cond ((null? head)
+		   new-part-out)
+		  ((pair? head)
+		   (loop head new-part-out))
+		  (else
+		   (cons head new-part-out))))))))
+
+(define out-force-string
+  (lambda (obj)
+    (if (char? obj)
+	(string obj)
+	obj)))
+
+; Transforme une liste impropre en une liste propre qui s'ecrit
+; de la meme facon
+(define out-regular-list
+  (let ((symbolic-dot (string->symbol ".")))
+    (lambda (p)
+      (let ((tail (cdr p)))
+	(cond ((null? tail)
+	       p)
+	      ((pair? tail)
+	       (cons (car p) (out-regular-list tail)))
+	      (else
+	       (list (car p) symbolic-dot tail)))))))
+
+; Cree des chaines d'espaces de facon paresseuse
+(define out-blanks
+  (let ((cache-v (make-vector 80 #f)))
+    (lambda (n)
+      (or (vector-ref cache-v n)
+	  (let ((result (make-string n #\space)))
+	    (vector-set! cache-v n result)
+	    result)))))
+
+; Insere le separateur entre chaque element d'une liste non-vide
+(define out-separate
+  (lambda (text-l sep)
+    (if (null? (cdr text-l))
+	text-l
+	(cons (car text-l) (cons sep (out-separate (cdr text-l) sep))))))
+
+; Met des donnees en colonnes.  Retourne comme out-pp-aux-list
+(define out-pp-columns
+  (lambda (left right wmax txt&lens)
+    (let loop1 ((tls txt&lens) (lwmax 0) (lwlast 0) (lines '()))
+      (if (null? tls)
+	  (vector #t 0 lwmax lwlast (reverse lines))
+	  (let loop2 ((tls tls) (len 0) (first? #t) (prev-pad 0) (line '()))
+	    (cond ((null? tls)
+		   (loop1 tls
+			  (max len lwmax)
+			  len
+			  (cons (reverse line) lines)))
+		  ((> (+ left len prev-pad 1 wmax) out-max-col)
+		   (loop1 tls
+			  (max len lwmax)
+			  len
+			  (cons (reverse line) lines)))
+		  (first?
+		   (let ((text     (caar tls))
+			 (text-len (cdar tls)))
+		     (loop2 (cdr tls)
+			    (+ len text-len)
+			    #f
+			    (- wmax text-len)
+			    (cons text line))))
+		  ((pair? (cdr tls))
+		   (let* ((prev-pad-s (out-blanks prev-pad))
+			  (text     (caar tls))
+			  (text-len (cdar tls)))
+		     (loop2 (cdr tls)
+			    (+ len prev-pad 1 text-len)
+			    #f
+			    (- wmax text-len)
+			    (cons text (cons " " (cons prev-pad-s line))))))
+		  (else
+		   (let ((prev-pad-s (out-blanks prev-pad))
+			 (text     (caar tls))
+			 (text-len (cdar tls)))
+		     (if (> (+ left len prev-pad 1 text-len) right)
+			 (loop1 tls
+				(max len lwmax)
+				len
+				(cons (reverse line) lines))
+			 (loop2 (cdr tls)
+				(+ len prev-pad 1 text-len)
+				#f
+				(- wmax text-len)
+				(append (list text " " prev-pad-s)
+					line)))))))))))
+
+; Retourne un vecteur #( multiline? width-all width-max width-last text-l )
+(define out-pp-aux-list
+  (lambda (l left right)
+    (let loop ((l l) (multi? #f) (wall -1) (wmax -1) (wlast -1) (txt&lens '()))
+      (if (null? l)
+	  (cond (multi?
+		 (vector #t wall wmax wlast (map car (reverse txt&lens))))
+		((<= (+ left wall) right)
+		 (vector #f wall wmax wlast (map car (reverse txt&lens))))
+		((<= (+ left wmax 1 wmax) out-max-col)
+		 (out-pp-columns left right wmax (reverse txt&lens)))
+		(else
+		 (vector #t wall wmax wlast (map car (reverse txt&lens)))))
+	  (let* ((obj (car l))
+		 (last? (null? (cdr l)))
+		 (this-right (if last? right out-max-col))
+		 (result (out-pp-aux obj left this-right))
+		 (obj-multi? (vector-ref result 0))
+		 (obj-wmax   (vector-ref result 1))
+		 (obj-wlast  (vector-ref result 2))
+		 (obj-text   (vector-ref result 3)))
+	    (loop (cdr l)
+		  (or multi? obj-multi?)
+		  (+ wall obj-wmax 1)
+		  (max wmax obj-wmax)
+		  obj-wlast
+		  (cons (cons obj-text obj-wmax) txt&lens)))))))
+
+; Retourne un vecteur #( multiline? wmax wlast text )
+(define out-pp-aux
+  (lambda (obj left right)
+    (cond ((boolean? obj)
+	   (vector #f 2 2 (if obj '("#t") '("#f"))))
+	  ((null? obj)
+	   (vector #f 2 2 '("()")))
+	  ((number? obj)
+	   (let* ((s (number->string obj))
+		  (len (string-length s)))
+	     (vector #f len len (list s))))
+	  ((symbol? obj)
+	   (let* ((s (symbol->string obj))
+		  (len (string-length s)))
+	     (vector #f len len (list s))))
+	  ((char? obj)
+	   (cond ((char=? obj #\space)
+		  (vector #f 7 7 (list "#\\space")))
+		 ((char=? obj #\newline)
+		  (vector #f 9 9 (list "#\\newline")))
+		 (else
+		  (vector #f 3 3 (list "#\\" obj)))))
+	  ((string? obj)
+	   (let loop ((i (- (string-length obj) 1))
+		      (len 1)
+		      (text '("\"")))
+	     (if (= i -1)
+		 (vector #f (+ len 1) (+ len 1) (cons "\"" text))
+		 (let ((c (string-ref obj i)))
+		   (cond ((char=? c #\\)
+			  (loop (- i 1) (+ len 2) (cons "\\\\" text)))
+			 ((char=? c #\")
+			  (loop (- i 1) (+ len 2) (cons "\\\"" text)))
+			 (else
+			  (loop (- i 1) (+ len 1) (cons (string c) text))))))))
+	  ((pair? obj)
+	   (let* ((l (out-regular-list obj))
+		  (result (out-pp-aux-list l (+ left 1) (- right 1)))
+		  (multiline? (vector-ref result 0))
+		  (width-all  (vector-ref result 1))
+		  (width-max  (vector-ref result 2))
+		  (width-last (vector-ref result 3))
+		  (text-l     (vector-ref result 4)))
+	     (if multiline?
+		 (let* ((sep (list #\newline (out-blanks left)))
+			(formatted-text (out-separate text-l sep))
+			(text (list "(" formatted-text ")")))
+		   (vector #t
+			   (+ (max width-max (+ width-last 1)) 1)
+			   (+ width-last 2)
+			   text))
+		 (let* ((sep (list " "))
+			(formatted-text (out-separate text-l sep))
+			(text (list "(" formatted-text ")")))
+		   (vector #f (+ width-all 2) (+ width-all 2) text)))))
+	  ((and (vector? obj) (zero? (vector-length obj)))
+	   (vector #f 3 3 '("#()")))
+	  ((vector? obj)
+	   (let* ((l (vector->list obj))
+		  (result (out-pp-aux-list l (+ left 2) (- right 1)))
+		  (multiline? (vector-ref result 0))
+		  (width-all  (vector-ref result 1))
+		  (width-max  (vector-ref result 2))
+		  (width-last (vector-ref result 3))
+		  (text-l     (vector-ref result 4)))
+	     (if multiline?
+		 (let* ((sep (list #\newline (out-blanks (+ left 1))))
+			(formatted-text (out-separate text-l sep))
+			(text (list "#(" formatted-text ")")))
+		   (vector #t
+			   (+ (max width-max (+ width-last 1)) 2)
+			   (+ width-last 3)
+			   text))
+		 (let* ((sep (list " "))
+			(formatted-text (out-separate text-l sep))
+			(text (list "#(" formatted-text ")")))
+		   (vector #f (+ width-all 3) (+ width-all 3) text)))))
+	  (else
+	   (display "Internal error: out-pp")
+	   (newline)))))
+
+; Retourne la chaine a afficher
+(define out-pp
+  (lambda (obj col)
+    (let* ((list-rec-of-strings-n-chars
+	    (vector-ref (out-pp-aux obj col out-max-col) 3))
+	   (list-of-strings-n-chars
+	    (out-flatten-list list-rec-of-strings-n-chars))
+	   (list-of-strings
+	    (map out-force-string list-of-strings-n-chars)))
+      (apply string-append list-of-strings))))
+
+
+
+
+;
+; Nice-printer, plus rapide mais moins beau que le pretty-printer
+;
+
+(define out-np
+  (lambda (obj start)
+    (letrec ((line-pad
+	      (string-append (string #\newline)
+			     (out-blanks (- start 1))))
+	     (step-line
+	      (lambda (p)
+		(set-car! p line-pad)))
+	     (p-bool
+	      (lambda (obj col objw texts hole cont)
+		(let ((text (if obj "#t" "#f")))
+		  (cont (+ col 2) (+ objw 2) (cons text texts) hole))))
+	     (p-number
+	      (lambda (obj col objw texts hole cont)
+		(let* ((text (number->string obj))
+		       (len (string-length text)))
+		  (cont (+ col len) (+ objw len) (cons text texts) hole))))
+	     (p-symbol
+	      (lambda (obj col objw texts hole cont)
+		(let* ((text (symbol->string obj))
+		       (len (string-length text)))
+		  (cont (+ col len) (+ objw len) (cons text texts) hole))))
+	     (p-char
+	      (lambda (obj col objw texts hole cont)
+		(let* ((text
+			(cond ((char=? obj #\space) "#\\space")
+			      ((char=? obj #\newline) "#\\newline")
+			      (else (string-append "#\\" (string obj)))))
+		       (len (string-length text)))
+		  (cont (+ col len) (+ objw len) (cons text texts) hole))))
+	     (p-list
+	      (lambda (obj col objw texts hole cont)
+		(p-tail obj (+ col 1) (+ objw 1) (cons "(" texts) hole cont)))
+	     (p-vector
+	      (lambda (obj col objw texts hole cont)
+		(p-list (vector->list obj)
+			(+ col 1) (+ objw 1) (cons "#" texts) hole cont)))
+	     (p-tail
+	      (lambda (obj col objw texts hole cont)
+		(if (null? obj)
+		    (cont (+ col 1) (+ objw 1) (cons ")" texts) hole)
+		    (p-obj (car obj) col objw texts hole
+			   (make-cdr-cont obj cont)))))
+	     (make-cdr-cont
+	      (lambda (obj cont)
+		(lambda (col objw texts hole)
+		  (cond ((null? (cdr obj))
+			 (cont (+ col 1) (+ objw 1) (cons ")" texts) hole))
+			((> col out-max-col)
+			 (step-line hole)
+			 (let ((hole2 (cons " " texts)))
+			   (p-cdr obj (+ start objw 1) 0 hole2 hole2 cont)))
+			(else
+			 (let ((hole2 (cons " " texts)))
+			   (p-cdr obj (+ col 1) 0 hole2 hole2 cont)))))))
+	     (p-cdr
+	      (lambda (obj col objw texts hole cont)
+		(if (pair? (cdr obj))
+		    (p-tail (cdr obj) col objw texts hole cont)
+		    (p-dot col objw texts hole
+			   (make-cdr-cont (list #f (cdr obj)) cont)))))
+	     (p-dot
+	      (lambda (col objw texts hole cont)
+		(cont (+ col 1) (+ objw 1) (cons "." texts) hole)))
+	     (p-obj
+	      (lambda (obj col objw texts hole cont)
+		(cond ((boolean? obj)
+		       (p-bool obj col objw texts hole cont))
+		      ((number? obj)
+		       (p-number obj col objw texts hole cont))
+		      ((symbol? obj)
+		       (p-symbol obj col objw texts hole cont))
+		      ((char? obj)
+		       (p-char obj col objw texts hole cont))
+		      ((or (null? obj) (pair? obj))
+		       (p-list obj col objw texts hole cont))
+		      ((vector? obj)
+		       (p-vector obj col objw texts hole cont))))))
+      (p-obj obj start 0 '() (cons #f #f)
+	     (lambda (col objw texts hole)
+	       (if (> col out-max-col)
+		   (step-line hole))
+	       (apply string-append (reverse texts)))))))
+
+
+
+
+;
+; Fonction pour afficher une table
+; Appelle la sous-routine adequate pour le type de fin de table
+;
+
+; Affiche la table d'un driver
+(define out-print-table
+  (lambda (args-alist
+	   <<EOF>>-action <<ERROR>>-action rules
+	   nl-start no-nl-start arcs-v acc-v
+	   port)
+    (let* ((filein
+	    (cdr (assq 'filein args-alist)))
+	   (table-name
+	    (cdr (assq 'table-name args-alist)))
+	   (pretty?
+	    (assq 'pp args-alist))
+	   (counters-type
+	    (let ((a (assq 'counters args-alist)))
+	      (if a (cdr a) 'line)))
+	   (counters-param-list
+	    (cond ((eq? counters-type 'none)
+		   ")")
+		  ((eq? counters-type 'line)
+		   " yyline)")
+		  (else ; 'all
+		   " yyline yycolumn yyoffset)")))
+	   (counters-param-list-short
+	    (if (char=? (string-ref counters-param-list 0) #\space)
+		(substring counters-param-list
+			   1
+			   (string-length counters-param-list))
+		counters-param-list))
+	   (clean-eof-action
+	    (out-clean-action <<EOF>>-action))
+	   (clean-error-action
+	    (out-clean-action <<ERROR>>-action))
+	   (rule-op
+	    (lambda (rule) (out-clean-action (get-rule-action rule))))
+	   (rules-l
+	    (vector->list rules))
+	   (clean-actions-l
+	    (map rule-op rules-l))
+	   (yytext?-l
+	    (map get-rule-yytext? rules-l)))
+
+      ; Commentaires prealables
+      (display ";" port)
+      (newline port)
+      (display "; Table generated from the file " port)
+      (display filein port)
+      (display " by SILex 1.0" port)
+      (newline port)
+      (display ";" port)
+      (newline port)
+      (newline port)
+
+      ; Ecrire le debut de la table
+      (display "(define " port)
+      (display table-name port)
+      (newline port)
+      (display "  (vector" port)
+      (newline port)
+
+      ; Ecrire la description du type de compteurs
+      (display "   '" port)
+      (write counters-type port)
+      (newline port)
+
+      ; Ecrire l'action pour la fin de fichier
+      (display "   (lambda (yycontinue yygetc yyungetc)" port)
+      (newline port)
+      (display "     (lambda (yytext" port)
+      (display counters-param-list port)
+      (newline port)
+      (display clean-eof-action port)
+      (display "       ))" port)
+      (newline port)
+
+      ; Ecrire l'action pour le cas d'erreur
+      (display "   (lambda (yycontinue yygetc yyungetc)" port)
+      (newline port)
+      (display "     (lambda (yytext" port)
+      (display counters-param-list port)
+      (newline port)
+      (display clean-error-action port)
+      (display "       ))" port)
+      (newline port)
+
+      ; Ecrire le vecteur des actions des regles ordinaires
+      (display "   (vector" port)
+      (newline port)
+      (let loop ((al clean-actions-l) (yyl yytext?-l))
+	(if (pair? al)
+	    (let ((yytext? (car yyl)))
+	      (display "    " port)
+	      (write yytext? port)
+	      (newline port)
+	      (display "    (lambda (yycontinue yygetc yyungetc)" port)
+	      (newline port)
+	      (if yytext?
+		  (begin
+		    (display "      (lambda (yytext" port)
+		    (display counters-param-list port))
+		  (begin
+		    (display "      (lambda (" port)
+		    (display counters-param-list-short port)))
+	      (newline port)
+	      (display (car al) port)
+	      (display "        ))" port)
+	      (if (pair? (cdr al))
+		  (newline port))
+	      (loop (cdr al) (cdr yyl)))))
+      (display ")" port)
+      (newline port)
+
+      ; Ecrire l'automate
+      (cond ((assq 'portable args-alist)
+	     (out-print-table-chars
+	      pretty?
+	      nl-start no-nl-start arcs-v acc-v
+	      port))
+	    ((assq 'code args-alist)
+	     (out-print-table-code
+	      counters-type (vector-length rules) yytext?-l
+	      nl-start no-nl-start arcs-v acc-v
+	      port))
+	    (else
+	     (out-print-table-data
+	      pretty?
+	      nl-start no-nl-start arcs-v acc-v
+	      port))))))
+
+;
+; Affiche l'automate sous forme d'arbres de decision
+; Termine la table du meme coup
+;
+
+(define out-print-table-data
+  (lambda (pretty? nl-start no-nl-start arcs-v acc-v port)
+    (let* ((len (vector-length arcs-v))
+	   (trees-v (make-vector len)))
+      (let loop ((i 0))
+	(if (< i len)
+	    (begin
+	      (vector-set! trees-v i (prep-arcs->tree (vector-ref arcs-v i)))
+	      (loop (+ i 1)))))
+
+      ; Decrire le format de l'automate
+      (display "   'decision-trees" port)
+      (newline port)
+
+      ; Ecrire l'etat de depart pour le cas "debut de la ligne"
+      (display "   " port)
+      (write nl-start port)
+      (newline port)
+
+      ; Ecrire l'etat de depart pour le cas "pas au debut de la ligne"
+      (display "   " port)
+      (write no-nl-start port)
+      (newline port)
+
+      ; Ecrire la table de transitions
+      (display "   '" port)
+      (if pretty?
+	  (display (out-pp trees-v 5) port)
+	  (display (out-np trees-v 5) port))
+      (newline port)
+
+      ; Ecrire la table des acceptations
+      (display "   '" port)
+      (if pretty?
+	  (display (out-pp acc-v 5) port)
+	  (display (out-np acc-v 5) port))
+
+      ; Ecrire la fin de la table
+      (display "))" port)
+      (newline port))))
+
+;
+; Affiche l'automate sous forme de listes de caracteres taggees
+; Termine la table du meme coup
+;
+
+(define out-print-table-chars
+  (lambda (pretty? nl-start no-nl-start arcs-v acc-v port)
+    (let* ((len (vector-length arcs-v))
+	   (portable-v (make-vector len))
+	   (arc-op (lambda (arc)
+		     (cons (class->tagged-char-list (car arc)) (cdr arc)))))
+      (let loop ((s 0))
+	(if (< s len)
+	    (let* ((arcs (vector-ref arcs-v s))
+		   (port-arcs (map arc-op arcs)))
+	      (vector-set! portable-v s port-arcs)
+	      (loop (+ s 1)))))
+
+      ; Decrire le format de l'automate
+      (display "   'tagged-chars-lists" port)
+      (newline port)
+
+      ; Ecrire l'etat de depart pour le cas "debut de la ligne"
+      (display "   " port)
+      (write nl-start port)
+      (newline port)
+
+      ; Ecrire l'etat de depart pour le cas "pas au debut de la ligne"
+      (display "   " port)
+      (write no-nl-start port)
+      (newline port)
+
+      ; Ecrire la table de transitions
+      (display "   '" port)
+      (if pretty?
+	  (display (out-pp portable-v 5) port)
+	  (display (out-np portable-v 5) port))
+      (newline port)
+
+      ; Ecrire la table des acceptations
+      (display "   '" port)
+      (if pretty?
+	  (display (out-pp acc-v 5) port)
+	  (display (out-np acc-v 5) port))
+
+      ; Ecrire la fin de la table
+      (display "))" port)
+      (newline port))))
+
+;
+; Genere l'automate en code Scheme
+; Termine la table du meme coup
+;
+
+(define out-print-code-trans3
+  (lambda (margin tree action-var port)
+    (newline port)
+    (display (out-blanks margin) port)
+    (cond ((eq? tree 'err)
+	   (display action-var port))
+	  ((number? tree)
+	   (display "(state-" port)
+	   (display tree port)
+	   (display " " port)
+	   (display action-var port)
+	   (display ")" port))
+	  ((eq? (car tree) '=)
+	   (display "(if (= c " port)
+	   (display (list-ref tree 1) port)
+	   (display ")" port)
+	   (out-print-code-trans3 (+ margin 4)
+				  (list-ref tree 2)
+				  action-var
+				  port)
+	   (out-print-code-trans3 (+ margin 4)
+				  (list-ref tree 3)
+				  action-var
+				  port)
+	   (display ")" port))
+	  (else
+	   (display "(if (< c " port)
+	   (display (list-ref tree 0) port)
+	   (display ")" port)
+	   (out-print-code-trans3 (+ margin 4)
+				  (list-ref tree 1)
+				  action-var
+				  port)
+	   (out-print-code-trans3 (+ margin 4)
+				  (list-ref tree 2)
+				  action-var
+				  port)
+	   (display ")" port)))))
+
+(define out-print-code-trans2
+  (lambda (margin tree action-var port)
+    (newline port)
+    (display (out-blanks margin) port)
+    (display "(if c" port)
+    (out-print-code-trans3 (+ margin 4) tree action-var port)
+    (newline port)
+    (display (out-blanks (+ margin 4)) port)
+    (display action-var port)
+    (display ")" port)))
+
+(define out-print-code-trans1
+  (lambda (margin tree action-var port)
+    (newline port)
+    (display (out-blanks margin) port)
+    (if (eq? tree 'err)
+	(display action-var port)
+	(begin
+	  (display "(let ((c (read-char)))" port)
+	  (out-print-code-trans2 (+ margin 2) tree action-var port)
+	  (display ")" port)))))
+
+(define out-print-table-code
+  (lambda (counters nbrules yytext?-l
+	   nl-start no-nl-start arcs-v acc-v
+	   port)
+    (let* ((counters-params
+	    (cond ((eq? counters 'none) ")")
+		  ((eq? counters 'line) " yyline)")
+		  ((eq? counters 'all)  " yyline yycolumn yyoffset)")))
+	   (counters-params-short
+	    (cond ((eq? counters 'none) ")")
+		  ((eq? counters 'line) "yyline)")
+		  ((eq? counters 'all)  "yyline yycolumn yyoffset)")))
+	   (nbstates (vector-length arcs-v))
+	   (trees-v (make-vector nbstates)))
+      (let loop ((s 0))
+	(if (< s nbstates)
+	    (begin
+	      (vector-set! trees-v s (prep-arcs->tree (vector-ref arcs-v s)))
+	      (loop (+ s 1)))))
+
+      ; Decrire le format de l'automate
+      (display "   'code" port)
+      (newline port)
+
+      ; Ecrire l'entete de la fonction
+      (display "   (lambda (<<EOF>>-pre-action" port)
+      (newline port)
+      (display "            <<ERROR>>-pre-action" port)
+      (newline port)
+      (display "            rules-pre-action" port)
+      (newline port)
+      (display "            IS)" port)
+      (newline port)
+
+      ; Ecrire le debut du letrec et les variables d'actions brutes
+      (display "     (letrec" port)
+      (newline port)
+      (display "         ((user-action-<<EOF>> #f)" port)
+      (newline port)
+      (display "          (user-action-<<ERROR>> #f)" port)
+      (newline port)
+      (let loop ((i 0))
+	(if (< i nbrules)
+	    (begin
+	      (display "          (user-action-" port)
+	      (write i port)
+	      (display " #f)" port)
+	      (newline port)
+	      (loop (+ i 1)))))
+
+      ; Ecrire l'extraction des fonctions du IS
+      (display "          (start-go-to-end    " port)
+      (display "(cdr (assq 'start-go-to-end IS)))" port)
+      (newline port)
+      (display "          (end-go-to-point    " port)
+      (display "(cdr (assq 'end-go-to-point IS)))" port)
+      (newline port)
+      (display "          (init-lexeme        " port)
+      (display "(cdr (assq 'init-lexeme IS)))" port)
+      (newline port)
+      (display "          (get-start-line     " port)
+      (display "(cdr (assq 'get-start-line IS)))" port)
+      (newline port)
+      (display "          (get-start-column   " port)
+      (display "(cdr (assq 'get-start-column IS)))" port)
+      (newline port)
+      (display "          (get-start-offset   " port)
+      (display "(cdr (assq 'get-start-offset IS)))" port)
+      (newline port)
+      (display "          (peek-left-context  " port)
+      (display "(cdr (assq 'peek-left-context IS)))" port)
+      (newline port)
+      (display "          (peek-char          " port)
+      (display "(cdr (assq 'peek-char IS)))" port)
+      (newline port)
+      (display "          (read-char          " port)
+      (display "(cdr (assq 'read-char IS)))" port)
+      (newline port)
+      (display "          (get-start-end-text " port)
+      (display "(cdr (assq 'get-start-end-text IS)))" port)
+      (newline port)
+      (display "          (user-getc          " port)
+      (display "(cdr (assq 'user-getc IS)))" port)
+      (newline port)
+      (display "          (user-ungetc        " port)
+      (display "(cdr (assq 'user-ungetc IS)))" port)
+      (newline port)
+
+      ; Ecrire les variables d'actions
+      (display "          (action-<<EOF>>" port)
+      (newline port)
+      (display "           (lambda (" port)
+      (display counters-params-short port)
+      (newline port)
+      (display "             (user-action-<<EOF>> \"\"" port)
+      (display counters-params port)
+      (display "))" port)
+      (newline port)
+      (display "          (action-<<ERROR>>" port)
+      (newline port)
+      (display "           (lambda (" port)
+      (display counters-params-short port)
+      (newline port)
+      (display "             (user-action-<<ERROR>> \"\"" port)
+      (display counters-params port)
+      (display "))" port)
+      (newline port)
+      (let loop ((i 0) (yyl yytext?-l))
+	(if (< i nbrules)
+	    (begin
+	      (display "          (action-" port)
+	      (display i port)
+	      (newline port)
+	      (display "           (lambda (" port)
+	      (display counters-params-short port)
+	      (newline port)
+	      (if (car yyl)
+		  (begin
+		    (display "             (let ((yytext" port)
+		    (display " (get-start-end-text)))" port)
+		    (newline port)
+		    (display "               (start-go-to-end)" port)
+		    (newline port)
+		    (display "               (user-action-" port)
+		    (display i port)
+		    (display " yytext" port)
+		    (display counters-params port)
+		    (display ")))" port)
+		    (newline port))
+		  (begin
+		    (display "             (start-go-to-end)" port)
+		    (newline port)
+		    (display "             (user-action-" port)
+		    (display i port)
+		    (display counters-params port)
+		    (display "))" port)
+		    (newline port)))
+	      (loop (+ i 1) (cdr yyl)))))
+
+      ; Ecrire les variables d'etats
+      (let loop ((s 0))
+	(if (< s nbstates)
+	    (let* ((tree (vector-ref trees-v s))
+		   (acc (vector-ref acc-v s))
+		   (acc-eol (car acc))
+		   (acc-no-eol (cdr acc)))
+	      (display "          (state-" port)
+	      (display s port)
+	      (newline port)
+	      (display "           (lambda (action)" port)
+	      (cond ((not acc-eol)
+		     (out-print-code-trans1 13 tree "action" port))
+		    ((not acc-no-eol)
+		     (newline port)
+		     (if (eq? tree 'err)
+			 (display "             (let* ((c (peek-char))" port)
+			 (display "             (let* ((c (read-char))" port))
+		     (newline port)
+		     (display "                    (new-action (if (o" port)
+		     (display "r (not c) (= c lexer-integer-newline))" port)
+		     (newline port)
+		     (display "                                  " port)
+		     (display "  (begin (end-go-to-point) action-" port)
+		     (display acc-eol port)
+		     (display ")" port)
+		     (newline port)
+		     (display "                       " port)
+		     (display "             action)))" port)
+		     (if (eq? tree 'err)
+			 (out-print-code-trans1 15 tree "new-action" port)
+			 (out-print-code-trans2 15 tree "new-action" port))
+		     (display ")" port))
+		    ((< acc-eol acc-no-eol)
+		     (newline port)
+		     (display "             (end-go-to-point)" port)
+		     (newline port)
+		     (if (eq? tree 'err)
+			 (display "             (let* ((c (peek-char))" port)
+			 (display "             (let* ((c (read-char))" port))
+		     (newline port)
+		     (display "                    (new-action (if (o" port)
+		     (display "r (not c) (= c lexer-integer-newline))" port)
+		     (newline port)
+		     (display "                      " port)
+		     (display "              action-" port)
+		     (display acc-eol port)
+		     (newline port)
+		     (display "                      " port)
+		     (display "              action-" port)
+		     (display acc-no-eol port)
+		     (display ")))" port)
+		     (if (eq? tree 'err)
+			 (out-print-code-trans1 15 tree "new-action" port)
+			 (out-print-code-trans2 15 tree "new-action" port))
+		     (display ")" port))
+		    (else
+		     (let ((action-var
+			    (string-append "action-"
+					   (number->string acc-eol))))
+		       (newline port)
+		       (display "             (end-go-to-point)" port)
+		       (out-print-code-trans1 13 tree action-var port))))
+	      (display "))" port)
+	      (newline port)
+	      (loop (+ s 1)))))
+
+      ; Ecrire la variable de lancement de l'automate
+      (display "          (start-automaton" port)
+      (newline port)
+      (display "           (lambda ()" port)
+      (newline port)
+      (if (= nl-start no-nl-start)
+	  (begin
+	    (display "             (if (peek-char)" port)
+	    (newline port)
+	    (display "                 (state-" port)
+	    (display nl-start port)
+	    (display " action-<<ERROR>>)" port)
+	    (newline port)
+	    (display "                 action-<<EOF>>)" port))
+	  (begin
+	    (display "             (cond ((not (peek-char))" port)
+	    (newline port)
+	    (display "                    action-<<EOF>>)" port)
+	    (newline port)
+	    (display "                   ((= (peek-left-context)" port)
+	    (display " lexer-integer-newline)" port)
+	    (newline port)
+	    (display "                    (state-" port)
+	    (display nl-start port)
+	    (display " action-<<ERROR>>))" port)
+	    (newline port)
+	    (display "                   (else" port)
+	    (newline port)
+	    (display "                    (state-" port)
+	    (display no-nl-start port)
+	    (display " action-<<ERROR>>)))" port)))
+      (display "))" port)
+      (newline port)
+
+      ; Ecrire la fonction principale de lexage
+      (display "          (final-lexer" port)
+      (newline port)
+      (display "           (lambda ()" port)
+      (newline port)
+      (display "             (init-lexeme)" port)
+      (newline port)
+      (cond ((eq? counters 'none)
+	     (display "             ((start-automaton))" port))
+	    ((eq? counters 'line)
+	     (display "             (let ((yyline (get-start-line)))" port)
+	     (newline port)
+	     (display "               ((start-automaton) yyline))" port))
+	    ((eq? counters 'all)
+	     (display "             (let ((yyline (get-start-line))" port)
+	     (newline port)
+	     (display "                   (yycolumn (get-start-column))" port)
+	     (newline port)
+	     (display "                   (yyoffset (get-start-offset)))" port)
+	     (newline port)
+	     (display "               ((start-automat" port)
+	     (display "on) yyline yycolumn yyoffset))" port)))
+      (display "))" port)
+
+      ; Fermer les bindings du grand letrec
+      (display ")" port)
+      (newline port)
+
+      ; Initialiser les variables user-action-XX
+      (display "       (set! user-action-<<EOF>>" port)
+      (display " (<<EOF>>-pre-action" port)
+      (newline port)
+      (display "                                  final-lexer" port)
+      (display " user-getc user-ungetc))" port)
+      (newline port)
+      (display "       (set! user-action-<<ERROR>>" port)
+      (display " (<<ERROR>>-pre-action" port)
+      (newline port)
+      (display "                                    final-lexer" port)
+      (display " user-getc user-ungetc))" port)
+      (newline port)
+      (let loop ((r 0))
+	(if (< r nbrules)
+	    (let* ((str-r (number->string r))
+		   (blanks (out-blanks (string-length str-r))))
+	      (display "       (set! user-action-" port)
+	      (display str-r port)
+	      (display " ((vector-ref rules-pre-action " port)
+	      (display (number->string (+ (* 2 r) 1)) port)
+	      (display ")" port)
+	      (newline port)
+	      (display blanks port)
+	      (display "                           final-lexer " port)
+	      (display "user-getc user-ungetc))" port)
+	      (newline port)
+	      (loop (+ r 1)))))
+
+      ; Faire retourner le lexer final et fermer la table au complet
+      (display "       final-lexer))))" port)
+      (newline port))))
+
+;
+; Fonctions necessaires a l'initialisation automatique du lexer
+;
+
+(define out-print-driver-functions
+  (lambda (args-alist port)
+    (let ((counters   (cdr (or (assq 'counters args-alist) '(z . line))))
+	  (table-name (cdr (assq 'table-name args-alist))))
+      (display ";" port)
+      (newline port)
+      (display "; User functions" port)
+      (newline port)
+      (display ";" port)
+      (newline port)
+      (newline port)
+      (display "(define lexer #f)" port)
+      (newline port)
+      (newline port)
+      (if (not (eq? counters 'none))
+	  (begin
+	    (display "(define lexer-get-line   #f)" port)
+	    (newline port)
+	    (if (eq? counters 'all)
+		(begin
+		  (display "(define lexer-get-column #f)" port)
+		  (newline port)
+		  (display "(define lexer-get-offset #f)" port)
+		  (newline port)))))
+      (display "(define lexer-getc       #f)" port)
+      (newline port)
+      (display "(define lexer-ungetc     #f)" port)
+      (newline port)
+      (newline port)
+      (display "(define lexer-init" port)
+      (newline port)
+      (display "  (lambda (input-type input)" port)
+      (newline port)
+      (display "    (let ((IS (lexer-make-IS input-type input '" port)
+      (write counters port)
+      (display ")))" port)
+      (newline port)
+      (display "      (set! lexer (lexer-make-lexer " port)
+      (display table-name port)
+      (display " IS))" port)
+      (newline port)
+      (if (not (eq? counters 'none))
+	  (begin
+	    (display "      (set! lexer-get-line   (lexer-get-func-line IS))"
+		     port)
+	    (newline port)
+	    (if (eq? counters 'all)
+		(begin
+		  (display
+		   "      (set! lexer-get-column (lexer-get-func-column IS))"
+		   port)
+		  (newline port)
+		  (display
+		   "      (set! lexer-get-offset (lexer-get-func-offset IS))"
+		   port)
+		  (newline port)))))
+      (display "      (set! lexer-getc       (lexer-get-func-getc IS))" port)
+      (newline port)
+      (display "      (set! lexer-ungetc     (lexer-get-func-ungetc IS)))))"
+	       port)
+      (newline port))))
+
+;
+; Fonction principale
+; Affiche une table ou un driver complet
+;
+
+(define output
+  (lambda (args-alist
+	   <<EOF>>-action <<ERROR>>-action rules
+	   nl-start no-nl-start arcs acc)
+    (let* ((fileout          (cdr (assq 'fileout args-alist)))
+	   (port             (open-output-file fileout))
+	   (complete-driver? (cdr (assq 'complete-driver? args-alist))))
+      (if complete-driver?
+	  (begin
+	    (out-print-run-time-lib port)
+	    (newline port)))
+      (out-print-table args-alist
+		       <<EOF>>-action <<ERROR>>-action rules
+		       nl-start no-nl-start arcs acc
+		       port)
+      (if complete-driver?
+	  (begin
+	    (newline port)
+	    (out-print-driver-functions args-alist port)))
+      (close-output-port port))))
+
+; Module output2.scm.
+
+;
+; Fonction de copiage du fichier run-time
+;
+
+(define out-print-run-time-lib
+  (lambda (port)
+    (display "; *** This file start" port)
+    (display "s with a copy of the " port)
+    (display "file multilex.scm ***" port)
+    (newline port)
+    (display "; SILex - Scheme Implementation of Lex
+; Copyright (C) 2001  Danny Dube'
+; 
+; This program 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
+; of the License, or (at your option) any later version.
+; 
+; This program 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 this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+
+;
+; Gestion des Input Systems
+; Fonctions a utiliser par l'usager:
+;   lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc,
+;   lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
+;
+
+; Taille initiale par defaut du buffer d'entree
+(define lexer-init-buffer-len 1024)
+
+; Numero du caractere newline
+(define lexer-integer-newline (char->integer #\\newline))
+
+; Constructeur d'IS brut
+(define lexer-raw-IS-maker
+  (lambda (buffer read-ptr input-f counters)
+    (let ((input-f          input-f)                ; Entree reelle
+	  (buffer           buffer)                 ; Buffer
+	  (buflen           (string-length buffer))
+	  (read-ptr         read-ptr)
+	  (start-ptr        1)                      ; Marque de debut de lexeme
+	  (start-line       1)
+	  (start-column     1)
+	  (start-offset     0)
+	  (end-ptr          1)                      ; Marque de fin de lexeme
+	  (point-ptr        1)                      ; Le point
+	  (user-ptr         1)                      ; Marque de l'usager
+	  (user-line        1)
+	  (user-column      1)
+	  (user-offset      0)
+	  (user-up-to-date? #t))                    ; Concerne la colonne seul.
+      (letrec
+	  ((start-go-to-end-none         ; Fonctions de depl. des marques
+	    (lambda ()
+	      (set! start-ptr end-ptr)))
+	   (start-go-to-end-line
+	    (lambda ()
+	      (let loop ((ptr start-ptr) (line start-line))
+		(if (= ptr end-ptr)
+		    (begin
+		      (set! start-ptr ptr)
+		      (set! start-line line))
+		    (if (char=? (string-ref buffer ptr) #\\newline)
+			(loop (+ ptr 1) (+ line 1))
+			(loop (+ ptr 1) line))))))
+	   (start-go-to-end-all
+	    (lambda ()
+	      (set! start-offset (+ start-offset (- end-ptr start-ptr)))
+	      (let loop ((ptr start-ptr)
+			 (line start-line)
+			 (column start-column))
+		(if (= ptr end-ptr)
+		    (begin
+		      (set! start-ptr ptr)
+		      (set! start-line line)
+		      (set! start-column column))
+		    (if (char=? (string-ref buffer ptr) #\\newline)
+			(loop (+ ptr 1) (+ line 1) 1)
+			(loop (+ ptr 1) line (+ column 1)))))))
+	   (start-go-to-user-none
+	    (lambda ()
+	      (set! start-ptr user-ptr)))
+	   (start-go-to-user-line
+	    (lambda ()
+	      (set! start-ptr user-ptr)
+	      (set! start-line user-line)))
+	   (start-go-to-user-all
+	    (lambda ()
+	      (set! start-line user-line)
+	      (set! start-offset user-offset)
+	      (if user-up-to-date?
+		  (begin
+		    (set! start-ptr user-ptr)
+		    (set! start-column user-column))
+		  (let loop ((ptr start-ptr) (column start-column))
+		    (if (= ptr user-ptr)
+			(begin
+			  (set! start-ptr ptr)
+			  (set! start-column column))
+			(if (char=? (string-ref buffer ptr) #\\newline)
+			    (loop (+ ptr 1) 1)
+			    (loop (+ ptr 1) (+ column 1))))))))
+	   (end-go-to-point
+	    (lambda ()
+	      (set! end-ptr point-ptr)))
+	   (point-go-to-start
+	    (lambda ()
+	      (set! point-ptr start-ptr)))
+	   (user-go-to-start-none
+	    (lambda ()
+	      (set! user-ptr start-ptr)))
+	   (user-go-to-start-line
+	    (lambda ()
+	      (set! user-ptr start-ptr)
+	      (set! user-line start-line)))
+	   (user-go-to-start-all
+	    (lambda ()
+	      (set! user-ptr start-ptr)
+	      (set! user-line start-line)
+	      (set! user-column start-column)
+	      (set! user-offset start-offset)
+	      (set! user-up-to-date? #t)))
+	   (init-lexeme-none             ; Debute un nouveau lexeme
+	    (lambda ()
+	      (if (< start-ptr user-ptr)
+		  (start-go-to-user-none))
+	      (point-go-to-start)))
+	   (init-lexeme-line
+	    (lambda ()
+	      (if (< start-ptr user-ptr)
+		  (start-go-to-user-line))
+	      (point-go-to-start)))
+	   (init-lexeme-all
+	    (lambda ()
+	      (if (< start-ptr user-ptr)
+		  (start-go-to-user-all))
+	      (point-go-to-start)))
+	   (get-start-line               ; Obtention des stats du debut du lxm
+	    (lambda ()
+	      start-line))
+	   (get-start-column
+	    (lambda ()
+	      start-column))
+	   (get-start-offset
+	    (lambda ()
+	      start-offset))
+	   (peek-left-context            ; Obtention de caracteres (#f si EOF)
+	    (lambda ()
+	      (char->integer (string-ref buffer (- start-ptr 1)))))
+	   (peek-char
+	    (lambda ()
+	      (if (< point-ptr read-ptr)
+		  (char->integer (string-ref buffer point-ptr))
+		  (let ((c (input-f)))
+		    (if (char? c)
+			(begin
+			  (if (= read-ptr buflen)
+			      (reorganize-buffer))
+			  (string-set! buffer point-ptr c)
+			  (set! read-ptr (+ point-ptr 1))
+			  (char->integer c))
+			(begin
+			  (set! input-f (lambda () 'eof))
+			  #f))))))
+	   (read-char
+	    (lambda ()
+	      (if (< point-ptr read-ptr)
+		  (let ((c (string-ref buffer point-ptr)))
+		    (set! point-ptr (+ point-ptr 1))
+		    (char->integer c))
+		  (let ((c (input-f)))
+		    (if (char? c)
+			(begin
+			  (if (= read-ptr buflen)
+			      (reorganize-buffer))
+			  (string-set! buffer point-ptr c)
+			  (set! read-ptr (+ point-ptr 1))
+			  (set! point-ptr read-ptr)
+			  (char->integer c))
+			(begin
+			  (set! input-f (lambda () 'eof))
+			  #f))))))
+	   (get-start-end-text           ; Obtention du lexeme
+	    (lambda ()
+	      (substring buffer start-ptr end-ptr)))
+	   (get-user-line-line           ; Fonctions pour l'usager
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-line))
+	      user-line))
+	   (get-user-line-all
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-all))
+	      user-line))
+	   (get-user-column-all
+	    (lambda ()
+	      (cond ((< user-ptr start-ptr)
+		     (user-go-to-start-all)
+		     user-column)
+		    (user-up-to-date?
+		     user-column)
+		    (else
+		     (let loop ((ptr start-ptr) (column start-column))
+		       (if (= ptr user-ptr)
+			   (begin
+			     (set! user-column column)
+			     (set! user-up-to-date? #t)
+			     column)
+			   (if (char=? (string-ref buffer ptr) #\\newline)
+			       (loop (+ ptr 1) 1)
+			       (loop (+ ptr 1) (+ column 1)))))))))
+	   (get-user-offset-all
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-all))
+	      user-offset))
+	   (user-getc-none
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-none))
+	      (if (< user-ptr read-ptr)
+		  (let ((c (string-ref buffer user-ptr)))
+		    (set! user-ptr (+ user-ptr 1))
+		    c)
+		  (let ((c (input-f)))
+		    (if (char? c)
+			(begin
+			  (if (= read-ptr buflen)
+			      (reorganize-buffer))
+			  (string-set! buffer user-ptr c)
+			  (set! read-ptr (+ read-ptr 1))
+			  (set! user-ptr read-ptr)
+			  c)
+			(begin
+			  (set! input-f (lambda () 'eof))
+			  'eof))))))
+	   (user-getc-line
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-line))
+	      (if (< user-ptr read-ptr)
+		  (let ((c (string-ref buffer user-ptr)))
+		    (set! user-ptr (+ user-ptr 1))
+		    (if (char=? c #\\newline)
+			(set! user-line (+ user-line 1)))
+		    c)
+		  (let ((c (input-f)))
+		    (if (char? c)
+			(begin
+			  (if (= read-ptr buflen)
+			      (reorganize-buffer))
+			  (string-set! buffer user-ptr c)
+			  (set! read-ptr (+ read-ptr 1))
+			  (set! user-ptr read-ptr)
+			  (if (char=? c #\\newline)
+			      (set! user-line (+ user-line 1)))
+			  c)
+			(begin
+			  (set! input-f (lambda () 'eof))
+			  'eof))))))
+	   (user-getc-all
+	    (lambda ()
+	      (if (< user-ptr start-ptr)
+		  (user-go-to-start-all))
+	      (if (< user-ptr read-ptr)
+		  (let ((c (string-ref buffer user-ptr)))
+		    (set! user-ptr (+ user-ptr 1))
+		    (if (char=? c #\\newline)
+			(begin
+			  (set! user-line (+ user-line 1))
+			  (set! user-column 1))
+			(set! user-column (+ user-column 1)))
+		    (set! user-offset (+ user-offset 1))
+		    c)
+		  (let ((c (input-f)))
+		    (if (char? c)
+			(begin
+			  (if (= read-ptr buflen)
+			      (reorganize-buffer))
+			  (string-set! buffer user-ptr c)
+			  (set! read-ptr (+ read-ptr 1))
+			  (set! user-ptr read-ptr)
+			  (if (char=? c #\\newline)
+			      (begin
+				(set! user-line (+ user-line 1))
+				(set! user-column 1))
+			      (set! user-column (+ user-column 1)))
+			  (set! user-offset (+ user-offset 1))
+			  c)
+			(begin
+			  (set! input-f (lambda () 'eof))
+			  'eof))))))
+	   (user-ungetc-none
+	    (lambda ()
+	      (if (> user-ptr start-ptr)
+		  (set! user-ptr (- user-ptr 1)))))
+	   (user-ungetc-line
+	    (lambda ()
+	      (if (> user-ptr start-ptr)
+		  (begin
+		    (set! user-ptr (- user-ptr 1))
+		    (let ((c (string-ref buffer user-ptr)))
+		      (if (char=? c #\\newline)
+			  (set! user-line (- user-line 1))))))))
+	   (user-ungetc-all
+	    (lambda ()
+	      (if (> user-ptr start-ptr)
+		  (begin
+		    (set! user-ptr (- user-ptr 1))
+		    (let ((c (string-ref buffer user-ptr)))
+		      (if (char=? c #\\newline)
+			  (begin
+			    (set! user-line (- user-line 1))
+			    (set! user-up-to-date? #f))
+			  (set! user-column (- user-column 1)))
+		      (set! user-offset (- user-offset 1)))))))
+	   (reorganize-buffer            ; Decaler ou agrandir le buffer
+	    (lambda ()
+	      (if (< (* 2 start-ptr) buflen)
+		  (let* ((newlen (* 2 buflen))
+			 (newbuf (make-string newlen))
+			 (delta (- start-ptr 1)))
+		    (let loop ((from (- start-ptr 1)))
+		      (if (< from buflen)
+			  (begin
+			    (string-set! newbuf
+					 (- from delta)
+					 (string-ref buffer from))
+			    (loop (+ from 1)))))
+		    (set! buffer    newbuf)
+		    (set! buflen    newlen)
+		    (set! read-ptr  (- read-ptr delta))
+		    (set! start-ptr (- start-ptr delta))
+		    (set! end-ptr   (- end-ptr delta))
+		    (set! point-ptr (- point-ptr delta))
+		    (set! user-ptr  (- user-ptr delta)))
+		  (let ((delta (- start-ptr 1)))
+		    (let loop ((from (- start-ptr 1)))
+		      (if (< from buflen)
+			  (begin
+			    (string-set! buffer
+					 (- from delta)
+					 (string-ref buffer from))
+			    (loop (+ from 1)))))
+		    (set! read-ptr  (- read-ptr delta))
+		    (set! start-ptr (- start-ptr delta))
+		    (set! end-ptr   (- end-ptr delta))
+		    (set! point-ptr (- point-ptr delta))
+		    (set! user-ptr  (- user-ptr delta)))))))
+	(list (cons 'start-go-to-end
+		    (cond ((eq? counters 'none) start-go-to-end-none)
+			  ((eq? counters 'line) start-go-to-end-line)
+			  ((eq? counters 'all ) start-go-to-end-all)))
+	      (cons 'end-go-to-point
+		    end-go-to-point)
+	      (cons 'init-lexeme
+		    (cond ((eq? counters 'none) init-lexeme-none)
+			  ((eq? counters 'line) init-lexeme-line)
+			  ((eq? counters 'all ) init-lexeme-all)))
+	      (cons 'get-start-line
+		    get-start-line)
+	      (cons 'get-start-column
+		    get-start-column)
+	      (cons 'get-start-offset
+		    get-start-offset)
+	      (cons 'peek-left-context
+		    peek-left-context)
+	      (cons 'peek-char
+		    peek-char)
+	      (cons 'read-char
+		    read-char)
+	      (cons 'get-start-end-text
+		    get-start-end-text)
+	      (cons 'get-user-line
+		    (cond ((eq? counters 'none) #f)
+			  ((eq? counters 'line) get-user-line-line)
+			  ((eq? counters 'all ) get-user-line-all)))
+	      (cons 'get-user-column
+		    (cond ((eq? counters 'none) #f)
+			  ((eq? counters 'line) #f)
+			  ((eq? counters 'all ) get-user-column-all)))
+	      (cons 'get-user-offset
+		    (cond ((eq? counters 'none) #f)
+			  ((eq? counters 'line) #f)
+			  ((eq? counters 'all ) get-user-offset-all)))
+	      (cons 'user-getc
+		    (cond ((eq? counters 'none) user-getc-none)
+			  ((eq? counters 'line) user-getc-line)
+			  ((eq? counters 'all ) user-getc-all)))
+	      (cons 'user-ungetc
+		    (cond ((eq? counters 'none) user-ungetc-none)
+			  ((eq? counters 'line) user-ungetc-line)
+			  ((eq? counters 'all ) user-ungetc-all))))))))
+
+; Construit un Input System
+; Le premier parametre doit etre parmi \"port\", \"procedure\" ou \"string\"
+; Prend un parametre facultatif qui doit etre parmi
+; \"none\", \"line\" ou \"all\"
+(define lexer-make-IS
+  (lambda (input-type input . largs)
+    (let ((counters-type (cond ((null? largs)
+				'line)
+			       ((memq (car largs) '(none line all))
+				(car largs))
+			       (else
+				'line))))
+      (cond ((and (eq? input-type 'port) (input-port? input))
+	     (let* ((buffer   (make-string lexer-init-buffer-len #\\newline))
+		    (read-ptr 1)
+		    (input-f  (lambda () (read-char input))))
+	       (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+	    ((and (eq? input-type 'procedure) (procedure? input))
+	     (let* ((buffer   (make-string lexer-init-buffer-len #\\newline))
+		    (read-ptr 1)
+		    (input-f  input))
+	       (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+	    ((and (eq? input-type 'string) (string? input))
+	     (let* ((buffer   (string-append (string #\\newline) input))
+		    (read-ptr (string-length buffer))
+		    (input-f  (lambda () 'eof)))
+	       (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+	    (else
+	     (let* ((buffer   (string #\\newline))
+		    (read-ptr 1)
+		    (input-f  (lambda () 'eof)))
+	       (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))))))
+
+; Les fonctions:
+;   lexer-get-func-getc, lexer-get-func-ungetc,
+;   lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
+(define lexer-get-func-getc
+  (lambda (IS) (cdr (assq 'user-getc IS))))
+(define lexer-get-func-ungetc
+  (lambda (IS) (cdr (assq 'user-ungetc IS))))
+(define lexer-get-func-line
+  (lambda (IS) (cdr (assq 'get-user-line IS))))
+(define lexer-get-func-column
+  (lambda (IS) (cdr (assq 'get-user-column IS))))
+(define lexer-get-func-offset
+  (lambda (IS) (cdr (assq 'get-user-offset IS))))
+
+;
+; Gestion des lexers
+;
+
+; Fabrication de lexer a partir d'arbres de decision
+(define lexer-make-tree-lexer
+  (lambda (tables IS)
+    (letrec
+	(; Contenu de la table
+	 (counters-type        (vector-ref tables 0))
+	 (<<EOF>>-pre-action   (vector-ref tables 1))
+	 (<<ERROR>>-pre-action (vector-ref tables 2))
+	 (rules-pre-actions    (vector-ref tables 3))
+	 (table-nl-start       (vector-ref tables 5))
+	 (table-no-nl-start    (vector-ref tables 6))
+	 (trees-v              (vector-ref tables 7))
+	 (acc-v                (vector-ref tables 8))
+
+	 ; Contenu du IS
+	 (IS-start-go-to-end    (cdr (assq 'start-go-to-end IS)))
+	 (IS-end-go-to-point    (cdr (assq 'end-go-to-point IS)))
+	 (IS-init-lexeme        (cdr (assq 'init-lexeme IS)))
+	 (IS-get-start-line     (cdr (assq 'get-start-line IS)))
+	 (IS-get-start-column   (cdr (assq 'get-start-column IS)))
+	 (IS-get-start-offset   (cdr (assq 'get-start-offset IS)))
+	 (IS-peek-left-context  (cdr (assq 'peek-left-context IS)))
+	 (IS-peek-char          (cdr (assq 'peek-char IS)))
+	 (IS-read-char          (cdr (assq 'read-char IS)))
+	 (IS-get-start-end-text (cdr (assq 'get-start-end-text IS)))
+	 (IS-get-user-line      (cdr (assq 'get-user-line IS)))
+	 (IS-get-user-column    (cdr (assq 'get-user-column IS)))
+	 (IS-get-user-offset    (cdr (assq 'get-user-offset IS)))
+	 (IS-user-getc          (cdr (assq 'user-getc IS)))
+	 (IS-user-ungetc        (cdr (assq 'user-ungetc IS)))
+
+	 ; Resultats
+	 (<<EOF>>-action   #f)
+	 (<<ERROR>>-action #f)
+	 (rules-actions    #f)
+	 (states           #f)
+	 (final-lexer      #f)
+
+	 ; Gestion des hooks
+	 (hook-list '())
+	 (add-hook
+	  (lambda (thunk)
+	    (set! hook-list (cons thunk hook-list))))
+	 (apply-hooks
+	  (lambda ()
+	    (let loop ((l hook-list))
+	      (if (pair? l)
+		  (begin
+		    ((car l))
+		    (loop (cdr l)))))))
+
+	 ; Preparation des actions
+	 (set-action-statics
+	  (lambda (pre-action)
+	    (pre-action final-lexer IS-user-getc IS-user-ungetc)))
+	 (prepare-special-action-none
+	  (lambda (pre-action)
+	    (let ((action #f))
+	      (let ((result
+		     (lambda ()
+		       (action \"\")))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-special-action-line
+	  (lambda (pre-action)
+	    (let ((action #f))
+	      (let ((result
+		     (lambda (yyline)
+		       (action \"\" yyline)))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-special-action-all
+	  (lambda (pre-action)
+	    (let ((action #f))
+	      (let ((result
+		     (lambda (yyline yycolumn yyoffset)
+		       (action \"\" yyline yycolumn yyoffset)))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-special-action
+	  (lambda (pre-action)
+	    (cond ((eq? counters-type 'none)
+		   (prepare-special-action-none pre-action))
+		  ((eq? counters-type 'line)
+		   (prepare-special-action-line pre-action))
+		  ((eq? counters-type 'all)
+		   (prepare-special-action-all  pre-action)))))
+	 (prepare-action-yytext-none
+	  (lambda (pre-action)
+	    (let ((get-start-end-text IS-get-start-end-text)
+		  (start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda ()
+		       (let ((yytext (get-start-end-text)))
+			 (start-go-to-end)
+			 (action yytext))))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-yytext-line
+	  (lambda (pre-action)
+	    (let ((get-start-end-text IS-get-start-end-text)
+		  (start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda (yyline)
+		       (let ((yytext (get-start-end-text)))
+			 (start-go-to-end)
+			 (action yytext yyline))))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-yytext-all
+	  (lambda (pre-action)
+	    (let ((get-start-end-text IS-get-start-end-text)
+		  (start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda (yyline yycolumn yyoffset)
+		       (let ((yytext (get-start-end-text)))
+			 (start-go-to-end)
+			 (action yytext yyline yycolumn yyoffset))))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-yytext
+	  (lambda (pre-action)
+	    (cond ((eq? counters-type 'none)
+		   (prepare-action-yytext-none pre-action))
+		  ((eq? counters-type 'line)
+		   (prepare-action-yytext-line pre-action))
+		  ((eq? counters-type 'all)
+		   (prepare-action-yytext-all  pre-action)))))
+	 (prepare-action-no-yytext-none
+	  (lambda (pre-action)
+	    (let ((start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda ()
+		       (start-go-to-end)
+		       (action)))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-no-yytext-line
+	  (lambda (pre-action)
+	    (let ((start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda (yyline)
+		       (start-go-to-end)
+		       (action yyline)))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-no-yytext-all
+	  (lambda (pre-action)
+	    (let ((start-go-to-end    IS-start-go-to-end)
+		  (action             #f))
+	      (let ((result
+		     (lambda (yyline yycolumn yyoffset)
+		       (start-go-to-end)
+		       (action yyline yycolumn yyoffset)))
+		    (hook
+		     (lambda ()
+		       (set! action (set-action-statics pre-action)))))
+		(add-hook hook)
+		result))))
+	 (prepare-action-no-yytext
+	  (lambda (pre-action)
+	    (cond ((eq? counters-type 'none)
+		   (prepare-action-no-yytext-none pre-action))
+		  ((eq? counters-type 'line)
+		   (prepare-action-no-yytext-line pre-action))
+		  ((eq? counters-type 'all)
+		   (prepare-action-no-yytext-all  pre-action)))))
+
+	 ; Fabrique les fonctions de dispatch
+	 (prepare-dispatch-err
+	  (lambda (leaf)
+	    (lambda (c)
+	      #f)))
+	 (prepare-dispatch-number
+	  (lambda (leaf)
+	    (let ((state-function #f))
+	      (let ((result
+		     (lambda (c)
+		       state-function))
+		    (hook
+		     (lambda ()
+		       (set! state-function (vector-ref states leaf)))))
+		(add-hook hook)
+		result))))
+	 (prepare-dispatch-leaf
+	  (lambda (leaf)
+	    (if (eq? leaf 'err)
+		(prepare-dispatch-err leaf)
+		(prepare-dispatch-number leaf))))
+	 (prepare-dispatch-<
+	  (lambda (tree)
+	    (let ((left-tree  (list-ref tree 1))
+		  (right-tree (list-ref tree 2)))
+	      (let ((bound      (list-ref tree 0))
+		    (left-func  (prepare-dispatch-tree left-tree))
+		    (right-func (prepare-dispatch-tree right-tree)))
+		(lambda (c)
+		  (if (< c bound)
+		      (left-func c)
+		      (right-func c)))))))
+	 (prepare-dispatch-=
+	  (lambda (tree)
+	    (let ((left-tree  (list-ref tree 2))
+		  (right-tree (list-ref tree 3)))
+	      (let ((bound      (list-ref tree 1))
+		    (left-func  (prepare-dispatch-tree left-tree))
+		    (right-func (prepare-dispatch-tree right-tree)))
+		(lambda (c)
+		  (if (= c bound)
+		      (left-func c)
+		      (right-func c)))))))
+	 (prepare-dispatch-tree
+	  (lambda (tree)
+	    (cond ((not (pair? tree))
+		   (prepare-dispatch-leaf tree))
+		  ((eq? (car tree) '=)
+		   (prepare-dispatch-= tree))
+		  (else
+		   (prepare-dispatch-< tree)))))
+	 (prepare-dispatch
+	  (lambda (tree)
+	    (let ((dicho-func (prepare-dispatch-tree tree)))
+	      (lambda (c)
+		(and c (dicho-func c))))))
+
+	 ; Fabrique les fonctions de transition (read & go) et (abort)
+	 (prepare-read-n-go
+	  (lambda (tree)
+	    (let ((dispatch-func (prepare-dispatch tree))
+		  (read-char     IS-read-char))
+	      (lambda ()
+		(dispatch-func (read-char))))))
+	 (prepare-abort
+	  (lambda (tree)
+	    (lambda ()
+	      #f)))
+	 (prepare-transition
+	  (lambda (tree)
+	    (if (eq? tree 'err)
+		(prepare-abort     tree)
+		(prepare-read-n-go tree))))
+
+	 ; Fabrique les fonctions d'etats ([set-end] & trans)
+	 (prepare-state-no-acc
+	   (lambda (s r1 r2)
+	     (let ((trans-func (prepare-transition (vector-ref trees-v s))))
+	       (lambda (action)
+		 (let ((next-state (trans-func)))
+		   (if next-state
+		       (next-state action)
+		       action))))))
+	 (prepare-state-yes-no
+	  (lambda (s r1 r2)
+	    (let ((peek-char       IS-peek-char)
+		  (end-go-to-point IS-end-go-to-point)
+		  (new-action1     #f)
+		  (trans-func (prepare-transition (vector-ref trees-v s))))
+	      (let ((result
+		     (lambda (action)
+		       (let* ((c (peek-char))
+			      (new-action
+			       (if (or (not c) (= c lexer-integer-newline))
+				   (begin
+				     (end-go-to-point)
+				     new-action1)
+				   action))
+			      (next-state (trans-func)))
+			 (if next-state
+			     (next-state new-action)
+			     new-action))))
+		    (hook
+		     (lambda ()
+		       (set! new-action1 (vector-ref rules-actions r1)))))
+		(add-hook hook)
+		result))))
+	 (prepare-state-diff-acc
+	  (lambda (s r1 r2)
+	    (let ((end-go-to-point IS-end-go-to-point)
+		  (peek-char       IS-peek-char)
+		  (new-action1     #f)
+		  (new-action2     #f)
+		  (trans-func (prepare-transition (vector-ref trees-v s))))
+	      (let ((result
+		     (lambda (action)
+		       (end-go-to-point)
+		       (let* ((c (peek-char))
+			      (new-action
+			       (if (or (not c) (= c lexer-integer-newline))
+				   new-action1
+				   new-action2))
+			      (next-state (trans-func)))
+			 (if next-state
+			     (next-state new-action)
+			     new-action))))
+		    (hook
+		     (lambda ()
+		       (set! new-action1 (vector-ref rules-actions r1))
+		       (set! new-action2 (vector-ref rules-actions r2)))))
+		(add-hook hook)
+		result))))
+	 (prepare-state-same-acc
+	  (lambda (s r1 r2)
+	    (let ((end-go-to-point IS-end-go-to-point)
+		  (trans-func (prepare-transition (vector-ref trees-v s)))
+		  (new-action #f))
+	      (let ((result
+		     (lambda (action)
+		       (end-go-to-point)
+		       (let ((next-state (trans-func)))
+			 (if next-state
+			     (next-state new-action)
+			     new-action))))
+		    (hook
+		     (lambda ()
+		       (set! new-action (vector-ref rules-actions r1)))))
+		(add-hook hook)
+		result))))
+	 (prepare-state
+	  (lambda (s)
+	    (let* ((acc (vector-ref acc-v s))
+		   (r1 (car acc))
+		   (r2 (cdr acc)))
+	      (cond ((not r1)  (prepare-state-no-acc   s r1 r2))
+		    ((not r2)  (prepare-state-yes-no   s r1 r2))
+		    ((< r1 r2) (prepare-state-diff-acc s r1 r2))
+		    (else      (prepare-state-same-acc s r1 r2))))))
+
+	 ; Fabrique la fonction de lancement du lexage a l'etat de depart
+	 (prepare-start-same
+	  (lambda (s1 s2)
+	    (let ((peek-char    IS-peek-char)
+		  (eof-action   #f)
+		  (start-state  #f)
+		  (error-action #f))
+	      (let ((result
+		     (lambda ()
+		       (if (not (peek-char))
+			   eof-action
+			   (start-state error-action))))
+		    (hook
+		     (lambda ()
+		       (set! eof-action   <<EOF>>-action)
+		       (set! start-state  (vector-ref states s1))
+		       (set! error-action <<ERROR>>-action))))
+		(add-hook hook)
+		result))))
+	 (prepare-start-diff
+	  (lambda (s1 s2)
+	    (let ((peek-char         IS-peek-char)
+		  (eof-action        #f)
+		  (peek-left-context IS-peek-left-context)
+		  (start-state1      #f)
+		  (start-state2      #f)
+		  (error-action      #f))
+	      (let ((result
+		     (lambda ()
+		       (cond ((not (peek-char))
+			      eof-action)
+			     ((= (peek-left-context) lexer-integer-newline)
+			      (start-state1 error-action))
+			     (else
+			      (start-state2 error-action)))))
+		    (hook
+		     (lambda ()
+		       (set! eof-action <<EOF>>-action)
+		       (set! start-state1 (vector-ref states s1))
+		       (set! start-state2 (vector-ref states s2))
+		       (set! error-action <<ERROR>>-action))))
+		(add-hook hook)
+		result))))
+	 (prepare-start
+	  (lambda ()
+	    (let ((s1 table-nl-start)
+		  (s2 table-no-nl-start))
+	      (if (= s1 s2)
+		  (prepare-start-same s1 s2)
+		  (prepare-start-diff s1 s2)))))
+
+	 ; Fabrique la fonction principale
+	 (prepare-lexer-none
+	  (lambda ()
+	    (let ((init-lexeme IS-init-lexeme)
+		  (start-func  (prepare-start)))
+	      (lambda ()
+		(init-lexeme)
+		((start-func))))))
+	 (prepare-lexer-line
+	  (lambda ()
+	    (let ((init-lexeme    IS-init-lexeme)
+		  (get-start-line IS-get-start-line)
+		  (start-func     (prepare-start)))
+	      (lambda ()
+		(init-lexeme)
+		(let ((yyline (get-start-line)))
+		  ((start-func) yyline))))))
+	 (prepare-lexer-all
+	  (lambda ()
+	    (let ((init-lexeme      IS-init-lexeme)
+		  (get-start-line   IS-get-start-line)
+		  (get-start-column IS-get-start-column)
+		  (get-start-offset IS-get-start-offset)
+		  (start-func       (prepare-start)))
+	      (lambda ()
+		(init-lexeme)
+		(let ((yyline   (get-start-line))
+		      (yycolumn (get-start-column))
+		      (yyoffset (get-start-offset)))
+		  ((start-func) yyline yycolumn yyoffset))))))
+	 (prepare-lexer
+	  (lambda ()
+	    (cond ((eq? counters-type 'none) (prepare-lexer-none))
+		  ((eq? counters-type 'line) (prepare-lexer-line))
+		  ((eq? counters-type 'all)  (prepare-lexer-all))))))
+
+      ; Calculer la valeur de <<EOF>>-action et de <<ERROR>>-action
+      (set! <<EOF>>-action   (prepare-special-action <<EOF>>-pre-action))
+      (set! <<ERROR>>-action (prepare-special-action <<ERROR>>-pre-action))
+
+      ; Calculer la valeur de rules-actions
+      (let* ((len (quotient (vector-length rules-pre-actions) 2))
+	     (v (make-vector len)))
+	(let loop ((r (- len 1)))
+	  (if (< r 0)
+	      (set! rules-actions v)
+	      (let* ((yytext? (vector-ref rules-pre-actions (* 2 r)))
+		     (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1)))
+		     (action (if yytext?
+				 (prepare-action-yytext    pre-action)
+				 (prepare-action-no-yytext pre-action))))
+		(vector-set! v r action)
+		(loop (- r 1))))))
+
+      ; Calculer la valeur de states
+      (let* ((len (vector-length trees-v))
+	     (v (make-vector len)))
+	(let loop ((s (- len 1)))
+	  (if (< s 0)
+	      (set! states v)
+	      (begin
+		(vector-set! v s (prepare-state s))
+		(loop (- s 1))))))
+
+      ; Calculer la valeur de final-lexer
+      (set! final-lexer (prepare-lexer))
+
+      ; Executer les hooks
+      (apply-hooks)
+
+      ; Resultat
+      final-lexer)))
+
+; Fabrication de lexer a partir de listes de caracteres taggees
+(define lexer-make-char-lexer
+  (let* ((char->class
+	  (lambda (c)
+	    (let ((n (char->integer c)))
+	      (list (cons n n)))))
+	 (merge-sort
+	  (lambda (l combine zero-elt)
+	    (if (null? l)
+		zero-elt
+		(let loop1 ((l l))
+		  (if (null? (cdr l))
+		      (car l)
+		      (loop1
+		       (let loop2 ((l l))
+			 (cond ((null? l)
+				l)
+			       ((null? (cdr l))
+				l)
+			       (else
+				(cons (combine (car l) (cadr l))
+				      (loop2 (cddr l))))))))))))
+	 (finite-class-union
+	  (lambda (c1 c2)
+	    (let loop ((c1 c1) (c2 c2) (u '()))
+	      (if (null? c1)
+		  (if (null? c2)
+		      (reverse u)
+		      (loop c1 (cdr c2) (cons (car c2) u)))
+		  (if (null? c2)
+		      (loop (cdr c1) c2 (cons (car c1) u))
+		      (let* ((r1 (car c1))
+			     (r2 (car c2))
+			     (r1start (car r1))
+			     (r1end (cdr r1))
+			     (r2start (car r2))
+			     (r2end (cdr r2)))
+			(if (<= r1start r2start)
+			    (cond ((< (+ r1end 1) r2start)
+				   (loop (cdr c1) c2 (cons r1 u)))
+				  ((<= r1end r2end)
+				   (loop (cdr c1)
+					 (cons (cons r1start r2end) (cdr c2))
+					 u))
+				  (else
+				   (loop c1 (cdr c2) u)))
+			    (cond ((> r1start (+ r2end 1))
+				   (loop c1 (cdr c2) (cons r2 u)))
+				  ((>= r1end r2end)
+				   (loop (cons (cons r2start r1end) (cdr c1))
+					 (cdr c2)
+					 u))
+				  (else
+				   (loop (cdr c1) c2 u))))))))))
+	 (char-list->class
+	  (lambda (cl)
+	    (let ((classes (map char->class cl)))
+	      (merge-sort classes finite-class-union '()))))
+	 (class-<
+	  (lambda (b1 b2)
+	    (cond ((eq? b1 'inf+) #f)
+		  ((eq? b2 'inf-) #f)
+		  ((eq? b1 'inf-) #t)
+		  ((eq? b2 'inf+) #t)
+		  (else (< b1 b2)))))
+	 (finite-class-compl
+	  (lambda (c)
+	    (let loop ((c c) (start 'inf-))
+	      (if (null? c)
+		  (list (cons start 'inf+))
+		  (let* ((r (car c))
+			 (rstart (car r))
+			 (rend (cdr r)))
+		    (if (class-< start rstart)
+			(cons (cons start (- rstart 1))
+			      (loop c rstart))
+			(loop (cdr c) (+ rend 1))))))))
+	 (tagged-chars->class
+	  (lambda (tcl)
+	    (let* ((inverse? (car tcl))
+		   (cl (cdr tcl))
+		   (class-tmp (char-list->class cl)))
+	      (if inverse? (finite-class-compl class-tmp) class-tmp))))
+	 (charc->arc
+	  (lambda (charc)
+	    (let* ((tcl (car charc))
+		   (dest (cdr charc))
+		   (class (tagged-chars->class tcl)))
+	      (cons class dest))))
+	 (arc->sharcs
+	  (lambda (arc)
+	    (let* ((range-l (car arc))
+		   (dest (cdr arc))
+		   (op (lambda (range) (cons range dest))))
+	      (map op range-l))))
+	 (class-<=
+	  (lambda (b1 b2)
+	    (cond ((eq? b1 'inf-) #t)
+		  ((eq? b2 'inf+) #t)
+		  ((eq? b1 'inf+) #f)
+		  ((eq? b2 'inf-) #f)
+		  (else (<= b1 b2)))))
+	 (sharc-<=
+	  (lambda (sharc1 sharc2)
+	    (class-<= (caar sharc1) (caar sharc2))))
+	 (merge-sharcs
+	  (lambda (l1 l2)
+	    (let loop ((l1 l1) (l2 l2))
+	      (cond ((null? l1)
+		     l2)
+		    ((null? l2)
+		     l1)
+		    (else
+		     (let ((sharc1 (car l1))
+			   (sharc2 (car l2)))
+		       (if (sharc-<= sharc1 sharc2)
+			   (cons sharc1 (loop (cdr l1) l2))
+			   (cons sharc2 (loop l1 (cdr l2))))))))))
+	 (class-= eqv?)
+	 (fill-error
+	  (lambda (sharcs)
+	    (let loop ((sharcs sharcs) (start 'inf-))
+	      (cond ((class-= start 'inf+)
+		     '())
+		    ((null? sharcs)
+		     (cons (cons (cons start 'inf+) 'err)
+			   (loop sharcs 'inf+)))
+		    (else
+		     (let* ((sharc (car sharcs))
+			    (h (caar sharc))
+			    (t (cdar sharc)))
+		       (if (class-< start h)
+			   (cons (cons (cons start (- h 1)) 'err)
+				 (loop sharcs h))
+			   (cons sharc (loop (cdr sharcs)
+					     (if (class-= t 'inf+)
+						 'inf+
+						 (+ t 1)))))))))))
+	 (charcs->tree
+	  (lambda (charcs)
+	    (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc))))
+		   (sharcs-l (map op charcs))
+		   (sorted-sharcs (merge-sort sharcs-l merge-sharcs '()))
+		   (full-sharcs (fill-error sorted-sharcs))
+		   (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
+		   (table (list->vector (map op full-sharcs))))
+	      (let loop ((left 0) (right (- (vector-length table) 1)))
+		(if (= left right)
+		    (cdr (vector-ref table left))
+		    (let ((mid (quotient (+ left right 1) 2)))
+		      (if (and (= (+ left 2) right)
+			       (= (+ (car (vector-ref table mid)) 1)
+				  (car (vector-ref table right)))
+			       (eqv? (cdr (vector-ref table left))
+				     (cdr (vector-ref table right))))
+			  (list '=
+				(car (vector-ref table mid))
+				(cdr (vector-ref table mid))
+				(cdr (vector-ref table left)))
+			  (list (car (vector-ref table mid))
+				(loop left (- mid 1))
+				(loop mid right))))))))))
+    (lambda (tables IS)
+      (let ((counters         (vector-ref tables 0))
+	    (<<EOF>>-action   (vector-ref tables 1))
+	    (<<ERROR>>-action (vector-ref tables 2))
+	    (rules-actions    (vector-ref tables 3))
+	    (nl-start         (vector-ref tables 5))
+	    (no-nl-start      (vector-ref tables 6))
+	    (charcs-v         (vector-ref tables 7))
+	    (acc-v            (vector-ref tables 8)))
+	(let* ((len (vector-length charcs-v))
+	       (v (make-vector len)))
+	  (let loop ((i (- len 1)))
+	    (if (>= i 0)
+		(begin
+		  (vector-set! v i (charcs->tree (vector-ref charcs-v i)))
+		  (loop (- i 1)))
+		(lexer-make-tree-lexer
+		 (vector counters
+			 <<EOF>>-action
+			 <<ERROR>>-action
+			 rules-actions
+			 'decision-trees
+			 nl-start
+			 no-nl-start
+			 v
+			 acc-v)
+		 IS))))))))
+
+; Fabrication d'un lexer a partir de code pre-genere
+(define lexer-make-code-lexer
+  (lambda (tables IS)
+    (let ((<<EOF>>-pre-action   (vector-ref tables 1))
+	  (<<ERROR>>-pre-action (vector-ref tables 2))
+	  (rules-pre-action     (vector-ref tables 3))
+	  (code                 (vector-ref tables 5)))
+      (code <<EOF>>-pre-action <<ERROR>>-pre-action rules-pre-action IS))))
+
+(define lexer-make-lexer
+  (lambda (tables IS)
+    (let ((automaton-type (vector-ref tables 4)))
+      (cond ((eq? automaton-type 'decision-trees)
+	     (lexer-make-tree-lexer tables IS))
+	    ((eq? automaton-type 'tagged-chars-lists)
+	     (lexer-make-char-lexer tables IS))
+	    ((eq? automaton-type 'code)
+	     (lexer-make-code-lexer tables IS))))))
+" port)))
+
+; Module main.scm.
+
+;
+; Gestion d'erreurs
+;
+
+(define lex-exit-continuation #f)
+(define lex-unwind-protect-list '())
+(define lex-error-filename #f)
+
+(define lex-unwind-protect
+  (lambda (proc)
+    (set! lex-unwind-protect-list (cons proc lex-unwind-protect-list))))
+
+(define lex-error
+  (lambda (line column . l)
+    (let* ((linestr (if line   (number->string line)   #f))
+	   (colstr  (if column (number->string column) #f))
+	   (namelen (string-length lex-error-filename))
+	   (linelen (if line   (string-length linestr) -1))
+	   (collen  (if column (string-length colstr)  -1))
+	   (totallen (+ namelen 1 linelen 1 collen 2)))
+      (display "Lex error:")
+      (newline)
+      (display lex-error-filename)
+      (if line
+	  (begin
+	    (display ":")
+	    (display linestr)))
+      (if column
+	  (begin
+	    (display ":")
+	    (display colstr)))
+      (display ": ")
+      (let loop ((l l))
+	(if (null? l)
+	    (newline)
+	    (let ((item (car l)))
+	      (display item)
+	      (if (equal? '#\newline item)
+		  (let loop2 ((i totallen))
+		    (if (> i 0)
+			(begin
+			  (display #\space)
+			  (loop2 (- i 1))))))
+	      (loop (cdr l)))))
+      (newline)
+      (let loop ((l lex-unwind-protect-list))
+	(if (pair? l)
+	    (begin
+	      ((car l))
+	      (loop (cdr l)))))
+      (lex-exit-continuation #f))))
+
+
+
+
+;
+; Decoupage des arguments
+;
+
+(define lex-recognized-args
+  '(complete-driver?
+    filein
+    table-name
+    fileout
+    counters
+    portable
+    code
+    pp))
+
+(define lex-valued-args
+  '(complete-driver?
+    filein
+    table-name
+    fileout
+    counters))
+
+(define lex-parse-args
+  (lambda (args)
+    (let loop ((args args))
+      (if (null? args)
+	  '()
+	  (let ((sym (car args)))
+	    (cond ((not (symbol? sym))
+		   (lex-error #f #f "bad option list."))
+		  ((not (memq sym lex-recognized-args))
+		   (lex-error #f #f "unrecognized option \"" sym "\"."))
+		  ((not (memq sym lex-valued-args))
+		   (cons (cons sym '()) (loop (cdr args))))
+		  ((null? (cdr args))
+		   (lex-error #f #f "the value of \"" sym "\" not specified."))
+		  (else
+		   (cons (cons sym (cadr args)) (loop (cddr args))))))))))
+
+
+
+
+;
+; Differentes etapes de la fabrication de l'automate
+;
+
+(define lex1
+  (lambda (filein)
+;     (display "lex1: ") (write (get-internal-run-time)) (newline)
+    (parser filein)))
+
+(define lex2
+  (lambda (filein)
+    (let* ((result (lex1 filein))
+	   (<<EOF>>-action (car result))
+	   (<<ERROR>>-action (cadr result))
+	   (rules (cddr result)))
+;       (display "lex2: ") (write (get-internal-run-time)) (newline)
+      (append (list <<EOF>>-action <<ERROR>>-action rules)
+	      (re2nfa rules)))))
+
+(define lex3
+  (lambda (filein)
+    (let* ((result (lex2 filein))
+	   (<<EOF>>-action   (list-ref result 0))
+	   (<<ERROR>>-action (list-ref result 1))
+	   (rules            (list-ref result 2))
+	   (nl-start         (list-ref result 3))
+	   (no-nl-start      (list-ref result 4))
+	   (arcs             (list-ref result 5))
+	   (acc              (list-ref result 6)))
+;       (display "lex3: ") (write (get-internal-run-time)) (newline)
+      (append (list <<EOF>>-action <<ERROR>>-action rules)
+	      (noeps nl-start no-nl-start arcs acc)))))
+
+(define lex4
+  (lambda (filein)
+    (let* ((result (lex3 filein))
+	   (<<EOF>>-action   (list-ref result 0))
+	   (<<ERROR>>-action (list-ref result 1))
+	   (rules            (list-ref result 2))
+	   (nl-start         (list-ref result 3))
+	   (no-nl-start      (list-ref result 4))
+	   (arcs             (list-ref result 5))
+	   (acc              (list-ref result 6)))
+;       (display "lex4: ") (write (get-internal-run-time)) (newline)
+      (append (list <<EOF>>-action <<ERROR>>-action rules)
+	      (sweep nl-start no-nl-start arcs acc)))))
+
+(define lex5
+  (lambda (filein)
+    (let* ((result (lex4 filein))
+	   (<<EOF>>-action   (list-ref result 0))
+	   (<<ERROR>>-action (list-ref result 1))
+	   (rules            (list-ref result 2))
+	   (nl-start         (list-ref result 3))
+	   (no-nl-start      (list-ref result 4))
+	   (arcs             (list-ref result 5))
+	   (acc              (list-ref result 6)))
+;       (display "lex5: ") (write (get-internal-run-time)) (newline)
+      (append (list <<EOF>>-action <<ERROR>>-action rules)
+	      (nfa2dfa nl-start no-nl-start arcs acc)))))
+
+(define lex6
+  (lambda (args-alist)
+    (let* ((filein           (cdr (assq 'filein args-alist)))
+	   (result           (lex5 filein))
+	   (<<EOF>>-action   (list-ref result 0))
+	   (<<ERROR>>-action (list-ref result 1))
+	   (rules            (list-ref result 2))
+	   (nl-start         (list-ref result 3))
+	   (no-nl-start      (list-ref result 4))
+	   (arcs             (list-ref result 5))
+	   (acc              (list-ref result 6)))
+;       (display "lex6: ") (write (get-internal-run-time)) (newline)
+      (prep-set-rules-yytext? rules)
+      (output args-alist
+	      <<EOF>>-action <<ERROR>>-action
+	      rules nl-start no-nl-start arcs acc)
+      #t)))
+
+(define lex7
+  (lambda (args)
+    (call-with-current-continuation
+     (lambda (exit)
+       (set! lex-exit-continuation exit)
+       (set! lex-unwind-protect-list '())
+       (set! lex-error-filename (cadr (memq 'filein args)))
+       (let* ((args-alist (lex-parse-args args))
+	      (result (lex6 args-alist)))
+; 	 (display "lex7: ") (write (get-internal-run-time)) (newline)
+	 result)))))
+
+
+
+
+;
+; Fonctions principales
+;
+
+(define lex
+  (lambda (filein fileout . options)
+    (lex7 (append (list 'complete-driver? #t
+			'filein filein
+			'table-name "lexer-default-table"
+			'fileout fileout)
+		  options))))
+
+(define lex-tables
+  (lambda (filein table-name fileout . options)
+    (lex7 (append (list 'complete-driver? #f
+			'filein filein
+			'table-name table-name
+			'fileout fileout)
+		  options))))
+
-- 
cgit v1.2.3