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

*** empty log message ***

Browse Source 
original commit: 1b5db6f34eeca19e4f8f5583dbebf137cb0ed1f4
tokens
Scott Owens 23 years ago
parent 555ff29b20
commit 0ead202815
1 changed files with 20 additions and 21 deletions
Show Stats Download Patch File Download Diff File

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

@ -33,17 +33,16 @@
x)))) x))))
(syntax->list (syntax (re-act ...)))) (syntax->list (syntax (re-act ...))))
(let ((table (generate-table (syntax (re-act ...)) stx))) (let ((table (generate-table (syntax (re-act ...)) stx)))
(with-syntax ((start-state (table-start table)) (with-syntax ((start-state-stx (table-start table))
(trans-table (table-trans table)) (trans-table-stx (table-trans table))
(eof-table (table-eof table)) (eof-table-stx (table-eof table))
(no-lookahead (table-no-lookahead table)) (no-lookahead-stx (table-no-lookahead table))
(actions `(vector ,@(vector->list (table-actions table))))) (actions-stx `(vector ,@(vector->list (table-actions table)))))
(if wrap? (if wrap?
(syntax (lambda (lb) (syntax (lambda (lb)
(lexer-body lb start-state trans-table eof-table actions no-lookahead list))) (lexer-body lb start-state-stx trans-table-stx eof-table-stx actions-stx no-lookahead-stx #t)))
(syntax (lambda (lb) (syntax (lambda (lb)
(lexer-body lb start-state trans-table eof-table actions no-lookahead (lambda (a b c) a)))))))))))))) (lexer-body lb start-state-stx trans-table-stx eof-table-stx actions-stx no-lookahead-stx #f)))))))))))))
(values (values
(build-lexer #f) (build-lexer #f)
(build-lexer #t)))) (build-lexer #t))))
@ -87,7 +86,7 @@
(define (lexer-body lb start-state trans-table eof-table actions no-lookahead wrap) (define (lexer-body lb start-state trans-table eof-table actions no-lookahead wrap?)
(unless (lex-buffer? lb) (unless (lex-buffer? lb)
(raise-type-error (raise-type-error
'lexer 'lexer
@ -120,14 +119,14 @@
(arithmetic-shift state 8))))))) (arithmetic-shift state 8)))))))
(cond (cond
((not next-state) ((not next-state)
(do-match lb first-pos longest-match-length longest-match-action wrap)) (do-match lb first-pos longest-match-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)))
(do-match lb (do-match lb
first-pos first-pos
(if act length longest-match-length) (if act length longest-match-length)
(if act act longest-match-action) (if act act longest-match-action)
wrap))) wrap?)))
(else (else
(let ((act (vector-ref actions next-state))) (let ((act (vector-ref actions next-state)))
(lexer-loop next-state (lexer-loop next-state
@ -140,7 +139,7 @@
length length
longest-match-length))))))))) longest-match-length)))))))))
(define (do-match lb first-pos longest-match-length longest-match-action wrap) (define (do-match lb first-pos longest-match-length longest-match-action wrap?)
(let* ((match (get-match lb longest-match-length)) (let* ((match (get-match lb longest-match-length))
(end-pos (get-position lb))) (end-pos (get-position lb)))
(if (not longest-match-action) (if (not longest-match-action)
@ -152,15 +151,15 @@
(position-offset first-pos) (position-offset first-pos)
(- (position-offset end-pos) (position-offset first-pos)))) (- (position-offset end-pos) (position-offset first-pos))))
(let/ec ret (let/ec ret
(wrap (let ((act (longest-match-action
(longest-match-action
(lambda () first-pos) (lambda () first-pos)
(lambda () end-pos) (lambda () end-pos)
(lambda () match) (lambda () match)
ret ret
lb) lb)))
first-pos (if wrap?
end-pos)))) (list act first-pos end-pos)
act)))))
;; Lex buffer is NOT thread safe ;; Lex buffer is NOT thread safe

Write Preview
Loading…
Cancel
Save