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/output2.scm | 1159 +++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 1159 insertions(+)
 create mode 100644 src/guile/silex/output2.scm

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

diff --git a/src/guile/silex/output2.scm b/src/guile/silex/output2.scm
new file mode 100644
index 0000000..cb0276d
--- /dev/null
+++ b/src/guile/silex/output2.scm
@@ -0,0 +1,1159 @@
+; 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.
+
+;
+; 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)))
-- 
cgit v1.2.3