Add SILex, for simplicity.

1 files changed, 226 insertions, 0 deletions

diff --git a/src/guile/silex/main.scm b/src/guile/silex/main.scm
new file mode 100644
index 0000000..f157334
--- /dev/null
+++ b/src/guile/silex/main.scm
@@ -0,0 +1,226 @@
+; 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.
+
+;
+; Gestion d'erreurs
+;
+
+(define lex-exit-continuation #f)
+(define lex-unwind-protect-list '())
+(define lex-error-filename #f)
+
+(define lex-unwind-protect
+  (lambda (proc)
+    (set! lex-unwind-protect-list (cons proc lex-unwind-protect-list))))
+
+(define lex-error
+  (lambda (line column . l)
+    (let* ((linestr (if line   (number->string line)   #f))
+	   (colstr  (if column (number->string column) #f))
+	   (namelen (string-length lex-error-filename))
+	   (linelen (if line   (string-length linestr) -1))
+	   (collen  (if column (string-length colstr)  -1))
+	   (totallen (+ namelen 1 linelen 1 collen 2)))
+      (display "Lex error:")
+      (newline)
+      (display lex-error-filename)
+      (if line
+	  (begin
+	    (display ":")
+	    (display linestr)))
+      (if column
+	  (begin
+	    (display ":")
+	    (display colstr)))
+      (display ": ")
+      (let loop ((l l))
+	(if (null? l)
+	    (newline)
+	    (let ((item (car l)))
+	      (display item)
+	      (if (equal? '#\newline item)
+		  (let loop2 ((i totallen))
+		    (if (> i 0)
+			(begin
+			  (display #\space)
+			  (loop2 (- i 1))))))
+	      (loop (cdr l)))))
+      (newline)
+      (let loop ((l lex-unwind-protect-list))
+	(if (pair? l)
+	    (begin
+	      ((car l))
+	      (loop (cdr l)))))
+      (lex-exit-continuation #f))))
+
+
+
+
+;
+; Decoupage des arguments
+;
+
+(define lex-recognized-args
+  '(complete-driver?
+    filein
+    table-name
+    fileout
+    counters
+    portable
+    code
+    pp))
+
+(define lex-valued-args
+  '(complete-driver?
+    filein
+    table-name
+    fileout
+    counters))
+
+(define lex-parse-args
+  (lambda (args)
+    (let loop ((args args))
+      (if (null? args)
+	  '()
+	  (let ((sym (car args)))
+	    (cond ((not (symbol? sym))
+		   (lex-error #f #f "bad option list."))
+		  ((not (memq sym lex-recognized-args))
+		   (lex-error #f #f "unrecognized option \"" sym "\"."))
+		  ((not (memq sym lex-valued-args))
+		   (cons (cons sym '()) (loop (cdr args))))
+		  ((null? (cdr args))
+		   (lex-error #f #f "the value of \"" sym "\" not specified."))
+		  (else
+		   (cons (cons sym (cadr args)) (loop (cddr args))))))))))
+
+
+
+
+;
+; Differentes etapes de la fabrication de l'automate
+;
+
+(define lex1
+  (lambda (filein)
+;     (display "lex1: ") (write (get-internal-run-time)) (newline)
+    (parser filein)))
+
+(define lex2
+  (lambda (filein)
+    (let* ((result (lex1 filein))
+	   (<<EOF>>-action (car result))
+	   (<<ERROR>>-action (cadr result))
+	   (rules (cddr result)))
+;       (display "lex2: ") (write (get-internal-run-time)) (newline)
+      (append (list <<EOF>>-action <<ERROR>>-action rules)
+	      (re2nfa rules)))))
+
+(define lex3
+  (lambda (filein)
+    (let* ((result (lex2 filein))
+	   (<<EOF>>-action   (list-ref result 0))
+	   (<<ERROR>>-action (list-ref result 1))
+	   (rules            (list-ref result 2))
+	   (nl-start         (list-ref result 3))
+	   (no-nl-start      (list-ref result 4))
+	   (arcs             (list-ref result 5))
+	   (acc              (list-ref result 6)))
+;       (display "lex3: ") (write (get-internal-run-time)) (newline)
+      (append (list <<EOF>>-action <<ERROR>>-action rules)
+	      (noeps nl-start no-nl-start arcs acc)))))
+
+(define lex4
+  (lambda (filein)
+    (let* ((result (lex3 filein))
+	   (<<EOF>>-action   (list-ref result 0))
+	   (<<ERROR>>-action (list-ref result 1))
+	   (rules            (list-ref result 2))
+	   (nl-start         (list-ref result 3))
+	   (no-nl-start      (list-ref result 4))
+	   (arcs             (list-ref result 5))
+	   (acc              (list-ref result 6)))
+;       (display "lex4: ") (write (get-internal-run-time)) (newline)
+      (append (list <<EOF>>-action <<ERROR>>-action rules)
+	      (sweep nl-start no-nl-start arcs acc)))))
+
+(define lex5
+  (lambda (filein)
+    (let* ((result (lex4 filein))
+	   (<<EOF>>-action   (list-ref result 0))
+	   (<<ERROR>>-action (list-ref result 1))
+	   (rules            (list-ref result 2))
+	   (nl-start         (list-ref result 3))
+	   (no-nl-start      (list-ref result 4))
+	   (arcs             (list-ref result 5))
+	   (acc              (list-ref result 6)))
+;       (display "lex5: ") (write (get-internal-run-time)) (newline)
+      (append (list <<EOF>>-action <<ERROR>>-action rules)
+	      (nfa2dfa nl-start no-nl-start arcs acc)))))
+
+(define lex6
+  (lambda (args-alist)
+    (let* ((filein           (cdr (assq 'filein args-alist)))
+	   (result           (lex5 filein))
+	   (<<EOF>>-action   (list-ref result 0))
+	   (<<ERROR>>-action (list-ref result 1))
+	   (rules            (list-ref result 2))
+	   (nl-start         (list-ref result 3))
+	   (no-nl-start      (list-ref result 4))
+	   (arcs             (list-ref result 5))
+	   (acc              (list-ref result 6)))
+;       (display "lex6: ") (write (get-internal-run-time)) (newline)
+      (prep-set-rules-yytext? rules)
+      (output args-alist
+	      <<EOF>>-action <<ERROR>>-action
+	      rules nl-start no-nl-start arcs acc)
+      #t)))
+
+(define lex7
+  (lambda (args)
+    (call-with-current-continuation
+     (lambda (exit)
+       (set! lex-exit-continuation exit)
+       (set! lex-unwind-protect-list '())
+       (set! lex-error-filename (cadr (memq 'filein args)))
+       (let* ((args-alist (lex-parse-args args))
+	      (result (lex6 args-alist)))
+; 	 (display "lex7: ") (write (get-internal-run-time)) (newline)
+	 result)))))
+
+
+
+
+;
+; Fonctions principales
+;
+
+(define lex
+  (lambda (filein fileout . options)
+    (lex7 (append (list 'complete-driver? #t
+			'filein filein
+			'table-name "lexer-default-table"
+			'fileout fileout)
+		  options))))
+
+(define lex-tables
+  (lambda (filein table-name fileout . options)
+    (lex7 (append (list 'complete-driver? #f
+			'filein filein
+			'table-name table-name
+			'fileout fileout)
+		  options))))