aboutsummaryrefslogtreecommitdiff
path: root/src/guile/silex/prep.scm
diff options
context:
space:
mode:
authorLudovic Courtès2008-01-18 12:36:59 +0100
committerLudovic Courtès2008-01-18 12:36:59 +0100
commit7efd05778cddec0293e0d48199f3aeee2aad6178 (patch)
tree806be6fc0190c511374f15332c4465e27048b111 /src/guile/silex/prep.scm
parenta3b7dfffbda5fe148920c7556244ab35b99109a5 (diff)
downloadskribilo-7efd05778cddec0293e0d48199f3aeee2aad6178.tar.gz
skribilo-7efd05778cddec0293e0d48199f3aeee2aad6178.tar.lz
skribilo-7efd05778cddec0293e0d48199f3aeee2aad6178.zip
Add SILex, for simplicity.
Diffstat (limited to 'src/guile/silex/prep.scm')
-rw-r--r--src/guile/silex/prep.scm130
1 files changed, 130 insertions, 0 deletions
diff --git a/src/guile/silex/prep.scm b/src/guile/silex/prep.scm
new file mode 100644
index 0000000..ca13e78
--- /dev/null
+++ b/src/guile/silex/prep.scm
@@ -0,0 +1,130 @@
+; 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.
+
+;
+; 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)))))))