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

add `exn:fail:{filesystem,syntax}:missing-module'

Browse Source 
These exception types are intended as a hook for a programming
environment to recommend packages that can provide a module that isn't
found (through an uncaught-exception handler). The new exceptions are
generated by the default module name resolver and defaultload
handler. In addition to the exceptions, there's a new
`prop:exn:missing-module' property and `exn:missing-module?', which is
what an environment should use to detect relevant exceptions.

There's also a new `current-module-path-for-load' parameter, which
just provides a commuincation path from the module name resolver to
the the load handler. The parameter is a relatively ugly piece of the
puzzle, but it's the best I could find to squash the new functionality
into the existing stack of handlers.
This commit is contained in:
Matthew Flatt 2013-04-21 17:51:44 -06:00
parent 91efc754ba
commit 426a8c0d39
20 changed files with 1304 additions and 943 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/racket/private/kernstruct.rkt
View File

@ -211,6 +211,28 @@
'(#f #f #f)
(quote-syntax exn:fail:syntax)))
(λ () (quote-syntax kernel:exn:fail:syntax:unbound)))))
(begin
(#%require
(rename '#%kernel
kernel:exn:fail:syntax:missing-module
exn:fail:syntax:missing-module))
(define make-exn:fail:syntax:missing-module
kernel:exn:fail:syntax:missing-module)
(define-syntax exn:fail:syntax:missing-module
(make-self-ctr-struct-info
(λ ()
(list
(quote-syntax struct:exn:fail:syntax:missing-module)
(quote-syntax make-exn:fail:syntax:missing-module)
(quote-syntax exn:fail:syntax:missing-module?)
(list
(quote-syntax exn:fail:syntax:missing-module-path)
(quote-syntax exn:fail:syntax-exprs)
(quote-syntax exn-continuation-marks)
(quote-syntax exn-message))
'(#f #f #f #f)
(quote-syntax exn:fail:syntax)))
(λ () (quote-syntax kernel:exn:fail:syntax:missing-module)))))
(begin
(#%require (rename '#%kernel kernel:exn:fail:read exn:fail:read))
(define make-exn:fail:read kernel:exn:fail:read)
@ -339,6 +361,27 @@
'(#f #f #f)
(quote-syntax exn:fail:filesystem)))
(λ () (quote-syntax kernel:exn:fail:filesystem:errno)))))
(begin
(#%require
(rename '#%kernel
kernel:exn:fail:filesystem:missing-module
exn:fail:filesystem:missing-module))
(define make-exn:fail:filesystem:missing-module
kernel:exn:fail:filesystem:missing-module)
(define-syntax exn:fail:filesystem:missing-module
(make-self-ctr-struct-info
(λ ()
(list
(quote-syntax struct:exn:fail:filesystem:missing-module)
(quote-syntax make-exn:fail:filesystem:missing-module)
(quote-syntax exn:fail:filesystem:missing-module?)
(list
(quote-syntax exn:fail:filesystem:missing-module--path)
(quote-syntax exn-continuation-marks)
(quote-syntax exn-message))
'(#f #f #f)
(quote-syntax exn:fail:filesystem)))
(λ () (quote-syntax kernel:exn:fail:filesystem:missing-module)))))
(begin
(#%require (rename '#%kernel kernel:exn:fail:network exn:fail:network))
(define make-exn:fail:network kernel:exn:fail:network)

58
collects/scribblings/reference/exns.scrbl
View File

@ -615,6 +615,7 @@ exn
exn:fail:contract:variable
exn:fail:syntax
exn:fail:syntax:unbound
exn:fail:syntax:missing-module
exn:fail:read
exn:fail:read:eof
exn:fail:read:non-char
@ -622,6 +623,7 @@ exn
exn:fail:filesystem:exists
exn:fail:filesystem:version
exn:fail:filesystem:errno
exn:fail:filesystem:missing-module
exn:fail:network
exn:fail:network:errno
exn:fail:out-of-memory
@ -677,7 +679,9 @@ or @tech{module-level variable}.}
Raised for a syntax error that is not a @racket[read] error. The
@racket[exprs] indicate the relevant source expressions,
least-specific to most-specific.}
least-specific to most-specific.
This structure type implements the @racket[prop:exn:srclocs] property.}
@defstruct[(exn:fail:syntax:unbound exn:fail:syntax) ()
#:inspector #f]{
@ -685,6 +689,22 @@ least-specific to most-specific.}
Raised by @racket[#%top] or @racket[set!] for an
unbound identifier within a module.}
@defstruct[(exn:fail:syntax:missing-module exn:fail:syntax) ([path module-path?])
#:inspector #f]{
Raised by the default @tech{module name resolver} or default
@tech{load handler} to report a module path---a reported in the
@racket[path] field---whose implementation file cannot be
found.
The default @tech{module name resolver} raises this exception only
when it is given a syntax object as its second argument, and the
default @tech{load handler} raises this exception only when the value
of @racket[current-module-path-for-load] is a syntax object (in which
case both the @racket[exprs] field and the @racket[path] field
are determined by the syntax object.
This structure type implements the @racket[prop:exn:missing-module] property.}
@defstruct[(exn:fail:read exn:fail) ([srclocs (listof srcloc?)])
#:inspector #f]{
@ -735,6 +755,21 @@ code (under Windows, only), and @racket['gai] indicates a
hostnames, but it allowed in @racket[exn:fail:filesystem:errno]
instances for consistency).}
@defstruct[(exn:fail:filesystem:missing-module exn:fail:filesystem) ([path module-path?])
#:inspector #f]{
Raised by the default @tech{module name resolver} or default
@tech{load handler} to report a module path---a reported in the
@racket[path] field---whose implementation file cannot be
found.
The default @tech{module name resolver} raises this exception only
when it is @emph{not} given a syntax object as its second argument, and the
default @tech{load handler} raises this exception only when the value
of @racket[current-module-path-for-load] is @emph{not} a syntax object.
This structure type implements the @racket[prop:exn:missing-module] property.}
@defstruct[(exn:fail:network exn:fail) ()
#:inspector #f]{
@ -892,3 +927,24 @@ The fields of a @racket[srcloc] instance are as follows:
0) or @racket[#f] (unknown).}
]}
@defthing[prop:exn:missing-module struct-type-property?]{
A property that identifies structure types that provide a module path
for a load that fails because a module is not found.
The property value must be a procedure that accepts a single
value---the structure type instance from which to extract source
locations---and returns a @tech{module path}.}
@defproc[(exn:missing-module? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] has the @racket[prop:exn:missing-module]
property, @racket[#f] otherwise.}
@defproc[(exn:missing-module-accessor [v exn:srclocs?])
(exn:missing-module? . -> . module-path?)]{
Returns the @tech{module path}-getting procedure associated with @racket[v].}

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

@ -171,6 +171,18 @@ is @racket[#f], the module's name (as determined by
@racket[current-module-declare-name]) is used as the source name
instead of the parameter value.}
@defparam[current-module-path-for-load path (or/c #f module-path?
(and/c syntax?
(lambda (stx)
(module-path? (syntax->datum s)))))]{
A @tech{parameter} that determines a module path used for
@racket[exn:fail:syntax:missing-module] and
@racket[exn:fail:filesytem:missing-module] exceptions as raised by the
default @tech{load handler}. The parameter is normally set by a
@tech{module name resolver}.}
@;------------------------------------------------------------------------
@section[#:tag "modpathidx"]{Compiled Modules and References}

5
doc/release-notes/racket/HISTORY.txt
View File

@ -1,3 +1,8 @@
Version 5.3.4.4
Added current-module-path-for-load, exn:fail:syntax:missing-module,
exn:fail:filesystem:missing-module, prop:exn:missing-module,
exn:missing-module?, and exn:missing-module-accessor
Version 5.3.4.3
Added make-environment-variables
Changed initialization of current-directory to use PWD

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

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

1796
src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

55
src/racket/src/error.c
View File

@ -257,6 +257,7 @@ Scheme_Config *scheme_init_error_escape_proc(Scheme_Config *config)
%V = scheme_value
%@ = list of scheme_value to write splice
%D = scheme value to display
%W = scheme value to write
%_ = skip pointer
%- = skip int
@ -336,6 +337,7 @@ static intptr_t sch_vsprintf(char *s, intptr_t maxlen, const char *msg, va_list
case 'V':
case '@':
case 'D':
case 'W':
case 'T':
case 'Q':
case '_':
@ -578,6 +580,15 @@ static intptr_t sch_vsprintf(char *s, intptr_t maxlen, const char *msg, va_list
tlen = dlen;
}
break;
case 'W':
{
Scheme_Object *o;
intptr_t dlen;
o = (Scheme_Object *)ptrs[pp++];
t = scheme_write_to_string(o, &dlen);
tlen = dlen;
}
break;
case '_':
{
pp++;
@ -4365,6 +4376,24 @@ static Scheme_Object *errno_field_check(int argc, Scheme_Object **argv)
return scheme_values (3, argv);
}
static Scheme_Object *module_path_field_check(int pos, int argc, Scheme_Object **argv)
{
if (!scheme_is_module_path(argv[pos]))
scheme_wrong_field_contract(argv[pos+1], "(or/c #f module-path?)", argv[pos]);
return scheme_values (pos+1, argv);
}
static Scheme_Object *module_path_field_check_2(int argc, Scheme_Object **argv)
{
return module_path_field_check(2, argc, argv);
}
static Scheme_Object *module_path_field_check_3(int argc, Scheme_Object **argv)
{
return module_path_field_check(3, argc, argv);
}
static Scheme_Object *extract_syntax_locations(int argc, Scheme_Object **argv)
{
if (scheme_is_struct_instance(exn_table[MZEXN_FAIL_SYNTAX].type, argv[0])) {
@ -4401,6 +4430,32 @@ static Scheme_Object *extract_read_locations(int argc, Scheme_Object **argv)
return NULL;
}
static Scheme_Object *extract_module_path(int pos, int argc, Scheme_Object **argv,
int exn_kind, const
char *accessor_name, const char *contract)
{
if (scheme_is_struct_instance(exn_table[exn_kind].type, argv[0]))
return scheme_struct_ref(argv[0], pos);
scheme_wrong_contract(accessor_name, contract, 0, argc, argv);
return NULL;
}
static Scheme_Object *extract_module_path_2(int argc, Scheme_Object **argv)
{
return extract_module_path(2, argc, argv,
MZEXN_FAIL_FILESYSTEM_MISSING_MODULE,
"exn:fail:filesystem:missing-module:path-accessor",
"exn:fail:filesystem:missing-module?");
}
static Scheme_Object *extract_module_path_3(int argc, Scheme_Object **argv)
{
return extract_module_path(3, argc, argv,
MZEXN_FAIL_SYNTAX_MISSING_MODULE,
"exn:fail:syntax:missing-module:path-accessor",
"exn:fail:syntax:missing-module?");
}
void scheme_init_exn(Scheme_Env *env)
{
int i, j;

2
src/racket/src/file.c
View File

@ -3939,7 +3939,7 @@ static Scheme_Object *copy_file(int argc, Scheme_Object **argv)
Scheme_Object *a[2], * volatile in, * volatile out;
reason = NULL;
in = scheme_do_open_input_file("copy-file", 0, 1, argv, 1, &reason, &err_val);
in = scheme_do_open_input_file("copy-file", 0, 1, argv, 1, &reason, &err_val, 0);
if (!in) {
has_err_val = !!err_val;
goto failed;

12
src/racket/src/makeexn
View File

@ -48,7 +48,11 @@ propeties (the latter in curly braces), strings are contracts/comments.
{exn:source scheme_source_property |scheme_make_prim(extract_syntax_locations)|}]
"syntax error, but not a \\scmfirst{read} error"
(unbound []
"unbound module variable"))
"unbound module variable")
(missing-module [module_path_field_check_3
(path "module path" "module path")
{exn:module-path scheme_module_path_property |scheme_make_prim(extract_module_path_3)|}]
"error resolving a module path"))
(read [read_field_check
(srclocs "immutable list of \\scmk{srcloc}s (see \\SecRef{linecol})" "source location(s) of error")
{exn:source scheme_source_property |scheme_make_prim(extract_read_locations)|}]
@ -60,7 +64,11 @@ propeties (the latter in curly braces), strings are contracts/comments.
(version [] "version mismatch loading an extension")
(errno [errno_field_check
(errno "pair of symbol and number" "system error code")]
"error with system error code"))
"error with system error code")
(missing-module [module_path_field_check_2
(-path "module path" "module path")
{exn:module-path scheme_module_path_property |scheme_make_prim(extract_module_path_2)|}]
"error resolving a module path"))
(network [] "TCP and UDP errors"
(errno [errno_field_check
(errno "pair of symbol and number" "system error code")]

24
src/racket/src/module.c
View File

@ -46,6 +46,7 @@ SHARED_OK static mzrt_mutex *modpath_table_mutex;
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 *current_module_load_path(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[]);
@ -428,6 +429,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_PARAMETER("current-module-path-for-load", current_module_load_path, MZCONFIG_CURRENT_MODULE_LOAD_PATH, 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);
@ -1036,6 +1038,28 @@ current_module_name_source(int argc, Scheme_Object *argv[])
-1, source_p, "symbol, complete path, or #f", 1);
}
static Scheme_Object *load_path_p(int argc, Scheme_Object **argv)
{
Scheme_Object *o = argv[0];
if (!SCHEME_FALSEP(o)
&& !scheme_is_module_path(o)
&& (!SCHEME_STXP(o)
|| !scheme_is_module_path(scheme_syntax_to_datum(o, 0, NULL))))
return NULL;
return o;
}
static Scheme_Object *
current_module_load_path(int argc, Scheme_Object *argv[])
{
return scheme_param_config("current-module-path-for-load",
scheme_make_integer(MZCONFIG_CURRENT_MODULE_LOAD_PATH),
argc, argv,
-1, load_path_p, "module path, module path as syntax, or #f", 1);
}
/**********************************************************************/
/* procedures */
/**********************************************************************/

