add tracking of require and provide subforms

Use `syntax-track-origin` and 'disappeared-use properties to
communicate `require` and `provide` form bindings to tools such as
Check Syntax.

Relevant to PR 13186

pkgs/racket-test-core/tests/racket/module.rktl

@@ -1353,6 +1353,42 @@
 
 (test #t syntax? (expand-syntax (expand lifted-require-of-submodule)))
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check addition of 'disappeared-use by `provide`
+
+(require (rename-in racket/base [lib racket-base:lib]))
+
+(let ()
+  (define (find-disappeared stx id)
+    (let loop ([s stx])
+      (cond
+       [(syntax? s)
+        (define p (cons (syntax-property s 'disappeared-use)
+                        (syntax-property s 'origin)))
+        (or (let loop ([p p])
+              (cond
+               [(identifier? p) (and (free-identifier=? p id)
+                                     (eq? (syntax-e p) (syntax-e id)))]
+               [(pair? p) (or (loop (car p))
+                              (loop (cdr p)))]
+               [else #f]))
+            (loop (syntax-e s)))]
+       [(pair? s)
+        (or (loop (car s))
+            (loop (cdr s)))]
+       [else #f])))
+  (let ([form (expand `(module m racket/base
+                        (provide (struct-out s))
+                        (struct s ())))])
+    (test #t find-disappeared form #'struct-out))
+  (let ([form (expand `(module m racket/base
+                        (require (only-in racket/base car))))])
+    (test #t find-disappeared form #'only-in))
+  (let ([form (expand `(module m racket/base
+                        (require (rename-in racket/base [lib racket-base:lib])
+                                 (racket-base:lib "racket/base"))))])
+    (test #t find-disappeared form #'racket-base:lib)))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)

racket/collects/racket/private/reqprov.rkt

@@ -55,16 +55,16 @@
                   (if (and (eq? new-mp #'mp)
                            (eq? (car d) 'submod))
                       stx
-                      (datum->syntax
+                      (syntax-track/form (datum->syntax
                                           stx
                                           (list* kw new-mp #'rest)
-                       stx
+                                          stx)
                                          stx)))])]
             [(eq? (car d) kw) stx]
-            [else (datum->syntax
+            [else (syntax-track/form (datum->syntax
                                       stx
                                       (cons kw (cdr d))
-                   stx
+                                      stx)
                                      stx)]))
          stx)))
   
@@ -298,12 +298,13 @@
                         (simple-path? #'path)
                         (list (mode-wrap
                                base-mode
+                               (syntax-track/form
                                 (datum->syntax
                                  #'path
                                  (syntax-e
                                   (quasisyntax
                                    (prefix pfx #,(xlate-path #'path))))
-                                in
+                                 in)
                                 in)))]
                        [(except-in path id ...)
                         (and (simple-path? #'path)
@@ -312,14 +313,19 @@
                                (lambda (a b) #t)))
                         (list (mode-wrap
                                base-mode
+                               (syntax-track/form
                                 (datum->syntax
                                  #'path
                                  (syntax-e
                                   (quasisyntax/loc in
-                                   (all-except #,(xlate-path #'path) id ...))))))]
+                                    (all-except #,(xlate-path #'path) id ...))))
+                                in)))]
                        ;; General case:
                        [_ (let-values ([(imports sources) (expand-import in)])
                             ;; TODO: collapse back to simple cases when possible
+                            (cons/syntax-track/form
+                             #'(just-meta 0)
+                             in
                              (append
                               (map (lambda (import)
                                      #`(just-meta
@@ -332,7 +338,7 @@
                               (map (lambda (src)
                                      (mode-wrap (phase+ base-mode (import-source-mode src))
                                                 #`(only #,(import-source-mod-path-stx src))))
-                                  sources)))]))]
+                                   sources))))]))]
                   [transform-one
                    (lambda (in)
                      ;; Recognize `for-syntax', etc. for simple cases:
@@ -340,14 +346,20 @@
                        [(for-meta n elem ...)
                         (or (exact-integer? (syntax-e #'n))
                             (not (syntax-e #'n)))
+                        (cons/syntax-track/form
+                         #'(for-meta n)
+                         in
                          (apply append
                                 (map (lambda (in)
                                        (transform-simple in (syntax-e #'n)))
-                                    (syntax->list #'(elem ...))))]
+                                     (syntax->list #'(elem ...)))))]
                        [(for-something elem ...)
                         (and (identifier? #'for-something)
                              (ormap (lambda (i) (free-identifier=? i #'for-something))
                                     (list #'for-syntax #'for-template #'for-label)))
+                        (cons/syntax-track/form
+                         #'(for-something)
+                         in
                          (apply append
                                 (map (lambda (in)
                                        (transform-simple in
@@ -358,7 +370,7 @@
                                                            -1]
                                                           [(free-identifier=? #'for-something #'for-label)
                                                            #f])))
-                                    (syntax->list #'(elem ...))))]
+                                     (syntax->list #'(elem ...)))))]
                        [_ (transform-simple in 0 #| run phase |#)]))])
            (syntax-case stx ()
              [(_ in)
@@ -401,6 +413,15 @@
                            "not at module level or top level"
                            stx)]))
 
+  (define-for-syntax (syntax-track/form stx orig)
+    (syntax-track-origin stx orig (syntax-local-introduce (car (syntax-e orig)))))
+
+  (define-for-syntax (cons/syntax-track/form stx orig l)
+    ;; Add `stx` as a dummy require if needed to track `orig`
+    (if (pair? l)
+        (cons (syntax-track/form (car l) orig)
+              (cdr l))
+        (cons (syntax-track/form stx orig) l)))
 
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; require transformers
@@ -721,11 +742,32 @@
                           exports)))])
          (syntax-case stx ()
            [(_ out ...)
-            (with-syntax ([(new-out ...)
+            (let ([outs (syntax->list #'(out ...))])
-                           (apply append
+              (with-syntax ([(new-out ...) (apply append (map transform-simple outs))])
-                                  (map transform-simple (syntax->list #'(out ...))))])
+                (copy-disappeared-uses
+                 outs
                  (syntax/loc stx
-                (begin new-out ...)))]))]))
+                   (begin new-out ...)))))]))]))
+
+  (define-for-syntax (copy-disappeared-uses outs r)
+    (cond
+     [(null? outs) r]
+     [else
+      (let ([p (syntax-property (car outs) 'disappeared-use)]
+            [name (if (identifier? (car outs))
+                      #f
+                      (syntax-local-introduce (car (syntax-e (car outs)))))]
+            [combine (lambda (b a)
+                       (if a
+                           (if b
+                               (cons a b)
+                               a)
+                           b))])
+        (syntax-property r 'disappeared-use
+                         (combine p
+                                  (combine
+                                   name
+                                   (syntax-property r 'disappeared-use)))))]))
 
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; provide transformers

racket/collects/racket/provide-transform.rkt

@@ -75,7 +75,9 @@
                         #f
                         "result from provide pre-transformer is not a syntax object"
                         stx))
-                     v)
+                     (syntax-property v
+                                      'disappeared-use
+                                      (syntax-local-introduce #'id)))
                    stx))]
             [_ stx]))))
 

racket/src/racket/src/module.c

@@ -11016,7 +11016,7 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e,
                     Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec,
                     Scheme_Object **_expanded)
 {
-  Scheme_Object *l, *rebuilt = scheme_null, *protect_stx = NULL;
+  Scheme_Object *l, *rebuilt = scheme_null, *protect_stx = NULL, *rebuild_from = scheme_null;
   int protect_cnt = 0, mode_cnt = 0, expanded = 0;
   Scheme_Object *mode = scheme_make_integer(0), *mode_stx = NULL;
   Scheme_Object *all_x_defs_out, *all_x_defs;
@@ -11041,6 +11041,8 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e,
         if (SAME_OBJ(protect_symbol, av)) {
           if (protect_cnt)
             scheme_wrong_syntax(NULL, a, e, "nested `protect' not allowed");
+          if (_expanded)
+            rebuild_from = scheme_make_pair(a, rebuild_from);
           protect_stx = a;
           a = SCHEME_STX_CDR(a);
           a = scheme_flatten_syntax_list(a, NULL);
@@ -11142,6 +11144,9 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e,
         if (!all_x_defs) all_x_defs = scheme_null;
         p = expand_provide(p, at_phase, tables, all_defs, cenv, rec, drec);
 
+        if (_expanded)
+          rebuild_from = scheme_make_pair(p, rebuild_from);
+
         /* Check for '(begin datum ...) result: */
         p = scheme_flatten_syntax_list(p, &islist);
         if (!islist)
@@ -11440,6 +11445,12 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e,
       a = SCHEME_STX_CAR(e);
       rebuilt = scheme_make_pair(a, scheme_reverse(rebuilt));
       rebuilt = scheme_datum_to_syntax(rebuilt, e, e, 0, 2);
+
+      while (SCHEME_PAIRP(rebuild_from)) {
+        rebuilt = scheme_stx_track(rebuilt, SCHEME_CAR(rebuild_from), NULL);
+        rebuild_from = SCHEME_CDR(rebuild_from);
+      }
+
       *_expanded = rebuilt;
     } else {
       *_expanded = e;

racket/src/racket/src/syntax.c

@@ -656,7 +656,7 @@ Scheme_Object *scheme_stx_track(Scheme_Object *naya,
 	for (; SCHEME_PAIRP(oe); oe = SCHEME_CDR(oe)) {
 	  a = SCHEME_CAR(SCHEME_CAR(oe));
 	  if (!SAME_OBJ(a, source_symbol) && !SAME_OBJ(a, share_symbol)) {
-	    if (!SAME_OBJ(a, origin_symbol)) {
+	    if (!origin || !SAME_OBJ(a, origin_symbol)) {
 	      p = ICONS(SCHEME_CAR(oe), scheme_null);
 	    } else {
 	      p = ICONS(ICONS(a, ICONS(origin, 
@@ -675,7 +675,7 @@ Scheme_Object *scheme_stx_track(Scheme_Object *naya,
 
 	oe = first;
       } 
-      if (add) {
+      if (add && origin) {
 	oe = ICONS(ICONS(origin_symbol, 
 			 ICONS(origin, scheme_null)),
 		  oe);
@@ -686,10 +686,14 @@ Scheme_Object *scheme_stx_track(Scheme_Object *naya,
     oe = NULL;
   }
 
-  if (!oe)
+  if (!oe) {
+    if (origin)
       oe = ICONS(ICONS(origin_symbol, 
                        ICONS(origin, scheme_null)),
                  scheme_null);
+    else
+      oe = scheme_null;
+  }
 
   /* Merge ne and oe (ne takes precedence). */