Make check-syntax work for variables bound by define-lex-trans and

define-lex-abbrev.

original commit: 6914c94ebb2f8339ef3fd9c7393fd3199526fed6

collects/parser-tools/lex.ss

@@ -85,7 +85,7 @@
                                  ids)))
                         (_ #t)))
                     spec/re-act-lst)))
-             (let-values (((trans start actions no-look)
+             (let-values (((trans start actions no-look disappeared-uses)
                            (build-lexer re-act-lst)))
                (with-syntax ((start-state-stx start)
                              (trans-table-stx trans)
@@ -104,17 +104,20 @@
                               (wrap-action spec-comment-act))
                              (eof-act-stx (wrap-action eof-act))
                              (wrap? wrap?))
-                 (syntax 
+                 (syntax-property
-                  (lexer-body start-state-stx 
+                  (syntax/loc stx
-                              trans-table-stx
+                   (lexer-body start-state-stx 
-                              actions-stx
+                               trans-table-stx
-                              no-lookahead-stx
+                               actions-stx
-                              spec-act-stx
+                               no-lookahead-stx
-                              spec-error-act-stx
+                               spec-act-stx
-                              has-comment-act?-stx
+                               spec-error-act-stx
-                              spec-comment-act-stx
+                               has-comment-act?-stx
-                              eof-act-stx
+                               spec-comment-act-stx
-                              wrap?))))))))))
+                               eof-act-stx
+                               wrap?))
+                  'disappeared-use
+                  disappeared-uses)))))))))
 
   (define-syntax lexer (make-lexer-trans #f))
   (define-syntax lexer-src-pos (make-lexer-trans #t))
@@ -123,7 +126,7 @@
     (syntax-case stx ()
       ((_ name re)
        (identifier? (syntax name))
-       (syntax
+       (syntax/loc stx
         (define-syntax name
           (make-lex-abbrev (quote-syntax re)))))
       (_ 
@@ -141,7 +144,7 @@
                          (syntax-case a ()
                            ((name re)
                             (identifier? (syntax name))
-                            (syntax (define-lex-abbrev name re)))
+                            (syntax/loc a (define-lex-abbrev name re)))
                            (_ (raise-syntax-error
                                #f
                                "form should be (define-lex-abbrevs (name re) ...)"

collects/parser-tools/private-lex/actions.ss

@@ -1,6 +1,6 @@
 (module actions mzscheme
   (provide (all-defined))
-  (require (lib "stx.ss" "syntax"))
+  ;(require (lib "stx.ss" "syntax"))
     
   ;; get-special-action: (syntax-object list) syntax-object syntax-object  -> syntax-object
   ;; Returns the first action from a rule of the form ((which-special) action)

collects/parser-tools/private-lex/front.ss

@@ -126,11 +126,13 @@
               ((dfa->no-look d1) (vector #t))
               ((dfa->no-look d2) (vector #t #f #f #t)))
 
-  ;; build-lexer : syntax-object list -> (values table nat (vector-of (union #f syntax-object)) (vector-of bool))
+  ;; build-lexer : syntax-object list ->
+  ;;   (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)
-    (let* ((s-re-acts (map (lambda (so)
+    (let* ((disappeared-uses (box null))
-                             (cons (parse (car (syntax->list so)))
+           (s-re-acts (map (lambda (so)
+                             (cons (parse (car (syntax->list so)) disappeared-uses)
                                    (cadr (syntax->list so))))
                            sos))
 
@@ -144,5 +146,6 @@
            (dfa (build-dfa re-acts cache)))
       ;(print-dfa dfa)
       ;(printf "states: ~a~n" (dfa-num-states dfa))
-      (values (dfa->1d-table dfa) (dfa-start-state dfa) (dfa->actions dfa) (dfa->no-look dfa))))
+      (values (dfa->1d-table dfa) (dfa-start-state dfa) (dfa->actions dfa) (dfa->no-look dfa)
+              (unbox disappeared-uses))))
   )

collects/parser-tools/private-lex/stx.ss

@@ -1,5 +1,6 @@
 (module stx mzscheme
-  (require "util.ss")
+  (require (lib "boundmap.ss" "syntax")
+           "util.ss")
   
   (provide parse)
 
@@ -28,10 +29,13 @@
               ((char-range-arg #'"1" #'here) (char->integer #\1)))
   
   
-  ;; parse : syntax-object -> s-re (see re.ss)
+  ;; parse : syntax-object (box (list-of syntax-object)) -> s-re (see re.ss)
   ;; checks for errors and generates the plain s-exp form for s
   ;; Expands lex-abbrevs and applies lex-trans.
-  (define (parse stx)
+  (define (parse stx disappeared-uses)
+    (let ((parse
+           (lambda (stx)
+             (parse stx disappeared-uses))))
     (syntax-case stx (repetition union intersection complement concatenation
                       char-range char-complement)
       (_
@@ -41,6 +45,7 @@
            (raise-syntax-error 'regular-expression
                                "undefined abbreviation"
                                stx))
+         (set-box! disappeared-uses (cons stx (unbox disappeared-uses)))
          (parse (lex-abbrev-abbrev expansion))))
       (_
        (or (char? (syntax-e stx)) (string? (syntax-e stx)))
@@ -105,7 +110,9 @@
            `(char-complement ,parsed))))
        ((op form ...)
         (identifier? (syntax op))
-        (let ((expansion (syntax-local-value (syntax op) (lambda () #f))))
+        (let* ((o (syntax op))
+               (expansion (syntax-local-value o (lambda () #f))))
+          (set-box! disappeared-uses (cons o (unbox disappeared-uses)))
           (cond
             ((lex-trans? expansion)
              (parse ((lex-trans-f expansion) stx)))
@@ -121,7 +128,7 @@
        (raise-syntax-error
         'regular-expression
         "not a char, string, identifier, or (op args ...)"
-        stx))))
+        stx)))))