53
src/racket/src/port.c
View File

@ -4491,11 +4491,12 @@ Scheme_Object *scheme_terminal_port_p(int argc, Scheme_Object *argv[])
return is_fd_terminal(fd) ? scheme_true : scheme_false;
}
static void filename_exn(char *name, char *msg, char *filename, int err)
static void filename_exn(char *name, char *msg, char *filename, int err, int maybe_module_errno)
{
char *dir, *drive;
int len;
char *pre, *rel, *post;
Scheme_Object *mod_path, *mp;
len = strlen(filename);
@ -4514,6 +4515,38 @@ static void filename_exn(char *name, char *msg, char *filename, int err)
rel = dir ? dir : (drive ? drive : "");
post = dir ? "" : "";
if (maybe_module_errno && (err == maybe_module_errno)) {
mod_path = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_LOAD_PATH);
if (SCHEME_TRUEP(mod_path)) {
if (SCHEME_STXP(mod_path)) {
mp = scheme_syntax_to_datum(mod_path, 0, NULL);
scheme_raise_exn(MZEXN_FAIL_SYNTAX_MISSING_MODULE,
scheme_make_pair(mod_path, scheme_null),
mp,
"%s: %s\n"
" module path: %W\n"
" path: %q%s%q%s\n"
" system error: " FILENAME_EXN_E,
name, "cannot open module file",
mp, filename,
pre, rel, post,
err);
} else {
scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_MISSING_MODULE,
mod_path,
"%s: %s\n"
" module path: %W\n"
" path: %q%s%q%s\n"
" system error: " FILENAME_EXN_E,
name, "cannot open module file",
mod_path, filename,
pre, rel, post,
err);
}
return;
}
}
scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
"%s: %s\n"
" path: %q%s%q%s\n"
@ -4525,7 +4558,7 @@ static void filename_exn(char *name, char *msg, char *filename, int err)
Scheme_Object *
scheme_do_open_input_file(char *name, int offset, int argc, Scheme_Object *argv[],
int internal, char **err, int *eerrno)
int internal, char **err, int *eerrno, int for_module)
{
#ifdef USE_FD_PORTS
int fd;
@ -4601,7 +4634,7 @@ scheme_do_open_input_file(char *name, int offset, int argc, Scheme_Object *argv[
*err = "cannot open source file";
*eerrno = errno;
} else
filename_exn(name, "cannot open input file", filename, errno);
filename_exn(name, "cannot open input file", filename, errno, (for_module ? ENOENT : 0));
return NULL;
} else {
int ok;
@ -4619,7 +4652,7 @@ scheme_do_open_input_file(char *name, int offset, int argc, Scheme_Object *argv[
*err = "source is a directory";
*eerrno = 0;
} else
filename_exn(name, "cannot open directory as a file", filename, 0);
filename_exn(name, "cannot open directory as a file", filename, 0, 0);
return NULL;
} else {
regfile = S_ISREG(buf.st_mode);
@ -4643,14 +4676,14 @@ scheme_do_open_input_file(char *name, int offset, int argc, Scheme_Object *argv[
*err = "cannot open source file";
*eerrno = errv;
} else
filename_exn(name, "cannot open input file", filename, GetLastError());
filename_exn(name, "cannot open input file", filename, GetLastError(), (for_module ? ERROR_FILE_NOT_FOUND : 0));
return NULL;
} else
regfile = (GetFileType(fd) == FILE_TYPE_DISK);
if ((mode[1] == 't') && !regfile) {
CloseHandle(fd);
filename_exn(name, "cannot use text-mode on a non-file device", filename, 0);
filename_exn(name, "cannot use text-mode on a non-file device", filename, 0, 0);
return NULL;
}
@ -4661,7 +4694,7 @@ scheme_do_open_input_file(char *name, int offset, int argc, Scheme_Object *argv[
*err = "source is a directory";
*eerrno = 0;
} else
filename_exn(name, err, filename, 0);
filename_exn(name, err, filename, 0, 0);
return NULL;
}
@ -4673,7 +4706,7 @@ scheme_do_open_input_file(char *name, int offset, int argc, Scheme_Object *argv[
*err = "cannot open source file";
*eerrno = errno;
} else
filename_exn(name, "cannot open input file", filename, errno);
filename_exn(name, "cannot open input file", filename, errno, (for_module ? ENOENT : 0));
return NULL;
}
@ -4877,7 +4910,7 @@ scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv
*err = "cannot open destination file";
*eerrno = errno;
} else
filename_exn(name, "cannot open output file", filename, errno);
filename_exn(name, "cannot open output file", filename, errno, 0);
return NULL;
}
}
@ -5077,7 +5110,7 @@ Scheme_Object *scheme_open_input_file(const char *name, const char *who)
Scheme_Object *a[1];
a[0]= scheme_make_path(name);
return scheme_do_open_input_file((char *)who, 0, 1, a, 0, NULL, NULL);
return scheme_do_open_input_file((char *)who, 0, 1, a, 0, NULL, NULL, 0);
}
Scheme_Object *scheme_open_output_file(const char *name, const char *who)

