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

*** empty log message ***

Browse Source 
original commit: 7e1760af87f82a8200c27971b6724dc405da046b
tokens
Scott Owens 21 years ago
parent 08792e684e
commit 6b3cee536e
1 changed files with 23 additions and 15 deletions
Show Stats Download Patch File Download Diff File

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

@ -60,14 +60,13 @@
"expects regular expression / action pairs" "expects regular expression / action pairs"
x)))) x))))
(syntax->list (syntax (re-act ...)))) (syntax->list (syntax (re-act ...))))
(let* ((error-continue-arg (gensym)) (let* ((spec/re-act-lst
(spec/re-act-lst
(syntax->list (syntax (re-act ...)))) (syntax->list (syntax (re-act ...))))
(spec-act (spec-act
(get-special-action spec/re-act-lst 'special #'(void))) (get-special-action spec/re-act-lst 'special #'(void)))
(spec-comment-act (spec-comment-act
(get-special-action spec/re-act-lst 'special-comment (get-special-action spec/re-act-lst 'special-comment
#`(#,error-continue-arg input-port))) #f))
(re-act-lst (re-act-lst
(filter-out-specials spec/re-act-lst (filter-out-specials spec/re-act-lst
'(special special-comment special-error)))) '(special special-comment special-error))))
@ -83,13 +82,17 @@
`(lambda (start-pos end-pos special return-without-pos input-port) `(lambda (start-pos end-pos special return-without-pos input-port)
,spec-act) ,spec-act)
spec-act)) spec-act))
(has-spec-comment-act-stx
(if spec-comment-act #t #f))
(spec-comment-act-stx (spec-comment-act-stx
(if spec-comment-act
(datum->syntax-object (datum->syntax-object
spec-comment-act spec-comment-act
`(lambda (start-pos end-pos ,error-continue-arg `(lambda (start-pos end-pos ,(gensym)
return-without-pos input-port) return-without-pos input-port)
,spec-comment-act) ,spec-comment-act)
spec-comment-act)) spec-comment-act)
#'void))
(wrap? wrap?)) (wrap? wrap?))
(syntax (syntax
(lexer-body start-state-stx (lexer-body start-state-stx
@ -98,6 +101,7 @@
actions-stx actions-stx
no-lookahead-stx no-lookahead-stx
spec-act-stx spec-act-stx
has-spec-comment-act-stx
spec-comment-act-stx spec-comment-act-stx
wrap?)))))))))))) wrap?))))))))))))
(values (values
@ -155,7 +159,7 @@
(vector-ref actions longest-match-action) wrap?))))) (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 has-spec-cmt-act? special-comment-action wrap?)
(letrec ((lexer (letrec ((lexer
(lambda (ip) (lambda (ip)
(unless (input-port? ip) (unless (input-port? ip)
@ -170,12 +174,16 @@
((eq? 'special first-char) ((eq? 'special first-char)
(let* ((comment? #f) (let* ((comment? #f)
(spec (with-handlers ((exn:special-comment? (spec (with-handlers ((exn:special-comment?
(lambda (x) (set! comment? #t) lexer))) (lambda (x) (set! comment? #t))))
(read-char-or-special ip)))) (read-char-or-special ip))))
(cond
((and comment? (not has-spec-cmt-act?))
(lexer ip))
(else
(do-match ip first-pos (if comment? (do-match ip first-pos (if comment?
special-comment-action special-comment-action
special-action) special-action)
spec wrap?))) spec wrap?)))))
(else (else
(let lexer-loop ( (let lexer-loop (
;; current-state ;; current-state

Write Preview
Loading…
Cancel
Save