add current-module-declare-source, variable-reference->module-source, convert soe sues of module paths to module sources

svn: r18804

collects/compiler/cm.ss

@@ -282,32 +282,39 @@
 
 (define depth (make-parameter 0))
 
+(define (actual-source-path path)
+  (if (file-exists? path) 
+      path
+      (let ([alt-path (rkt->ss path)])
+        (if (file-exists? alt-path)
+            alt-path
+            path))))
+
 (define (compile-zo mode path orig-path read-src-syntax)
-  ;; The `path' argument has been converted to .rkt or .ss form,
+  (let ([actual-path (actual-source-path orig-path)])
-  ;;  as appropriate.
+    ((manager-compile-notify-handler) actual-path)
-  ((manager-compile-notify-handler) orig-path)
+    (trace-printf "compiling: ~a" actual-path)
-  (trace-printf "compiling: ~a" orig-path)
+    (parameterize ([indent (string-append "  " (indent))])
-  (parameterize ([indent (string-append "  " (indent))])
+      (let* ([zo-name (path-add-suffix (get-compilation-path mode path) #".zo")]
-    (let* ([zo-name (path-add-suffix (get-compilation-path mode path) #".zo")]
+             [zo-exists? (file-exists? zo-name)])
-           [zo-exists? (file-exists? zo-name)])
+        (if (and zo-exists? (trust-existing-zos))
-      (if (and zo-exists? (trust-existing-zos))
+            (touch zo-name)
-          (touch zo-name)
+            (begin (when zo-exists? (delete-file zo-name))
-          (begin (when zo-exists? (delete-file zo-name))
+                   (log-info (format "cm: ~acompiling ~a" 
-                 (log-info (format "cm: ~acompiling ~a" 
+                                     (build-string 
-                                   (build-string 
+                                      (depth)
-                                    (depth)
+                                      (λ (x) (if (= 2 (modulo x 3)) #\| #\space)))
-                                    (λ (x) (if (= 2 (modulo x 3)) #\| #\space)))
+                                     actual-path))
-                                   orig-path))
+                   (parameterize ([depth (+ (depth) 1)])
-                 (parameterize ([depth (+ (depth) 1)])
+                     (with-handlers
-                   (with-handlers
+                         ([exn:get-module-code?
-                       ([exn:get-module-code?
+                           (lambda (ex)
-                         (lambda (ex)
+                             (compilation-failure mode path zo-name
-                           (compilation-failure mode path zo-name
+                                                  (exn:get-module-code-path ex)
-                                                (exn:get-module-code-path ex)
+                                                  (exn-message ex))
-                                                (exn-message ex))
+                             (raise ex))])
-                           (raise ex))])
+                       (compile-zo* mode path read-src-syntax zo-name)))))))
-                     (compile-zo* mode path read-src-syntax zo-name)))))))
+    (trace-printf "end compile: ~a" actual-path)))
-  (trace-printf "end compile: ~a" orig-path))
 
 (define (get-compiled-time mode path)
   (define-values (dir name) (get-compilation-dir+name mode path))

collects/drscheme/private/module-language.ss

@@ -293,13 +293,16 @@
         ;; module.  So the code is split among several thunks that follow.
         (define (*pre)
           (thread-cell-set! repl-init-thunk *error)
-          (current-module-declare-name resolved-modpath))
+          (current-module-declare-name resolved-modpath)
+          (current-module-declare-source path))
         (define (*post)
           (current-module-declare-name #f)
+          (current-module-declare-source #f)
           (when path ((current-module-name-resolver) resolved-modpath))
           (thread-cell-set! repl-init-thunk *init))
         (define (*error)
           (current-module-declare-name #f)
+          (current-module-declare-source #f)
           ;; syntax error => try to require the language to get a working repl
           (with-handlers ([void (λ (e)
                                   (raise-hopeless-syntax-error

collects/errortrace/lang/body.ss

@@ -9,12 +9,13 @@
   (syntax-case stx ()
     [(_ lang . body)
      (let ([e (annotate-top
-               (local-expand #`(module . #,(strip-context #`(n lang . body)))
+               (syntax-local-introduce
-                             'top-level
+                (local-expand #`(module . #,(strip-context #`(n lang . body)))
-                             null)
+                              'top-level
+                              null))
                0)])
        (syntax-case e ()
          [(mod nm lang (mb . body)) 
-          #'(#%plain-module-begin 
+          #`(#%plain-module-begin 
              (require (only-in lang) errortrace/errortrace-key)
              . body)]))]))

