suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
svn: r18804
This commit is contained in:
Matthew Flatt 2010-04-13 02:48:40 +00:00
parent 49f68dc6d6
commit ce2d286586
27 changed files with 992 additions and 850 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
collects/compiler/cm.ss
View File

@ -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,
;; as appropriate.
((manager-compile-notify-handler) orig-path)
(trace-printf "compiling: ~a" orig-path)
(parameterize ([indent (string-append " " (indent))])
(let* ([zo-name (path-add-suffix (get-compilation-path mode path) #".zo")]
[zo-exists? (file-exists? zo-name)])
(if (and zo-exists? (trust-existing-zos))
(touch zo-name)
(begin (when zo-exists? (delete-file zo-name))
(log-info (format "cm: ~acompiling ~a"
(build-string
(depth)
(λ (x) (if (= 2 (modulo x 3)) #\| #\space)))
orig-path))
(parameterize ([depth (+ (depth) 1)])
(with-handlers
([exn:get-module-code?
(lambda (ex)
(compilation-failure mode path zo-name
(exn:get-module-code-path ex)
(exn-message ex))
(raise ex))])
(compile-zo* mode path read-src-syntax zo-name)))))))
(trace-printf "end compile: ~a" orig-path))
(let ([actual-path (actual-source-path orig-path)])
((manager-compile-notify-handler) actual-path)
(trace-printf "compiling: ~a" actual-path)
(parameterize ([indent (string-append " " (indent))])
(let* ([zo-name (path-add-suffix (get-compilation-path mode path) #".zo")]
[zo-exists? (file-exists? zo-name)])
(if (and zo-exists? (trust-existing-zos))
(touch zo-name)
(begin (when zo-exists? (delete-file zo-name))
(log-info (format "cm: ~acompiling ~a"
(build-string
(depth)
(λ (x) (if (= 2 (modulo x 3)) #\| #\space)))
actual-path))
(parameterize ([depth (+ (depth) 1)])
(with-handlers
([exn:get-module-code?
(lambda (ex)
(compilation-failure mode path zo-name
(exn:get-module-code-path ex)
(exn-message ex))
(raise ex))])
(compile-zo* mode path read-src-syntax zo-name)))))))
(trace-printf "end compile: ~a" actual-path)))
(define (get-compiled-time mode path)
(define-values (dir name) (get-compilation-dir+name mode path))

5
collects/drscheme/private/module-language.ss
View File

@ -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

9
collects/errortrace/lang/body.ss
View File

@ -9,12 +9,13 @@
(syntax-case stx ()
[(_ lang . body)
(let ([e (annotate-top
(local-expand #`(module . #,(strip-context #`(n lang . body)))
'top-level
null)
(syntax-local-introduce
(local-expand #`(module . #,(strip-context #`(n lang . body)))
'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)]))]))

3
collects/r6rs/run.ss
View File

@ -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))))])

2
collects/scheme/contract/private/base.ss
View File

@ -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 ()

11
collects/scheme/contract/private/legacy.ss
View File

@ -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
[(symbol? resolved) `(quote ,resolved)]
[else `(file ,(path->string resolved))]))]))
(cond
[(symbol? resolved) `(quote ,resolved)]
[else `(file ,(path->string resolved))])]))
blame))
(define (unpack-source info)

4
collects/scheme/contract/private/provide.ss
View File

@ -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)

24
collects/scribblings/reference/eval.scrbl
View File

@ -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
@filepath{.rkt} file exists. In addition, the default
@tech{compiled-load handler} checks for @filepath{.zo} (bytecode)
files and @filepath{.so} (native Unix), @filepath{.dll} (native
Windows), or @filepath{.dylib} (native Mac OS X) files.
file when the given path ends with @filepath{.rkt}, no @filepath{.rkt}
file exists, and when the handler's second argument is a symbol. In
addition, the default @tech{compiled-load handler} checks for
@filepath{.zo} (bytecode) files and @filepath{.so} (native Unix),
@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
@filepath{.ss} file exists, then @filepath{.zo} and
@scheme[_file] ends with @filepath{.rkt}, no such file exists, the
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

22
collects/scribblings/reference/module-reflect.scrbl
View File

@ -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
private @tech{continuation mark} the filename being loaded, and it
checks whether such a mark 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.
name (while the @tech{compiled-load handler} sets
@scheme[current-module-declare-source]). Also, the default
@tech{module name resolver} records in a private @tech{continuation
mark} the module being loaded, and it checks whether such a mark
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}

10
collects/scribblings/reference/namespaces.scrbl
View File

@ -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?]{

8
collects/unstable/location.ss
View File

@ -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))

10
collects/unstable/scribblings/srcloc.scrbl
View File

@ -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

1
src/mzscheme/include/scheme.h
View File

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

1464
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

20
src/mzscheme/src/env.c
View File

@ -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[])
{

2
src/mzscheme/src/error.c
View File

@ -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,

6
src/mzscheme/src/eval.c
View File

@ -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 = "";

75
src/mzscheme/src/module.c
View File

@ -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);

2
src/mzscheme/src/mzmark.c
View File

@ -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);

1
src/mzscheme/src/mzmarksrc.c
View File

@ -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);

29
src/mzscheme/src/mzrt.c
View File

@ -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;

2
src/mzscheme/src/schminc.h
View File

@ -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

1
src/mzscheme/src/schpriv.h
View File

@ -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 */

4
src/mzscheme/src/schvers.h
View File

@ -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)

32
src/mzscheme/src/startup.inc
View File

@ -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)))))"
"((or(and try-main?"
"(parameterize((current-module-declare-source #f))"
"(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) "
"(if try-main? path alt-path)"
" expect-module))))))))))"
"(let((p(if try-main? path alt-path)))"
"(parameterize((current-module-declare-source(and 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)) "

36
src/mzscheme/src/startup.ss
View File

@ -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?
(date>=? modes so path-d))
(and try-alt?
(date>=? modes alt-so alt-path-d)))
[(and try-main?
(date>=? modes so path-d))
=> (lambda (so-d)
(with-dir (lambda () ((current-load-extension) (car so-d) expect-module))))]
[(or (and try-main?
(date>=? modes zo path-d))
(and try-alt?
(date>=? modes alt-zo path-d)))
(parameterize ([current-module-declare-source #f])
(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))
=> (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)
(if try-main? path alt-path)
expect-module)))]))))))
(let ([p (if try-main? path alt-path)])
(parameterize ([current-module-declare-source (and expect-module
(not try-main?)
p)])
(with-dir (lambda () ((current-load) p expect-module)))))]))))))
(define-values (default-reader-guard)
(lambda (path) path))

2
src/mzscheme/src/syntax.c
View File

@ -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",