Add SILex, for simplicity.

1 files changed, 1078 insertions, 0 deletions

diff --git a/src/guile/silex/output.scm b/src/guile/silex/output.scm
new file mode 100644
index 0000000..fc76b01
--- /dev/null
+++ b/src/guile/silex/output.scm
@@ -0,0 +1,1078 @@
+; 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.
+
+;
+; 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))))