path: root/src/guile/silex/output.scm

; 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))))