Add SILex, for simplicity.

1 files changed, 195 insertions, 0 deletions

diff --git a/src/guile/silex/re2nfa.scm b/src/guile/silex/re2nfa.scm
new file mode 100644
index 0000000..bf7c004
--- /dev/null
+++ b/src/guile/silex/re2nfa.scm
@@ -0,0 +1,195 @@
+; 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.
+
+; Le vecteur d'etats contient la table de transition du nfa.
+; Chaque entree contient les arcs partant de l'etat correspondant.
+; Les arcs sont stockes dans une liste.
+; Chaque arc est une paire (class . destination).
+; Les caracteres d'une classe sont enumeres par ranges.
+; Les ranges sont donnes dans une liste,
+;   chaque element etant une paire (debut . fin).
+; Le symbole eps peut remplacer une classe.
+; L'acceptation est decrite par une paire (acc-if-eol . acc-if-no-eol).
+
+; Quelques variables globales
+(define r2n-counter 0)
+(define r2n-v-arcs '#(#f))
+(define r2n-v-acc '#(#f))
+(define r2n-v-len 1)
+
+; Initialisation des variables globales
+(define r2n-init
+  (lambda ()
+    (set! r2n-counter 0)
+    (set! r2n-v-arcs (vector '()))
+    (set! r2n-v-acc (vector #f))
+    (set! r2n-v-len 1)))
+
+; Agrandissement des vecteurs
+(define r2n-extend-v
+  (lambda ()
+    (let* ((new-len (* 2 r2n-v-len))
+	   (new-v-arcs (make-vector new-len '()))
+	   (new-v-acc (make-vector new-len #f)))
+      (let loop ((i 0))
+	(if (< i r2n-v-len)
+	    (begin
+	      (vector-set! new-v-arcs i (vector-ref r2n-v-arcs i))
+	      (vector-set! new-v-acc i (vector-ref r2n-v-acc i))
+	      (loop (+ i 1)))))
+      (set! r2n-v-arcs new-v-arcs)
+      (set! r2n-v-acc new-v-acc)
+      (set! r2n-v-len new-len))))
+
+; Finalisation des vecteurs
+(define r2n-finalize-v
+  (lambda ()
+    (let* ((new-v-arcs (make-vector r2n-counter))
+	   (new-v-acc (make-vector r2n-counter)))
+      (let loop ((i 0))
+	(if (< i r2n-counter)
+	    (begin
+	      (vector-set! new-v-arcs i (vector-ref r2n-v-arcs i))
+	      (vector-set! new-v-acc i (vector-ref r2n-v-acc i))
+	      (loop (+ i 1)))))
+      (set! r2n-v-arcs new-v-arcs)
+      (set! r2n-v-acc new-v-acc)
+      (set! r2n-v-len r2n-counter))))
+
+; Creation d'etat
+(define r2n-get-state
+  (lambda (acc)
+    (if (= r2n-counter r2n-v-len)
+	(r2n-extend-v))
+    (let ((state r2n-counter))
+      (set! r2n-counter (+ r2n-counter 1))
+      (vector-set! r2n-v-acc state (or acc (cons #f #f)))
+      state)))
+
+; Ajout d'un arc
+(define r2n-add-arc
+  (lambda (start chars end)
+    (vector-set! r2n-v-arcs
+		 start
+		 (cons (cons chars end) (vector-ref r2n-v-arcs start)))))
+
+; Construction de l'automate a partir des regexp
+(define r2n-build-epsilon
+  (lambda (re start end)
+    (r2n-add-arc start 'eps end)))
+
+(define r2n-build-or
+  (lambda (re start end)
+    (let ((re1 (get-re-attr1 re))
+	  (re2 (get-re-attr2 re)))
+      (r2n-build-re re1 start end)
+      (r2n-build-re re2 start end))))
+
+(define r2n-build-conc
+  (lambda (re start end)
+    (let* ((re1 (get-re-attr1 re))
+	   (re2 (get-re-attr2 re))
+	   (inter (r2n-get-state #f)))
+      (r2n-build-re re1 start inter)
+      (r2n-build-re re2 inter end))))
+
+(define r2n-build-star
+  (lambda (re start end)
+    (let* ((re1 (get-re-attr1 re))
+	   (inter1 (r2n-get-state #f))
+	   (inter2 (r2n-get-state #f)))
+      (r2n-add-arc start 'eps inter1)
+      (r2n-add-arc inter1 'eps inter2)
+      (r2n-add-arc inter2 'eps end)
+      (r2n-build-re re1 inter2 inter1))))
+
+(define r2n-build-plus
+  (lambda (re start end)
+    (let* ((re1 (get-re-attr1 re))
+	   (inter1 (r2n-get-state #f))
+	   (inter2 (r2n-get-state #f)))
+      (r2n-add-arc start 'eps inter1)
+      (r2n-add-arc inter2 'eps inter1)
+      (r2n-add-arc inter2 'eps end)
+      (r2n-build-re re1 inter1 inter2))))
+
+(define r2n-build-question
+  (lambda (re start end)
+    (let ((re1 (get-re-attr1 re)))
+      (r2n-add-arc start 'eps end)
+      (r2n-build-re re1 start end))))
+
+(define r2n-build-class
+  (lambda (re start end)
+    (let ((class (get-re-attr1 re)))
+      (r2n-add-arc start class end))))
+
+(define r2n-build-char
+  (lambda (re start end)
+    (let* ((c (get-re-attr1 re))
+	   (class (list (cons c c))))
+      (r2n-add-arc start class end))))
+
+(define r2n-build-re
+  (let ((sub-function-v (vector r2n-build-epsilon
+				r2n-build-or
+				r2n-build-conc
+				r2n-build-star
+				r2n-build-plus
+				r2n-build-question
+				r2n-build-class
+				r2n-build-char)))
+    (lambda (re start end)
+      (let* ((re-type (get-re-type re))
+	     (sub-f (vector-ref sub-function-v re-type)))
+	(sub-f re start end)))))
+
+; Construction de l'automate relatif a une regle
+(define r2n-build-rule
+  (lambda (rule ruleno nl-start no-nl-start)
+    (let* ((re (get-rule-regexp rule))
+	   (bol? (get-rule-bol? rule))
+	   (eol? (get-rule-eol? rule))
+	   (rule-start (r2n-get-state #f))
+	   (rule-end (r2n-get-state (if eol?
+					(cons ruleno #f)
+					(cons ruleno ruleno)))))
+      (r2n-build-re re rule-start rule-end)
+      (r2n-add-arc nl-start 'eps rule-start)
+      (if (not bol?)
+	  (r2n-add-arc no-nl-start 'eps rule-start)))))
+
+; Construction de l'automate complet
+(define re2nfa
+  (lambda (rules)
+    (let ((nb-of-rules (vector-length rules)))
+      (r2n-init)
+      (let* ((nl-start (r2n-get-state #f))
+	     (no-nl-start (r2n-get-state #f)))
+	(let loop ((i 0))
+	  (if (< i nb-of-rules)
+	      (begin
+		(r2n-build-rule (vector-ref rules i)
+				i
+				nl-start
+				no-nl-start)
+		(loop (+ i 1)))))
+	(r2n-finalize-v)
+	(let ((v-arcs r2n-v-arcs)
+	      (v-acc r2n-v-acc))
+	  (r2n-init)
+	  (list nl-start no-nl-start v-arcs v-acc))))))