preserve submoduleness in module path index for expanded submodules

The preserved path is exposed by a new `module-path-index-submodule'
function, and `module-path-index-join' now accepts an optional
submodule path.

Also, fixed a problem with `collapse-module-path-index' when
a module path indx is built on a resolved module path that
is a submodule path.

In addition to the main repair, `collapse-module-path[-index]' is
correctly documented to allow '(quote <sym>) rel-to paths.

Finally, `collapse-module-path-index' changed to use a symbolic
resolved module path that appears as the base of a module path
index, rather than falling back to the given rel-to path. It's
possble that the old beavior was intentional, but it wasn't tested,
and it seems more likely to have been a bug.

Closes PR 12724

collects/scribblings/reference/module-reflect.scrbl

@@ -28,7 +28,7 @@ Returns @racket[#f] if @racket[v] is a @tech{resolved module path},
                                                 (and/c path? complete-path?)
                                                 (cons/c (or/c symbol?
                                                               (and/c path? complete-path?))
-                                                        (cons/c symbol? (listof symbol?))))])
+                                                        (non-empty-listof symbol?)))])
          resolved-module-path?]{
 
 Returns a @tech{resolved module path} that encapsulates @racket[path],
@@ -47,7 +47,7 @@ A @tech{resolved module path} is interned. That is, if two
                (and/c path? complete-path?)
                (cons/c (or/c symbol?
                              (and/c path? complete-path?))
-                       (cons/c symbol? (listof symbol?))))]{
+                       (non-empty-listof symbol?)))]{
 
 Returns the path or symbol encapsulated by a @tech{resolved module path}.
 A list result corresponds to a @tech{submodule} path.}
@@ -196,8 +196,9 @@ path index}. If the identifier is instead defined in a module that is
 imported via a module path (as opposed to a literal module name), then
 the identifier's source module will be reported using a @tech{module
 path index} that contains the @racket[require]d module path and the
-``self'' @tech{module path index}.
+``self'' @tech{module path index}. A ``self'' @tech{module path index}
-
+has a submodule path when the module that it refers to is a
+@tech{submodule}.
 
 A @tech{module path index} has state. When it is @deftech{resolved} to
 a @tech{resolved module path}, then the @tech{resolved module path} is
@@ -234,8 +235,9 @@ resolved name can depend on the value of
          (values (or/c module-path? #f)
                  (or/c module-path-index? resolved-module-path? #f))]{
 
-Returns two values: a module path, and a base @tech{module path index}
+Returns two values: a module path, and a base path---either a
-or @racket[#f] to which the module path is relative.
+@tech{module path index}, @tech{resolved module path}, or
+@racket[#f]---to which the first path is relative.
 
 A @racket[#f] second result means that the path is relative to an
 unspecified directory (i.e., its resolution depends on the value of
@@ -244,15 +246,29 @@ unspecified directory (i.e., its resolution depends on the value of
 
 A @racket[#f] for the first result implies a @racket[#f] for the
 second result, and means that @racket[mpi] represents ``self'' (see
-above).}
+above). Such a @tech{module path index} may have a non-@racket[#f]
+submodule path as reported by @racket[module-path-index-submodule].}
+
+
+@defproc[(module-path-index-submodule [mpi module-path-index?])
+         (or/c #f (non-empty-listof symbol?))]{
+
+Returns a non-empty list of symbols if @racket[mpi] is a ``self'' (see
+above) @tech{module path index} that refers to a @tech{submodule}. The
+result is always @racket[#f] if either result of
+@racket[(module-path-index-split mpi)] is non-@racket[#f].}
+
 
 @defproc[(module-path-index-join [path (or/c module-path? #f)]
-                                 [mpi (or/c module-path-index? resolved-module-path? #f)])
+                                 [base (or/c module-path-index? resolved-module-path? #f)]
+                                 [submod (or/c #f (non-empty-listof symbol?)) #f])
          module-path-index?]{
 
-Combines @racket[path] and @racket[mpi] to create a new @tech{module
+Combines @racket[path], @racket[base], and @racket[submod] to create a
-path index}. The @racket[path] argument can @racket[#f] only if
+new @tech{module path index}. The @racket[path] argument can
-@racket[mpi] is also @racket[#f].}
+@racket[#f] only if @racket[base] is also @racket[#f]. The
+@racket[submod] argument can be a list only when @racket[path] and
+@racket[base] are both @racket[#f].}
 
 @defproc[(compiled-module-expression? [v any/c]) boolean?]{
 
@@ -262,9 +278,9 @@ declaration, @racket[#f] otherwise. See also
 
 
 @defproc*[([(module-compiled-name [compiled-module-code compiled-module-expression?])
-            (or/c symbol? (cons/c symbol? (cons/c symbol? (listof symbol?))))]
+            (or/c symbol? (cons/c symbol? (non-empty-listof symbol?)))]
            [(module-compiled-name [compiled-module-code compiled-module-expression?]
-                                  [name (or/c symbol? (cons/c symbol? (cons/c symbol? (listof symbol?))))])
+                                  [name (or/c symbol? (cons/c symbol? (non-empty-listof symbol?)))])
             compiled-module-expression?])]{
 
 Takes a module declaration in compiled form and either gets the

collects/syntax/modcollapse.rkt

@@ -18,7 +18,7 @@
                            (cons/c 'file any/c)
                            (cons/c 'planet any/c)
                            (cons/c 'quote any/c))
-                          (listof symbol?))))))
+                          (cons/c symbol? (listof symbol?)))))))
 
 (define rel-to-module-path-v/c
   (or/c simple-rel-to-module-path-v/c 

collects/syntax/modresolve.rkt

@@ -118,8 +118,11 @@
     (if path
         (resolve-module-path path (resolve-possible-module-path-index base relto))
         (let ()
+          (define sm (module-path-index-submodule mpi))
           (define-values (dir submod) (force-relto relto #f))
-          (combine-submod (path-ss->rkt dir) submod)))))
+          (combine-submod (path-ss->rkt dir) (if (and sm submod)
+                                                 (append submod sm)
+                                                 (or sm submod)))))))
 
 (define (resolve-possible-module-path-index base relto)
   (cond [(module-path-index? base)

collects/syntax/private/modcollapse-noctc.rkt

@@ -345,11 +345,21 @@ Use syntax/modcollapse instead.
              (collapse-module-path-index base relto-mp)]
             [(resolved-module-path? base)
              (let ([n (resolved-module-path-name base)])
-               (if (path? n)
+               (if (pair? n)
-                   n
+                   (if (path? (car n))
-                   (force-relto relto-mp)))]
+                       (cons 'submod n)
+                       (list* 'submod `(quote ,(car n)) (cdr n)))
+                   (if (path? n)
+                       n
+                       `(quote ,n))))]
             [else (force-relto relto-mp)])))
-        (force-relto relto-mp))))
+        (let ([r (force-relto relto-mp)]
+              [sm (module-path-index-submodule mpi)])
+          (if sm
+              (if (and (pair? r) (eq? (car r) 'submod))
+                  (append r sm)
+                  (list* 'submod r sm))
+              r)))))
 
 (provide collapse-module-path
          collapse-module-path-index)

collects/syntax/scribblings/modcollapse.scrbl

@@ -6,7 +6,8 @@
 @defmodule[syntax/modcollapse]
 
 @defproc[(collapse-module-path [module-path-v module-path?]
-                               [rel-to-module-path-v any/c]) 
+                               [rel-to-module-path-v (or/c module-path?
+                                                           (-> module-path?))])
          (or/c path? module-path?)]{
 
 Returns a ``simplified'' module path by combining
@@ -14,13 +15,14 @@ Returns a ``simplified'' module path by combining
 latter must have one of the following forms: a @racket['(lib ....)] or
 symbol module path; a @racket['(file ....)] module path; a
 @racket['(planet ....)] module path; a @techlink[#:doc refman]{path};
-a @racket['(submod _base _symbol)] module path or @racket['(submod
+@racket['(@#,racket[quote] @#,racket[_symbol])];
-_path _symbol ...)] list; or a thunk to generate one of those.
+a @racket['(submod @#,racket[_base] @#,racket[_symbol] ...)] module path 
+where @racket[_base] would be allowed; or a thunk to generate one of those.
 
 The result can be a path if @racket[module-path-v] contains a path
 element that is needed for the result, or if
 @racket[rel-to-module-path-v] is a non-string path that is needed for
-the result. Similarly, the result can be @racket[submod] wrapping a
+the result. Similarly, the result can be @racket['submod] wrapping a
 path.  Otherwise, the result is a module path in the sense of
 @racket[module-path?].
 
@@ -32,7 +34,8 @@ base is normalized in the case of a @racket['lib] or @racket['planet]
 base.}
 
 @defproc[(collapse-module-path-index [module-path-index module-path-index?]
-                                     [rel-to-module-path-v any/c])
+                                     [rel-to-module-path-v (or/c module-path?
+                                                                 (-> module-path?))])
          (or/c path? module-path?)]{
 
 Like @racket[collapse-module-path], but the input is a @techlink[#:doc

collects/tests/racket/moddep.rktl

@@ -86,6 +86,19 @@
 (when (eq? (system-path-convention-type) 'unix)
   (test (expand-user-path "~/x.rkt") resolve-module-path '(file "~/x.rkt") #f))
 
+(test `(submod ,(build-path (current-directory) "x.rkt") sub2)
+      resolve-module-path-index
+      (module-path-index-join `(submod ".." sub2)
+                              (module-path-index-join #f #f '(sub1)))
+      (build-path (current-directory) "x.rkt"))
+
+(test `(submod ,(build-path (current-directory) "x.rkt") sub3 sub2)
+      resolve-module-path-index
+      (module-path-index-join `(submod ".." sub2)
+                              (module-path-index-join #f #f '(sub1)))
+      `(submod ,(build-path (current-directory) "x.rkt") sub3))
+
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; collapse-module-path[-index]
 
@@ -307,6 +320,26 @@
 (err/rt-test (collapse-module-path "/apple.ss" (current-directory)))
 (err/rt-test (collapse-module-path-index "apple.ss" (current-directory)))
 
+(test '(submod 'z sub2) 
+      collapse-module-path-index
+      (module-path-index-join `(submod ".." sub2)
+                              (make-resolved-module-path
+                               '(z sub1)))
+      ''a)
+
+(test `(submod ,(build-path (find-system-path 'temp-dir) "z") sub2)
+      collapse-module-path-index
+      (module-path-index-join `(submod ".." sub2)
+                              (make-resolved-module-path
+                               (list (build-path (find-system-path 'temp-dir) "z") 'sub1)))
+      ''a)
+
+(test `(submod 'a sub2)
+      collapse-module-path-index
+      (module-path-index-join `(submod ".." sub2)
+                              (module-path-index-join #f #f '(sub1)))
+      ''a)
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)

collects/tests/racket/submodule.rktl

@@ -325,6 +325,37 @@
        (module* inner-main #f
          (print-cake 20))))))
 
+(syntax-case (parameterize ([current-namespace (make-base-namespace)])
+               (expand
+                '(module m racket/base
+                   (define x 0)
+                   (module* sub #f
+                     (+ x 1))))) ()
+  [(_ name lang (mb (def (x1) _) (mod sub #f
+                                      (mb_ (app cwv (lam () (app_ + x2 _))
+                                                _)))))
+   (begin
+     (test #t free-identifier=? #'x1 #'x2)
+     (let ([mpi (car (identifier-binding #'x2))])
+       (define-values (a b) (module-path-index-split mpi))
+       (test '(submod "..") values a)
+       (test #t module-path-index? b)
+       (define-values (ba bb) (module-path-index-split b))
+       (test #f values ba)
+       (test #f values bb)
+       (test '(sub) module-path-index-submodule b)))])
+
+(parameterize ([current-namespace (make-base-namespace)])
+  (eval
+   (expand
+    '(module m racket
+       (module X racket
+         (define x 1)
+         (provide x))
+       (module Y racket
+         (require (submod ".." X))
+         (define y (add1 x)))))))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; `begin-for-syntax' doesn't affect `module' with non-#f language:
 

doc/release-notes/racket/HISTORY.txt

@@ -1,3 +1,7 @@
+Version 5.3.0.3
+Added module-path-index-submodule
+Changed module-path-index-join to support a submodule argument
+
 Version 5.3.0.1
 ffi/unsafe: integer-type bounds consistently checked
 

src/racket/include/schthread.h

@@ -171,6 +171,7 @@ typedef struct Thread_Local_Variables {
   void *retry_alloc_r1_;
   double scheme_jit_save_fp_;
   struct Scheme_Bucket_Table *starts_table_;
+  struct Scheme_Bucket_Table *submodule_empty_modidx_table_;
   struct Scheme_Modidx *modidx_caching_chain_;
   struct Scheme_Object *global_shift_cache_;
   struct mz_proc_thread *proc_thread_self_;
@@ -526,6 +527,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
 #define retry_alloc_r1 XOA (scheme_get_thread_local_variables()->retry_alloc_r1_)
 #define scheme_jit_save_fp XOA (scheme_get_thread_local_variables()->scheme_jit_save_fp_)
 #define starts_table XOA (scheme_get_thread_local_variables()->starts_table_)
+#define submodule_empty_modidx_table XOA (scheme_get_thread_local_variables()->submodule_empty_modidx_table_)
 #define modidx_caching_chain XOA (scheme_get_thread_local_variables()->modidx_caching_chain_)
 #define global_shift_cache XOA (scheme_get_thread_local_variables()->global_shift_cache_)
 #define proc_thread_self XOA (scheme_get_thread_local_variables()->proc_thread_self_)

src/racket/src/module.c

@@ -71,6 +71,7 @@ static Scheme_Object *module_path_index_p(int argc, Scheme_Object *argv[]);
 static Scheme_Object *module_path_index_resolve(int argc, Scheme_Object *argv[]);
 static Scheme_Object *module_path_index_split(int argc, Scheme_Object *argv[]);
 static Scheme_Object *module_path_index_join(int argc, Scheme_Object *argv[]);
+static Scheme_Object *module_path_index_submodule(int argc, Scheme_Object *argv[]);
 
 static Scheme_Object *is_module_path(int argc, Scheme_Object **argv);
 
@@ -227,6 +228,7 @@ READ_ONLY static Scheme_Object *empty_self_modname;
 
 THREAD_LOCAL_DECL(static Scheme_Object *empty_self_shift_cache);
 THREAD_LOCAL_DECL(static Scheme_Bucket_Table *starts_table);
+THREAD_LOCAL_DECL(static Scheme_Bucket_Table *submodule_empty_modidx_table);
 #if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
 THREAD_LOCAL_DECL(static Scheme_Bucket_Table *place_local_modpath_table);
 #endif
@@ -321,6 +323,8 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob
                            Scheme_Object **exsnoms,
 			   int start, int count, int do_uninterned);
 
+static Scheme_Object *get_submodule_empty_self_modidx(Scheme_Object *submodule_path);
+
 #define MODCHAIN_TABLE(p) ((Scheme_Hash_Table *)(SCHEME_VEC_ELS(p)[0]))
 #define MODCHAIN_AVAIL(p, n) (SCHEME_VEC_ELS(p)[3+n])
 
@@ -426,7 +430,8 @@ void scheme_init_module(Scheme_Env *env)
   GLOBAL_FOLDING_PRIM("module-path-index?",               module_path_index_p,        1, 1, 1, env); 
   GLOBAL_PRIM_W_ARITY("module-path-index-resolve",        module_path_index_resolve,  1, 1, env); 
   GLOBAL_PRIM_W_ARITY2("module-path-index-split",         module_path_index_split,    1, 1, 2, 2, env); 
-  GLOBAL_PRIM_W_ARITY("module-path-index-join",           module_path_index_join,     2, 2, env);
+  GLOBAL_PRIM_W_ARITY("module-path-index-submodule",      module_path_index_submodule,1, 1, env); 
+  GLOBAL_PRIM_W_ARITY("module-path-index-join",           module_path_index_join,     2, 3, env);
   GLOBAL_FOLDING_PRIM("resolved-module-path?",            resolved_module_path_p,     1, 1, 1, env);
   GLOBAL_PRIM_W_ARITY("make-resolved-module-path",        make_resolved_module_path,  1, 1, env);
   GLOBAL_PRIM_W_ARITY("resolved-module-path-name",        resolved_module_path_name,  1, 1, env);
@@ -3296,9 +3301,52 @@ static Scheme_Object *module_path_index_join(int argc, Scheme_Object *argv[])
                           argv[1]);
   }
 
+  if (argc > 2) {
+    Scheme_Object *l = argv[2];
+    if (SCHEME_TRUEP(l)) {
+      if (SCHEME_PAIRP(l)) {
+        while (SCHEME_PAIRP(l)) {
+          if (!SCHEME_SYMBOLP(SCHEME_CAR(l)))
+            break;
+          l = SCHEME_CDR(l);
+        }
+      } else
+        l = scheme_false;
+      if (!SCHEME_NULLP(l))
+        scheme_wrong_type("module-path-index-join", "non-empty list of symbols", 2, argc, argv);
+      if (SCHEME_TRUEP(argv[0]) || SCHEME_TRUEP(argv[1]))
+        scheme_arg_mismatch("module-path-index-join", 
+                            "first or second non-#f argument results a #f third argument, given: ",
+                            argv[2]);
+      return get_submodule_empty_self_modidx(argv[2]);
+    }
+  }
+
   return scheme_make_modidx(argv[0], argv[1], scheme_false);
 }
 
+static Scheme_Object *module_path_index_submodule(int argc, Scheme_Object *argv[])
+{
+  Scheme_Modidx *modidx;
+  Scheme_Object *a;
+
+  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type))
+    scheme_wrong_type("module-path-index-submodule", "module-path-index", 0, argc, argv);
+
+  modidx = (Scheme_Modidx *)argv[0];
+  a = modidx->resolved;
+  if (SCHEME_TRUEP(modidx->path)
+      || SCHEME_TRUEP(modidx->base)
+      || SCHEME_FALSEP(a))
+    return scheme_false;
+
+  a = scheme_resolved_module_path_value(a);
+  if (!SCHEME_PAIRP(a))
+    return scheme_false;
+
+  return SCHEME_CDR(a);
+}
+
 void scheme_init_module_path_table()
 {
   REGISTER_SO(modpath_table);
@@ -3557,6 +3605,33 @@ int same_resolved_modidx(Scheme_Object *a, Scheme_Object *b)
   return scheme_equal(a, b);
 }
 
+static Scheme_Object *get_submodule_empty_self_modidx(Scheme_Object *submodule_path)
+{
+  Scheme_Bucket *b;
+
+  if (SCHEME_NULLP(submodule_path))
+    return empty_self_modidx;
+
+  if (!submodule_empty_modidx_table) {
+    REGISTER_SO(submodule_empty_modidx_table);
+    submodule_empty_modidx_table = scheme_make_weak_equal_table();
+  }
+
+  scheme_start_atomic();
+  b = scheme_bucket_from_table(submodule_empty_modidx_table, (const char *)submodule_path);
+  if (!b->val) {
+    submodule_path = make_resolved_module_path_obj(scheme_make_pair(scheme_resolved_module_path_value(empty_self_modname),
+                                                                    submodule_path));
+    submodule_path = scheme_make_modidx(scheme_false, 
+                                        scheme_false,
+                                        submodule_path);
+    b->val = submodule_path;
+  }
+  scheme_end_atomic_no_swap();
+
+  return b->val;
+}
+
 static Scheme_Object *_module_resolve_k(void);
 
 static Scheme_Object *_module_resolve(Scheme_Object *modidx, Scheme_Object *stx, Scheme_Env *env, int load_it)
@@ -6399,6 +6474,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
   Scheme_Comp_Env *benv;
   Scheme_Module *m;
   Scheme_Object *mbval, *orig_ii;
+  Scheme_Object *this_empty_self_modidx;
   int saw_mb, check_mb = 0, skip_strip = 0;
   Scheme_Object *restore_confusing_name = NULL;
   LOG_EXPAND_DECLS;
@@ -6653,14 +6729,18 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
 
   fm = scheme_stx_property(fm, module_name_symbol, scheme_resolved_module_path_value(rmp));
 
+  this_empty_self_modidx = get_submodule_empty_self_modidx(submodule_path);
+
   if (ii) {
     /* phase shift to replace self_modidx of previous expansion (if any): */
-    fm = scheme_stx_phase_shift(fm, NULL, empty_self_modidx, self_modidx, NULL, m->insp);
+    fm = scheme_stx_phase_shift(fm, NULL, this_empty_self_modidx, self_modidx, NULL, m->insp);
 
     fm = scheme_add_rename(fm, rn_set);
-  } else if (skip_strip) {
+  } else {
-    /* phase shift to replace self_modidx of previous expansion: */
+    if (skip_strip) {
-    fm = scheme_stx_phase_shift(fm, NULL, empty_self_modidx, self_modidx, NULL, m->insp);      
+      /* phase shift to replace self_modidx of previous expansion: */
+      fm = scheme_stx_phase_shift(fm, NULL, this_empty_self_modidx, self_modidx, NULL, m->insp);      
+    }
   }
 
   SCHEME_EXPAND_OBSERVE_RENAME_ONE(rec[drec].observer, fm);
@@ -6768,17 +6848,17 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
 			       SCHEME_CAR(hints));
       fm = scheme_stx_property(fm, 
 			       scheme_intern_symbol("module-self-path-index"),
-			       empty_self_modidx);
+			       this_empty_self_modidx);
     }
 
     /* 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);
+      fm = phase_shift_skip_submodules(fm, self_modidx, this_empty_self_modidx, -1);
     else
-      fm = scheme_stx_phase_shift(fm, NULL, self_modidx, empty_self_modidx, NULL, NULL);
+      fm = scheme_stx_phase_shift(fm, NULL, self_modidx, this_empty_self_modidx, NULL, NULL);
 
     /* make self_modidx like the empty modidx */
-    ((Scheme_Modidx *)self_modidx)->resolved = empty_self_modname;
+    ((Scheme_Modidx *)self_modidx)->resolved = ((Scheme_Modidx *)this_empty_self_modidx)->resolved;
   }
 
   if (rec[drec].comp || (rec[drec].depth != -2)) {

src/racket/src/schminc.h

@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1045
+#define EXPECTED_PRIM_COUNT 1046
 #define EXPECTED_UNSAFE_COUNT 78
 #define EXPECTED_FLFXNUM_COUNT 68
 #define EXPECTED_FUTURES_COUNT 13

src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.3.0.2"
+#define MZSCHEME_VERSION "5.3.0.3"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 3
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 2
+#define MZSCHEME_VERSION_W 3
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)