From c8851d31c5ba3e959221126cfedc560b300c25ed Mon Sep 17 00:00:00 2001 From: "Jesse A. Tov" Date: Sun, 28 Jul 2019 20:17:35 -0500 Subject: [PATCH] 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. --- br-parser-tools-lib/br-parser-tools/lex.rkt | 39 +++++++++++-------- .../br-parser-tools/private-lex/front.rkt | 6 +-- .../br-parser-tools/private-lex/stx.rkt | 13 ++----- 3 files changed, 29 insertions(+), 29 deletions(-) diff --git a/br-parser-tools-lib/br-parser-tools/lex.rkt b/br-parser-tools-lib/br-parser-tools/lex.rkt index 5bd3f87..5441f12 100644 --- a/br-parser-tools-lib/br-parser-tools/lex.rkt +++ b/br-parser-tools-lib/br-parser-tools/lex.rkt @@ -4,6 +4,7 @@ ;; create and use the buffer that the lexer reads from. See docs. (require (for-syntax racket/list + racket/syntax syntax/stx syntax/define syntax/boundmap @@ -69,12 +70,20 @@ [input-port (make-rename-transformer #'input-port-p)] [lexeme-srcloc (make-rename-transformer #'lexeme-srcloc-p)]) 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) (λ (stx) (syntax-case stx () [(_ . RE+ACTS) - (let () + (begin-with-disappeared-uses (define spec/re-acts (syntax->list #'RE+ACTS)) (for/and ([x (in-list spec/re-acts)]) (syntax-case x () @@ -101,7 +110,7 @@ (define re-actnames (map (λ (re-act name) (list (stx-car re-act) name)) re-acts names)) (when (null? spec/re-acts) (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 (unless (and ;; All the successor states are final @@ -130,19 +139,17 @@ [HAS-COMMENT-ACT?-STX (if (syntax-e spec-comment-act) #t #f)] [SPEC-COMMENT-ACT-STX (wrap-action spec-comment-act src-loc-style)] [EOF-ACT-STX (wrap-action eof-act src-loc-style)]) - (syntax-property - (syntax/loc stx (let ([NAME ACT] ...) - (let ([proc (lexer-body START-STATE-STX - TRANS-TABLE-STX - (vector ACT-NAME ...) - NO-LOOKAHEAD-STX - SPEC-ACT-STX - HAS-COMMENT-ACT?-STX - SPEC-COMMENT-ACT-STX - EOF-ACT-STX)]) - ;; reverse eta to get named procedures: - (λ (port) (proc port))))) - 'disappeared-use disappeared-uses)))]))) + (syntax/loc stx (let ([NAME ACT] ...) + (let ([proc (lexer-body START-STATE-STX + TRANS-TABLE-STX + (vector ACT-NAME ...) + NO-LOOKAHEAD-STX + SPEC-ACT-STX + HAS-COMMENT-ACT?-STX + SPEC-COMMENT-ACT-STX + EOF-ACT-STX)]) + ;; reverse eta to get named procedures: + (λ (port) (proc port)))))))]))) (define-syntax lexer (make-lexer-macro 'lexer #f)) (define-syntax lexer-src-pos (make-lexer-macro 'lexer-src-pos 'lexer-src-pos)) diff --git a/br-parser-tools-lib/br-parser-tools/private-lex/front.rkt b/br-parser-tools-lib/br-parser-tools/private-lex/front.rkt index 603b32b..c34eba2 100644 --- a/br-parser-tools-lib/br-parser-tools/private-lex/front.rkt +++ b/br-parser-tools-lib/br-parser-tools/private-lex/front.rkt @@ -125,9 +125,8 @@ ;; (values table nat (vector-of (union #f syntax-object)) (vector-of bool) (list-of syntax-object)) ;; each syntax object has the form (re action) (define (build-lexer sos) - (define disappeared-uses (box null)) (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))))) (define cache (make-cache)) (define re-acts (for/list ([s-re-act (in-list s-re-acts)]) @@ -156,6 +155,5 @@ num-states (/ (* 4.0 (+ 2 num-states (* 2 num-vectors) num-entries (* 5 num-different-entries))) 1024))) - (values table (dfa-start-state dfa) (dfa->actions dfa) (dfa->no-look dfa) - (unbox disappeared-uses))) + (values table (dfa-start-state dfa) (dfa->actions dfa) (dfa->no-look dfa))) diff --git a/br-parser-tools-lib/br-parser-tools/private-lex/stx.rkt b/br-parser-tools-lib/br-parser-tools/private-lex/stx.rkt index 326ecb3..07e80c3 100644 --- a/br-parser-tools-lib/br-parser-tools/private-lex/stx.rkt +++ b/br-parser-tools-lib/br-parser-tools/private-lex/stx.rkt @@ -1,5 +1,5 @@ #lang racket/base -(require "util.rkt" syntax/id-table) +(require "util.rkt" syntax/id-table racket/syntax) (provide parse) (define (bad-args stx num) @@ -32,24 +32,21 @@ ;; 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 ;; Expands lex-abbrevs and applies lex-trans. -(define (parse stx disappeared-uses) +(define (parse stx) (let loop ([stx stx] - [disappeared-uses disappeared-uses] ;; seen-lex-abbrevs: id-table [seen-lex-abbrevs (make-immutable-free-id-table)]) (let ([recur (λ (s) (loop (syntax-rearm s stx) - disappeared-uses seen-lex-abbrevs))] [recur/abbrev (λ (s id) (loop (syntax-rearm s stx) - disappeared-uses (free-id-table-set seen-lex-abbrevs id id)))]) (syntax-case (disarm stx) (repetition union intersection complement concatenation char-range char-complement) [_ (identifier? stx) - (let ([expansion (syntax-local-value stx (λ () #f))]) + (let ([expansion (syntax-local-value/record stx (λ (v) #t))]) (unless (lex-abbrev? expansion) (raise-syntax-error 'regular-expression "undefined abbreviation" @@ -61,7 +58,6 @@ stx #f (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))] [_ (or (char? (syntax-e stx)) (string? (syntax-e stx))) @@ -111,8 +107,7 @@ `(char-complement ,parsed))] ((OP form ...) (identifier? #'OP) - (let* ([expansion (syntax-local-value #'OP (λ () #f))]) - (set-box! disappeared-uses (cons #'OP (unbox disappeared-uses))) + (let* ([expansion (syntax-local-value/record #'OP (λ (v) #t))]) (cond [(lex-trans? expansion) (recur ((lex-trans-f expansion) (disarm stx)))]