diff options
Diffstat (limited to 'src/guile/silex/main.scm')
| -rw-r--r-- | src/guile/silex/main.scm | 226 |
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)))) |