; 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.
;
; Fonctions auxilliaires du lexer
;
(define parse-spec-char
(lambda (lexeme line column)
(make-tok char-tok lexeme line column newline-ch)))
(define parse-digits-char
(lambda (lexeme line column)
(let* ((num (substring lexeme 1 (string-length lexeme)))
(n (string->number num)))
(make-tok char-tok lexeme line column n))))
(define parse-quoted-char
(lambda (lexeme line column)
(let ((c (string-ref lexeme 1)))
(make-tok char-tok lexeme line column (char->integer c)))))
(define parse-ordinary-char
(lambda (lexeme line column)
(let ((c (string-ref lexeme 0)))
(make-tok char-tok lexeme line column (char->integer c)))))
(define string-downcase
(lambda (s)
(let* ((l (string->list s))
(ld (map char-downcase l)))
(list->string ld))))
(define extract-id
(lambda (s)
(let ((len (string-length s)))
(substring s 1 (- len 1)))))
(define parse-id
(lambda (lexeme line column)
(make-tok id-tok lexeme line column (string-downcase lexeme) lexeme)))
(define parse-id-ref
(lambda (lexeme line column)
(let* ((orig-name (extract-id lexeme))
(name (string-downcase orig-name)))
(make-tok subst-tok lexeme line column name orig-name))))
(define parse-power-m
(lambda (lexeme line column)
(let* ((len (string-length lexeme))
(substr (substring lexeme 1 (- len 1)))
(m (string->number substr))
(range (cons m m)))
(make-tok power-tok lexeme line column range))))
(define parse-power-m-inf
(lambda (lexeme line column)
(let* ((len (string-length lexeme))
(substr (substring lexeme 1 (- len 2)))
(m (string->number substr))
(range (cons m 'inf)))
(make-tok power-tok lexeme line column range))))
(define parse-power-m-n
(lambda (lexeme line column)
(let ((len (string-length lexeme)))
(let loop ((comma 2))
(if (char=? (string-ref lexeme comma) #\,)
(let* ((sub1 (substring lexeme 1 comma))
(sub2 (substring lexeme (+ comma 1) (- len 1)))
(m (string->number sub1))
(n (string->number sub2))
(range (cons m n)))
(make-tok power-tok lexeme line column range))
(loop (+ comma 1)))))))
;
; Lexer generique
;
(define lexer-raw #f)
(define lexer-stack '())
(define lexer-alist #f)
(define lexer-buffer #f)
(define lexer-buffer-empty? #t)
(define lexer-history '())
(define lexer-history-interp #f)
(define init-lexer
(lambda (port)
(let* ((IS (lexer-make-IS 'port port 'all))
(action-lexer (lexer-make-lexer action-tables IS))
(class-lexer (lexer-make-lexer class-tables IS))
(macro-lexer (lexer-make-lexer macro-tables IS))
(regexp-lexer (lexer-make-lexer regexp-tables IS))
(string-lexer (lexer-make-lexer string-tables IS)))
(set! lexer-raw #f)
(set! lexer-stack '())
(set! lexer-alist
(list (cons 'action action-lexer)
(cons 'class class-lexer)
(cons 'macro macro-lexer)
(cons 'regexp regexp-lexer)
(cons 'string string-lexer)))
(set! lexer-buffer-empty? #t)
(set! lexer-history '()))))
; Lexer brut
; S'assurer qu'il n'y a pas de risque de changer de
; lexer quand le buffer est rempli
(define push-lexer
(lambda (name)
(set! lexer-stack (cons lexer-raw lexer-stack))
(set! lexer-raw (cdr (assq name lexer-alist)))))
(define pop-lexer
(lambda ()
(set! lexer-raw (car lexer-stack))
(set! lexer-stack (cdr lexer-stack))))
; Traite le "unget" (capacite du unget: 1)
(define lexer2
(lambda ()
(if lexer-buffer-empty?
(lexer-raw)
(begin
(set! lexer-buffer-empty? #t)
lexer-buffer))))
(define lexer2-unget
(lambda (tok)
(set! lexer-buffer tok)
(set! lexer-buffer-empty? #f)))
; Traite l'historique
(define lexer
(lambda ()
(let* ((tok (lexer2))
(tok-lexeme (get-tok-lexeme tok))
(hist-lexeme (if lexer-history-interp
(blank-translate tok-lexeme)
tok-lexeme)))
(set! lexer-history (cons hist-lexeme lexer-history))
tok)))
(define lexer-unget
(lambda (tok)
(set! lexer-history (cdr lexer-history))
(lexer2-unget tok)))
(define lexer-set-blank-history
(lambda (b)
(set! lexer-history-interp b)))
(define blank-translate
(lambda (s)
(let ((ss (string-copy s)))
(let loop ((i (- (string-length ss) 1)))
(cond ((< i 0)
ss)
((char=? (string-ref ss i) (integer->char tab-ch))
(loop (- i 1)))
((char=? (string-ref ss i) #\newline)
(loop (- i 1)))
(else
(string-set! ss i #\space)
(loop (- i 1))))))))
(define lexer-get-history
(lambda ()
(let* ((rightlist (reverse lexer-history))
(str (apply string-append rightlist))
(strlen (string-length str))
(str2 (if (and (> strlen 0)
(char=? (string-ref str (- strlen 1)) #\newline))
str
(string-append str (string #\newline)))))
(set! lexer-history '())
str2)))
;
; Traitement des listes de tokens
;
(define de-anchor-tokens
(let ((not-anchor-toks (make-dispatch-table number-of-tokens
(list (cons caret-tok #f)
(cons dollar-tok #f)
(cons <<EOF>>-tok #f)
(cons <<ERROR>>-tok #f))
#t)))
(lambda (tok-list)
(if (null? tok-list)
'()
(let* ((tok (car tok-list))
(tok-type (get-tok-type tok))
(toks (cdr tok-list))
(new-toks (de-anchor-tokens toks)))
(cond ((vector-ref not-anchor-toks tok-type)
(cons tok new-toks))
((or (= tok-type caret-tok) (= tok-type dollar-tok))
(let* ((line (get-tok-line tok))
(column (get-tok-column tok))
(attr (if (= tok-type caret-tok) caret-ch dollar-ch))
(new-tok (make-tok char-tok "" line column attr)))
(cons new-tok new-toks)))
((= tok-type <<EOF>>-tok)
(lex-error (get-tok-line tok)
(get-tok-column tok)
"the <<EOF>> anchor must be used alone"
" and only after %%."))
((= tok-type <<ERROR>>-tok)
(lex-error (get-tok-line tok)
(get-tok-column tok)
"the <<ERROR>> anchor must be used alone"
" and only after %%."))))))))
(define strip-end
(lambda (l)
(if (null? (cdr l))
'()
(cons (car l) (strip-end (cdr l))))))
(define extract-anchors
(lambda (tok-list)
(let* ((tok1 (car tok-list))
(line (get-tok-line tok1))
(tok1-type (get-tok-type tok1)))
(cond ((and (= tok1-type <<EOF>>-tok) (null? (cdr tok-list)))
(make-rule line #t #f #f #f '() #f))
((and (= tok1-type <<ERROR>>-tok) (null? (cdr tok-list)))
(make-rule line #f #t #f #f '() #f))
(else
(let* ((bol? (= tok1-type caret-tok))
(tok-list2 (if bol? (cdr tok-list) tok-list)))
(if (null? tok-list2)
(make-rule line #f #f bol? #f tok-list2 #f)
(let* ((len (length tok-list2))
(tok2 (list-ref tok-list2 (- len 1)))
(tok2-type (get-tok-type tok2))
(eol? (= tok2-type dollar-tok))
(tok-list3 (if eol?
(strip-end tok-list2)
tok-list2)))
(make-rule line #f #f bol? eol? tok-list3 #f)))))))))
(define char-list->conc
(lambda (char-list)
(if (null? char-list)
(make-re epsilon-re)
(let loop ((cl char-list))
(let* ((c (car cl))
(cl2 (cdr cl)))
(if (null? cl2)
(make-re char-re c)
(make-re conc-re (make-re char-re c) (loop cl2))))))))
(define parse-tokens-atom
(let ((action-table
(make-dispatch-table
number-of-tokens
(list (cons lpar-tok
(lambda (tok tok-list macros)
(parse-tokens-sub tok-list macros)))
(cons dot-tok
(lambda (tok tok-list macros)
(cons (make-re class-re dot-class) (cdr tok-list))))
(cons subst-tok
(lambda (tok tok-list macros)
(let* ((name (get-tok-attr tok))
(ass (assoc name macros)))
(if ass
(cons (cdr ass) (cdr tok-list))
(lex-error (get-tok-line tok)
(get-tok-column tok)
"unknown macro \""
(get-tok-2nd-attr tok)
"\".")))))
(cons char-tok
(lambda (tok tok-list macros)
(let ((c (get-tok-attr tok)))
(cons (make-re char-re c) (cdr tok-list)))))
(cons class-tok
(lambda (tok tok-list macros)
(let ((class (get-tok-attr tok)))
(cons (make-re class-re class) (cdr tok-list)))))
(cons string-tok
(lambda (tok tok-list macros)
(let* ((char-list (get-tok-attr tok))
(re (char-list->conc char-list)))
(cons re (cdr tok-list))))))
(lambda (tok tok-list macros)
(lex-error (get-tok-line tok)
(get-tok-column tok)
"syntax error in regular expression.")))))
(lambda (tok-list macros)
(let* ((tok (car tok-list))
(tok-type (get-tok-type tok))
(action (vector-ref action-table tok-type)))
(action tok tok-list macros)))))
(define check-power-tok
(lambda (tok)
(let* ((range (get-tok-attr tok))
(start (car range))
(end (cdr range)))
(if (or (eq? 'inf end) (<= start end))
range
(lex-error (get-tok-line tok)
(get-tok-column tok)
"incorrect power specification.")))))
(define power->star-plus
(lambda (re range)
(power->star-plus-rec re (car range) (cdr range))))
(define power->star-plus-rec
(lambda (re start end)
(cond ((eq? end 'inf)
(cond ((= start 0)
(make-re star-re re))
((= start 1)
(make-re plus-re re))
(else
(make-re conc-re
re
(power->star-plus-rec re (- start 1) 'inf)))))
((= start 0)
(cond ((= end 0)
(make-re epsilon-re))
((= end 1)
(make-re question-re re))
(else
(make-re question-re
(power->star-plus-rec re 1 end)))))
((= start 1)
(if (= end 1)
re
(make-re conc-re re (power->star-plus-rec re 0 (- end 1)))))
(else
(make-re conc-re
re
(power->star-plus-rec re (- start 1) (- end 1)))))))
(define parse-tokens-fact
(let ((not-op-toks (make-dispatch-table number-of-tokens
(list (cons question-tok #f)
(cons plus-tok #f)
(cons star-tok #f)
(cons power-tok #f))
#t)))
(lambda (tok-list macros)
(let* ((result (parse-tokens-atom tok-list macros))
(re (car result))
(tok-list2 (cdr result)))
(let loop ((re re) (tok-list3 tok-list2))
(let* ((tok (car tok-list3))
(tok-type (get-tok-type tok)))
(cond ((vector-ref not-op-toks tok-type)
(cons re tok-list3))
((= tok-type question-tok)
(loop (make-re question-re re) (cdr tok-list3)))
((= tok-type plus-tok)
(loop (make-re plus-re re) (cdr tok-list3)))
((= tok-type star-tok)
(loop (make-re star-re re) (cdr tok-list3)))
((= tok-type power-tok)
(loop (power->star-plus re (check-power-tok tok))
(cdr tok-list3))))))))))
(define parse-tokens-conc
(lambda (tok-list macros)
(let* ((result1 (parse-tokens-fact tok-list macros))
(re1 (car result1))
(tok-list2 (cdr result1))
(tok (car tok-list2))
(tok-type (get-tok-type tok)))
(cond ((or (= tok-type pipe-tok)
(= tok-type rpar-tok))
result1)
(else ; Autres facteurs
(let* ((result2 (parse-tokens-conc tok-list2 macros))
(re2 (car result2))
(tok-list3 (cdr result2)))
(cons (make-re conc-re re1 re2) tok-list3)))))))
(define parse-tokens-or
(lambda (tok-list macros)
(let* ((result1 (parse-tokens-conc tok-list macros))
(re1 (car result1))
(tok-list2 (cdr result1))
(tok (car tok-list2))
(tok-type (get-tok-type tok)))
(cond ((= tok-type pipe-tok)
(let* ((tok-list3 (cdr tok-list2))
(result2 (parse-tokens-or tok-list3 macros))
(re2 (car result2))
(tok-list4 (cdr result2)))
(cons (make-re or-re re1 re2) tok-list4)))
(else ; rpar-tok
result1)))))
(define parse-tokens-sub
(lambda (tok-list macros)
(let* ((tok-list2 (cdr tok-list)) ; Manger le lpar-tok
(result (parse-tokens-or tok-list2 macros))
(re (car result))
(tok-list3 (cdr result))
(tok-list4 (cdr tok-list3))) ; Manger le rpar-tok
(cons re tok-list4))))
(define parse-tokens-match
(lambda (tok-list line)
(let loop ((tl tok-list) (count 0))
(if (null? tl)
(if (> count 0)
(lex-error line
#f
"mismatched parentheses."))
(let* ((tok (car tl))
(tok-type (get-tok-type tok)))
(cond ((= tok-type lpar-tok)
(loop (cdr tl) (+ count 1)))
((= tok-type rpar-tok)
(if (zero? count)
(lex-error line
#f
"mismatched parentheses."))
(loop (cdr tl) (- count 1)))
(else
(loop (cdr tl) count))))))))
; Ne traite pas les anchors
(define parse-tokens
(lambda (tok-list macros)
(if (null? tok-list)
(make-re epsilon-re)
(let ((line (get-tok-line (car tok-list))))
(parse-tokens-match tok-list line)
(let* ((begin-par (make-tok lpar-tok "" line 1))
(end-par (make-tok rpar-tok "" line 1)))
(let* ((tok-list2 (append (list begin-par)
tok-list
(list end-par)))
(result (parse-tokens-sub tok-list2 macros)))
(car result))))))) ; (cdr result) == () obligatoirement
(define tokens->regexp
(lambda (tok-list macros)
(let ((tok-list2 (de-anchor-tokens tok-list)))
(parse-tokens tok-list2 macros))))
(define tokens->rule
(lambda (tok-list macros)
(let* ((rule (extract-anchors tok-list))
(tok-list2 (get-rule-regexp rule))
(tok-list3 (de-anchor-tokens tok-list2))
(re (parse-tokens tok-list3 macros)))
(set-rule-regexp rule re)
rule)))
; Retourne une paire: <<EOF>>-action et vecteur des regles ordinaires
(define adapt-rules
(lambda (rules)
(let loop ((r rules) (revr '()) (<<EOF>>-action #f) (<<ERROR>>-action #f))
(if (null? r)
(cons (or <<EOF>>-action default-<<EOF>>-action)
(cons (or <<ERROR>>-action default-<<ERROR>>-action)
(list->vector (reverse revr))))
(let ((r1 (car r)))
(cond ((get-rule-eof? r1)
(if <<EOF>>-action
(lex-error (get-rule-line r1)
#f
"the <<EOF>> anchor can be "
"used at most once.")
(loop (cdr r)
revr
(get-rule-action r1)
<<ERROR>>-action)))
((get-rule-error? r1)
(if <<ERROR>>-action
(lex-error (get-rule-line r1)
#f
"the <<ERROR>> anchor can be "
"used at most once.")
(loop (cdr r)
revr
<<EOF>>-action
(get-rule-action r1))))
(else
(loop (cdr r)
(cons r1 revr)
<<EOF>>-action
<<ERROR>>-action))))))))
;
; Analyseur de fichier lex
;
(define parse-hv-blanks
(lambda ()
(let* ((tok (lexer))
(tok-type (get-tok-type tok)))
(if (or (= tok-type hblank-tok)
(= tok-type vblank-tok))
(parse-hv-blanks)
(lexer-unget tok)))))
(define parse-class-range
(lambda ()
(let* ((tok (lexer))
(tok-type (get-tok-type tok)))
(cond ((= tok-type char-tok)
(let* ((c (get-tok-attr tok))
(tok2 (lexer))
(tok2-type (get-tok-type tok2)))
(if (not (= tok2-type minus-tok))
(begin
(lexer-unget tok2)
(cons c c))
(let* ((tok3 (lexer))
(tok3-type (get-tok-type tok3)))
(cond ((= tok3-type char-tok)
(let ((c2 (get-tok-attr tok3)))
(if (> c c2)
(lex-error (get-tok-line tok3)
(get-tok-column tok3)
"bad range specification in "
"character class;"
#\newline
"the start character is "
"higher than the end one.")
(cons c c2))))
((or (= tok3-type rbrack-tok)
(= tok3-type minus-tok))
(lex-error (get-tok-line tok3)
(get-tok-column tok3)
"bad range specification in "
"character class; a specification"
#\newline
"like \"-x\", \"x--\" or \"x-]\" has "
"been used."))
((= tok3-type eof-tok)
(lex-error (get-tok-line tok3)
#f
"eof of file found while parsing "
"a character class.")))))))
((= tok-type minus-tok)
(lex-error (get-tok-line tok)
(get-tok-column tok)
"bad range specification in character class; a "
"specification"
#\newline
"like \"-x\", \"x--\" or \"x-]\" has been used."))
((= tok-type rbrack-tok)
#f)
((= tok-type eof-tok)
(lex-error (get-tok-line tok)
#f
"eof of file found while parsing "
"a character class."))))))
(define parse-class
(lambda (initial-class negative-class? line column)
(push-lexer 'class)
(let loop ((class initial-class))
(let ((new-range (parse-class-range)))
(if new-range
(loop (class-union (list new-range) class))
(let ((class (if negative-class?
(class-compl class)
class)))
(pop-lexer)
(make-tok class-tok "" line column class)))))))
(define parse-string
(lambda (line column)
(push-lexer 'string)
(let ((char-list (let loop ()
(let* ((tok (lexer))
(tok-type (get-tok-type tok)))
(cond ((= tok-type char-tok)
(cons (get-tok-attr tok) (loop)))
((= tok-type doublequote-tok)
(pop-lexer)
'())
(else ; eof-tok
(lex-error (get-tok-line tok)
#f
"end of file found while "
"parsing a string.")))))))
(make-tok string-tok "" line column char-list))))
(define parse-regexp
(let* ((end-action
(lambda (tok loop)
(lexer-unget tok)
(pop-lexer)
(lexer-set-blank-history #f)
`()))
(action-table
(make-dispatch-table
number-of-tokens
(list (cons eof-tok end-action)
(cons hblank-tok end-action)
(cons vblank-tok end-action)
(cons lbrack-tok
(lambda (tok loop)
(let ((tok1 (parse-class (list)
#f
(get-tok-line tok)
(get-tok-column tok))))
(cons tok1 (loop)))))
(cons lbrack-rbrack-tok
(lambda (tok loop)
(let ((tok1 (parse-class
(list (cons rbrack-ch rbrack-ch))
#f
(get-tok-line tok)
(get-tok-column tok))))
(cons tok1 (loop)))))
(cons lbrack-caret-tok
(lambda (tok loop)
(let ((tok1 (parse-class (list)
#t
(get-tok-line tok)
(get-tok-column tok))))
(cons tok1 (loop)))))
(cons lbrack-minus-tok
(lambda (tok loop)
(let ((tok1 (parse-class
(list (cons minus-ch minus-ch))
#f
(get-tok-line tok)
(get-tok-column tok))))
(cons tok1 (loop)))))
(cons doublequote-tok
(lambda (tok loop)
(let ((tok1 (parse-string (get-tok-line tok)
(get-tok-column tok))))
(cons tok1 (loop)))))
(cons illegal-tok
(lambda (tok loop)
(lex-error (get-tok-line tok)
(get-tok-column tok)
"syntax error in macro reference."))))
(lambda (tok loop)
(cons tok (loop))))))
(lambda ()
(push-lexer 'regexp)
(lexer-set-blank-history #t)
(parse-hv-blanks)
(let loop ()
(let* ((tok (lexer))
(tok-type (get-tok-type tok))
(action (vector-ref action-table tok-type)))
(action tok loop))))))
(define parse-ws1-regexp ; Exige un blanc entre le nom et la RE d'une macro
(lambda ()
(let* ((tok (lexer))
(tok-type (get-tok-type tok)))
(cond ((or (= tok-type hblank-tok) (= tok-type vblank-tok))
(parse-regexp))
(else ; percent-percent-tok, id-tok ou illegal-tok
(lex-error (get-tok-line tok)
(get-tok-column tok)
"white space expected."))))))
(define parse-macro
(lambda (macros)
(push-lexer 'macro)
(parse-hv-blanks)
(let* ((tok (lexer))
(tok-type (get-tok-type tok)))
(cond ((= tok-type id-tok)
(let* ((name (get-tok-attr tok))
(ass (assoc name macros)))
(if ass
(lex-error (get-tok-line tok)
(get-tok-column tok)
"the macro \""
(get-tok-2nd-attr tok)
"\" has already been defined.")
(let* ((tok-list (parse-ws1-regexp))
(regexp (tokens->regexp tok-list macros)))
(pop-lexer)
(cons name regexp)))))
((= tok-type percent-percent-tok)
(pop-lexer)
#f)
((= tok-type illegal-tok)
(lex-error (get-tok-line tok)
(get-tok-column tok)
"macro name expected."))
((= tok-type eof-tok)
(lex-error (get-tok-line tok)
#f
"end of file found before %%."))))))
(define parse-macros
(lambda ()
(let loop ((macros '()))
(let ((macro (parse-macro macros)))
(if macro
(loop (cons macro macros))
macros)))))
(define parse-action-end
(lambda (<<EOF>>-action? <<ERROR>>-action? action?)
(let ((act (lexer-get-history)))
(cond (action?
act)
(<<EOF>>-action?
(string-append act default-<<EOF>>-action))
(<<ERROR>>-action?
(string-append act default-<<ERROR>>-action))
(else
(string-append act default-action))))))
(define parse-action
(lambda (<<EOF>>-action? <<ERROR>>-action?)
(push-lexer 'action)
(let loop ((action? #f))
(let* ((tok (lexer))
(tok-type (get-tok-type tok)))
(cond ((= tok-type char-tok)
(loop #t))
((= tok-type hblank-tok)
(loop action?))
((= tok-type vblank-tok)
(push-lexer 'regexp)
(let* ((tok (lexer))
(tok-type (get-tok-type tok))
(bidon (lexer-unget tok)))
(pop-lexer)
(if (or (= tok-type hblank-tok)
(= tok-type vblank-tok))
(loop action?)
(begin
(pop-lexer)
(parse-action-end <<EOF>>-action?
<<ERROR>>-action?
action?)))))
(else ; eof-tok
(lexer-unget tok)
(pop-lexer)
(parse-action-end <<EOF>>-action?
<<ERROR>>-action?
action?)))))))
(define parse-rule
(lambda (macros)
(let ((tok-list (parse-regexp)))
(if (null? tok-list)
#f
(let* ((rule (tokens->rule tok-list macros))
(action
(parse-action (get-rule-eof? rule) (get-rule-error? rule))))
(set-rule-action rule action)
rule)))))
(define parse-rules
(lambda (macros)
(parse-action #f #f)
(let loop ()
(let ((rule (parse-rule macros)))
(if rule
(cons rule (loop))
'())))))
(define parser
(lambda (filename)
(let* ((port (open-input-file filename))
(port-open? #t))
(lex-unwind-protect (lambda ()
(if port-open?
(close-input-port port))))
(init-lexer port)
(let* ((macros (parse-macros))
(rules (parse-rules macros)))
(close-input-port port)
(set! port-open? #f)
(adapt-rules rules)))))
