mbutterick
/
br-parser-tools
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

*** empty log message ***

Browse Source 
original commit: 17e9ac305563e736049bef0b956ca048284a8117
tokens
Scott Owens 21 years ago
parent 7ce12965f5
commit 08792e684e
1 changed files with 84 additions and 72 deletions
Show Stats Download Patch File Download Diff File

156
collects/parser-tools/lex.ss
Unescape Escape View File

@ -60,10 +60,17 @@
"expects regular expression / action pairs" "expects regular expression / action pairs"
x)))) x))))
(syntax->list (syntax (re-act ...)))) (syntax->list (syntax (re-act ...))))
(let* ((spec/re-act-lst (syntax->list (syntax (re-act ...)))) (let* ((error-continue-arg (gensym))
(spec-act (get-special-action spec/re-act-lst 'special #'here)) (spec/re-act-lst
(spec-comment-act (get-special-action spec/re-act-lst 'special-comment #'here)) (syntax->list (syntax (re-act ...))))
(re-act-lst (filter-out-specials spec/re-act-lst '(special special-comment)))) (spec-act
(get-special-action spec/re-act-lst 'special #'(void)))
(spec-comment-act
(get-special-action spec/re-act-lst 'special-comment
#`(#,error-continue-arg input-port)))
(re-act-lst
(filter-out-specials spec/re-act-lst
'(special special-comment special-error))))
(let ((table (generate-table re-act-lst stx))) (let ((table (generate-table re-act-lst stx)))
(with-syntax ((start-state-stx (table-start table)) (with-syntax ((start-state-stx (table-start table))
(trans-table-stx (table-trans table)) (trans-table-stx (table-trans table))
@ -79,7 +86,8 @@
(spec-comment-act-stx (spec-comment-act-stx
(datum->syntax-object (datum->syntax-object
spec-comment-act spec-comment-act
`(lambda (start-pos end-pos ,(gensym) return-without-pos input-port) `(lambda (start-pos end-pos ,error-continue-arg
return-without-pos input-port)
,spec-comment-act) ,spec-comment-act)
spec-comment-act)) spec-comment-act))
(wrap? wrap?)) (wrap? wrap?))
@ -143,76 +151,80 @@
(let ((first-pos (get-position ip))) (let ((first-pos (get-position ip)))
(let-values (((longest-match-length length longest-match-action) (let-values (((longest-match-length length longest-match-action)
(lexer ip peek-string))) (lexer ip peek-string)))
(check-match ip first-pos longest-match-length length (vector-ref actions longest-match-action) wrap?))))) (check-match ip first-pos longest-match-length length
(vector-ref actions longest-match-action) wrap?)))))
(define (lexer-body start-state trans-table eof-table actions no-lookahead (define (lexer-body start-state trans-table eof-table actions no-lookahead
special-action special-comment-action wrap?) special-action special-comment-action wrap?)
(lambda (ip) (letrec ((lexer
(unless (input-port? ip) (lambda (ip)
(raise-type-error (unless (input-port? ip)
'lexer (raise-type-error
"input-port" 'lexer
0 "input-port"
ip)) 0
(let ((first-pos (get-position ip)) ip))
(first-char (peek-char-or-special ip 0))) (let ((first-pos (get-position ip))
(cond (first-char (peek-char-or-special ip 0)))
((eq? 'special first-char) (cond
(let* ((comment? #f) ((eq? 'special first-char)
(spec (with-handlers ((exn:special-comment? (let* ((comment? #f)
(lambda (x) (set! comment? #t) #f))) (spec (with-handlers ((exn:special-comment?
(read-char-or-special ip)))) (lambda (x) (set! comment? #t) lexer)))
(do-match ip first-pos (if comment? (read-char-or-special ip))))
special-comment-action (do-match ip first-pos (if comment?
special-action) special-comment-action
spec wrap?))) special-action)
(else spec wrap?)))
(let lexer-loop ( (else
;; current-state (let lexer-loop (
(state start-state) ;; current-state
;; the character to transition on (state start-state)
(char first-char) ;; the character to transition on
;; action for the longest match seen thus far (char first-char)
;; including a match at the current state ;; action for the longest match seen thus far
(longest-match-action ;; including a match at the current state
(vector-ref actions start-state)) (longest-match-action
;; how many characters have been read (vector-ref actions start-state))
;; including the one just read ;; how many characters have been read
(length 1) ;; including the one just read
;; how many characters are in the longest match (length 1)
(longest-match-length 1)) ;; how many characters are in the longest match
(let ((next-state (longest-match-length 1))
(cond (let ((next-state
((eof-object? char) (cond
(vector-ref eof-table state)) ((eof-object? char)
((eq? char 'special) (vector-ref eof-table state))
#f) ((eq? char 'special)
(else #f)
(vector-ref (else
trans-table (vector-ref
(+ (char->integer char) (* 256 state))))))) trans-table
(cond (+ (char->integer char) (* 256 state)))))))
((not next-state) (cond
(check-match ip first-pos longest-match-length length longest-match-action wrap?)) ((not next-state)
((vector-ref no-lookahead next-state) (check-match ip first-pos longest-match-length
(let ((act (vector-ref actions next-state))) length longest-match-action wrap?))
(check-match ip ((vector-ref no-lookahead next-state)
first-pos (let ((act (vector-ref actions next-state)))
(if act length longest-match-length) (check-match ip
length first-pos
(if act act longest-match-action) (if act length longest-match-length)
wrap?))) length
(else (if act act longest-match-action)
(let ((act (vector-ref actions next-state))) wrap?)))
(lexer-loop next-state (else
(peek-char-or-special ip length) (let ((act (vector-ref actions next-state)))
(if act (lexer-loop next-state
act (peek-char-or-special ip length)
longest-match-action) (if act
(add1 length) act
(if act longest-match-action)
length (add1 length)
longest-match-length)))))))))))) (if act
length
longest-match-length)))))))))))))
lexer))
(define id (lambda (x) x)) (define id (lambda (x) x))

Write Preview
Loading…
Cancel
Save