mbutterick
/
brag
1
0
Fork 0
Code Issues 3 Pull Requests 1 Projects Releases Wiki Activity

Refactor lexer stuff a bit

Browse Source
remotes/jackfirth/master
Jack Firth 2 years ago
parent ac5370f26a
commit 434b104127
1 changed files with 203 additions and 218 deletions
Show Stats Download Patch File Download Diff File

421
parser-tools/lex.rkt
Unescape Escape View File

@ -3,192 +3,186 @@
;; Provides the syntax used to create lexers and the functions needed to ;; Provides the syntax used to create lexers and the functions needed to
;; create and use the buffer that the lexer reads from. See docs. ;; create and use the buffer that the lexer reads from. See docs.
(require (for-syntax racket/syntax (require (for-syntax racket/base
syntax/stx racket/contract/base
syntax/define syntax/define
yaragg/parser-tools/private-lex/util racket/match
racket/promise
syntax/stx
racket/syntax
yaragg/parser-tools/private-lex/actions yaragg/parser-tools/private-lex/actions
yaragg/parser-tools/private-lex/front yaragg/parser-tools/private-lex/front
yaragg/parser-tools/private-lex/unicode-chars yaragg/parser-tools/private-lex/unicode-chars
racket/base yaragg/parser-tools/private-lex/util)
racket/promise)) racket/contract/base
racket/stxparam
(require racket/stxparam syntax/parse/define
syntax/readerr syntax/readerr
yaragg/parser-tools/private-lex/token) yaragg/parser-tools/private-lex/token)
(provide lexer lexer-src-pos lexer-srcloc define-lex-abbrev define-lex-abbrevs define-lex-trans
(provide lexer
;; Dealing with tokens and related structures lexer-src-pos
define-tokens define-empty-tokens token-name token-value token? lexer-srcloc
define-lex-abbrev
define-lex-abbrevs
define-lex-trans
define-tokens
define-empty-tokens
token-name
token-value
token?
(struct-out position) (struct-out position)
(struct-out position-token) (struct-out position-token)
(struct-out srcloc-token) (struct-out srcloc-token)
;; File path for highlighting errors while lexing
file-path file-path
lexer-file-path ;; alternate name lexer-file-path
any-char
;; Lex abbrevs for unicode char sets. any-string
any-char any-string nothing alphabetic lower-case upper-case title-case nothing
numeric symbolic punctuation graphic whitespace blank iso-control alphabetic
lower-case
upper-case
title-case
numeric
symbolic
punctuation
graphic
whitespace
blank
iso-control
char-set
start-pos
end-pos
lexeme
lexeme-srcloc
input-port
return-without-pos
return-without-srcloc)
;; A regular expression operator
char-set)
;; wrap-action: syntax-object src-pos? -> syntax-object ;; wrap-action: syntax-object src-pos? -> syntax-object
(define-for-syntax (wrap-action action src-loc-style) (define-for-syntax (wrap-action action src-loc-style)
(with-syntax ([action-stx (define/with-syntax action-stx
(cond (cond
[(eq? src-loc-style 'lexer-src-pos) [(eq? src-loc-style 'lexer-src-pos)
#`(let/ec ret #`(let/ec ret
(syntax-parameterize (syntax-parameterize ([return-without-pos (make-rename-transformer #'ret)])
([return-without-pos (make-rename-transformer #'ret)]) (position-token #,action start-pos end-pos)))]
(position-token #,action start-pos end-pos)))] [(eq? src-loc-style 'lexer-srcloc)
[(eq? src-loc-style 'lexer-srcloc) #`(let/ec ret
#`(let/ec ret (syntax-parameterize ([return-without-srcloc (make-rename-transformer #'ret)])
(syntax-parameterize (srcloc-token #,action lexeme-srcloc)))]
([return-without-srcloc (make-rename-transformer #'ret)]) [else action]))
(srcloc-token #,action lexeme-srcloc)))] (syntax/loc action
[else action])]) (λ (start-pos-p end-pos-p lexeme-p input-port-p)
(syntax/loc action (define lexeme-srcloc-p (make-srcloc (object-name input-port-p)
(λ (start-pos-p end-pos-p lexeme-p input-port-p) (position-line start-pos-p)
(define lexeme-srcloc-p (make-srcloc (object-name input-port-p) (position-col start-pos-p)
(position-line start-pos-p) (position-offset start-pos-p)
(position-col start-pos-p) (and (number? (position-offset end-pos-p))
(position-offset start-pos-p) (number? (position-offset start-pos-p))
(and (number? (position-offset end-pos-p)) (- (position-offset end-pos-p)
(number? (position-offset start-pos-p)) (position-offset start-pos-p)))))
(- (position-offset end-pos-p) (syntax-parameterize
(position-offset start-pos-p))))) ([start-pos (make-rename-transformer #'start-pos-p)]
(syntax-parameterize [end-pos (make-rename-transformer #'end-pos-p)]
([start-pos (make-rename-transformer #'start-pos-p)] [lexeme (make-rename-transformer #'lexeme-p)]
[end-pos (make-rename-transformer #'end-pos-p)] [input-port (make-rename-transformer #'input-port-p)]
[lexeme (make-rename-transformer #'lexeme-p)] [lexeme-srcloc (make-rename-transformer #'lexeme-srcloc-p)])
[input-port (make-rename-transformer #'input-port-p)] action-stx))))
[lexeme-srcloc (make-rename-transformer #'lexeme-srcloc-p)])
action-stx)))))
(define-for-syntax (make-lexer-macro caller src-loc-style) (define-for-syntax (make-lexer-macro caller src-loc-style)
(λ (stx) (λ (stx)
(syntax-case stx () (syntax-case stx ()
[(_ . RE+ACTS) [(_ . RE+ACTS)
(with-disappeared-uses (with-disappeared-uses
(let () (define spec/re-acts (syntax->list #'RE+ACTS))
(define spec/re-acts (syntax->list #'RE+ACTS)) (for/and ([x (in-list spec/re-acts)])
(for/and ([x (in-list spec/re-acts)]) (syntax-case x ()
(syntax-case x () [(RE ACT) #t]
[(RE ACT) #t] [else (raise-syntax-error caller "not a regular expression / action pair" stx x)]))
[else (raise-syntax-error caller "not a regular expression / action pair" stx x)])) (define eof-act
(define eof-act (get-special-action spec/re-acts #'eof (case src-loc-style (get-special-action spec/re-acts
[(lexer-src-pos) #'(return-without-pos eof)] #'eof
[(lexer-srcloc) #'(return-without-srcloc eof)] (case src-loc-style
[else #'eof]))) [(lexer-src-pos) #'(return-without-pos eof)]
(define spec-act (get-special-action spec/re-acts #'special #'(void))) [(lexer-srcloc) #'(return-without-srcloc eof)]
(define spec-comment-act (get-special-action spec/re-acts #'special-comment #'#f)) [else #'eof])))
(define ids (list #'special #'special-comment #'eof)) (define spec-act (get-special-action spec/re-acts #'special #'(void)))
(define re-acts (filter (λ (spec/re-act) (define spec-comment-act (get-special-action spec/re-acts #'special-comment #'#f))
(syntax-case spec/re-act () (define ids (list #'special #'special-comment #'eof))
[((special) act) (define re-acts
(not (ormap (filter (λ (spec/re-act)
(λ (x) (syntax-case spec/re-act ()
(and (identifier? #'special) [((special) act)
(module-or-top-identifier=? #'special x))) (not (for/or ([x (in-list ids)])
ids))] (and (identifier? #'special)
[_ #t])) spec/re-acts)) (module-or-top-identifier=? #'special x))))]
(define names (map (λ (x) (datum->syntax #f (gensym))) re-acts)) [_ #t]))
(define acts (map (λ (x) (stx-car (stx-cdr x))) re-acts)) spec/re-acts))
(define re-actnames (map (λ (re-act name) (list (stx-car re-act) name)) re-acts names)) (define names (map (λ (x) (datum->syntax #f (gensym))) re-acts))
(when (null? spec/re-acts) (define acts (map (λ (x) (stx-car (stx-cdr x))) re-acts))
(raise-syntax-error caller "expected at least one action" stx)) (define re-actnames (map (λ (re-act name) (list (stx-car re-act) name)) re-acts names))
(define-values (trans start action-names no-look) (build-lexer re-actnames)) (when (null? spec/re-acts)
(when (vector-ref action-names start) ;; Start state is final (raise-syntax-error caller "expected at least one action" stx))
(unless (and (define-values (trans start action-names no-look) (build-lexer re-actnames))
;; All the successor states are final (when (vector-ref action-names start) ;; Start state is final
(vector? (vector-ref trans start)) (unless (and
(andmap (λ (x) (vector-ref action-names (vector-ref x 2))) ;; All the successor states are final
(vector->list (vector-ref trans start))) (vector? (vector-ref trans start))
;; Each character has a successor state (andmap (λ (x) (vector-ref action-names (vector-ref x 2)))
(let loop ([check 0] (vector->list (vector-ref trans start)))
[nexts (vector->list (vector-ref trans start))]) ;; Each character has a successor state
(cond (let loop ([check 0]
[(null? nexts) #f] [nexts (vector->list (vector-ref trans start))])
[else (cond
(let ([next (car nexts)]) [(null? nexts) #f]
(and (= (vector-ref next 0) check) [else
(let ([next-check (vector-ref next 1)]) (let ([next (car nexts)])
(or (>= next-check max-char-num) (and (= (vector-ref next 0) check)
(loop (add1 next-check) (cdr nexts))))))]))) (let ([next-check (vector-ref next 1)])
(eprintf "warning: lexer at ~a can accept the empty string\n" stx))) (or (>= next-check max-char-num)
(with-syntax ([START-STATE-STX start] (loop (add1 next-check) (cdr nexts))))))])))
[TRANS-TABLE-STX trans] (eprintf "warning: lexer at ~a can accept the empty string\n" stx)))
[NO-LOOKAHEAD-STX no-look] (with-syntax ([START-STATE-STX start]
[(NAME ...) names] [TRANS-TABLE-STX trans]
[(ACT ...) (map (λ (a) (wrap-action a src-loc-style)) acts)] [NO-LOOKAHEAD-STX no-look]
[(ACT-NAME ...) (vector->list action-names)] [(NAME ...) names]
[SPEC-ACT-STX (wrap-action spec-act src-loc-style)] [(ACT ...) (map (λ (a) (wrap-action a src-loc-style)) acts)]
[HAS-COMMENT-ACT?-STX (and (syntax-e spec-comment-act) #t)] [(ACT-NAME ...) (vector->list action-names)]
[SPEC-COMMENT-ACT-STX (wrap-action spec-comment-act src-loc-style)] [SPEC-ACT-STX (wrap-action spec-act src-loc-style)]
[EOF-ACT-STX (wrap-action eof-act src-loc-style)]) [HAS-COMMENT-ACT?-STX (and (syntax-e spec-comment-act) #t)]
(syntax/loc stx (let ([NAME ACT] ...) [SPEC-COMMENT-ACT-STX (wrap-action spec-comment-act src-loc-style)]
(let ([proc (lexer-body START-STATE-STX [EOF-ACT-STX (wrap-action eof-act src-loc-style)])
TRANS-TABLE-STX (syntax/loc stx (let ([NAME ACT] ...)
(vector ACT-NAME ...) (let ([proc (lexer-body START-STATE-STX
NO-LOOKAHEAD-STX TRANS-TABLE-STX
SPEC-ACT-STX (vector ACT-NAME ...)
HAS-COMMENT-ACT?-STX NO-LOOKAHEAD-STX
SPEC-COMMENT-ACT-STX SPEC-ACT-STX
EOF-ACT-STX)]) HAS-COMMENT-ACT?-STX
;; reverse eta to get named procedures: SPEC-COMMENT-ACT-STX
(λ (port) (proc port))))))))]))) EOF-ACT-STX)])
;; reverse eta to get named procedures:
(λ (port) (proc port)))))))])))
(define-syntax lexer (make-lexer-macro 'lexer #f)) (define-syntax lexer (make-lexer-macro 'lexer #f))
(define-syntax lexer-src-pos (make-lexer-macro 'lexer-src-pos 'lexer-src-pos)) (define-syntax lexer-src-pos (make-lexer-macro 'lexer-src-pos 'lexer-src-pos))
(define-syntax lexer-srcloc (make-lexer-macro 'lexer-srcloc 'lexer-srcloc)) (define-syntax lexer-srcloc (make-lexer-macro 'lexer-srcloc 'lexer-srcloc))
(define-syntax (define-lex-abbrev stx) (define-syntax-parse-rule (define-lex-abbrev NAME:id RE)
(syntax-case stx () (define-syntax NAME
[(_ NAME RE) (identifier? #'NAME) (lex-abbrev (λ () (quote-syntax RE)))))
(syntax/loc stx
(define-syntax NAME
(lex-abbrev (λ () (quote-syntax RE)))))]
[_ (raise-syntax-error 'define-lex-abbrev "form should be (define-lex-abbrev name re)" stx)]))
(define-syntax (define-lex-abbrevs stx) (define-syntax-parse-rule (define-lex-abbrevs (id:id re) ...)
(syntax-case stx () (begin (define-lex-abbrev id re) ...))
[(_ . XS)
(with-syntax ([(ABBREV ...) (map
(λ (a)
(syntax-case a ()
[(NAME RE) (identifier? #'NAME)
(syntax/loc a (define-lex-abbrev NAME RE))]
[_ (raise-syntax-error
#f
"form should be (define-lex-abbrevs (name re) ...)"
stx
a)]))
(syntax->list #'XS))])
(syntax/loc stx (begin ABBREV ...)))]
[_ (raise-syntax-error #f "form should be (define-lex-abbrevs (name re) ...)" stx)]))
(define-syntax (define-lex-trans stx) (define-syntax (define-lex-trans stx)
(syntax-case stx () (syntax-parse stx
[(_ name-form body-form) [(_ id:id trans-expr)
(let-values (((name body) #'(define-syntax id (lex-trans trans-expr))]
(normalize-definition #'(define-syntax name-form body-form) #'λ))) [(_ (id:id stx-id:id) body-expr:expr)
#'(define-syntax id (lex-trans (λ (stx-id) body-expr)))]))
#`(define-syntax #,name
(let ((func #,body))
(unless (procedure? func)
(raise-syntax-error 'define-lex-trans "expected a procedure as the transformer, got ~e" func))
(unless (procedure-arity-includes? func 1)
(raise-syntax-error 'define-lex-trans "expected a procedure that accepts 1 argument as the transformer, got ~e" func))
(lex-trans func))))]
[_
(raise-syntax-error
#f
"form should be (define-lex-trans name transformer)"
stx)]))
(define (get-next-state-helper char min max table) (define (get-next-state-helper char min max table)
@ -203,10 +197,10 @@
[(<= r1 char r2) (vector-ref el 2)] [(<= r1 char r2) (vector-ref el 2)]
[(< char r1) (get-next-state-helper char min try table)] [(< char r1) (get-next-state-helper char min try table)]
[else (get-next-state-helper char (add1 try) max table)])])) [else (get-next-state-helper char (add1 try) max table)])]))
(define (get-next-state char table) (define (get-next-state char table)
(and table (get-next-state-helper char 0 (vector-length table) table))) (and table (get-next-state-helper char 0 (vector-length table) table)))
@ -215,7 +209,6 @@
(define (lexer ip) (define (lexer ip)
(define first-pos (get-position ip)) (define first-pos (get-position ip))
(define first-char (peek-char-or-special ip 0)) (define first-char (peek-char-or-special ip 0))
;(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))] (do-match ip first-pos eof-action (read-char-or-special ip))]
@ -264,8 +257,6 @@
(define act (vector-ref actions next-state)) (define act (vector-ref actions next-state))
(define next-length-bytes (+ (char-utf-8-length char) length-bytes)) (define next-length-bytes (+ (char-utf-8-length char) length-bytes))
(define next-char (peek-char-or-special ip next-length-bytes)) (define next-char (peek-char-or-special ip next-length-bytes))
#;(printf "(peek-char-or-special port ~e) = ~e\n"
next-length-bytes next-char)
(lexer-loop next-state (lexer-loop next-state
next-char next-char
(if act (if act
@ -299,68 +290,62 @@
(define lexer-file-path file-path) (define lexer-file-path file-path)
(define (do-match ip first-pos action value) (define (do-match ip first-pos action value)
#;(printf "(action ~a ~a ~a ~a)\n"
(position-offset first-pos) (position-offset (get-position ip)) value ip)
(action first-pos (get-position ip) value ip)) (action first-pos (get-position ip) value ip))
(define (get-position ip) (define (get-position ip)
(define-values (line col off) (port-next-location ip)) (define-values (line col off) (port-next-location ip))
(position off line col)) (position off line col))
(define-syntax (create-unicode-abbrevs stx)
(syntax-case stx ()
[(_ CTXT)
(with-syntax ([(RANGES ...) (for/list ([range (in-list (list (force alphabetic-ranges)
(force lower-case-ranges)
(force upper-case-ranges)
(force title-case-ranges)
(force numeric-ranges)
(force symbolic-ranges)
(force punctuation-ranges)
(force graphic-ranges)
(force whitespace-ranges)
(force blank-ranges)
(force iso-control-ranges)))])
`(union ,@(map (λ (x)
`(char-range ,(integer->char (car x))
,(integer->char (cdr x))))
range)))]
[(NAMES ...) (for/list ([sym (in-list '(alphabetic
lower-case
upper-case
title-case
numeric
symbolic
punctuation
graphic
whitespace
blank
iso-control))])
(datum->syntax #'CTXT sym #f))])
#'(define-lex-abbrevs (NAMES RANGES) ...))]))
(define-lex-abbrev any-char (char-complement (union))) (define-lex-abbrev any-char (char-complement (union)))
(define-lex-abbrev any-string (intersection)) (define-lex-abbrev any-string (intersection))
(define-lex-abbrev nothing (union)) (define-lex-abbrev nothing (union))
(create-unicode-abbrevs #'here)
(define-for-syntax (unicode-lex-abbrev range)
(define/with-syntax ((lower upper) ...)
(for/list ([range-component (in-list (force range))])
(match-define (cons lower-int upper-int) range-component)
(list (integer->char lower-int) (integer->char upper-int))))
(lex-abbrev (λ () #'(union (char-range lower upper) ...))))
(define-syntax-parse-rule (define-unicode-abbrev name:id range:expr)
(define-syntax name (unicode-lex-abbrev range)))
(define-unicode-abbrev alphabetic alphabetic-ranges)
(define-unicode-abbrev lower-case lower-case-ranges)
(define-unicode-abbrev upper-case upper-case-ranges)
(define-unicode-abbrev title-case title-case-ranges)
(define-unicode-abbrev numeric numeric-ranges)
(define-unicode-abbrev symbolic symbolic-ranges)
(define-unicode-abbrev punctuation punctuation-ranges)
(define-unicode-abbrev graphic graphic-ranges)
(define-unicode-abbrev whitespace whitespace-ranges)
(define-unicode-abbrev blank blank-ranges)
(define-unicode-abbrev iso-control iso-control-ranges)
(define-lex-trans (char-set stx) (define-lex-trans (char-set stx)
(syntax-case stx () (syntax-parse stx
[(_ STR) [(_ STR:string)
(string? (syntax-e #'STR)) #:with (CHAR ...) (string->list (syntax-e #'STR))
(with-syntax ([(CHAR ...) (string->list (syntax-e #'STR))]) #'(union CHAR ...)]))
#'(union CHAR ...))]))
(define-for-syntax (make-lex-keyword-transformer id)
(make-set!-transformer
(λ (stx)
(raise-syntax-error id "use of lexer keyword is not in an appropriate lexer action" stx))))
(define-syntax-rule (provide-lex-keyword ID ...) (define-syntax-rule (define-lex-keyword ID)
(begin (define-syntax-parameter ID (make-lex-keyword-transformer 'ID)))
(define-syntax-parameter ID
(make-set!-transformer
(λ (stx)
(raise-syntax-error
'provide-lex-keyword
(format "use of a lexer keyword (~a) is not in an appropriate lexer action" 'ID)
stx))))
...
(provide ID ...)))
(provide-lex-keyword start-pos end-pos lexeme lexeme-srcloc input-port return-without-pos return-without-srcloc) (define-lex-keyword start-pos)
(define-lex-keyword end-pos)
(define-lex-keyword lexeme)
(define-lex-keyword lexeme-srcloc)
(define-lex-keyword input-port)
(define-lex-keyword return-without-pos)
(define-lex-keyword return-without-srcloc)

Write Preview
Loading…
Cancel
Save