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

@@ -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))

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)))
  

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)))]