Fixes Check Syntax arrows for lexer generator.

There was a bug in disappeared-use tracking--a missing
syntax-local-introduce. This change uses `with-disappeared-uses` and
`syntax-local-value/record`, instead of the (broken) manual tracking
that was present before.

I believe that non-BR parser-tools also has this bug, but I haven't
ported the fix yet.
master
Jesse A. Tov 5 years ago committed by Matthew Butterick
parent f8c3f37646
commit c8851d31c5

@ -4,6 +4,7 @@
;; 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/list (require (for-syntax racket/list
racket/syntax
syntax/stx syntax/stx
syntax/define syntax/define
syntax/boundmap syntax/boundmap
@ -69,12 +70,20 @@
[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)))))
(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)
(let () (begin-with-disappeared-uses
(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 ()
@ -101,7 +110,7 @@
(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))
(when (null? spec/re-acts) (when (null? spec/re-acts)
(raise-syntax-error caller "expected at least one action" stx)) (raise-syntax-error caller "expected at least one action" stx))
(define-values (trans start action-names no-look disappeared-uses) (build-lexer re-actnames)) (define-values (trans start action-names no-look) (build-lexer re-actnames))
(when (vector-ref action-names start) ;; Start state is final (when (vector-ref action-names start) ;; Start state is final
(unless (and (unless (and
;; All the successor states are final ;; All the successor states are final
@ -130,19 +139,17 @@
[HAS-COMMENT-ACT?-STX (if (syntax-e spec-comment-act) #t #f)] [HAS-COMMENT-ACT?-STX (if (syntax-e spec-comment-act) #t #f)]
[SPEC-COMMENT-ACT-STX (wrap-action spec-comment-act src-loc-style)] [SPEC-COMMENT-ACT-STX (wrap-action spec-comment-act src-loc-style)]
[EOF-ACT-STX (wrap-action eof-act src-loc-style)]) [EOF-ACT-STX (wrap-action eof-act src-loc-style)])
(syntax-property (syntax/loc stx (let ([NAME ACT] ...)
(syntax/loc stx (let ([NAME ACT] ...) (let ([proc (lexer-body START-STATE-STX
(let ([proc (lexer-body START-STATE-STX TRANS-TABLE-STX
TRANS-TABLE-STX (vector ACT-NAME ...)
(vector ACT-NAME ...) NO-LOOKAHEAD-STX
NO-LOOKAHEAD-STX SPEC-ACT-STX
SPEC-ACT-STX HAS-COMMENT-ACT?-STX
HAS-COMMENT-ACT?-STX 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)))))
'disappeared-use disappeared-uses)))])))
(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))

@ -125,9 +125,8 @@
;; (values table nat (vector-of (union #f syntax-object)) (vector-of bool) (list-of syntax-object)) ;; (values table nat (vector-of (union #f syntax-object)) (vector-of bool) (list-of syntax-object))
;; each syntax object has the form (re action) ;; each syntax object has the form (re action)
(define (build-lexer sos) (define (build-lexer sos)
(define disappeared-uses (box null))
(define s-re-acts (for/list ([so (in-list sos)]) (define s-re-acts (for/list ([so (in-list sos)])
(cons (parse (stx-car so) disappeared-uses) (cons (parse (stx-car so))
(stx-car (stx-cdr so))))) (stx-car (stx-cdr so)))))
(define cache (make-cache)) (define cache (make-cache))
(define re-acts (for/list ([s-re-act (in-list s-re-acts)]) (define re-acts (for/list ([s-re-act (in-list s-re-acts)])
@ -156,6 +155,5 @@
num-states num-states
(/ (* 4.0 (+ 2 num-states (* 2 num-vectors) num-entries (/ (* 4.0 (+ 2 num-states (* 2 num-vectors) num-entries
(* 5 num-different-entries))) 1024))) (* 5 num-different-entries))) 1024)))
(values table (dfa-start-state dfa) (dfa->actions dfa) (dfa->no-look dfa) (values table (dfa-start-state dfa) (dfa->actions dfa) (dfa->no-look dfa)))
(unbox disappeared-uses)))

@ -1,5 +1,5 @@
#lang racket/base #lang racket/base
(require "util.rkt" syntax/id-table) (require "util.rkt" syntax/id-table racket/syntax)
(provide parse) (provide parse)
(define (bad-args stx num) (define (bad-args stx num)
@ -32,24 +32,21 @@
;; parse : syntax-object (box (list-of syntax-object)) -> s-re (see re.rkt) ;; parse : syntax-object (box (list-of syntax-object)) -> s-re (see re.rkt)
;; checks for errors and generates the plain s-exp form for s ;; checks for errors and generates the plain s-exp form for s
;; Expands lex-abbrevs and applies lex-trans. ;; Expands lex-abbrevs and applies lex-trans.
(define (parse stx disappeared-uses) (define (parse stx)
(let loop ([stx stx] (let loop ([stx stx]
[disappeared-uses disappeared-uses]
;; seen-lex-abbrevs: id-table ;; seen-lex-abbrevs: id-table
[seen-lex-abbrevs (make-immutable-free-id-table)]) [seen-lex-abbrevs (make-immutable-free-id-table)])
(let ([recur (λ (s) (let ([recur (λ (s)
(loop (syntax-rearm s stx) (loop (syntax-rearm s stx)
disappeared-uses
seen-lex-abbrevs))] seen-lex-abbrevs))]
[recur/abbrev (λ (s id) [recur/abbrev (λ (s id)
(loop (syntax-rearm s stx) (loop (syntax-rearm s stx)
disappeared-uses
(free-id-table-set seen-lex-abbrevs id id)))]) (free-id-table-set seen-lex-abbrevs id id)))])
(syntax-case (disarm stx) (repetition union intersection complement concatenation (syntax-case (disarm stx) (repetition union intersection complement concatenation
char-range char-complement) char-range char-complement)
[_ [_
(identifier? stx) (identifier? stx)
(let ([expansion (syntax-local-value stx (λ () #f))]) (let ([expansion (syntax-local-value/record stx (λ (v) #t))])
(unless (lex-abbrev? expansion) (unless (lex-abbrev? expansion)
(raise-syntax-error 'regular-expression (raise-syntax-error 'regular-expression
"undefined abbreviation" "undefined abbreviation"
@ -61,7 +58,6 @@
stx stx
#f #f
(list (free-id-table-ref seen-lex-abbrevs stx)))) (list (free-id-table-ref seen-lex-abbrevs stx))))
(set-box! disappeared-uses (cons stx (unbox disappeared-uses)))
(recur/abbrev ((lex-abbrev-get-abbrev expansion)) stx))] (recur/abbrev ((lex-abbrev-get-abbrev expansion)) stx))]
[_ [_
(or (char? (syntax-e stx)) (string? (syntax-e stx))) (or (char? (syntax-e stx)) (string? (syntax-e stx)))
@ -111,8 +107,7 @@
`(char-complement ,parsed))] `(char-complement ,parsed))]
((OP form ...) ((OP form ...)
(identifier? #'OP) (identifier? #'OP)
(let* ([expansion (syntax-local-value #'OP (λ () #f))]) (let* ([expansion (syntax-local-value/record #'OP (λ (v) #t))])
(set-box! disappeared-uses (cons #'OP (unbox disappeared-uses)))
(cond (cond
[(lex-trans? expansion) [(lex-trans? expansion)
(recur ((lex-trans-f expansion) (disarm stx)))] (recur ((lex-trans-f expansion) (disarm stx)))]

Loading…
Cancel
Save