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

include source-location in "missing module" exceptions

Browse Source 
Also, add `current-directory-for-user' and `srcloc->string', and
adjust the way that source-location paths are reported to be
relative to `current-directory-for-user'.
This commit is contained in:
Matthew Flatt 2013-05-29 09:20:27 -06:00
parent 7c87a975a6
commit 6b2a4ff54d
19 changed files with 946 additions and 829 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/drracket/private/expanding-place.rkt
View File

@ -129,7 +129,8 @@
#:use-use-current-security-guard? #t)
(ep-log-info "expanding-place.rkt: 04 setting directories")
(let ([init-dir (get-init-dir path)])
(current-directory init-dir))
(current-directory init-dir)
(current-directory-for-user init-dir))
(current-load-relative-directory #f)
(define sp (open-input-string program-as-string))
(port-count-lines! sp)

3
collects/drracket/private/rep.rkt
View File

@ -1545,7 +1545,8 @@ TODO
(current-rep this)
(let ([dir (or (send context get-directory)
drracket:init:first-dir)])
(current-directory dir))
(current-directory dir)
(current-directory-for-user dir))
(set! user-namespace-box (make-weak-box (current-namespace)))

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

@ -929,6 +929,15 @@ The fields of a @racket[srcloc] instance are as follows:
]}
@defproc[(srcloc->string [srcloc srcloc?]) (or/c string? #f)]{
Formats @racket[srcloc] as a string suitable for error reporting. A
path source in @racket[srcloc] is shown relative to the value of
@racket[current-directory-for-user]. The result is @racket[#f] if
@racket[srcloc] does not contain enough information to format a
string.}
@defthing[prop:exn:missing-module struct-type-property?]{
A property that identifies structure types that provide a module path

12
collects/scribblings/reference/filesystem.scrbl
View File

@ -413,6 +413,18 @@ variable---if the value of the environment variable identifies the
same directory as the operating system's report of the current
directory.}
@defparam*[current-directory-for-user path path-string? (and/c path? complete-path?)]{
Like @racket[current-directory], but use only by
@racket[srcloc->string] for reporting paths relative to a
directory.
Normally, @racket[current-directory-for-user] should stay at its
initial value, reflecting the directory where a user started a
process. A tool such as DrRacket, however, implicitly lets a user
select a directory (for the file being edited), in which case updating
@racket[current-directory-for-user] makes sense.}
@defproc[(current-drive) path?]{

1
collects/slideshow/main.rkt
View File

@ -8,4 +8,3 @@
(module reader syntax/module-reader
slideshow)

10
collects/syntax/readerr.rkt
View File

@ -29,12 +29,10 @@
(make-exn:fail:read
(format "~a~a"
(cond [(not (error-print-source-location)) ""]
[(and line col)
(format "~a:~a:~a: " source-name line col)]
[pos
(format "~a::~a: " source-name pos)]
[else
(format "~a: " source-name)])
[(srcloc->string (srcloc source-name line col pos span))
(lambda (s)
(format "~a: " s))]
[else ""])
msg)
(current-continuation-marks)
(cons (make-srcloc source-name line col pos span)

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

@ -1,3 +1,6 @@
Version 5.3.4.11
Added current-directory-for-user, srcloc->string
Version 5.3.4.10
Move explode-path from racket/path to racket/base
Changed read-on-demand-source to support #t

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

@ -1368,6 +1368,8 @@ enum {
MZCONFIG_CURRENT_DIRECTORY,
MZCONFIG_CURRENT_ENV_VARS,
MZCONFIG_CURRENT_USER_DIRECTORY,
MZCONFIG_RANDOM_STATE,
MZCONFIG_CURRENT_MODULE_RESOLVER,

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

File diff suppressed because it is too large Load Diff

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

@ -116,6 +116,7 @@ static Scheme_Object *emergency_error_display_proc(int, Scheme_Object *[]);
static Scheme_Object *def_error_value_string_proc(int, Scheme_Object *[]);
static Scheme_Object *def_exit_handler_proc(int, Scheme_Object *[]);
static Scheme_Object *default_yield_handler(int, Scheme_Object *[]);
static Scheme_Object *srcloc_to_string(int argc, Scheme_Object **argv);
static Scheme_Object *log_message(int argc, Scheme_Object *argv[]);
static Scheme_Object *log_level_p(int argc, Scheme_Object *argv[]);
@ -728,6 +729,8 @@ void scheme_init_error(Scheme_Env *env)
GLOBAL_PARAMETER("current-logger", current_logger, MZCONFIG_LOGGER, env);
GLOBAL_NONCM_PRIM("srcloc->string", srcloc_to_string, 1, 1, env);
REGISTER_SO(scheme_def_exit_proc);
REGISTER_SO(default_display_handler);
REGISTER_SO(emergency_display_handler);
@ -2011,24 +2014,18 @@ void scheme_system_error(const char *name, const char *what, int errid)
#define MZERR_MAX_SRC_LEN 100
static char *make_srcloc_string(Scheme_Stx_Srcloc *srcloc, intptr_t *len)
static char *make_srcloc_string(Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, intptr_t *len)
{
intptr_t line, col;
Scheme_Object *src;
char *srcstr, *result;
intptr_t srclen, rlen;
if (!srcloc->src || (SCHEME_FALSEP(srcloc->src) && (srcloc->pos < 0))) {
if (!src || (SCHEME_FALSEP(src) && (pos < 0))) {
if (len) *len = 0;
return NULL;
}
line = srcloc->line;
col = srcloc->col;
if (col < 0)
col = srcloc->pos;
src = srcloc->src;
col = pos;
if (src && SCHEME_PATHP(src)) {
/* Strip off prefix matching the current directory: */
@ -2063,6 +2060,48 @@ static char *make_srcloc_string(Scheme_Stx_Srcloc *srcloc, intptr_t *len)
return result;
}
static char *make_stx_srcloc_string(Scheme_Stx_Srcloc *srcloc, intptr_t *len)
{
return make_srcloc_string(srcloc->src, srcloc->line, srcloc->col, srcloc->pos, len);
}
char *scheme_make_srcloc_string(Scheme_Object *stx, intptr_t *len)
{
return make_stx_srcloc_string(((Scheme_Stx *)stx)->srcloc, len);
}
static intptr_t struct_number_ref(Scheme_Object *s, int pos)
{
s = scheme_struct_ref(s, pos);
if (SCHEME_FALSEP(s))
return -1;
else
return SCHEME_INT_VAL(s);
}
Scheme_Object *srcloc_to_string(int argc, Scheme_Object **argv)
{
Scheme_Object *src;
char *s;
intptr_t len, line, col, pos;
if (!scheme_is_location(argv[0]))
scheme_wrong_contract("srcloc->string", "srcloc?", 0, argc, argv);
src = scheme_struct_ref(argv[0], 0);
if (SCHEME_FALSEP(src)) src = NULL;
line = struct_number_ref(argv[0], 1);
col = struct_number_ref(argv[0], 2);
pos = struct_number_ref(argv[0], 3);
s = make_srcloc_string(src, line, col, pos, &len);
if (s)
return scheme_make_sized_utf8_string(s, len);
else
return scheme_false;
}
void scheme_read_err(Scheme_Object *port,
Scheme_Object *stxsrc,
intptr_t line, intptr_t col, intptr_t pos, intptr_t span,
@ -2100,7 +2139,7 @@ void scheme_read_err(Scheme_Object *port,
pos = ((Scheme_Stx *)xsrc)->srcloc->pos;
if (show_loc)
fn = make_srcloc_string(((Scheme_Stx *)xsrc)->srcloc, &fnlen);
fn = make_stx_srcloc_string(((Scheme_Stx *)xsrc)->srcloc, &fnlen);
else
fn = NULL;
} else
@ -2212,7 +2251,7 @@ static void do_wrong_syntax(const char *where,
if (form) {
Scheme_Object *pform;
if (SCHEME_STXP(form)) {
p = make_srcloc_string(((Scheme_Stx *)form)->srcloc, &plen);
p = make_stx_srcloc_string(((Scheme_Stx *)form)->srcloc, &plen);
pform = scheme_syntax_to_datum(form, 0, NULL);
/* Try to extract syntax name from syntax */
@ -2256,7 +2295,7 @@ static void do_wrong_syntax(const char *where,
Scheme_Object *pform;
if (SCHEME_STXP(detail_form)) {
if (((Scheme_Stx *)detail_form)->srcloc->line >= 0)
p = make_srcloc_string(((Scheme_Stx *)detail_form)->srcloc, &plen);
p = make_stx_srcloc_string(((Scheme_Stx *)detail_form)->srcloc, &plen);
pform = scheme_syntax_to_datum(detail_form, 0, NULL);
/* To go in exn record: */
form = detail_form;

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

@ -210,6 +210,7 @@ static Scheme_Object *find_system_path(int argc, Scheme_Object **argv);
#ifdef DIR_FUNCTION
static Scheme_Object *current_directory(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_user_directory(int argc, Scheme_Object *argv[]);
#endif
static int has_null(const char *s, intptr_t l);
@ -541,6 +542,11 @@ void scheme_init_file(Scheme_Env *env)
"current-directory",
MZCONFIG_CURRENT_DIRECTORY),
env);
scheme_add_global_constant("current-directory-for-user",
scheme_register_parameter(current_user_directory,
"current-directory-for-user",
MZCONFIG_CURRENT_USER_DIRECTORY),
env);
#endif
#ifndef NO_FILE_SYSTEM_UTILS
@ -1258,7 +1264,7 @@ Scheme_Object *scheme_remove_current_directory_prefix(Scheme_Object *fn)
Scheme_Object *cwd;
intptr_t len;
cwd = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_DIRECTORY);
cwd = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_USER_DIRECTORY);
fn = TO_PATH(fn);
@ -5911,6 +5917,18 @@ static Scheme_Object *current_directory(int argc, Scheme_Object **argv)
"path-string?", 1);
}
static Scheme_Object *current_user_directory(int argc, Scheme_Object **argv)
{
if (!argc)
scheme_security_check_file("current-directory-for-user", NULL, SCHEME_GUARD_FILE_EXISTS);
return scheme_param_config2("current-directory-for-user",
scheme_make_integer(MZCONFIG_CURRENT_USER_DIRECTORY),
argc, argv,
-1, cwd_check,
"path-string?", 1);
}
#endif
static Scheme_Object *collpaths_gen_p(int argc, Scheme_Object **argv, int rel_ok, int abs_ok, int sym_ok)

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

@ -4521,15 +4521,20 @@ static void filename_exn(char *name, char *msg, char *filename, int err, int may
mod_path = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_LOAD_PATH);
if (SCHEME_TRUEP(mod_path)) {
if (SCHEME_STXP(mod_path)) {
char *srcloc;
intptr_t srcloc_len;
mp = scheme_syntax_to_datum(mod_path, 0, NULL);
srcloc = scheme_make_srcloc_string(mod_path, &srcloc_len);
scheme_raise_exn(MZEXN_FAIL_SYNTAX_MISSING_MODULE,
scheme_make_pair(mod_path, scheme_null),
mp,
"%s: %s\n"
"%t%s: %s\n"
" module path: %W\n"
" path: %q%s%q%s\n"
" system error: " FILENAME_EXN_E,
name, "cannot open module file",
srcloc, srcloc_len,
srcloc_len ? "" : name,
"cannot open module file",
mp, filename,
pre, rel, post,
err);

2
src/racket/src/ratfloat.inc
View File

@ -194,4 +194,4 @@ Scheme_Object *SCHEME_RATIONAL_FROM_FLOAT(FP_TYPE d)
#undef FP_TYPE_FROM_INT
#undef FP_LDEXP
#undef FP_EQV
#undef FP_IS_ZERO
#undef FP_IS_ZERO

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

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

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

@ -3571,6 +3571,8 @@ void scheme_non_fixnum_result(const char *name, Scheme_Object *o);
void scheme_raise_out_of_memory(const char *where, const char *msg, ...);
char *scheme_make_srcloc_string(Scheme_Object *stx, intptr_t *len);
uintptr_t scheme_get_max_symbol_length();
char *scheme_make_arity_expect_string(const char *map_name,

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

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

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

@ -893,6 +893,12 @@
"(values null(car l))"
"(let-values(((c f)(loop(cdr l))))"
"(values(cons(car l) c) f)))))))"
"(define(format-source-location stx)"
"(srcloc->string(srcloc(syntax-source stx)"
"(syntax-line stx)"
"(syntax-column stx)"
"(syntax-position stx)"
"(syntax-span stx))))"
"(define-values(orig-paramz) #f)"
"(define-values(standard-module-name-resolver)"
"(let-values()"
@ -1022,7 +1028,11 @@
"(current-directory))))"
"(show-collection-err(lambda(msg)"
"(let((msg(string-append"
" \"standard-module-name-resolver: \" "
"(or(and stx"
"(error-print-source-location)"
"(format-source-location stx))"
" \"standard-module-name-resolver\")"
" \": \""
" (regexp-replace #rx\"\\n\" "
" msg"
" (format \"\\n for module path: ~s\\n\""

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

@ -1021,6 +1021,13 @@
(let-values ([(c f) (loop (cdr l))])
(values (cons (car l) c) f)))))))
(define (format-source-location stx)
(srcloc->string (srcloc (syntax-source stx)
(syntax-line stx)
(syntax-column stx)
(syntax-position stx)
(syntax-span stx))))
(define-values (orig-paramz) #f)
(define-values (standard-module-name-resolver)
@ -1155,7 +1162,11 @@
(current-directory)))]
[show-collection-err (lambda (msg)
(let ([msg (string-append
"standard-module-name-resolver: "
(or (and stx
(error-print-source-location)
(format-source-location stx))
"standard-module-name-resolver")
": "
(regexp-replace #rx"\n"
msg
(format "\n for module path: ~s\n"

1
src/racket/src/thread.c
View File

@ -7457,6 +7457,7 @@ static void make_initial_config(Scheme_Thread *p)
}
}
#endif
init_param(cells, paramz, MZCONFIG_CURRENT_USER_DIRECTORY, s);
scheme_set_original_dir(s);
}