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

Inlines `begin-with-disappeared-uses`, which means the big indentation

Browse Source 
change is in this commit instead of the previous one.
pull/6/head
Jesse A. Tov 5 years ago
parent a1d0b422c8
commit 0e0e758851
No known key found for this signature in database
GPG Key ID: C5668BA5047AE6BD
1 changed files with 68 additions and 75 deletions
Show Stats Download Patch File Download Diff File

143
br-parser-tools-lib/br-parser-tools/lex.rkt
Unescape Escape View File

@ -71,85 +71,78 @@
[lexeme-srcloc (make-rename-transformer #'lexeme-srcloc-p)]) [lexeme-srcloc (make-rename-transformer #'lexeme-srcloc-p)])
action-stx))))) action-stx)))))
(begin-for-syntax
; This macro only exists to keep the indentation below the same,
; in order to make the diff easier to read. So it probably makes
; sense to inline it after reading.
(define-syntax-rule (begin-with-disappeared-uses body0 body ...)
(with-disappeared-uses
(let () body0 body ...))))
(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)
(begin-with-disappeared-uses (with-disappeared-uses
(define spec/re-acts (syntax->list #'RE+ACTS)) (let ()
(for/and ([x (in-list spec/re-acts)]) (define spec/re-acts (syntax->list #'RE+ACTS))
(syntax-case x () (for/and ([x (in-list spec/re-acts)])
[(RE ACT) #t] (syntax-case x ()
[else (raise-syntax-error caller "not a regular expression / action pair" stx x)])) [(RE ACT) #t]
(define eof-act (get-special-action spec/re-acts #'eof (case src-loc-style [else (raise-syntax-error caller "not a regular expression / action pair" stx x)]))
[(lexer-src-pos) #'(return-without-pos eof)] (define eof-act (get-special-action spec/re-acts #'eof (case src-loc-style
[(lexer-srcloc) #'(return-without-srcloc eof)] [(lexer-src-pos) #'(return-without-pos eof)]
[else #'eof]))) [(lexer-srcloc) #'(return-without-srcloc eof)]
(define spec-act (get-special-action spec/re-acts #'special #'(void))) [else #'eof])))
(define spec-comment-act (get-special-action spec/re-acts #'special-comment #'#f)) (define spec-act (get-special-action spec/re-acts #'special #'(void)))
(define ids (list #'special #'special-comment #'eof)) (define spec-comment-act (get-special-action spec/re-acts #'special-comment #'#f))
(define re-acts (filter (λ (spec/re-act) (define ids (list #'special #'special-comment #'eof))
(syntax-case spec/re-act () (define re-acts (filter (λ (spec/re-act)
[((special) act) (syntax-case spec/re-act ()
(not (ormap [((special) act)
(λ (x) (not (ormap
(and (identifier? #'special) (λ (x)
(module-or-top-identifier=? #'special x))) (and (identifier? #'special)
ids))] (module-or-top-identifier=? #'special x)))
[_ #t])) spec/re-acts)) ids))]
(define names (map (λ (x) (datum->syntax #f (gensym))) re-acts)) [_ #t])) spec/re-acts))
(define acts (map (λ (x) (stx-car (stx-cdr x))) re-acts)) (define names (map (λ (x) (datum->syntax #f (gensym))) re-acts))
(define re-actnames (map (λ (re-act name) (list (stx-car re-act) name)) re-acts names)) (define acts (map (λ (x) (stx-car (stx-cdr x))) re-acts))
(when (null? spec/re-acts) (define re-actnames (map (λ (re-act name) (list (stx-car re-act) name)) re-acts names))
(raise-syntax-error caller "expected at least one action" stx)) (when (null? spec/re-acts)
(define-values (trans start action-names no-look) (build-lexer re-actnames)) (raise-syntax-error caller "expected at least one action" stx))
(when (vector-ref action-names start) ;; Start state is final (define-values (trans start action-names no-look) (build-lexer re-actnames))
(unless (and (when (vector-ref action-names start) ;; Start state is final
;; All the successor states are final (unless (and
(vector? (vector-ref trans start)) ;; All the successor states are final
(andmap (λ (x) (vector-ref action-names (vector-ref x 2))) (vector? (vector-ref trans start))
(vector->list (vector-ref trans start))) (andmap (λ (x) (vector-ref action-names (vector-ref x 2)))
;; Each character has a successor state (vector->list (vector-ref trans start)))
(let loop ([check 0] ;; Each character has a successor state
[nexts (vector->list (vector-ref trans start))]) (let loop ([check 0]
(cond [nexts (vector->list (vector-ref trans start))])
[(null? nexts) #f] (cond
[else [(null? nexts) #f]
(let ([next (car nexts)]) [else
(and (= (vector-ref next 0) check) (let ([next (car nexts)])
(let ([next-check (vector-ref next 1)]) (and (= (vector-ref next 0) check)
(or (>= next-check max-char-num) (let ([next-check (vector-ref next 1)])
(loop (add1 next-check) (cdr nexts))))))]))) (or (>= next-check max-char-num)
(eprintf "warning: lexer at ~a can accept the empty string\n" stx))) (loop (add1 next-check) (cdr nexts))))))])))
(with-syntax ([START-STATE-STX start] (eprintf "warning: lexer at ~a can accept the empty string\n" stx)))
[TRANS-TABLE-STX trans] (with-syntax ([START-STATE-STX start]
[NO-LOOKAHEAD-STX no-look] [TRANS-TABLE-STX trans]
[(NAME ...) names] [NO-LOOKAHEAD-STX no-look]
[(ACT ...) (map (λ (a) (wrap-action a src-loc-style)) acts)] [(NAME ...) names]
[(ACT-NAME ...) (vector->list action-names)] [(ACT ...) (map (λ (a) (wrap-action a src-loc-style)) acts)]
[SPEC-ACT-STX (wrap-action spec-act src-loc-style)] [(ACT-NAME ...) (vector->list action-names)]
[HAS-COMMENT-ACT?-STX (if (syntax-e spec-comment-act) #t #f)] [SPEC-ACT-STX (wrap-action spec-act src-loc-style)]
[SPEC-COMMENT-ACT-STX (wrap-action spec-comment-act src-loc-style)] [HAS-COMMENT-ACT?-STX (if (syntax-e spec-comment-act) #t #f)]
[EOF-ACT-STX (wrap-action eof-act src-loc-style)]) [SPEC-COMMENT-ACT-STX (wrap-action spec-comment-act src-loc-style)]
(syntax/loc stx (let ([NAME ACT] ...) [EOF-ACT-STX (wrap-action eof-act src-loc-style)])
(let ([proc (lexer-body START-STATE-STX (syntax/loc stx (let ([NAME ACT] ...)
TRANS-TABLE-STX (let ([proc (lexer-body START-STATE-STX
(vector ACT-NAME ...) TRANS-TABLE-STX
NO-LOOKAHEAD-STX (vector ACT-NAME ...)
SPEC-ACT-STX NO-LOOKAHEAD-STX
HAS-COMMENT-ACT?-STX SPEC-ACT-STX
SPEC-COMMENT-ACT-STX HAS-COMMENT-ACT?-STX
EOF-ACT-STX)]) SPEC-COMMENT-ACT-STX
;; reverse eta to get named procedures: EOF-ACT-STX)])
(λ (port) (proc port)))))))]))) ;; 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))

Write Preview
Loading…
Cancel
Save