collects/r6rs/run.ss

@@ -202,6 +202,7 @@
         (let ([code (get-module-code main #:source-reader r6rs-read-syntax)]
               [rpath (module-path-index-resolve
                       (module-path-index-join main #f))])
-          (parameterize ([current-module-declare-name rpath])
+          (parameterize ([current-module-declare-name rpath]
+                         [current-module-declare-source main])
             (eval code))
           (dynamic-require rpath #f))))])

collects/scheme/contract/private/base.ss

@@ -21,7 +21,7 @@ improve method arity mismatch contract violation error messages?
          "blame.ss")
 
 (define-syntax-parameter current-contract-region
-  (λ (stx) #'(quote-module-path)))
+  (λ (stx) #'(quote-module-source)))
 
 (define-syntax (contract stx)
   (syntax-case stx ()

collects/scheme/contract/private/legacy.ss

@@ -96,15 +96,14 @@
 ;; Other representations of blame are returned as-is.
 (define (unpack-blame blame)
   (if (variable-reference? blame)
-      (let ([rp (variable-reference->resolved-module-path blame)])
+      (let ([resolved (variable-reference->module-source blame)])
         (cond
-         [(not rp) 
+         [(not resolved) 
           'top-level]
          [else
-          (let ([resolved (resolved-module-path-name rp)])
+          (cond
-            (cond
+           [(symbol? resolved) `(quote ,resolved)]
-             [(symbol? resolved) `(quote ,resolved)]
+           [else `(file ,(path->string resolved))])]))
-             [else `(file ,(path->string resolved))]))]))
       blame))
 
 (define (unpack-source info)

collects/scheme/contract/private/provide.ss

@@ -46,7 +46,7 @@
                             #`(contract contract-id
                                         id
                                         pos-module-source
-                                        (quote-module-path)
+                                        (quote-module-source)
                                         'external-id
                                         (quote-srcloc id))))))])
                (when key
@@ -646,7 +646,7 @@
                 (with-syntax ([code
                                (quasisyntax/loc stx
                                  (begin
-                                   (define pos-module-source (quote-module-path))
+                                   (define pos-module-source (quote-module-source))
                                    
                                    #,@(if no-need-to-check-ctrct?
                                           (list)

collects/scribblings/reference/eval.scrbl

@@ -214,11 +214,12 @@ The protocol for a @tech{compiled-load handler} is the same as for the
 @tech{compiled-load handler} is expected to set
 @scheme[current-load-relative-directory] itself. The default
 @tech{compiled-load handler}, however, checks for a @filepath{.ss}
-file when then given path ends with @filepath{.rkt} and no
+file when the given path ends with @filepath{.rkt}, no @filepath{.rkt}
-@filepath{.rkt} file exists. In addition, the default
+file exists, and when the handler's second argument is a symbol. In
-@tech{compiled-load handler} checks for @filepath{.zo} (bytecode)
+addition, the default @tech{compiled-load handler} checks for
-files and @filepath{.so} (native Unix), @filepath{.dll} (native
+@filepath{.zo} (bytecode) files and @filepath{.so} (native Unix),
-Windows), or @filepath{.dylib} (native Mac OS X) files.
+@filepath{.dll} (native Windows), or @filepath{.dylib} (native Mac OS
+X) files.
 
 The check for a compiled file occurs whenever the given path
 @scheme[_file] ends with any extension (e.g., @filepath{.rkt} or
@@ -236,15 +237,22 @@ file is loaded only if its modification date is not older than the
 date for @scheme[_file]. If both @filepath{.zo} and
 @filepath{.so}/@filepath{.dll}/@filepath{.dylib} files are available,
 the @filepath{.so}/@filepath{.dll}/@filepath{.dylib} file is used.  If
-@scheme[_file] ends with @filepath{.rkt}, no such file exists, and a
+@scheme[_file] ends with @filepath{.rkt}, no such file exists, the
-@filepath{.ss} file exists, then @filepath{.zo} and
+handler's second argument is a symbol, and a @filepath{.ss} file
+exists, then @filepath{.zo} and
 @filepath{.so}/@filepath{.dll}/@filepath{.dylib} files are used only
 with names based on @scheme[_file] with its suffixed replaced by
 @filepath{.ss}.
 
 While a @filepath{.zo}, @filepath{.so}, @filepath{.dll}, or
 @filepath{.dylib} file is loaded, the current @scheme[load-relative]
-directory is set to the directory of the original @scheme[_file].
+directory is set to the directory of the original @scheme[_file].  If
+the file to be loaded has the suffix @filepath{.ss} while the
+requested file has the suffix @filepath{.rkt}, then the
+@scheme[current-module-declare-source] parameter is set to the full
+path of the loaded file, otherwise the
+@scheme[current-module-declare-source] parameter is set to
+@scheme[#f].
 
 If the original @scheme[_file] is loaded or a @filepath{.zo} variant is
 loaded, the @tech{load handler} is called to load the file. If any

collects/scribblings/reference/module-reflect.scrbl

@@ -104,11 +104,13 @@ the table and the corresponding file is loaded with a variant of
 
 While loading a file, the default @tech{module name resolver} sets the
 @scheme[current-module-declare-name] parameter to the resolved module
-name. Also, the default @tech{module name resolver} records in a
+name (while the @tech{compiled-load handler} sets
-private @tech{continuation mark} the filename being loaded, and it
+@scheme[current-module-declare-source]). Also, the default
-checks whether such a mark already exists; if such a continuation mark
+@tech{module name resolver} records in a private @tech{continuation
-does exist in the current continuation, then the @exnraise[exn:fail]
+mark} the module being loaded, and it checks whether such a mark
-with a message about a dependency cycle.
+already exists; if such a continuation mark does exist in the current
+continuation, then the @exnraise[exn:fail] with a message about a
+dependency cycle.
 
 Module loading is suppressed (i.e., @scheme[#f] is supplied as a third
 argument to the module name resolver) when resolving module paths in
@@ -134,6 +136,16 @@ a @scheme[module] declaration (when the parameter value is not
 declaration is ignored, and the parameter's value is used as the name
 of the declared module.}
 
+@defparam[current-module-declare-source src (or/c symbol? (and/c path? complete-path?) #f)]{
+
+A parameter that determines source information to be associated with a
+module when evaluating a @scheme[module] declaration. Source
+information is used in error messages and reflected by
+@scheme[variable-reference->module-source]. When the parameter value
+is @scheme[#f], the module's name (as determined by
+@scheme[current-module-declare-name]) is used as the source name
+instead of the parameter value.}
+
 @;------------------------------------------------------------------------
 @section[#:tag "modpathidx"]{Compiled Modules and References}
 

collects/scribblings/reference/namespaces.scrbl

@@ -377,6 +377,16 @@ result is a @tech{resolved module path} naming the module.
 If @scheme[varref] refers to a @tech{top-level variable}, then the
 result is @scheme[#f].}
 
+@defproc[(variable-reference->module-source [varref variable-reference?])
+         (or/c symbol? (and/c path? complete-path?) #f)]{
+
+If @scheme[varref] refers to a @tech{module-level variable}, the
+result is a path or symbol naming the module's source (which is
+typically, but not always, the same as in the resolved module path).
+
+If @scheme[varref] refers to a @tech{top-level variable}, then the
+result is @scheme[#f].}
+
 @defproc[(variable-reference->phase [varref variable-reference?])
          exact-nonnegative-integer?]{
 

collects/unstable/location.ss

@@ -9,6 +9,7 @@
          quote-character-position
          quote-character-span
          quote-module-path
+         quote-module-source
          quote-module-name)
 
 (define-syntax (quote-srcloc stx)
@@ -49,6 +50,9 @@
 (define-syntax-rule (quote-module-path)
   (variable-reference->module-path (#%variable-reference)))
 
+(define-syntax-rule (quote-module-source)
+  (variable-reference->module-src (#%variable-reference)))
+
 (define (variable-reference->module-path var)
   (module-name->module-path
    (variable-reference->module-name var)))
@@ -64,3 +68,7 @@
    [(path? name) `(file ,(path->string name))]
    [(symbol? name) `(quote ,name)]
    [else 'top-level]))
+
+(define (variable-reference->module-src var)
+  (or (variable-reference->module-source var)
+      'top-level))

collects/unstable/scribblings/srcloc.scrbl

@@ -1,5 +1,5 @@
 #lang scribble/manual
-@(require scribble/eval "utils.ss" (for-label scheme/base unstable/srcloc))
+@(require scribble/eval "utils.ss" (for-label scheme/base unstable/srcloc unstable/location))
 
 @(define unsyntax #f)
 
@@ -303,6 +303,14 @@ b
 
 }
 
+@defform[(quote-module-source)]{
+
+Like @scheme[quote-module-path], but for the enclosing module's source
+name, rather than its module path. The module path and source name are
+typically the same, but they can be different. For example, a source
+file whose name ends with @filepath{.ss} corersponds to a resolved
+module path ending with @filepath{.rkt}.}
+
 @defform[(quote-module-name)]{
 
 This form quotes the name (@tech[#:doc reference-path]{path} or @tech[#:doc

src/mzscheme/include/scheme.h

@@ -1233,6 +1233,7 @@ enum {
 
   MZCONFIG_CURRENT_MODULE_RESOLVER,
   MZCONFIG_CURRENT_MODULE_NAME,
+  MZCONFIG_CURRENT_MODULE_SRC,
 
   MZCONFIG_ERROR_PRINT_SRCLOC,
 

src/mzscheme/src/env.c

@@ -90,6 +90,7 @@ static Scheme_Object *namespace_mapped_symbols(int, Scheme_Object *[]);
 static Scheme_Object *namespace_module_registry(int, Scheme_Object *[]);
 static Scheme_Object *variable_p(int, Scheme_Object *[]);
 static Scheme_Object *variable_module_path(int, Scheme_Object *[]);
+static Scheme_Object *variable_module_source(int, Scheme_Object *[]);
 static Scheme_Object *variable_namespace(int, Scheme_Object *[]);
 static Scheme_Object *variable_top_level_namespace(int, Scheme_Object *[]);
 static Scheme_Object *variable_phase(int, Scheme_Object *[]);
@@ -650,6 +651,7 @@ static void make_kernel_env(void)
 
   GLOBAL_PRIM_W_ARITY("variable-reference?", variable_p, 1, 1, env);
   GLOBAL_PRIM_W_ARITY("variable-reference->resolved-module-path", variable_module_path, 1, 1, env);
+  GLOBAL_PRIM_W_ARITY("variable-reference->module-source", variable_module_source, 1, 1, env);
   GLOBAL_PRIM_W_ARITY("variable-reference->empty-namespace", variable_namespace, 1, 1, env);
   GLOBAL_PRIM_W_ARITY("variable-reference->namespace", variable_top_level_namespace, 1, 1, env);
   GLOBAL_PRIM_W_ARITY("variable-reference->phase", variable_phase, 1, 1, env);
@@ -4559,6 +4561,24 @@ static Scheme_Object *variable_module_path(int argc, Scheme_Object *argv[])
     return scheme_false;
 }
 
+static Scheme_Object *variable_module_source(int argc, Scheme_Object *argv[])
+{
+  Scheme_Env *env;
+
+  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type))
+    env = NULL;
+  else
+    env = ((Scheme_Bucket_With_Home *)SCHEME_PTR_VAL(argv[0]))->home;
+
+  if (!env)
+    scheme_wrong_type("variable-reference->module-source", "variable-reference", 0, argc, argv);
+
+  if (env->module)
+    return env->module->modsrc;
+  else
+    return scheme_false;
+}
+
 static Scheme_Object *
 now_transforming(int argc, Scheme_Object *argv[])
 {

src/mzscheme/src/error.c

@@ -1942,7 +1942,7 @@ void scheme_unbound_global(Scheme_Bucket *b)
 		     name,
 		     errmsg,
 		     name,
-		     ((Scheme_Bucket_With_Home *)b)->home->module->modname,
+		     ((Scheme_Bucket_With_Home *)b)->home->module->modsrc,
                      phase);
   } else {
     scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE,

src/mzscheme/src/eval.c

@@ -1877,7 +1877,7 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
 			  env->phase,
                           modname,
                           mod_phase,
-                          env->module ? env->module->modname : scheme_false);
+                          env->module ? env->module->modsrc : scheme_false);
       return NULL;
     }
 
@@ -1908,7 +1908,7 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
                           env->phase,
                           exprs ? SCHEME_CDR(modname) : modname,
                           mod_phase,
-                          env->module ? env->module->modname : scheme_false);    
+                          env->module ? env->module->modsrc : scheme_false);    
     }
     if (!(((Scheme_Bucket_With_Flags *)bkt)->flags & (GLOB_IS_IMMUTATED | GLOB_IS_LINKED)))
       ((Scheme_Bucket_With_Flags *)bkt)->flags |= GLOB_IS_LINKED;
@@ -2852,7 +2852,7 @@ char *scheme_optimize_context_to_string(Scheme_Object *context)
     }
 
     if (SAME_TYPE(SCHEME_TYPE(mod), scheme_module_type)) {
-      mctx = scheme_display_to_string(((Scheme_Module *)mod)->modname, NULL);
+      mctx = scheme_display_to_string(((Scheme_Module *)mod)->modsrc, NULL);
       mprefix = " in module: ";
     } else {
       mctx = "";

src/mzscheme/src/module.c

@@ -43,6 +43,7 @@ SHARED_OK static mzrt_mutex *modpath_table_mutex;
 /* locals */
 static Scheme_Object *current_module_name_resolver(int argc, Scheme_Object *argv[]);
 static Scheme_Object *current_module_name_prefix(int argc, Scheme_Object *argv[]);
+static Scheme_Object *current_module_name_source(int argc, Scheme_Object *argv[]);
 static Scheme_Object *dynamic_require_for_syntax(int argc, Scheme_Object *argv[]);
 static Scheme_Object *namespace_require(int argc, Scheme_Object *argv[]);
 static Scheme_Object *namespace_require_copy(int argc, Scheme_Object *argv[]);
@@ -375,6 +376,7 @@ void scheme_init_module(Scheme_Env *env)
 
   GLOBAL_PARAMETER("current-module-name-resolver",  current_module_name_resolver, MZCONFIG_CURRENT_MODULE_RESOLVER, env);
   GLOBAL_PARAMETER("current-module-declare-name",   current_module_name_prefix,   MZCONFIG_CURRENT_MODULE_NAME,     env);
+  GLOBAL_PARAMETER("current-module-declare-source", current_module_name_source,   MZCONFIG_CURRENT_MODULE_SRC,      env);
 
   GLOBAL_PRIM_W_ARITY("dynamic-require",                  scheme_dynamic_require,     2, 3, env);
   GLOBAL_PRIM_W_ARITY("dynamic-require-for-syntax",       dynamic_require_for_syntax, 2, 3, env);
@@ -449,6 +451,7 @@ void scheme_finish_kernel(Scheme_Env *env)
   }
 
   kernel->modname = kernel_modname;
+  kernel->modsrc = kernel_modname;
   kernel->requires = scheme_null;
   kernel->et_requires = scheme_null;
   kernel->tt_requires = scheme_null;
@@ -853,6 +856,30 @@ current_module_name_prefix(int argc, Scheme_Object *argv[])
 			     -1, prefix_p, "resolved-module-path or #f", 1);
 }
 
+static Scheme_Object *source_p(int argc, Scheme_Object **argv)
+{
+  Scheme_Object *o = argv[0];
+  
+  if (!SCHEME_FALSEP(o)
+      && !SCHEME_SYMBOLP(o)
+      && (!SCHEME_PATHP(o)
+          || !scheme_is_complete_path(SCHEME_PATH_VAL(o),
+                                      SCHEME_PATH_LEN(o),
+                                      SCHEME_PLATFORM_PATH_KIND)))
+    return NULL;
+
+  return o;
+}
+
+static Scheme_Object *
+current_module_name_source(int argc, Scheme_Object *argv[])
+{
+  return scheme_param_config("current-module-declared-name",
+			     scheme_make_integer(MZCONFIG_CURRENT_MODULE_SRC),
+			     argc, argv,
+			     -1, source_p, "symbol, complete path, or #f", 1);
+}
+
 /**********************************************************************/
 /*                            procedures                              */
 /**********************************************************************/
@@ -991,7 +1018,7 @@ static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[],
                   scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                                    "%s: name is provided as syntax: %V by module: %V",
                                    errname,
-                                   name, srcm->modname);
+                                   name, srcm->modsrc);
                 }
               }
 	      return NULL;
@@ -1050,7 +1077,7 @@ static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[],
 	    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
 			     "%s: name is not provided: %V by module: %V",
 			     errname,
-			     name, srcm->modname);
+			     name, srcm->modsrc);
           }
 	  return NULL;
 	}
@@ -1082,14 +1109,14 @@ static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[],
 	scheme_raise_exn(MZEXN_FAIL_CONTRACT,
 			 "%s: name is protected: %V from module: %V",
 			 errname,
-			 name, srcm->modname);
+			 name, srcm->modsrc);
     }
 
     if (!menv || !menv->toplevel) {
       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                        "%s: module initialization failed: %V",
                        errname,
-                       srcm->modname);
+                       srcm->modsrc);
     }
     
     b = scheme_bucket_from_table(menv->toplevel, (const char *)srcname);
@@ -3437,7 +3464,7 @@ static void check_certified(Scheme_Object *stx, Scheme_Object *certs,
                           "access from an uncertified context to %s %s from module: %D",
                           prot ? "protected" : "unexported",
                           var ? "variable" : "syntax",
-                          env->module->modname);
+                          env->module->modsrc);
     }
   }
 }
@@ -3643,7 +3670,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
     long srclen;
     
     if (from_env->module)
-      srcstr = scheme_display_to_string(from_env->module->modname, &srclen);
+      srcstr = scheme_display_to_string(from_env->module->modsrc, &srclen);
     else {
       srcstr = "";
       srclen = 0;
@@ -3653,7 +3680,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
                         "module mismatch, probably from old bytecode whose dependencies have changed: "
                         "variable not provided (directly or indirectly%s) from module: %D%s%t at source phase level: %d",
                         (position >= 0) ? " and at the expected position" : "",
-                        env->module->modname,
+                        env->module->modsrc,
                         srclen ? " accessed from module: " : "",
                         srcstr, srclen,
                         env->mod_phase);
@@ -4321,7 +4348,7 @@ static void start_module(Scheme_Module *m, Scheme_Env *env, int restart,
     if (SAME_OBJ(m->modname, SCHEME_CAR(l))) {
       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
 		       "module: import cycle detected at: %D",
-		       m->modname);
+		       m->modsrc);
     }
   }
 
@@ -4479,7 +4506,7 @@ static void *eval_module_body_k(void)
 static void eval_module_body(Scheme_Env *menv, Scheme_Env *env)
 {
 #ifdef MZ_USE_JIT
-  (void)scheme_module_run_start(menv, env, scheme_make_pair(menv->module->modname, scheme_true));
+  (void)scheme_module_run_start(menv, env, scheme_make_pair(menv->module->modsrc, scheme_true));
 #else
   (void)scheme_module_run_finish(menv, env);
 #endif
@@ -4643,7 +4670,7 @@ Scheme_Env *scheme_primitive_module(Scheme_Object *name, Scheme_Env *for_env)
 {
   Scheme_Module *m;
   Scheme_Env *env;
-  Scheme_Object *prefix, *insp;
+  Scheme_Object *prefix, *insp, *src;
   Scheme_Config *config;
 
   m = MALLOC_ONE_TAGGED(Scheme_Module);
@@ -4659,14 +4686,21 @@ Scheme_Env *scheme_primitive_module(Scheme_Object *name, Scheme_Env *for_env)
       name = prefix;
     else
       name = scheme_intern_resolved_module_path(name);
+    src = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_SRC);
+    if (SCHEME_FALSEP(src))
+      src = prefix;
+    else
+      src = scheme_intern_resolved_module_path(src);
     insp = scheme_get_param(config, MZCONFIG_CODE_INSPECTOR);
   }
   else {
     name = scheme_intern_resolved_module_path(name);
+    src = name;
     insp = scheme_get_current_inspector();
   }
 
   m->modname = name;
+  m->modsrc = src;
   m->requires = scheme_null;
   m->et_requires = scheme_null;
   m->tt_requires = scheme_null;
@@ -5070,12 +5104,15 @@ module_execute(Scheme_Object *data)
   Scheme_Module *m;
   Scheme_Env *env;
   Scheme_Env *old_menv;
-  Scheme_Object *prefix, *insp, **rt_insps, **et_insps;
+  Scheme_Config *config;
+  Scheme_Object *prefix, *src, *insp, **rt_insps, **et_insps;
 
   m = MALLOC_ONE_TAGGED(Scheme_Module);
   memcpy(m, data, sizeof(Scheme_Module));
 
-  prefix = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_NAME);
+  config = scheme_current_config();
+
+  prefix = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_NAME);
   if (SCHEME_MODNAMEP(prefix)) {
     m->modname = prefix;
     
@@ -5097,6 +5134,13 @@ module_execute(Scheme_Object *data)
     }
   }
 
+  src = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_SRC);
+  if (!SCHEME_FALSEP(src)) {
+    src = scheme_intern_resolved_module_path(src);
+    m->modsrc = src;
+  } else
+    m->modsrc = m->modname;
+
   env = scheme_environment_from_dummy(m->dummy);
 
   if (SAME_OBJ(m->modname, kernel_modname))
@@ -5829,6 +5873,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
   rmp = SCHEME_STX_VAL(nm);
   rmp = scheme_intern_resolved_module_path(rmp);
   m->modname = rmp;
+  m->modsrc = rmp;
 
   LOG_START_EXPAND(m);
 
@@ -10015,6 +10060,7 @@ static Scheme_Object *write_module(Scheme_Object *obj)
     l = cons(scheme_false, l);
 
   l = cons(m->me->src_modidx, l);
+  l = cons(SCHEME_PTR_VAL(m->modsrc), l);
   l = cons(SCHEME_PTR_VAL(m->modname), l);
 
   return l;
@@ -10059,6 +10105,11 @@ static Scheme_Object *read_module(Scheme_Object *obj)
   m->modname = e;
   obj = SCHEME_CDR(obj);
 
+  if (!SCHEME_PAIRP(obj)) return_NULL();
+  e = scheme_intern_resolved_module_path(SCHEME_CAR(obj));
+  m->modsrc = e;
+  obj = SCHEME_CDR(obj);
+
   if (!SCHEME_PAIRP(obj)) return_NULL();
   me->src_modidx = SCHEME_CAR(obj);
   obj = SCHEME_CDR(obj);

src/mzscheme/src/mzmark.c

@@ -2376,6 +2376,7 @@ static int module_val_SIZE(void *p, struct NewGC *gc) {
 static int module_val_MARK(void *p, struct NewGC *gc) {
   Scheme_Module *m = (Scheme_Module *)p;
   gcMARK2(m->modname, gc);
+  gcMARK2(m->modsrc, gc);
 
   gcMARK2(m->et_requires, gc);
   gcMARK2(m->requires, gc);
@@ -2422,6 +2423,7 @@ static int module_val_MARK(void *p, struct NewGC *gc) {
 static int module_val_FIXUP(void *p, struct NewGC *gc) {
   Scheme_Module *m = (Scheme_Module *)p;
   gcFIXUP2(m->modname, gc);
+  gcFIXUP2(m->modsrc, gc);
 
   gcFIXUP2(m->et_requires, gc);
   gcFIXUP2(m->requires, gc);

src/mzscheme/src/mzmarksrc.c

@@ -943,6 +943,7 @@ module_val {
  mark:
   Scheme_Module *m = (Scheme_Module *)p;
   gcMARK2(m->modname, gc);
+  gcMARK2(m->modsrc, gc);
 
   gcMARK2(m->et_requires, gc);
   gcMARK2(m->requires, gc);

src/mzscheme/src/mzrt.c

@@ -332,35 +332,6 @@ struct mzrt_rwlock {
   int readers, writers, write_waiting;
 };
 
-static mzrt_rwlock *locks[2];
-
-/* tests for rwlock implementation */
-#if 0
-static void *go(void *id)
-{
-  int i = *(int *)id, j, amt;
-
-  for (j = 0; j < 3; j++) {
-    amt = (random() % 400) + 100;
-    usleep(amt - 100);
-    if (!(i % 3)) {
-      mzrt_rwlock_wrlock(locks[0]);
-      printf("writing %d\n", i);
-      usleep(amt);
-      mzrt_rwlock_unlock(locks[0]);
-    } else {
-      mzrt_rwlock_rdlock(locks[0]);
-      printf("reading %d\n", i);
-      usleep(amt);
-      mzrt_rwlock_unlock(locks[0]);
-    }
-    printf("done %d\n", i);
-  }
-
-  return NULL;
-}
-#endif
-
 int mzrt_rwlock_create(mzrt_rwlock **lock) {
   int err;
 

src/mzscheme/src/schminc.h

@@ -13,7 +13,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 981
+#define EXPECTED_PRIM_COUNT 983
 #define EXPECTED_UNSAFE_COUNT 65
 #define EXPECTED_FLFXNUM_COUNT 53
 

src/mzscheme/src/schpriv.h

@@ -2821,6 +2821,7 @@ typedef struct Scheme_Module
   Scheme_Object so; /* scheme_module_type */
 
   Scheme_Object *modname;
+  Scheme_Object *modsrc;
 
   Scheme_Object *et_requires;  /* list of symbol-or-module-path-index */
   Scheme_Object *requires;     /* list of symbol-or-module-path-index */

src/mzscheme/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "4.2.5.8"
+#define MZSCHEME_VERSION "4.2.5.9"
 
 #define MZSCHEME_VERSION_X 4
 #define MZSCHEME_VERSION_Y 2
 #define MZSCHEME_VERSION_Z 5
-#define MZSCHEME_VERSION_W 8
+#define MZSCHEME_VERSION_W 9
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

src/mzscheme/src/startup.inc

@@ -486,22 +486,32 @@
 "(try-main?(or main-path-d(not alt-path-d)))"
 "(try-alt?(and alt-file(or alt-path-d(not main-path-d)))))"
 "(cond"
-"((or(and try-main?"
+"((and try-main?"
 "(date>=? modes so path-d))"
-"(and try-alt?"
-"(date>=? modes alt-so alt-path-d)))"
 " =>(lambda(so-d)"
-"(with-dir(lambda()((current-load-extension)(car so-d) expect-module)))))"
+"(parameterize((current-module-declare-source #f))"
-"((or(and try-main?"
+"(with-dir(lambda()((current-load-extension)(car so-d) expect-module))))))"
+"((and try-alt?"
+"(date>=? modes alt-so alt-path-d))"
+" =>(lambda(so-d)"
+"(parameterize((current-module-declare-source alt-path))"
+"(with-dir(lambda()((current-load-extension)(car so-d) expect-module))))))"
+"((and try-main?"
 "(date>=? modes zo path-d))"
-"(and try-alt?"
-"(date>=? modes alt-zo path-d)))"
 " =>(lambda(zo-d)"
-"(with-dir(lambda()((current-load)(car zo-d) expect-module)))))"
+"(parameterize((current-module-declare-source #f))"
+"(with-dir(lambda()((current-load)(car zo-d) expect-module))))))"
+"((and try-alt?"
+"(date>=? modes alt-zo path-d))"
+" =>(lambda(zo-d)"
+"(parameterize((current-module-declare-source alt-path))"
+"(with-dir(lambda()((current-load)(car zo-d) expect-module))))))"
 "(else"
-"(with-dir(lambda()((current-load) "
+"(let((p(if try-main? path alt-path)))"
-"(if try-main? path alt-path)"
+"(parameterize((current-module-declare-source(and expect-module "
-" expect-module))))))))))"
+"(not try-main?)"
+" p)))"
+"(with-dir(lambda()((current-load) p expect-module))))))))))))"
 "(define-values(default-reader-guard)"
 "(lambda(path) path))"
 "(define-values(-module-hash-table-table)(make-weak-hasheq)) "

src/mzscheme/src/startup.ss

@@ -567,22 +567,32 @@
                  [try-main? (or main-path-d (not alt-path-d))]
                  [try-alt? (and alt-file (or alt-path-d (not main-path-d)))])
             (cond
-             [(or (and try-main?
+             [(and try-main?
-                       (date>=? modes so path-d))
+                   (date>=? modes so path-d))
-                  (and try-alt?
-                       (date>=? modes alt-so alt-path-d)))
               => (lambda (so-d)
-                   (with-dir (lambda () ((current-load-extension) (car so-d) expect-module))))]
+                   (parameterize ([current-module-declare-source #f])
-             [(or (and try-main?
+                     (with-dir (lambda () ((current-load-extension) (car so-d) expect-module)))))]
-                       (date>=? modes zo path-d))
+             [(and try-alt?
-                  (and try-alt?
+                   (date>=? modes alt-so alt-path-d))
-                       (date>=? modes alt-zo path-d)))
+              => (lambda (so-d)
+                   (parameterize ([current-module-declare-source alt-path])
+                     (with-dir (lambda () ((current-load-extension) (car so-d) expect-module)))))]
+             [(and try-main?
+                   (date>=? modes zo path-d))
               => (lambda (zo-d)
-                   (with-dir (lambda () ((current-load) (car zo-d) expect-module))))]
+                   (parameterize ([current-module-declare-source #f])
+                     (with-dir (lambda () ((current-load) (car zo-d) expect-module)))))]
+             [(and try-alt?
+                   (date>=? modes alt-zo path-d))
+              => (lambda (zo-d)
+                   (parameterize ([current-module-declare-source alt-path])
+                     (with-dir (lambda () ((current-load) (car zo-d) expect-module)))))]
              [else
-              (with-dir (lambda () ((current-load) 
+              (let ([p (if try-main? path alt-path)])
-                                    (if try-main? path alt-path)
+                (parameterize ([current-module-declare-source (and expect-module 
-                                    expect-module)))]))))))
+                                                                   (not try-main?)
+                                                                   p)])
+                  (with-dir (lambda () ((current-load) p expect-module)))))]))))))
 
   (define-values (default-reader-guard)
     (lambda (path) path))

src/mzscheme/src/syntax.c

@@ -666,7 +666,7 @@ void scheme_set_global_bucket(char *who, Scheme_Bucket *b, Scheme_Object *val,
                               : "re-define a constant"))
 			: "set variable before its definition"),
 		       (Scheme_Object *)b->key,
-		       ((Scheme_Bucket_With_Home *)b)->home->module->modname);
+		       ((Scheme_Bucket_With_Home *)b)->home->module->modsrc);
     } else {
       scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, b->key,
 		       "%s: cannot %s variable: %S",