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

*** empty log message ***

Browse Source 
original commit: 4cc4dd1cf863a30562584774bdd9686fd54c99c0
tokens
Scott Owens 20 years ago
parent cf391ef45e
commit 24ad776c2d
1 changed files with 34 additions and 41 deletions
Show Stats Download Patch File Download Diff File

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

@ -35,20 +35,25 @@
(define file-path (make-parameter #f)) (define file-path (make-parameter #f))
;; wrap-action: syntax-object -> syntax-object ;; wrap-action: syntax-object src-pos? -> syntax-object
(define-for-syntax (wrap-action action) (define-for-syntax (wrap-action action src-pos?)
(with-syntax ((action-stx action)) (with-syntax ((action-stx
(if src-pos?
#`(let/ec ret
(syntax-parameterize
((return-without-pos (make-rename-transformer #'ret)))
(make-position-token #,action start-pos end-pos)))
action)))
(syntax/loc action (syntax/loc action
(lambda (start-pos-p end-pos-p lexeme-p return-without-pos-p input-port-p) (lambda (start-pos-p end-pos-p lexeme-p input-port-p)
(syntax-parameterize (syntax-parameterize
((start-pos (make-rename-transformer #'start-pos-p)) ((start-pos (make-rename-transformer #'start-pos-p))
(end-pos (make-rename-transformer #'end-pos-p)) (end-pos (make-rename-transformer #'end-pos-p))
(lexeme (make-rename-transformer #'lexeme-p)) (lexeme (make-rename-transformer #'lexeme-p))
(return-without-pos (make-rename-transformer #'return-without-pos-p))
(input-port (make-rename-transformer #'input-port-p))) (input-port (make-rename-transformer #'input-port-p)))
action-stx))))) action-stx)))))
(define-for-syntax (make-lexer-trans wrap?) (define-for-syntax (make-lexer-trans src-pos?)
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
((_) ((_)
@ -93,18 +98,17 @@
(no-lookahead-stx no-look) (no-lookahead-stx no-look)
(actions-stx (actions-stx
`(vector ,@(map (lambda (a) `(vector ,@(map (lambda (a)
(if a (wrap-action a) #f)) (if a (wrap-action a src-pos?) #f))
(vector->list actions)))) (vector->list actions))))
(spec-act-stx (spec-act-stx
(wrap-action spec-act)) (wrap-action spec-act src-pos?))
(spec-error-act-stx (spec-error-act-stx
(wrap-action spec-error-act)) (wrap-action spec-error-act src-pos?))
(has-comment-act?-stx (has-comment-act?-stx
(if (syntax-e spec-comment-act) #t #f)) (if (syntax-e spec-comment-act) #t #f))
(spec-comment-act-stx (spec-comment-act-stx
(wrap-action spec-comment-act)) (wrap-action spec-comment-act src-pos?))
(eof-act-stx (wrap-action eof-act)) (eof-act-stx (wrap-action eof-act src-pos?)))
(wrap? wrap?))
(syntax-property (syntax-property
(syntax/loc stx (syntax/loc stx
(lexer-body start-state-stx (lexer-body start-state-stx
@ -115,8 +119,7 @@
spec-error-act-stx spec-error-act-stx
has-comment-act?-stx has-comment-act?-stx
spec-comment-act-stx spec-comment-act-stx
eof-act-stx eof-act-stx))
wrap?))
'disappeared-use 'disappeared-use
disappeared-uses))))))))) disappeared-uses)))))))))
@ -197,21 +200,15 @@
(define (lexer-body start-state trans-table actions no-lookahead (define (lexer-body start-state trans-table actions no-lookahead
special-action special-error-action special-action special-error-action
has-special-comment-action? special-comment-action eof-action wrap?) has-special-comment-action? special-comment-action eof-action)
(letrec ((lexer (letrec ((lexer
(lambda (ip) (lambda (ip)
(unless (input-port? ip)
(raise-type-error
'lexer
"input-port"
0
ip))
(let ((first-pos (get-position ip)) (let ((first-pos (get-position ip))
(first-char (peek-char-or-special ip 0))) (first-char (peek-char-or-special ip 0)))
;; (printf "(peek-char-or-special port 0) = ~e~n" first-char) ;; (printf "(peek-char-or-special port 0) = ~e~n" first-char)
(cond (cond
((eof-object? first-char) ((eof-object? first-char)
(do-match ip first-pos eof-action (read-char-or-special ip) wrap?)) (do-match ip first-pos eof-action (read-char-or-special ip)))
((not (char? first-char)) ((not (char? first-char))
(let* ((comment? #f) (let* ((comment? #f)
(error? #f) (error? #f)
@ -228,7 +225,7 @@
(comment? special-comment-action) (comment? special-comment-action)
(error? special-error-action) (error? special-error-action)
(else special-action)) (else special-action))
spec wrap?))))) spec)))))
(else (else
(let lexer-loop ( (let lexer-loop (
;; current-state ;; current-state
@ -255,15 +252,14 @@
(cond (cond
((not next-state) ((not next-state)
(check-match ip first-pos longest-match-length (check-match ip first-pos longest-match-length
length-chars longest-match-action wrap?)) length-chars longest-match-action))
((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
first-pos first-pos
(if act length-chars longest-match-length) (if act length-chars longest-match-length)
length-chars length-chars
(if act act longest-match-action) (if act act longest-match-action))))
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
@ -276,11 +272,16 @@
(if act (if act
length-chars length-chars
longest-match-length))))))))))))) longest-match-length)))))))))))))
lexer)) (lambda (ip)
(unless (input-port? ip)
(define id (lambda (x) x)) (raise-type-error
'lexer
"input-port"
0
ip))
(lexer ip))))
(define (check-match lb first-pos longest-match-length length longest-match-action wrap?) (define (check-match lb first-pos longest-match-length length longest-match-action)
(unless longest-match-action (unless longest-match-action
(let* ((match (read-string length lb)) (let* ((match (read-string length lb))
(end-pos (get-position lb))) (end-pos (get-position lb)))
@ -293,19 +294,11 @@
(- (position-offset end-pos) (position-offset first-pos))))) (- (position-offset end-pos) (position-offset first-pos)))))
(let ((match (read-string longest-match-length lb))) (let ((match (read-string longest-match-length lb)))
;; (printf "(read-string ~e port) = ~e~n" longest-match-length match) ;; (printf "(read-string ~e port) = ~e~n" longest-match-length match)
(do-match lb first-pos longest-match-action match wrap?))) (do-match lb first-pos longest-match-action match)))
(define (do-match ip first-pos action value wrap?) (define (do-match ip first-pos action value)
(let ((end-pos (get-position ip))) (action first-pos (get-position ip) value ip))
(cond
(wrap?
(let/ec ret
(make-position-token (action first-pos end-pos value ret ip)
first-pos
end-pos)))
(else
(action first-pos end-pos value id ip)))))
(define (get-position ip) (define (get-position ip)
(let-values (((line col off) (port-next-location ip))) (let-values (((line col off) (port-next-location ip)))

Write Preview
Loading…
Cancel
Save