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

30
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,10 +151,12 @@
(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?)
(letrec ((lexer
(lambda (ip) (lambda (ip)
(unless (input-port? ip) (unless (input-port? ip)
(raise-type-error (raise-type-error
@ -160,7 +170,7 @@
((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) #f))) (lambda (x) (set! comment? #t) lexer)))
(read-char-or-special ip)))) (read-char-or-special ip))))
(do-match ip first-pos (if comment? (do-match ip first-pos (if comment?
special-comment-action special-comment-action
@ -193,7 +203,8 @@
(+ (char->integer char) (* 256 state))))))) (+ (char->integer char) (* 256 state)))))))
(cond (cond
((not next-state) ((not next-state)
(check-match ip first-pos longest-match-length length longest-match-action wrap?)) (check-match ip first-pos longest-match-length
length longest-match-action wrap?))
((vector-ref no-lookahead next-state) ((vector-ref no-lookahead next-state)
(let ((act (vector-ref actions next-state))) (let ((act (vector-ref actions next-state)))
(check-match ip (check-match ip
@ -212,7 +223,8 @@
(add1 length) (add1 length)
(if act (if act
length length
longest-match-length)))))))))))) longest-match-length)))))))))))))
lexer))
(define id (lambda (x) x)) (define id (lambda (x) x))

Write Preview
Loading…
Cancel
Save