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