diff options
Diffstat (limited to 'src/guile/silex/output.scm')
| -rw-r--r-- | src/guile/silex/output.scm | 1078 |
1 files changed, 1078 insertions, 0 deletions
diff --git a/src/guile/silex/output.scm b/src/guile/silex/output.scm new file mode 100644 index 0000000..fc76b01 --- /dev/null +++ b/src/guile/silex/output.scm @@ -0,0 +1,1078 @@ +; SILex - Scheme Implementation of Lex +; Copyright (C) 2001 Danny Dube' +; +; This program is free software; you can redistribute it and/or +; modify it under the terms of the GNU General Public License +; as published by the Free Software Foundation; either version 2 +; of the License, or (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. +; +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +; +; Nettoie les actions en enlevant les lignes blanches avant et apres +; + +(define out-split-in-lines + (lambda (s) + (let ((len (string-length s))) + (let loop ((i 0) (start 0)) + (cond ((= i len) + '()) + ((char=? (string-ref s i) #\newline) + (cons (substring s start (+ i 1)) + (loop (+ i 1) (+ i 1)))) + (else + (loop (+ i 1) start))))))) + +(define out-empty-line? + (lambda (s) + (let ((len (- (string-length s) 1))) + (let loop ((i 0)) + (cond ((= i len) + #t) + ((char-whitespace? (string-ref s i)) + (loop (+ i 1))) + (else + #f)))))) + +; Enleve les lignes vides dans une liste avant et apres l'action +(define out-remove-empty-lines + (lambda (lines) + (let loop ((lines lines) (top? #t)) + (if (null? lines) + '() + (let ((line (car lines))) + (cond ((not (out-empty-line? line)) + (cons line (loop (cdr lines) #f))) + (top? + (loop (cdr lines) #t)) + (else + (let ((rest (loop (cdr lines) #f))) + (if (null? rest) + '() + (cons line rest)))))))))) + +; Enleve les lignes vides avant et apres l'action +(define out-clean-action + (lambda (s) + (let* ((lines (out-split-in-lines s)) + (clean-lines (out-remove-empty-lines lines))) + (apply string-append clean-lines)))) + + + + +; +; Pretty-printer pour les booleens, la liste vide, les nombres, +; les symboles, les caracteres, les chaines, les listes et les vecteurs +; + +; Colonne limite pour le pretty-printer (a ne pas atteindre) +(define out-max-col 76) + +(define out-flatten-list + (lambda (ll) + (let loop ((ll ll) (part-out '())) + (if (null? ll) + part-out + (let* ((new-part-out (loop (cdr ll) part-out)) + (head (car ll))) + (cond ((null? head) + new-part-out) + ((pair? head) + (loop head new-part-out)) + (else + (cons head new-part-out)))))))) + +(define out-force-string + (lambda (obj) + (if (char? obj) + (string obj) + obj))) + +; Transforme une liste impropre en une liste propre qui s'ecrit +; de la meme facon +(define out-regular-list + (let ((symbolic-dot (string->symbol "."))) + (lambda (p) + (let ((tail (cdr p))) + (cond ((null? tail) + p) + ((pair? tail) + (cons (car p) (out-regular-list tail))) + (else + (list (car p) symbolic-dot tail))))))) + +; Cree des chaines d'espaces de facon paresseuse +(define out-blanks + (let ((cache-v (make-vector 80 #f))) + (lambda (n) + (or (vector-ref cache-v n) + (let ((result (make-string n #\space))) + (vector-set! cache-v n result) + result))))) + +; Insere le separateur entre chaque element d'une liste non-vide +(define out-separate + (lambda (text-l sep) + (if (null? (cdr text-l)) + text-l + (cons (car text-l) (cons sep (out-separate (cdr text-l) sep)))))) + +; Met des donnees en colonnes. Retourne comme out-pp-aux-list +(define out-pp-columns + (lambda (left right wmax txt&lens) + (let loop1 ((tls txt&lens) (lwmax 0) (lwlast 0) (lines '())) + (if (null? tls) + (vector #t 0 lwmax lwlast (reverse lines)) + (let loop2 ((tls tls) (len 0) (first? #t) (prev-pad 0) (line '())) + (cond ((null? tls) + (loop1 tls + (max len lwmax) + len + (cons (reverse line) lines))) + ((> (+ left len prev-pad 1 wmax) out-max-col) + (loop1 tls + (max len lwmax) + len + (cons (reverse line) lines))) + (first? + (let ((text (caar tls)) + (text-len (cdar tls))) + (loop2 (cdr tls) + (+ len text-len) + #f + (- wmax text-len) + (cons text line)))) + ((pair? (cdr tls)) + (let* ((prev-pad-s (out-blanks prev-pad)) + (text (caar tls)) + (text-len (cdar tls))) + (loop2 (cdr tls) + (+ len prev-pad 1 text-len) + #f + (- wmax text-len) + (cons text (cons " " (cons prev-pad-s line)))))) + (else + (let ((prev-pad-s (out-blanks prev-pad)) + (text (caar tls)) + (text-len (cdar tls))) + (if (> (+ left len prev-pad 1 text-len) right) + (loop1 tls + (max len lwmax) + len + (cons (reverse line) lines)) + (loop2 (cdr tls) + (+ len prev-pad 1 text-len) + #f + (- wmax text-len) + (append (list text " " prev-pad-s) + line))))))))))) + +; Retourne un vecteur #( multiline? width-all width-max width-last text-l ) +(define out-pp-aux-list + (lambda (l left right) + (let loop ((l l) (multi? #f) (wall -1) (wmax -1) (wlast -1) (txt&lens '())) + (if (null? l) + (cond (multi? + (vector #t wall wmax wlast (map car (reverse txt&lens)))) + ((<= (+ left wall) right) + (vector #f wall wmax wlast (map car (reverse txt&lens)))) + ((<= (+ left wmax 1 wmax) out-max-col) + (out-pp-columns left right wmax (reverse txt&lens))) + (else + (vector #t wall wmax wlast (map car (reverse txt&lens))))) + (let* ((obj (car l)) + (last? (null? (cdr l))) + (this-right (if last? right out-max-col)) + (result (out-pp-aux obj left this-right)) + (obj-multi? (vector-ref result 0)) + (obj-wmax (vector-ref result 1)) + (obj-wlast (vector-ref result 2)) + (obj-text (vector-ref result 3))) + (loop (cdr l) + (or multi? obj-multi?) + (+ wall obj-wmax 1) + (max wmax obj-wmax) + obj-wlast + (cons (cons obj-text obj-wmax) txt&lens))))))) + +; Retourne un vecteur #( multiline? wmax wlast text ) +(define out-pp-aux + (lambda (obj left right) + (cond ((boolean? obj) + (vector #f 2 2 (if obj '("#t") '("#f")))) + ((null? obj) + (vector #f 2 2 '("()"))) + ((number? obj) + (let* ((s (number->string obj)) + (len (string-length s))) + (vector #f len len (list s)))) + ((symbol? obj) + (let* ((s (symbol->string obj)) + (len (string-length s))) + (vector #f len len (list s)))) + ((char? obj) + (cond ((char=? obj #\space) + (vector #f 7 7 (list "#\\space"))) + ((char=? obj #\newline) + (vector #f 9 9 (list "#\\newline"))) + (else + (vector #f 3 3 (list "#\\" obj))))) + ((string? obj) + (let loop ((i (- (string-length obj) 1)) + (len 1) + (text '("\""))) + (if (= i -1) + (vector #f (+ len 1) (+ len 1) (cons "\"" text)) + (let ((c (string-ref obj i))) + (cond ((char=? c #\\) + (loop (- i 1) (+ len 2) (cons "\\\\" text))) + ((char=? c #\") + (loop (- i 1) (+ len 2) (cons "\\\"" text))) + (else + (loop (- i 1) (+ len 1) (cons (string c) text)))))))) + ((pair? obj) + (let* ((l (out-regular-list obj)) + (result (out-pp-aux-list l (+ left 1) (- right 1))) + (multiline? (vector-ref result 0)) + (width-all (vector-ref result 1)) + (width-max (vector-ref result 2)) + (width-last (vector-ref result 3)) + (text-l (vector-ref result 4))) + (if multiline? + (let* ((sep (list #\newline (out-blanks left))) + (formatted-text (out-separate text-l sep)) + (text (list "(" formatted-text ")"))) + (vector #t + (+ (max width-max (+ width-last 1)) 1) + (+ width-last 2) + text)) + (let* ((sep (list " ")) + (formatted-text (out-separate text-l sep)) + (text (list "(" formatted-text ")"))) + (vector #f (+ width-all 2) (+ width-all 2) text))))) + ((and (vector? obj) (zero? (vector-length obj))) + (vector #f 3 3 '("#()"))) + ((vector? obj) + (let* ((l (vector->list obj)) + (result (out-pp-aux-list l (+ left 2) (- right 1))) + (multiline? (vector-ref result 0)) + (width-all (vector-ref result 1)) + (width-max (vector-ref result 2)) + (width-last (vector-ref result 3)) + (text-l (vector-ref result 4))) + (if multiline? + (let* ((sep (list #\newline (out-blanks (+ left 1)))) + (formatted-text (out-separate text-l sep)) + (text (list "#(" formatted-text ")"))) + (vector #t + (+ (max width-max (+ width-last 1)) 2) + (+ width-last 3) + text)) + (let* ((sep (list " ")) + (formatted-text (out-separate text-l sep)) + (text (list "#(" formatted-text ")"))) + (vector #f (+ width-all 3) (+ width-all 3) text))))) + (else + (display "Internal error: out-pp") + (newline))))) + +; Retourne la chaine a afficher +(define out-pp + (lambda (obj col) + (let* ((list-rec-of-strings-n-chars + (vector-ref (out-pp-aux obj col out-max-col) 3)) + (list-of-strings-n-chars + (out-flatten-list list-rec-of-strings-n-chars)) + (list-of-strings + (map out-force-string list-of-strings-n-chars))) + (apply string-append list-of-strings)))) + + + + +; +; Nice-printer, plus rapide mais moins beau que le pretty-printer +; + +(define out-np + (lambda (obj start) + (letrec ((line-pad + (string-append (string #\newline) + (out-blanks (- start 1)))) + (step-line + (lambda (p) + (set-car! p line-pad))) + (p-bool + (lambda (obj col objw texts hole cont) + (let ((text (if obj "#t" "#f"))) + (cont (+ col 2) (+ objw 2) (cons text texts) hole)))) + (p-number + (lambda (obj col objw texts hole cont) + (let* ((text (number->string obj)) + (len (string-length text))) + (cont (+ col len) (+ objw len) (cons text texts) hole)))) + (p-symbol + (lambda (obj col objw texts hole cont) + (let* ((text (symbol->string obj)) + (len (string-length text))) + (cont (+ col len) (+ objw len) (cons text texts) hole)))) + (p-char + (lambda (obj col objw texts hole cont) + (let* ((text + (cond ((char=? obj #\space) "#\\space") + ((char=? obj #\newline) "#\\newline") + (else (string-append "#\\" (string obj))))) + (len (string-length text))) + (cont (+ col len) (+ objw len) (cons text texts) hole)))) + (p-list + (lambda (obj col objw texts hole cont) + (p-tail obj (+ col 1) (+ objw 1) (cons "(" texts) hole cont))) + (p-vector + (lambda (obj col objw texts hole cont) + (p-list (vector->list obj) + (+ col 1) (+ objw 1) (cons "#" texts) hole cont))) + (p-tail + (lambda (obj col objw texts hole cont) + (if (null? obj) + (cont (+ col 1) (+ objw 1) (cons ")" texts) hole) + (p-obj (car obj) col objw texts hole + (make-cdr-cont obj cont))))) + (make-cdr-cont + (lambda (obj cont) + (lambda (col objw texts hole) + (cond ((null? (cdr obj)) + (cont (+ col 1) (+ objw 1) (cons ")" texts) hole)) + ((> col out-max-col) + (step-line hole) + (let ((hole2 (cons " " texts))) + (p-cdr obj (+ start objw 1) 0 hole2 hole2 cont))) + (else + (let ((hole2 (cons " " texts))) + (p-cdr obj (+ col 1) 0 hole2 hole2 cont))))))) + (p-cdr + (lambda (obj col objw texts hole cont) + (if (pair? (cdr obj)) + (p-tail (cdr obj) col objw texts hole cont) + (p-dot col objw texts hole + (make-cdr-cont (list #f (cdr obj)) cont))))) + (p-dot + (lambda (col objw texts hole cont) + (cont (+ col 1) (+ objw 1) (cons "." texts) hole))) + (p-obj + (lambda (obj col objw texts hole cont) + (cond ((boolean? obj) + (p-bool obj col objw texts hole cont)) + ((number? obj) + (p-number obj col objw texts hole cont)) + ((symbol? obj) + (p-symbol obj col objw texts hole cont)) + ((char? obj) + (p-char obj col objw texts hole cont)) + ((or (null? obj) (pair? obj)) + (p-list obj col objw texts hole cont)) + ((vector? obj) + (p-vector obj col objw texts hole cont)))))) + (p-obj obj start 0 '() (cons #f #f) + (lambda (col objw texts hole) + (if (> col out-max-col) + (step-line hole)) + (apply string-append (reverse texts))))))) + + + + +; +; Fonction pour afficher une table +; Appelle la sous-routine adequate pour le type de fin de table +; + +; Affiche la table d'un driver +(define out-print-table + (lambda (args-alist + <<EOF>>-action <<ERROR>>-action rules + nl-start no-nl-start arcs-v acc-v + port) + (let* ((filein + (cdr (assq 'filein args-alist))) + (table-name + (cdr (assq 'table-name args-alist))) + (pretty? + (assq 'pp args-alist)) + (counters-type + (let ((a (assq 'counters args-alist))) + (if a (cdr a) 'line))) + (counters-param-list + (cond ((eq? counters-type 'none) + ")") + ((eq? counters-type 'line) + " yyline)") + (else ; 'all + " yyline yycolumn yyoffset)"))) + (counters-param-list-short + (if (char=? (string-ref counters-param-list 0) #\space) + (substring counters-param-list + 1 + (string-length counters-param-list)) + counters-param-list)) + (clean-eof-action + (out-clean-action <<EOF>>-action)) + (clean-error-action + (out-clean-action <<ERROR>>-action)) + (rule-op + (lambda (rule) (out-clean-action (get-rule-action rule)))) + (rules-l + (vector->list rules)) + (clean-actions-l + (map rule-op rules-l)) + (yytext?-l + (map get-rule-yytext? rules-l))) + + ; Commentaires prealables + (display ";" port) + (newline port) + (display "; Table generated from the file " port) + (display filein port) + (display " by SILex 1.0" port) + (newline port) + (display ";" port) + (newline port) + (newline port) + + ; Ecrire le debut de la table + (display "(define " port) + (display table-name port) + (newline port) + (display " (vector" port) + (newline port) + + ; Ecrire la description du type de compteurs + (display " '" port) + (write counters-type port) + (newline port) + + ; Ecrire l'action pour la fin de fichier + (display " (lambda (yycontinue yygetc yyungetc)" port) + (newline port) + (display " (lambda (yytext" port) + (display counters-param-list port) + (newline port) + (display clean-eof-action port) + (display " ))" port) + (newline port) + + ; Ecrire l'action pour le cas d'erreur + (display " (lambda (yycontinue yygetc yyungetc)" port) + (newline port) + (display " (lambda (yytext" port) + (display counters-param-list port) + (newline port) + (display clean-error-action port) + (display " ))" port) + (newline port) + + ; Ecrire le vecteur des actions des regles ordinaires + (display " (vector" port) + (newline port) + (let loop ((al clean-actions-l) (yyl yytext?-l)) + (if (pair? al) + (let ((yytext? (car yyl))) + (display " " port) + (write yytext? port) + (newline port) + (display " (lambda (yycontinue yygetc yyungetc)" port) + (newline port) + (if yytext? + (begin + (display " (lambda (yytext" port) + (display counters-param-list port)) + (begin + (display " (lambda (" port) + (display counters-param-list-short port))) + (newline port) + (display (car al) port) + (display " ))" port) + (if (pair? (cdr al)) + (newline port)) + (loop (cdr al) (cdr yyl))))) + (display ")" port) + (newline port) + + ; Ecrire l'automate + (cond ((assq 'portable args-alist) + (out-print-table-chars + pretty? + nl-start no-nl-start arcs-v acc-v + port)) + ((assq 'code args-alist) + (out-print-table-code + counters-type (vector-length rules) yytext?-l + nl-start no-nl-start arcs-v acc-v + port)) + (else + (out-print-table-data + pretty? + nl-start no-nl-start arcs-v acc-v + port)))))) + +; +; Affiche l'automate sous forme d'arbres de decision +; Termine la table du meme coup +; + +(define out-print-table-data + (lambda (pretty? nl-start no-nl-start arcs-v acc-v port) + (let* ((len (vector-length arcs-v)) + (trees-v (make-vector len))) + (let loop ((i 0)) + (if (< i len) + (begin + (vector-set! trees-v i (prep-arcs->tree (vector-ref arcs-v i))) + (loop (+ i 1))))) + + ; Decrire le format de l'automate + (display " 'decision-trees" port) + (newline port) + + ; Ecrire l'etat de depart pour le cas "debut de la ligne" + (display " " port) + (write nl-start port) + (newline port) + + ; Ecrire l'etat de depart pour le cas "pas au debut de la ligne" + (display " " port) + (write no-nl-start port) + (newline port) + + ; Ecrire la table de transitions + (display " '" port) + (if pretty? + (display (out-pp trees-v 5) port) + (display (out-np trees-v 5) port)) + (newline port) + + ; Ecrire la table des acceptations + (display " '" port) + (if pretty? + (display (out-pp acc-v 5) port) + (display (out-np acc-v 5) port)) + + ; Ecrire la fin de la table + (display "))" port) + (newline port)))) + +; +; Affiche l'automate sous forme de listes de caracteres taggees +; Termine la table du meme coup +; + +(define out-print-table-chars + (lambda (pretty? nl-start no-nl-start arcs-v acc-v port) + (let* ((len (vector-length arcs-v)) + (portable-v (make-vector len)) + (arc-op (lambda (arc) + (cons (class->tagged-char-list (car arc)) (cdr arc))))) + (let loop ((s 0)) + (if (< s len) + (let* ((arcs (vector-ref arcs-v s)) + (port-arcs (map arc-op arcs))) + (vector-set! portable-v s port-arcs) + (loop (+ s 1))))) + + ; Decrire le format de l'automate + (display " 'tagged-chars-lists" port) + (newline port) + + ; Ecrire l'etat de depart pour le cas "debut de la ligne" + (display " " port) + (write nl-start port) + (newline port) + + ; Ecrire l'etat de depart pour le cas "pas au debut de la ligne" + (display " " port) + (write no-nl-start port) + (newline port) + + ; Ecrire la table de transitions + (display " '" port) + (if pretty? + (display (out-pp portable-v 5) port) + (display (out-np portable-v 5) port)) + (newline port) + + ; Ecrire la table des acceptations + (display " '" port) + (if pretty? + (display (out-pp acc-v 5) port) + (display (out-np acc-v 5) port)) + + ; Ecrire la fin de la table + (display "))" port) + (newline port)))) + +; +; Genere l'automate en code Scheme +; Termine la table du meme coup +; + +(define out-print-code-trans3 + (lambda (margin tree action-var port) + (newline port) + (display (out-blanks margin) port) + (cond ((eq? tree 'err) + (display action-var port)) + ((number? tree) + (display "(state-" port) + (display tree port) + (display " " port) + (display action-var port) + (display ")" port)) + ((eq? (car tree) '=) + (display "(if (= c " port) + (display (list-ref tree 1) port) + (display ")" port) + (out-print-code-trans3 (+ margin 4) + (list-ref tree 2) + action-var + port) + (out-print-code-trans3 (+ margin 4) + (list-ref tree 3) + action-var + port) + (display ")" port)) + (else + (display "(if (< c " port) + (display (list-ref tree 0) port) + (display ")" port) + (out-print-code-trans3 (+ margin 4) + (list-ref tree 1) + action-var + port) + (out-print-code-trans3 (+ margin 4) + (list-ref tree 2) + action-var + port) + (display ")" port))))) + +(define out-print-code-trans2 + (lambda (margin tree action-var port) + (newline port) + (display (out-blanks margin) port) + (display "(if c" port) + (out-print-code-trans3 (+ margin 4) tree action-var port) + (newline port) + (display (out-blanks (+ margin 4)) port) + (display action-var port) + (display ")" port))) + +(define out-print-code-trans1 + (lambda (margin tree action-var port) + (newline port) + (display (out-blanks margin) port) + (if (eq? tree 'err) + (display action-var port) + (begin + (display "(let ((c (read-char)))" port) + (out-print-code-trans2 (+ margin 2) tree action-var port) + (display ")" port))))) + +(define out-print-table-code + (lambda (counters nbrules yytext?-l + nl-start no-nl-start arcs-v acc-v + port) + (let* ((counters-params + (cond ((eq? counters 'none) ")") + ((eq? counters 'line) " yyline)") + ((eq? counters 'all) " yyline yycolumn yyoffset)"))) + (counters-params-short + (cond ((eq? counters 'none) ")") + ((eq? counters 'line) "yyline)") + ((eq? counters 'all) "yyline yycolumn yyoffset)"))) + (nbstates (vector-length arcs-v)) + (trees-v (make-vector nbstates))) + (let loop ((s 0)) + (if (< s nbstates) + (begin + (vector-set! trees-v s (prep-arcs->tree (vector-ref arcs-v s))) + (loop (+ s 1))))) + + ; Decrire le format de l'automate + (display " 'code" port) + (newline port) + + ; Ecrire l'entete de la fonction + (display " (lambda (<<EOF>>-pre-action" port) + (newline port) + (display " <<ERROR>>-pre-action" port) + (newline port) + (display " rules-pre-action" port) + (newline port) + (display " IS)" port) + (newline port) + + ; Ecrire le debut du letrec et les variables d'actions brutes + (display " (letrec" port) + (newline port) + (display " ((user-action-<<EOF>> #f)" port) + (newline port) + (display " (user-action-<<ERROR>> #f)" port) + (newline port) + (let loop ((i 0)) + (if (< i nbrules) + (begin + (display " (user-action-" port) + (write i port) + (display " #f)" port) + (newline port) + (loop (+ i 1))))) + + ; Ecrire l'extraction des fonctions du IS + (display " (start-go-to-end " port) + (display "(cdr (assq 'start-go-to-end IS)))" port) + (newline port) + (display " (end-go-to-point " port) + (display "(cdr (assq 'end-go-to-point IS)))" port) + (newline port) + (display " (init-lexeme " port) + (display "(cdr (assq 'init-lexeme IS)))" port) + (newline port) + (display " (get-start-line " port) + (display "(cdr (assq 'get-start-line IS)))" port) + (newline port) + (display " (get-start-column " port) + (display "(cdr (assq 'get-start-column IS)))" port) + (newline port) + (display " (get-start-offset " port) + (display "(cdr (assq 'get-start-offset IS)))" port) + (newline port) + (display " (peek-left-context " port) + (display "(cdr (assq 'peek-left-context IS)))" port) + (newline port) + (display " (peek-char " port) + (display "(cdr (assq 'peek-char IS)))" port) + (newline port) + (display " (read-char " port) + (display "(cdr (assq 'read-char IS)))" port) + (newline port) + (display " (get-start-end-text " port) + (display "(cdr (assq 'get-start-end-text IS)))" port) + (newline port) + (display " (user-getc " port) + (display "(cdr (assq 'user-getc IS)))" port) + (newline port) + (display " (user-ungetc " port) + (display "(cdr (assq 'user-ungetc IS)))" port) + (newline port) + + ; Ecrire les variables d'actions + (display " (action-<<EOF>>" port) + (newline port) + (display " (lambda (" port) + (display counters-params-short port) + (newline port) + (display " (user-action-<<EOF>> \"\"" port) + (display counters-params port) + (display "))" port) + (newline port) + (display " (action-<<ERROR>>" port) + (newline port) + (display " (lambda (" port) + (display counters-params-short port) + (newline port) + (display " (user-action-<<ERROR>> \"\"" port) + (display counters-params port) + (display "))" port) + (newline port) + (let loop ((i 0) (yyl yytext?-l)) + (if (< i nbrules) + (begin + (display " (action-" port) + (display i port) + (newline port) + (display " (lambda (" port) + (display counters-params-short port) + (newline port) + (if (car yyl) + (begin + (display " (let ((yytext" port) + (display " (get-start-end-text)))" port) + (newline port) + (display " (start-go-to-end)" port) + (newline port) + (display " (user-action-" port) + (display i port) + (display " yytext" port) + (display counters-params port) + (display ")))" port) + (newline port)) + (begin + (display " (start-go-to-end)" port) + (newline port) + (display " (user-action-" port) + (display i port) + (display counters-params port) + (display "))" port) + (newline port))) + (loop (+ i 1) (cdr yyl))))) + + ; Ecrire les variables d'etats + (let loop ((s 0)) + (if (< s nbstates) + (let* ((tree (vector-ref trees-v s)) + (acc (vector-ref acc-v s)) + (acc-eol (car acc)) + (acc-no-eol (cdr acc))) + (display " (state-" port) + (display s port) + (newline port) + (display " (lambda (action)" port) + (cond ((not acc-eol) + (out-print-code-trans1 13 tree "action" port)) + ((not acc-no-eol) + (newline port) + (if (eq? tree 'err) + (display " (let* ((c (peek-char))" port) + (display " (let* ((c (read-char))" port)) + (newline port) + (display " (new-action (if (o" port) + (display "r (not c) (= c lexer-integer-newline))" port) + (newline port) + (display " " port) + (display " (begin (end-go-to-point) action-" port) + (display acc-eol port) + (display ")" port) + (newline port) + (display " " port) + (display " action)))" port) + (if (eq? tree 'err) + (out-print-code-trans1 15 tree "new-action" port) + (out-print-code-trans2 15 tree "new-action" port)) + (display ")" port)) + ((< acc-eol acc-no-eol) + (newline port) + (display " (end-go-to-point)" port) + (newline port) + (if (eq? tree 'err) + (display " (let* ((c (peek-char))" port) + (display " (let* ((c (read-char))" port)) + (newline port) + (display " (new-action (if (o" port) + (display "r (not c) (= c lexer-integer-newline))" port) + (newline port) + (display " " port) + (display " action-" port) + (display acc-eol port) + (newline port) + (display " " port) + (display " action-" port) + (display acc-no-eol port) + (display ")))" port) + (if (eq? tree 'err) + (out-print-code-trans1 15 tree "new-action" port) + (out-print-code-trans2 15 tree "new-action" port)) + (display ")" port)) + (else + (let ((action-var + (string-append "action-" + (number->string acc-eol)))) + (newline port) + (display " (end-go-to-point)" port) + (out-print-code-trans1 13 tree action-var port)))) + (display "))" port) + (newline port) + (loop (+ s 1))))) + + ; Ecrire la variable de lancement de l'automate + (display " (start-automaton" port) + (newline port) + (display " (lambda ()" port) + (newline port) + (if (= nl-start no-nl-start) + (begin + (display " (if (peek-char)" port) + (newline port) + (display " (state-" port) + (display nl-start port) + (display " action-<<ERROR>>)" port) + (newline port) + (display " action-<<EOF>>)" port)) + (begin + (display " (cond ((not (peek-char))" port) + (newline port) + (display " action-<<EOF>>)" port) + (newline port) + (display " ((= (peek-left-context)" port) + (display " lexer-integer-newline)" port) + (newline port) + (display " (state-" port) + (display nl-start port) + (display " action-<<ERROR>>))" port) + (newline port) + (display " (else" port) + (newline port) + (display " (state-" port) + (display no-nl-start port) + (display " action-<<ERROR>>)))" port))) + (display "))" port) + (newline port) + + ; Ecrire la fonction principale de lexage + (display " (final-lexer" port) + (newline port) + (display " (lambda ()" port) + (newline port) + (display " (init-lexeme)" port) + (newline port) + (cond ((eq? counters 'none) + (display " ((start-automaton))" port)) + ((eq? counters 'line) + (display " (let ((yyline (get-start-line)))" port) + (newline port) + (display " ((start-automaton) yyline))" port)) + ((eq? counters 'all) + (display " (let ((yyline (get-start-line))" port) + (newline port) + (display " (yycolumn (get-start-column))" port) + (newline port) + (display " (yyoffset (get-start-offset)))" port) + (newline port) + (display " ((start-automat" port) + (display "on) yyline yycolumn yyoffset))" port))) + (display "))" port) + + ; Fermer les bindings du grand letrec + (display ")" port) + (newline port) + + ; Initialiser les variables user-action-XX + (display " (set! user-action-<<EOF>>" port) + (display " (<<EOF>>-pre-action" port) + (newline port) + (display " final-lexer" port) + (display " user-getc user-ungetc))" port) + (newline port) + (display " (set! user-action-<<ERROR>>" port) + (display " (<<ERROR>>-pre-action" port) + (newline port) + (display " final-lexer" port) + (display " user-getc user-ungetc))" port) + (newline port) + (let loop ((r 0)) + (if (< r nbrules) + (let* ((str-r (number->string r)) + (blanks (out-blanks (string-length str-r)))) + (display " (set! user-action-" port) + (display str-r port) + (display " ((vector-ref rules-pre-action " port) + (display (number->string (+ (* 2 r) 1)) port) + (display ")" port) + (newline port) + (display blanks port) + (display " final-lexer " port) + (display "user-getc user-ungetc))" port) + (newline port) + (loop (+ r 1))))) + + ; Faire retourner le lexer final et fermer la table au complet + (display " final-lexer))))" port) + (newline port)))) + +; +; Fonctions necessaires a l'initialisation automatique du lexer +; + +(define out-print-driver-functions + (lambda (args-alist port) + (let ((counters (cdr (or (assq 'counters args-alist) '(z . line)))) + (table-name (cdr (assq 'table-name args-alist)))) + (display ";" port) + (newline port) + (display "; User functions" port) + (newline port) + (display ";" port) + (newline port) + (newline port) + (display "(define lexer #f)" port) + (newline port) + (newline port) + (if (not (eq? counters 'none)) + (begin + (display "(define lexer-get-line #f)" port) + (newline port) + (if (eq? counters 'all) + (begin + (display "(define lexer-get-column #f)" port) + (newline port) + (display "(define lexer-get-offset #f)" port) + (newline port))))) + (display "(define lexer-getc #f)" port) + (newline port) + (display "(define lexer-ungetc #f)" port) + (newline port) + (newline port) + (display "(define lexer-init" port) + (newline port) + (display " (lambda (input-type input)" port) + (newline port) + (display " (let ((IS (lexer-make-IS input-type input '" port) + (write counters port) + (display ")))" port) + (newline port) + (display " (set! lexer (lexer-make-lexer " port) + (display table-name port) + (display " IS))" port) + (newline port) + (if (not (eq? counters 'none)) + (begin + (display " (set! lexer-get-line (lexer-get-func-line IS))" + port) + (newline port) + (if (eq? counters 'all) + (begin + (display + " (set! lexer-get-column (lexer-get-func-column IS))" + port) + (newline port) + (display + " (set! lexer-get-offset (lexer-get-func-offset IS))" + port) + (newline port))))) + (display " (set! lexer-getc (lexer-get-func-getc IS))" port) + (newline port) + (display " (set! lexer-ungetc (lexer-get-func-ungetc IS)))))" + port) + (newline port)))) + +; +; Fonction principale +; Affiche une table ou un driver complet +; + +(define output + (lambda (args-alist + <<EOF>>-action <<ERROR>>-action rules + nl-start no-nl-start arcs acc) + (let* ((fileout (cdr (assq 'fileout args-alist))) + (port (open-output-file fileout)) + (complete-driver? (cdr (assq 'complete-driver? args-alist)))) + (if complete-driver? + (begin + (out-print-run-time-lib port) + (newline port))) + (out-print-table args-alist + <<EOF>>-action <<ERROR>>-action rules + nl-start no-nl-start arcs acc + port) + (if complete-driver? + (begin + (newline port) + (out-print-driver-functions args-alist port))) + (close-output-port port)))) |