diff options
author | Ludovic Courtès | 2008-01-18 12:36:59 +0100 |
---|---|---|
committer | Ludovic Courtès | 2008-01-18 12:36:59 +0100 |
commit | 7efd05778cddec0293e0d48199f3aeee2aad6178 (patch) | |
tree | 806be6fc0190c511374f15332c4465e27048b111 /src/guile/silex/util.scm | |
parent | a3b7dfffbda5fe148920c7556244ab35b99109a5 (diff) | |
download | skribilo-7efd05778cddec0293e0d48199f3aeee2aad6178.tar.gz skribilo-7efd05778cddec0293e0d48199f3aeee2aad6178.tar.lz skribilo-7efd05778cddec0293e0d48199f3aeee2aad6178.zip |
Add SILex, for simplicity.
Diffstat (limited to 'src/guile/silex/util.scm')
-rw-r--r-- | src/guile/silex/util.scm | 502 |
1 files changed, 502 insertions, 0 deletions
diff --git a/src/guile/silex/util.scm b/src/guile/silex/util.scm new file mode 100644 index 0000000..3259c06 --- /dev/null +++ b/src/guile/silex/util.scm @@ -0,0 +1,502 @@ +; 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. + +; +; 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)))))))))))) |