8
src/racket/src/portfun.c
View File

@ -2542,7 +2542,7 @@ make_output_port (int argc, Scheme_Object *argv[])
static Scheme_Object *
open_input_file (int argc, Scheme_Object *argv[])
{
return scheme_do_open_input_file("open-input-file", 0, argc, argv, 0, NULL, NULL);
return scheme_do_open_input_file("open-input-file", 0, argc, argv, 0, NULL, NULL, 0);
}
static Scheme_Object *
@ -2731,7 +2731,7 @@ call_with_input_file(int argc, Scheme_Object *argv[])
scheme_check_proc_arity("call-with-input-file", 1, 1, argc, argv);
port = scheme_do_open_input_file("call-with-input-file", 1, argc, argv, 0, NULL, NULL);
port = scheme_do_open_input_file("call-with-input-file", 1, argc, argv, 0, NULL, NULL, 0);
v = _scheme_apply_multi(argv[1], 1, &port);
@ -2802,7 +2802,7 @@ with_input_from_file(int argc, Scheme_Object *argv[])
scheme_check_proc_arity("with-input-from-file", 0, 1, argc, argv);
port = scheme_do_open_input_file("with-input-from-file", 1, argc, argv, 0, NULL, NULL);
port = scheme_do_open_input_file("with-input-from-file", 1, argc, argv, 0, NULL, NULL, 0);
config = scheme_extend_config(scheme_current_config(),
MZCONFIG_INPUT_PORT,
@ -4724,7 +4724,7 @@ static Scheme_Object *default_load(int argc, Scheme_Object *argv[])
"(or/c #f symbol? (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))",
1, argc, argv);
port = scheme_do_open_input_file("default-load-handler", 0, 1, argv, 0, NULL, NULL);
port = scheme_do_open_input_file("default-load-handler", 0, 1, argv, 0, NULL, NULL, SCHEME_TRUEP(expected_module));
/* Turn on line/column counting, unless it's a .zo file: */
if (SCHEME_PATHP(argv[0])) {

2
src/racket/src/read.c
View File

@ -5715,7 +5715,7 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in
scheme_release_file_descriptor();
a[0] = delay_info->path;
port = scheme_do_open_input_file("on-demand-loader", 0, 1, a, 0, NULL, NULL);
port = scheme_do_open_input_file("on-demand-loader", 0, 1, a, 0, NULL, NULL, 0);
savebuf = scheme_current_thread->error_buf;
scheme_current_thread->error_buf = &newbuf;

30
src/racket/src/schexn.h
View File

@ -12,6 +12,7 @@ enum {
MZEXN_FAIL_CONTRACT_VARIABLE,
MZEXN_FAIL_SYNTAX,
MZEXN_FAIL_SYNTAX_UNBOUND,
MZEXN_FAIL_SYNTAX_MISSING_MODULE,
MZEXN_FAIL_READ,
MZEXN_FAIL_READ_EOF,
MZEXN_FAIL_READ_NON_CHAR,
@ -19,6 +20,7 @@ enum {
MZEXN_FAIL_FILESYSTEM_EXISTS,
MZEXN_FAIL_FILESYSTEM_VERSION,
MZEXN_FAIL_FILESYSTEM_ERRNO,
MZEXN_FAIL_FILESYSTEM_MISSING_MODULE,
MZEXN_FAIL_NETWORK,
MZEXN_FAIL_NETWORK_ERRNO,
MZEXN_FAIL_OUT_OF_MEMORY,
@ -33,7 +35,7 @@ enum {
#ifdef _MZEXN_TABLE
#define MZEXN_MAXARGS 3
#define MZEXN_MAXARGS 4
#ifdef GLOBAL_EXN_ARRAY
static exn_rec exn_table[] = {
@ -47,21 +49,23 @@ static exn_rec exn_table[] = {
{ 3, NULL, NULL, 0, NULL, 2 },
{ 3, NULL, NULL, 0, NULL, 1 },
{ 3, NULL, NULL, 0, NULL, 8 },
{ 4, NULL, NULL, 0, NULL, 8 },
{ 3, NULL, NULL, 0, NULL, 1 },
{ 3, NULL, NULL, 0, NULL, 10 },
{ 3, NULL, NULL, 0, NULL, 10 },
{ 3, NULL, NULL, 0, NULL, 11 },
{ 3, NULL, NULL, 0, NULL, 11 },
{ 2, NULL, NULL, 0, NULL, 1 },
{ 2, NULL, NULL, 0, NULL, 13 },
{ 2, NULL, NULL, 0, NULL, 13 },
{ 3, NULL, NULL, 0, NULL, 13 },
{ 2, NULL, NULL, 0, NULL, 14 },
{ 2, NULL, NULL, 0, NULL, 14 },
{ 3, NULL, NULL, 0, NULL, 14 },
{ 3, NULL, NULL, 0, NULL, 14 },
{ 2, NULL, NULL, 0, NULL, 1 },
{ 3, NULL, NULL, 0, NULL, 17 },
{ 3, NULL, NULL, 0, NULL, 19 },
{ 2, NULL, NULL, 0, NULL, 1 },
{ 2, NULL, NULL, 0, NULL, 1 },
{ 2, NULL, NULL, 0, NULL, 1 },
{ 3, NULL, NULL, 0, NULL, 0 },
{ 3, NULL, NULL, 0, NULL, 22 },
{ 3, NULL, NULL, 0, NULL, 22 }
{ 3, NULL, NULL, 0, NULL, 24 },
{ 3, NULL, NULL, 0, NULL, 24 }
};
#else
static exn_rec *exn_table;
@ -83,6 +87,7 @@ static exn_rec *exn_table;
exn_table[MZEXN_FAIL_CONTRACT_VARIABLE].args = 3;
exn_table[MZEXN_FAIL_SYNTAX].args = 3;
exn_table[MZEXN_FAIL_SYNTAX_UNBOUND].args = 3;
exn_table[MZEXN_FAIL_SYNTAX_MISSING_MODULE].args = 4;
exn_table[MZEXN_FAIL_READ].args = 3;
exn_table[MZEXN_FAIL_READ_EOF].args = 3;
exn_table[MZEXN_FAIL_READ_NON_CHAR].args = 3;
@ -90,6 +95,7 @@ static exn_rec *exn_table;
exn_table[MZEXN_FAIL_FILESYSTEM_EXISTS].args = 2;
exn_table[MZEXN_FAIL_FILESYSTEM_VERSION].args = 2;
exn_table[MZEXN_FAIL_FILESYSTEM_ERRNO].args = 3;
exn_table[MZEXN_FAIL_FILESYSTEM_MISSING_MODULE].args = 3;
exn_table[MZEXN_FAIL_NETWORK].args = 2;
exn_table[MZEXN_FAIL_NETWORK_ERRNO].args = 3;
exn_table[MZEXN_FAIL_OUT_OF_MEMORY].args = 2;
@ -106,15 +112,19 @@ static exn_rec *exn_table;
static const char *MZEXN_FIELDS[2] = { "message", "continuation-marks" };
static const char *MZEXN_FAIL_CONTRACT_VARIABLE_FIELDS[1] = { "id" };
static const char *MZEXN_FAIL_SYNTAX_FIELDS[1] = { "exprs" };
static const char *MZEXN_FAIL_SYNTAX_MISSING_MODULE_FIELDS[1] = { "path" };
static const char *MZEXN_FAIL_READ_FIELDS[1] = { "srclocs" };
static const char *MZEXN_FAIL_FILESYSTEM_ERRNO_FIELDS[1] = { "errno" };
static const char *MZEXN_FAIL_FILESYSTEM_MISSING_MODULE_FIELDS[1] = { "-path" };
static const char *MZEXN_FAIL_NETWORK_ERRNO_FIELDS[1] = { "errno" };
static const char *MZEXN_BREAK_FIELDS[1] = { "continuation" };
#endif
#ifdef _MZEXN_DECL_PROPS
# define MZEXN_FAIL_SYNTAX_PROPS scheme_make_pair(scheme_make_pair(scheme_source_property, scheme_make_prim(extract_syntax_locations)), scheme_null)
# define MZEXN_FAIL_SYNTAX_MISSING_MODULE_PROPS scheme_make_pair(scheme_make_pair(scheme_module_path_property, scheme_make_prim(extract_module_path_3)), scheme_null)
# define MZEXN_FAIL_READ_PROPS scheme_make_pair(scheme_make_pair(scheme_source_property, scheme_make_prim(extract_read_locations)), scheme_null)
# define MZEXN_FAIL_FILESYSTEM_MISSING_MODULE_PROPS scheme_make_pair(scheme_make_pair(scheme_module_path_property, scheme_make_prim(extract_module_path_2)), scheme_null)
#endif
#ifdef _MZEXN_SETUP
@ -128,6 +138,7 @@ static exn_rec *exn_table;
SETUP_STRUCT(MZEXN_FAIL_CONTRACT_VARIABLE, EXN_PARENT(MZEXN_FAIL_CONTRACT), "exn:fail:contract:variable", 1, MZEXN_FAIL_CONTRACT_VARIABLE_FIELDS, scheme_null, scheme_make_prim(variable_field_check))
SETUP_STRUCT(MZEXN_FAIL_SYNTAX, EXN_PARENT(MZEXN_FAIL), "exn:fail:syntax", 1, MZEXN_FAIL_SYNTAX_FIELDS, MZEXN_FAIL_SYNTAX_PROPS, scheme_make_prim(syntax_field_check))
SETUP_STRUCT(MZEXN_FAIL_SYNTAX_UNBOUND, EXN_PARENT(MZEXN_FAIL_SYNTAX), "exn:fail:syntax:unbound", 0, NULL, scheme_null, NULL)
SETUP_STRUCT(MZEXN_FAIL_SYNTAX_MISSING_MODULE, EXN_PARENT(MZEXN_FAIL_SYNTAX), "exn:fail:syntax:missing-module", 1, MZEXN_FAIL_SYNTAX_MISSING_MODULE_FIELDS, MZEXN_FAIL_SYNTAX_MISSING_MODULE_PROPS, scheme_make_prim(module_path_field_check_3))
SETUP_STRUCT(MZEXN_FAIL_READ, EXN_PARENT(MZEXN_FAIL), "exn:fail:read", 1, MZEXN_FAIL_READ_FIELDS, MZEXN_FAIL_READ_PROPS, scheme_make_prim(read_field_check))
SETUP_STRUCT(MZEXN_FAIL_READ_EOF, EXN_PARENT(MZEXN_FAIL_READ), "exn:fail:read:eof", 0, NULL, scheme_null, NULL)
SETUP_STRUCT(MZEXN_FAIL_READ_NON_CHAR, EXN_PARENT(MZEXN_FAIL_READ), "exn:fail:read:non-char", 0, NULL, scheme_null, NULL)
@ -135,6 +146,7 @@ static exn_rec *exn_table;
SETUP_STRUCT(MZEXN_FAIL_FILESYSTEM_EXISTS, EXN_PARENT(MZEXN_FAIL_FILESYSTEM), "exn:fail:filesystem:exists", 0, NULL, scheme_null, NULL)
SETUP_STRUCT(MZEXN_FAIL_FILESYSTEM_VERSION, EXN_PARENT(MZEXN_FAIL_FILESYSTEM), "exn:fail:filesystem:version", 0, NULL, scheme_null, NULL)
SETUP_STRUCT(MZEXN_FAIL_FILESYSTEM_ERRNO, EXN_PARENT(MZEXN_FAIL_FILESYSTEM), "exn:fail:filesystem:errno", 1, MZEXN_FAIL_FILESYSTEM_ERRNO_FIELDS, scheme_null, scheme_make_prim(errno_field_check))
SETUP_STRUCT(MZEXN_FAIL_FILESYSTEM_MISSING_MODULE, EXN_PARENT(MZEXN_FAIL_FILESYSTEM), "exn:fail:filesystem:missing-module", 1, MZEXN_FAIL_FILESYSTEM_MISSING_MODULE_FIELDS, MZEXN_FAIL_FILESYSTEM_MISSING_MODULE_PROPS, scheme_make_prim(module_path_field_check_2))
SETUP_STRUCT(MZEXN_FAIL_NETWORK, EXN_PARENT(MZEXN_FAIL), "exn:fail:network", 0, NULL, scheme_null, NULL)
SETUP_STRUCT(MZEXN_FAIL_NETWORK_ERRNO, EXN_PARENT(MZEXN_FAIL_NETWORK), "exn:fail:network:errno", 1, MZEXN_FAIL_NETWORK_ERRNO_FIELDS, scheme_null, scheme_make_prim(errno_field_check))
SETUP_STRUCT(MZEXN_FAIL_OUT_OF_MEMORY, EXN_PARENT(MZEXN_FAIL), "exn:fail:out-of-memory", 0, NULL, scheme_null, NULL)

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

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1093
#define EXPECTED_PRIM_COUNT 1105
#define EXPECTED_UNSAFE_COUNT 100
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45

3
src/racket/src/schpriv.h
View File

@ -899,6 +899,7 @@ Scheme_Object *scheme_print_attribute_ref(Scheme_Object *s);
#define SCHEME_STRUCT_INSPECTOR(obj) (((Scheme_Structure *)obj)->stype->inspector)
extern Scheme_Object *scheme_source_property;
extern Scheme_Object *scheme_module_path_property;
Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_count);
Scheme_Object *scheme_make_blank_prefab_struct_instance(Scheme_Struct_Type *stype);
@ -3794,7 +3795,7 @@ void scheme_flush_orig_outputs(void);
Scheme_Object *scheme_file_stream_port_p(int, Scheme_Object *[]);
Scheme_Object *scheme_terminal_port_p(int, Scheme_Object *[]);
Scheme_Object *scheme_do_open_input_file(char *name, int offset, int argc, Scheme_Object *argv[],
int internal, char **err, int *eerrno);
int internal, char **err, int *eerrno, int for_module);
Scheme_Object *scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv[], int and_read,
int internal, char **err, int *eerrno);
Scheme_Object *scheme_file_position(int argc, Scheme_Object *argv[]);

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "5.3.4.3"
#define MZSCHEME_VERSION "5.3.4.4"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 4
#define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_W 4
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

39
src/racket/src/startup.inc
View File

@ -1011,14 +1011,24 @@
" base))))))"
"(current-load-relative-directory)"
"(current-directory))))"
"(show-collection-err(lambda(s)"
" (let ((s (string-append \"standard-module-name-resolver: \" s)))"
"(show-collection-err(lambda(msg)"
"(let((msg(string-append"
" \"standard-module-name-resolver: \" "
" (regexp-replace #rx\"\\n\" "
" msg"
" (format \"\\n for module path: ~s\\n\""
" s)))))"
"(raise"
"(if stx"
"(raise-syntax-error"
" #f"
" s"
" stx)"
"(error s)))))"
"(exn:fail:syntax:missing-module"
" msg"
"(current-continuation-marks)"
"(list stx)"
" s)"
"(exn:fail:filesystem:missing-module"
" msg"
"(current-continuation-marks)"
" s))))))"
"(ss->rkt(lambda(s)"
"(let((len(string-length s)))"
"(if(and(len . >= . 3)"
@ -1202,7 +1212,20 @@
"(namespace-module-registry(current-namespace))"
" normal-filename)"
" loading)"
"(parameterize((current-module-declare-name root-modname))"
"(parameterize((current-module-declare-name root-modname)"
"(current-module-path-for-load"
"((if stx"
"(lambda(p)(datum->syntax #f p stx))"
" values)"
"(cond"
"((symbol? s) s)"
"((and(pair? s)(eq?(car s) 'lib)) s)"
"(else(if(resolved-module-path? root-modname)"
"(let((src(resolved-module-path-name root-modname)))"
"(if(symbol? src)"
"(list 'quote src)"
" src))"
" root-modname))))))"
"((current-load/use-compiled) "
" filename "
"(let((sym(string->symbol(path->string no-sfx))))"

45
src/racket/src/startup.rktl
View File

@ -1144,14 +1144,24 @@
base))))))
(current-load-relative-directory)
(current-directory)))]
[show-collection-err (lambda (s)
(let ([s (string-append "standard-module-name-resolver: " s)])
(if stx
(raise-syntax-error
#f
s
stx)
(error s))))]
[show-collection-err (lambda (msg)
(let ([msg (string-append
"standard-module-name-resolver: "
(regexp-replace #rx"\n"
msg
(format "\n for module path: ~s\n"
s)))])
(raise
(if stx
(exn:fail:syntax:missing-module
msg
(current-continuation-marks)
(list stx)
s)
(exn:fail:filesystem:missing-module
msg
(current-continuation-marks)
s)))))]
[ss->rkt (lambda (s)
(let ([len (string-length s)])
(if (and (len . >= . 3)
@ -1343,7 +1353,24 @@
(namespace-module-registry (current-namespace))
normal-filename)
loading)
(parameterize ([current-module-declare-name root-modname])
(parameterize ([current-module-declare-name root-modname]
[current-module-path-for-load
;; If `s' is an absolute module path, then
;; keep it as-is, the better to let a tool
;; recommend how to get an unavailable module;
;; also, propagate the source location.
((if stx
(lambda (p) (datum->syntax #f p stx))
values)
(cond
[(symbol? s) s]
[(and (pair? s) (eq? (car s) 'lib)) s]
[else (if (resolved-module-path? root-modname)
(let ([src (resolved-module-path-name root-modname)])
(if (symbol? src)
(list 'quote src)
src))
root-modname)]))])
((current-load/use-compiled)
filename
(let ([sym (string->symbol (path->string no-sfx))])

53
src/racket/src/struct.c
View File

@ -29,6 +29,7 @@ READ_ONLY Scheme_Object *scheme_arity_at_least;
READ_ONLY Scheme_Object *scheme_date;
READ_ONLY Scheme_Object *scheme_make_arity_at_least;
READ_ONLY Scheme_Object *scheme_source_property;
READ_ONLY Scheme_Object *scheme_module_path_property;
READ_ONLY Scheme_Object *scheme_input_port_property;
READ_ONLY Scheme_Object *scheme_output_port_property;
READ_ONLY Scheme_Object *scheme_cpointer_property;
@ -173,6 +174,10 @@ static Scheme_Object *check_exn_source_property_value_ok(int argc, Scheme_Object
static Scheme_Object *exn_source_p(int argc, Scheme_Object **argv);
static Scheme_Object *exn_source_get(int argc, Scheme_Object **argv);
static Scheme_Object *check_exn_module_path_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *exn_module_path_p(int argc, Scheme_Object **argv);
static Scheme_Object *exn_module_path_get(int argc, Scheme_Object **argv);
static Scheme_Object *procedure_extract_target(int argc, Scheme_Object **argv);
static Scheme_Struct_Type *hash_prefab(Scheme_Struct_Type *type);
@ -791,6 +796,26 @@ scheme_init_struct (Scheme_Env *env)
1, 1, 1),
env);
REGISTER_SO(scheme_module_path_property);
{
guard = scheme_make_prim_w_arity(check_exn_module_path_property_value_ok,
"guard-for-prop:exn:srclocs",
2, 2);
scheme_module_path_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("prop:exn:missing-module"),
guard);
}
scheme_add_global_constant("prop:exn:missing-module", scheme_module_path_property, env);
scheme_add_global_constant("exn:missing-module?",
scheme_make_folding_prim(exn_module_path_p,
"exn:missing-module?",
1, 1, 1),
env);
scheme_add_global_constant("exn:missing-module-accessor",
scheme_make_folding_prim(exn_module_path_get,
"exn:missing-module-accessor",
1, 1, 1),
env);
{
Scheme_Object *p;
p = scheme_make_prim_w_arity(scheme_extract_checked_procedure,
@ -5298,6 +5323,34 @@ static Scheme_Object *check_exn_source_property_value_ok(int argc, Scheme_Object
/**********************************************************************/
static Scheme_Object *exn_module_path_p(int argc, Scheme_Object **argv)
{
return (scheme_struct_type_property_ref(scheme_module_path_property, argv[0])
? scheme_true
: scheme_false);
}
static Scheme_Object *exn_module_path_get(int argc, Scheme_Object **argv)
{
Scheme_Object *v;
v = scheme_struct_type_property_ref(scheme_module_path_property, argv[0]);
if (!v)
scheme_wrong_contract("exn:missing-module-accessor", "exn:missing-module?", 0, argc, argv);
return v;
}
static Scheme_Object *check_exn_module_path_property_value_ok(int argc, Scheme_Object *argv[])
/* This is the guard for prop:exn:srclocs */
{
scheme_check_proc_arity("guard-for-prop:exn:missing-module", 1, 0, argc, argv);
return argv[0];
}
/**********************************************************************/
static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, int argc, Scheme_Object **argv)
/* (chaperone-struct v mutator/selector redirect-proc ...) */
{