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