fix errortrace for submodules

collects/errortrace/errortrace-lib.rkt

@@ -40,21 +40,55 @@
                    (#%variable-reference)))
 (define (disarm stx)
   (syntax-disarm stx code-insp))
-    
-(define (add-test-coverage-init-code stx)
+
+(define (transform-all-modules stx proc [in-mod-id (namespace-module-identifier)])
   (syntax-case stx ()
     [(mod name init-import mb)
      (syntax-case (disarm #'mb) (#%plain-module-begin)
-       [(#%plain-module-begin b1 body ...)
-        (copy-props
-         stx
-         #`(#,(namespace-module-identifier) name init-import
-            #,(syntax-rearm
-               #`(#%plain-module-begin
-                  b1 ;; the requires that were introduced earlier
-                  (#%plain-app init-test-coverage '#,(remove-duplicates test-coverage-state))
-                  body ...)
-               #'mb)))])]))
+       [(#%plain-module-begin body ...)
+        (let ()
+          (define ((handle-top-form phase) expr)
+            (syntax-case* (disarm expr) (begin-for-syntax module module*) 
+                          (lambda (a b)
+                            (free-identifier=? a b phase 0))
+              [(begin-for-syntax body ...)
+               (syntax-rearm
+                (map (handle-top-form (add1 phase)) 
+                     (syntax->list #'(body ...)))
+                expr)]
+              [(module . _)
+               (transform-all-modules expr proc #f)]
+              [(module* . _)
+               (transform-all-modules expr proc #f)]
+              [else expr]))
+          (define mod-id (or in-mod-id #'mod))
+          (proc
+           (copy-props
+            stx
+            #`(#,mod-id name init-import
+                        #,(syntax-rearm
+                           #`(#%plain-module-begin
+                              . #,(map (handle-top-form 0) (syntax->list #'(body ...))))
+                           #'mb)))
+           mod-id))])]))
+    
+(define (add-test-coverage-init-code stx)
+  (transform-all-modules
+   stx
+   (lambda (stx mod-id)
+     (syntax-case stx ()
+       [(mod name init-import mb)
+        (syntax-case (disarm #'mb) (#%plain-module-begin)
+          [(#%plain-module-begin b1 body ...)
+           (copy-props
+            stx
+            #`(#,mod-id name init-import
+               #,(syntax-rearm
+                  #`(#%plain-module-begin
+                     b1 ;; the requires that were introduced earlier
+                     (#%plain-app init-test-coverage '#,(remove-duplicates test-coverage-state))
+                     body ...)
+                  #'mb)))])]))))
 
 (define (annotate-covered-file filename-path [display-string #f])
   (annotate-file filename-path
@@ -408,23 +442,25 @@
                                (namespace-base-phase)))
        (if (eq? (syntax-e #'name) 'errortrace-key)
            top-e
-           (let ([top-e (expand-syntax top-e)])
+           (let ([top-e (normal (expand-syntax top-e))])
              (initialize-test-coverage)
-             (syntax-case top-e (#%plain-module-begin)
-               [(mod name init-import mb)
-                (syntax-case (disarm #'mb) (#%plain-module-begin)
-                  [(#%plain-module-begin body ...)
-                   (let ([meta-depth ((count-meta-levels 0) #'(begin body ...))])
-                     (add-test-coverage-init-code
-                      (normal
-                       (copy-props
-                        top-e
-                        #`(#,(namespace-module-identifier) name init-import
-                           #,(syntax-rearm
-                              #`(#%plain-module-begin
-                                 #,(generate-key-imports meta-depth)
-                                 body ...)
-                              #'mb))))))])])))]
+             (add-test-coverage-init-code
+              (transform-all-modules 
+               top-e
+               (lambda (top-e mod-id)
+                 (syntax-case top-e ()
+                   [(mod name init-import mb)
+                    (syntax-case (disarm #'mb) (#%plain-module-begin)
+                      [(#%plain-module-begin body ...)
+                       (let ([meta-depth ((count-meta-levels 0) #'(begin body ...))])
+                         (copy-props
+                          top-e
+                          #`(#,mod-id name init-import
+                                      #,(syntax-rearm
+                                         #`(#%plain-module-begin
+                                            #,(generate-key-imports meta-depth)
+                                            body ...)
+                                         #'mb))))])]))))))]
       [_else
        (let ([e (normal top-e)])
          (let ([meta-depth ((count-meta-levels 0) e)])

collects/errortrace/stacktrace.rkt

@@ -396,23 +396,9 @@
                          (add1 phase)))]
 
          [(module name init-import mb)
-          (syntax-case (disarm #'mb) ()
-            [(__plain-module-begin body ...)
-             ;; Just wrap body expressions
-             (let ([bodys (syntax->list (syntax (body ...)))])
-               (let ([bodyl (map (lambda (b)
-                                   (annotate-top b 0))
-                                 bodys)]
-                     [mb #'mb])
-                 (rearm
-                  expr
-                  (rebuild
-                   disarmed-expr
-                   (list (cons
-                          mb
-                          (rearm
-                           mb
-                           (rebuild mb (map cons bodys bodyl)))))))))])]
+          (annotate-module expr disarmed-expr)]
+         [(module* name init-import mb)
+          (annotate-module expr disarmed-expr)]
          
          [(#%expression e)
           (rearm expr #`(#%expression #,(annotate (syntax e) phase)))]
@@ -578,6 +564,27 @@
                  (syntax->datum expr))])
        expr
        phase)))
+
+  (define (annotate-module expr disarmed-expr)
+    (syntax-case disarmed-expr ()
+      [(mod name init-import mb)
+       (syntax-case (disarm #'mb) ()
+         [(__plain-module-begin body ...)
+          ;; Just wrap body expressions
+          (let ([bodys (syntax->list (syntax (body ...)))])
+            (let ([bodyl (map (lambda (b)
+                                (annotate-top b 0))
+                              bodys)]
+                  [mb #'mb])
+              (rearm
+               expr
+               (rebuild
+                disarmed-expr
+                (list (cons
+                       mb
+                       (rearm
+                        mb
+                        (rebuild mb (map cons bodys bodyl)))))))))])]))
   
   (define annotate (make-annotate #f #f))
   (define annotate-top (make-annotate #t #f))

collects/scribblings/reference/syntax.scrbl

@@ -260,6 +260,20 @@ form. See also @racket[module-compiled-language-info],
 @racket[module->language-info], and
 @racketmodname[racket/language-info].
 
+If a @racket[module] form has a single body @racket[form] and if the
+form is a @racket[#%plain-module-begin] form, then the body
+@racket[form] is traversed to find @racket[module] and
+@racket[module*] forms that are either immediate or under
+@racket[begin-for-syntax]. (That is, the body is search before adding
+any lexical context due to the module's initial @racket[module-path]
+import.) Each such module form is given a @indexed-racket['submodule]
+@tech{syntax property} that whose value is the initial module form.
+Then, when @racket[module] or @racket[module*] is expanded in a
+submodule position, if the form has a @indexed-racket['submodule]
+@tech{syntax property}, the property value is used as the form to
+expand. This protocol avoids the contamination of submodule lexical
+scope when re-expanding @racket[module] forms that contain submodules.
+
 See also @secref["module-eval-model"] and @secref["mod-parse"].
 
 @defexamples[#:eval (syntax-eval)

collects/tests/errortrace/wrap.rkt

@@ -17,7 +17,7 @@
           (get-output-string o)))))
   (unless (regexp-match? (regexp-quote (format "~s" (syntax->datum err-stx)))
                          out-str)
-    (error 'test "not in context for: ~s" (syntax->datum expr))))
+    (error 'test "not in context for: ~s got: ~s" (syntax->datum expr) out-str)))
 
 (provide wrap-tests)
 (define (wrap-tests)
@@ -25,4 +25,7 @@
   (try err-stx)
   (try #`(syntax-case 'a ()
            (_ #,err-stx)))
+  (try #`(begin (module m racket/base (module n racket/base #,err-stx)) (require (submod 'm n))))
+  (try #`(begin (module m racket/base (module* n racket/base #,err-stx)) (require (submod 'm n))))
+  (try #`(begin (module m racket/base (module* n #f #,err-stx)) (require (submod 'm n))))
   (void))

collects/tests/racket/submodule.rktl

@@ -220,6 +220,13 @@
 
 (test 120 dynamic-require '(submod 'sub4-m n) 'x)
 
+(eval 
+ (expand
+  (expand '(module sub3.5-m racket
+             (begin-for-syntax
+              (module* n #f (define x 8.5) (provide x)))))))
+(test 8.5 dynamic-require '(submod 'sub3.5-m n) 'x)
+
 (eval 
  (expand
   (expand '(module sub3-m racket/base

src/racket/cmdline.inc

@@ -365,7 +365,7 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
             }
             /* Use a module path index so that multiple resolutions are no unduly
                sensitive to changes in the current directory or other configurations: */
-            mpi = scheme_make_modidx(a[0], scheme_false, scheme_false);
+            mpi = scheme_make_modidx(a[0], scheme_make_false(), scheme_make_false());
             if (!did_config)
               configure_environment(mpi);
             /* Run the module: */
@@ -377,9 +377,9 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
                                                                         scheme_make_pair(scheme_intern_symbol("main"),
                                                                                          scheme_null))),
                                       mpi,
-                                      scheme_false);
+                                      scheme_make_false());
             if (scheme_module_is_declared(a[0], 1)) {
-              a[1] = scheme_false;
+              a[1] = scheme_make_false();
               scheme_apply(scheme_builtin_value("dynamic-require"), 2, a);
             }
           }

src/racket/src/fun.c

@@ -7086,6 +7086,8 @@ scheme_get_stack_trace(Scheme_Object *mark_set)
 
       name = SCHEME_CAR(name);
       name = SCHEME_PTR_VAL(name);
+      if (SCHEME_PAIRP(name))
+        name = scheme_make_pair(scheme_intern_symbol("submod"), name);
       loc = scheme_make_location(name, scheme_false, 
                                  scheme_false, scheme_false, scheme_false);
 

src/racket/src/module.c

@@ -6120,6 +6120,201 @@ static Scheme_Object *strip_lexical_context(Scheme_Object *stx)
   return v;
 }
 
+static Scheme_Object *do_annotate_submodules_k(void);
+
+Scheme_Object *do_annotate_submodules(Scheme_Object *fm, int phase)
+{
+  Scheme_Object *a, *d, *v;
+  int changed = 0;
+
+#ifdef DO_STACK_CHECK
+# include "mzstkchk.h"
+  {
+    Scheme_Thread *p = scheme_current_thread;
+    p->ku.k.p1 = (void *)fm;
+    return scheme_handle_stack_overflow(do_annotate_submodules_k);
+  }
+#endif
+
+  if (!SCHEME_STX_PAIRP(fm))
+    return fm;
+
+  a = SCHEME_STX_CAR(fm);
+  if (SCHEME_STX_PAIRP(a)) {
+    v = SCHEME_STX_CAR(a);
+    if (SCHEME_STX_SYMBOLP(v)) {
+      if (scheme_stx_module_eq3(scheme_module_stx, v, 
+                                scheme_make_integer(0), scheme_make_integer(phase), 
+                                NULL)
+          || scheme_stx_module_eq3(scheme_modulestar_stx, v, 
+                                   scheme_make_integer(0), scheme_make_integer(phase), 
+                                   NULL)) {
+        /* found a submodule */
+        a = scheme_stx_property(a, scheme_intern_symbol("submodule"), a);
+        changed = 1;
+      } else if (scheme_stx_module_eq3(scheme_begin_for_syntax_stx, v, 
+                                       scheme_make_integer(0), scheme_make_integer(phase), 
+                                       NULL)) {
+        /* found `begin-for-syntax' */
+        v = do_annotate_submodules(a, phase+1);
+        if (!SAME_OBJ(v, a)) {
+          changed = 1;
+          a = v;
+        }
+      }
+    }
+  }
+
+  v = SCHEME_STX_CDR(fm);
+  d = do_annotate_submodules(v, phase);
+
+  if (!changed && SAME_OBJ(v, d))
+    return fm;
+   
+  v = scheme_make_pair(a, d);
+  if (SCHEME_STXP(fm))
+    v = scheme_datum_to_syntax(v, fm, fm, 0, 2);
+
+  return v;
+}
+
+static Scheme_Object *do_annotate_submodules_k(void)
+{
+  Scheme_Thread *p = scheme_current_thread;
+  Scheme_Object *fm = (Scheme_Object *)p->ku.k.p1;
+
+  p->ku.k.p1 = NULL;
+
+  return do_annotate_submodules(fm, p->ku.k.i1);
+}
+
+static Scheme_Object *annotate_existing_submodules(Scheme_Object *orig_fm)
+{
+  Scheme_Object *fm = orig_fm;
+
+  if (!SCHEME_STX_PAIRP(fm))
+    return orig_fm;
+  fm = SCHEME_STX_CAR(fm);
+  if (!SCHEME_STX_SYMBOLP(fm))
+    return orig_fm;
+
+  if (scheme_stx_module_eq(scheme_module_begin_stx, fm, 0)) {
+    /* It's a `#%plain-module-begin' form */
+    return do_annotate_submodules(orig_fm, 0);
+  }
+
+  return orig_fm;
+}
+
+static Scheme_Object *rebuild_with_phase_shift(Scheme_Object *orig, Scheme_Object *a, Scheme_Object *d, 
+                                               Scheme_Object *old_midx, Scheme_Object *new_midx)
+{
+  if (!a) a = SCHEME_STX_CAR(orig);
+  if (!d) d = SCHEME_STX_CDR(orig);
+
+  a = scheme_make_pair(a, d);
+
+  if (SCHEME_PAIRP(orig))
+    return a;
+
+  orig = scheme_stx_phase_shift(orig, NULL, old_midx, new_midx, NULL, NULL);
+  return scheme_datum_to_syntax(a, orig, orig, 0, 2);
+}
+
+static Scheme_Object *phase_shift_skip_submodules_k(void);
+
+static Scheme_Object *phase_shift_skip_submodules(Scheme_Object *fm, 
+                                                  Scheme_Object *old_midx, Scheme_Object *new_midx,
+                                                  int phase)
+{
+  Scheme_Object *v0, *v1, *v2, *v3, *v4, *naya;
+
+#ifdef DO_STACK_CHECK
+# include "mzstkchk.h"
+  {
+    Scheme_Thread *p = scheme_current_thread;
+    p->ku.k.p1 = (void *)fm;
+    p->ku.k.p2 = (void *)old_midx;
+    p->ku.k.p3 = (void *)new_midx;
+    p->ku.k.i1 = phase;
+    return scheme_handle_stack_overflow(phase_shift_skip_submodules_k);
+  }
+#endif
+
+  if (phase == -1) {
+    /* at top: */
+    v0 = SCHEME_STX_CDR(fm);
+    v1 = SCHEME_STX_CDR(v0);
+    v2 = SCHEME_STX_CDR(v1);
+    v3 = SCHEME_STX_CAR(v2);
+    v4 = SCHEME_STX_CDR(v3);
+
+    naya = phase_shift_skip_submodules(v4, old_midx, new_midx, 0);
+    if (SAME_OBJ(naya, v4)) {
+      return scheme_stx_phase_shift(fm, NULL, old_midx, new_midx, NULL, NULL);
+    } else {
+      v3 = rebuild_with_phase_shift(v3, NULL, naya, old_midx, new_midx);
+      v2 = rebuild_with_phase_shift(v2, v3, NULL, old_midx, new_midx);
+      v1 = rebuild_with_phase_shift(v1, NULL, v2, old_midx, new_midx);
+      v0 = rebuild_with_phase_shift(v0, NULL, v1, old_midx, new_midx);
+      return rebuild_with_phase_shift(fm, NULL, v0, old_midx, new_midx);
+    }
+  } else if (SCHEME_STX_NULLP(fm)) {
+    return fm;
+  } else {
+    v1 = SCHEME_STX_CAR(fm);
+    
+    if (SCHEME_STX_PAIRP(v1)) {
+      v2 = SCHEME_STX_CAR(v1);
+      if (SCHEME_STX_SYMBOLP(v2)) {
+        if (scheme_stx_module_eq3(scheme_module_stx, v2, 
+                                  scheme_make_integer(0), scheme_make_integer(phase),
+                                  NULL)
+            || scheme_stx_module_eq3(scheme_modulestar_stx, v2, 
+                                     scheme_make_integer(0), scheme_make_integer(phase),
+                                     NULL)) {
+          /* found a submodule */
+          v2 = SCHEME_STX_CDR(fm);
+          naya = phase_shift_skip_submodules(v2, old_midx, new_midx, phase);
+          return rebuild_with_phase_shift(fm, v1, naya, old_midx, new_midx);
+        } else if (scheme_stx_module_eq3(scheme_begin_for_syntax_stx, v2, 
+                                         scheme_make_integer(0), scheme_make_integer(phase),
+                                         NULL)) {
+          /* found `begin-for-syntax': */
+          naya = phase_shift_skip_submodules(v1, old_midx, new_midx, phase+1);
+          v2 = SCHEME_STX_CDR(fm);
+          v3 = phase_shift_skip_submodules(v2, old_midx, new_midx, phase+1);
+          if (SAME_OBJ(naya, v1) && SAME_OBJ(v2, v3))
+            return fm;
+          else
+            return rebuild_with_phase_shift(fm, naya, v3, old_midx, new_midx);
+        }
+      }
+    }
+
+    v3 = SCHEME_STX_CDR(fm);
+    v4 = phase_shift_skip_submodules(v3, old_midx, new_midx, phase);
+    if (SAME_OBJ(v3, v4))
+      return fm;
+    else
+      return rebuild_with_phase_shift(fm, v1, v4, old_midx, new_midx);
+  }
+}
+
+static Scheme_Object *phase_shift_skip_submodules_k(void)
+{
+  Scheme_Thread *p = scheme_current_thread;
+  Scheme_Object *fm = (Scheme_Object *)p->ku.k.p1;
+  Scheme_Object *old_midx = (Scheme_Object *)p->ku.k.p2;
+  Scheme_Object *new_midx = (Scheme_Object *)p->ku.k.p3;
+
+  p->ku.k.p1 = NULL;
+  p->ku.k.p2 = NULL;
+  p->ku.k.p3 = NULL;
+
+  return phase_shift_skip_submodules(fm, old_midx, new_midx, p->ku.k.i1);
+}
+
 static Scheme_Env *find_env(Scheme_Env *env, intptr_t ph)
 {
   intptr_t j;
@@ -6415,6 +6610,13 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
   if (SCHEME_STX_PAIRP(fm) && SCHEME_STX_NULLP(SCHEME_STX_CDR(fm))) {
     /* Perhaps expandable... */
     fm = SCHEME_STX_CAR(fm);
+
+    /* If the body is `#%plain-module-begin' and if any form is a
+       `module' form (i.e., already with the `module' binding, then
+       attach the original form as a property to the `module' form, so
+       that re-expansion can use it instead of dropping all lexical
+       context: */
+    fm = annotate_existing_submodules(fm);
   } else {
     fm = scheme_make_pair(scheme_datum_to_syntax(module_begin_symbol, form, mb_ctx, 0, 2), 
 			  fm);
@@ -6545,11 +6747,10 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
     }
 
     /* for future expansion, shift away from self_modidx: */
-    fm = scheme_stx_phase_shift(fm, NULL, self_modidx, empty_self_modidx, NULL, NULL);
-
-    /* Remember this syntax as-is for re-expansion: */
-    if (!SCHEME_NULLP(submodule_ancestry))
-      fm = scheme_stx_property(fm, scheme_intern_symbol("submodule"), fm);
+    if (m->pre_submodules) /* non-NULL => some submodules, even if it's '() */
+      fm = phase_shift_skip_submodules(fm, self_modidx, empty_self_modidx, -1);
+    else
+      fm = scheme_stx_phase_shift(fm, NULL, self_modidx, empty_self_modidx, NULL, NULL);
 
     /* make self_modidx like the empty modidx */
     ((Scheme_Modidx *)self_modidx)->resolved = empty_self_modname;
@@ -8496,6 +8697,9 @@ static Scheme_Object *expand_submodules(Scheme_Compile_Expand_Info *rec, int dre
       l = scheme_make_pair(SCHEME_CAR(mods), l);
       env->genv->module->pre_submodules = l;
     }
+  } else if (!SCHEME_NULLP(mods)) {
+    /* setting pre_submodules to '() indicates that there were submodules during expansion */
+    env->genv->module->pre_submodules = scheme_null;
   }
 
   return mods;