summaryrefslogtreecommitdiff
path: root/src/guile/silex/util.scm
diff options
context:
space:
mode:
Diffstat (limited to 'src/guile/silex/util.scm')
-rw-r--r--src/guile/silex/util.scm502
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))))))))))))
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-01 08:25:51 +0000