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 3 years ago
parent ac5370f26a
commit 434b104127
1 changed files with 203 additions and 218 deletions
Show Stats Download Patch File Download Diff File

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

@ -3,54 +3,76 @@
;; 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
;; Dealing with tokens and related structures (provide lexer
define-tokens define-empty-tokens token-name token-value token? lexer-src-pos
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
;; A regular expression operator upper-case
char-set) 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)
;; 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 (syntax-parameterize ([return-without-srcloc (make-rename-transformer #'ret)])
([return-without-srcloc (make-rename-transformer #'ret)])
(srcloc-token #,action lexeme-srcloc)))] (srcloc-token #,action lexeme-srcloc)))]
[else action])]) [else action]))
(syntax/loc action (syntax/loc action
(λ (start-pos-p end-pos-p lexeme-p input-port-p) (λ (start-pos-p end-pos-p lexeme-p input-port-p)
(define lexeme-srcloc-p (make-srcloc (object-name input-port-p) (define lexeme-srcloc-p (make-srcloc (object-name input-port-p)
@ -67,35 +89,37 @@
[lexeme (make-rename-transformer #'lexeme-p)] [lexeme (make-rename-transformer #'lexeme-p)]
[input-port (make-rename-transformer #'input-port-p)] [input-port (make-rename-transformer #'input-port-p)]
[lexeme-srcloc (make-rename-transformer #'lexeme-srcloc-p)]) [lexeme-srcloc (make-rename-transformer #'lexeme-srcloc-p)])
action-stx))))) 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 (get-special-action spec/re-acts #'eof (case src-loc-style (define eof-act
(get-special-action spec/re-acts
#'eof
(case src-loc-style
[(lexer-src-pos) #'(return-without-pos eof)] [(lexer-src-pos) #'(return-without-pos eof)]
[(lexer-srcloc) #'(return-without-srcloc eof)] [(lexer-srcloc) #'(return-without-srcloc eof)]
[else #'eof]))) [else #'eof])))
(define spec-act (get-special-action spec/re-acts #'special #'(void))) (define spec-act (get-special-action spec/re-acts #'special #'(void)))
(define spec-comment-act (get-special-action spec/re-acts #'special-comment #'#f)) (define spec-comment-act (get-special-action spec/re-acts #'special-comment #'#f))
(define ids (list #'special #'special-comment #'eof)) (define ids (list #'special #'special-comment #'eof))
(define re-acts (filter (λ (spec/re-act) (define re-acts
(filter (λ (spec/re-act)
(syntax-case spec/re-act () (syntax-case spec/re-act ()
[((special) act) [((special) act)
(not (ormap (not (for/or ([x (in-list ids)])
(λ (x)
(and (identifier? #'special) (and (identifier? #'special)
(module-or-top-identifier=? #'special x))) (module-or-top-identifier=? #'special x))))]
ids))] [_ #t]))
[_ #t])) spec/re-acts)) spec/re-acts))
(define names (map (λ (x) (datum->syntax #f (gensym))) re-acts)) (define names (map (λ (x) (datum->syntax #f (gensym))) re-acts))
(define acts (map (λ (x) (stx-car (stx-cdr x))) re-acts)) (define acts (map (λ (x) (stx-car (stx-cdr x))) re-acts))
(define re-actnames (map (λ (re-act name) (list (stx-car re-act) name)) re-acts names)) (define re-actnames (map (λ (re-act name) (list (stx-car re-act) name)) re-acts names))
@ -140,55 +164,25 @@
SPEC-COMMENT-ACT-STX SPEC-COMMENT-ACT-STX
EOF-ACT-STX)]) EOF-ACT-STX)])
;; reverse eta to get named procedures: ;; reverse eta to get named procedures:
(λ (port) (proc port))))))))]))) (λ (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 ()
[(_ NAME RE) (identifier? #'NAME)
(syntax/loc stx
(define-syntax NAME (define-syntax NAME
(lex-abbrev (λ () (quote-syntax RE)))))] (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)
@ -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-syntax-rule (provide-lex-keyword ID ...) (define-for-syntax (make-lex-keyword-transformer id)
(begin
(define-syntax-parameter ID
(make-set!-transformer (make-set!-transformer
(λ (stx) (λ (stx)
(raise-syntax-error (raise-syntax-error id "use of lexer keyword is not in an appropriate lexer action" stx))))
'provide-lex-keyword
(format "use of a lexer keyword (~a) is not in an appropriate lexer action" 'ID) (define-syntax-rule (define-lex-keyword ID)
stx)))) (define-syntax-parameter ID (make-lex-keyword-transformer 'ID)))
...
(provide ID ...))) (define-lex-keyword start-pos)
(define-lex-keyword end-pos)
(provide-lex-keyword start-pos end-pos lexeme lexeme-srcloc input-port return-without-pos return-without-srcloc) (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