fix errortrace for submodules

collects/errortrace/errortrace-lib.rkt

@@ -41,20 +41,54 @@
 (define (disarm stx)
   (syntax-disarm stx code-insp))
 
+(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 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
-         #`(#,(namespace-module-identifier) name init-import
+            #`(#,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)))])]))
+                  #'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)
+             (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 ...))])
-                     (add-test-coverage-init-code
-                      (normal
                          (copy-props
                           top-e
-                        #`(#,(namespace-module-identifier) name init-import
+                          #`(#,mod-id name init-import
                                       #,(syntax-rearm
                                          #`(#%plain-module-begin
                                             #,(generate-key-imports meta-depth)
                                             body ...)
-                              #'mb))))))])])))]
+                                         #'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) ()
+          (annotate-module expr disarmed-expr)]
-            [(__plain-module-begin body ...)
+         [(module* name init-import mb)
-             ;; Just wrap body expressions
+          (annotate-module expr disarmed-expr)]
-             (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)))))))))])]
          
          [(#%expression e)
           (rearm expr #`(#%expression #,(annotate (syntax e) phase)))]
@@ -579,6 +565,27 @@
        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))
   (define (annotate-named name expr phase)

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,12 +6747,11 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
     }
 
     /* for future expansion, shift away from self_modidx: */
+    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);
 
-    /* Remember this syntax as-is for re-expansion: */
-    if (!SCHEME_NULLP(submodule_ancestry))
-      fm = scheme_stx_property(fm, scheme_intern_symbol("submodule"), fm);
-
     /* 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;