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)))))))