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

*** empty log message ***

Browse Source 
original commit: 8635d4047964f05e30f295492d4891aa78e4717c
tokens
Scott Owens 21 years ago
parent 6b3cee536e
commit ea7676e8aa
1 changed files with 27 additions and 26 deletions
Show Stats Download Patch File Download Diff File

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

@ -64,35 +64,27 @@
(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-error-act
(get-special-action spec/re-act-lst 'special-error #f))
(spec-comment-act (spec-comment-act
(get-special-action spec/re-act-lst 'special-comment (get-special-action spec/re-act-lst 'special-comment #f))
#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))))
(let ((table (generate-table re-act-lst stx))) (let ((table (generate-table re-act-lst #'here 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))
(eof-table-stx (table-eof table)) (eof-table-stx (table-eof table))
(no-lookahead-stx (table-no-lookahead table)) (no-lookahead-stx (table-no-lookahead table))
(actions-stx `(vector ,@(vector->list (table-actions table)))) (actions-stx `(vector ,@(vector->list (table-actions table))))
(spec-act-stx (spec-act-stx
(datum->syntax-object (wrap-action spec-act 'special #'here spec-act))
spec-act (has-error-act?-stx (if spec-error-act #t #f))
`(lambda (start-pos end-pos special return-without-pos input-port) (spec-error-act-stx
,spec-act) (wrap-action spec-act 'exception #'here spec-error-act))
spec-act)) (has-comment-act?-stx (if spec-comment-act #t #f))
(has-spec-comment-act-stx
(if spec-comment-act #t #f))
(spec-comment-act-stx (spec-comment-act-stx
(if spec-comment-act (wrap-action spec-act (gensym) #'here spec-comment-act))
(datum->syntax-object
spec-comment-act
`(lambda (start-pos end-pos ,(gensym)
return-without-pos input-port)
,spec-comment-act)
spec-comment-act)
#'void))
(wrap? wrap?)) (wrap? wrap?))
(syntax (syntax
(lexer-body start-state-stx (lexer-body start-state-stx
@ -101,7 +93,9 @@
actions-stx actions-stx
no-lookahead-stx no-lookahead-stx
spec-act-stx spec-act-stx
has-spec-comment-act-stx has-error-act?-stx
spec-error-act-stx
has-comment-act?-stx
spec-comment-act-stx spec-comment-act-stx
wrap?)))))))))))) wrap?))))))))))))
(values (values
@ -159,7 +153,8 @@
(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 has-spec-cmt-act? special-comment-action wrap?) special-action has-special-error-action? special-error-action
has-special-comment-action? special-comment-action wrap?)
(letrec ((lexer (letrec ((lexer
(lambda (ip) (lambda (ip)
(unless (input-port? ip) (unless (input-port? ip)
@ -173,16 +168,22 @@
(cond (cond
((eq? 'special first-char) ((eq? 'special first-char)
(let* ((comment? #f) (let* ((comment? #f)
(error? #f)
(spec (with-handlers ((exn:special-comment? (spec (with-handlers ((exn:special-comment?
(lambda (x) (set! comment? #t)))) (lambda (x) (set! comment? #t)))
(not-break-exn?
(lambda (ex) (set! error? ex))))
(read-char-or-special ip)))) (read-char-or-special ip))))
(cond (cond
((and comment? (not has-spec-cmt-act?)) ((and comment? (not has-special-comment-action?))
(lexer ip)) (lexer ip))
((and error? (not has-special-error-action?))
(raise error?))
(else (else
(do-match ip first-pos (if comment? (do-match ip first-pos (cond
special-comment-action (comment? special-comment-action)
special-action) (error? special-error-action)
(else special-action))
spec wrap?))))) spec wrap?)))))
(else (else
(let lexer-loop ( (let lexer-loop (

Write Preview
Loading…
Cancel
Save