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

300.3

Browse Source 
svn: r1698
This commit is contained in:
Matthew Flatt 2005-12-27 17:49:13 +00:00
parent 678477648b
commit c38876b848
14 changed files with 4644 additions and 4455 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/mzlib/cm.ss
View File

@ -138,7 +138,12 @@
(lambda (out)
(with-handlers ((exn:fail?
(lambda (ex) (compilation-failure mode path zo-name #f (exn-message ex)))))
(write code out))
(parameterize ([current-write-relative-directory
(let-values ([(base name dir?) (split-path path)])
(if (eq? base 'relative)
(current-directory)
(path->complete-path base (current-directory))))])
(write code out)))
;; redundant, but close as early as possible:
(close-output-port out)
;; Note that we check time and write .deps before returning from with-compile-output...

39
collects/mzlib/compile.ss
View File

@ -33,25 +33,26 @@
(raise exn))])
(let ([out (open-output-file dest 'truncate/replace)]
[ok? #f])
(parameterize ([current-load-relative-directory
(let-values ([(base name dir?) (split-path src)])
(if (eq? base 'relative)
(current-directory)
(path->complete-path base (current-directory))))])
(dynamic-wind
void
(lambda ()
(let loop ()
(let ([r (read-syntax src in)])
(unless (eof-object? r)
(write (compile-syntax (filter (namespace-syntax-introduce r))) out)
(loop))))
(set! ok? #t))
(lambda ()
(close-output-port out)
(unless ok?
(with-handlers ([void void])
(delete-file dest)))))))))
(let ([dir (let-values ([(base name dir?) (split-path src)])
(if (eq? base 'relative)
(current-directory)
(path->complete-path base (current-directory))))])
(parameterize ([current-load-relative-directory dir]
[current-write-relative-directory dir])
(dynamic-wind
void
(lambda ()
(let loop ()
(let ([r (read-syntax src in)])
(unless (eof-object? r)
(write (compile-syntax (filter (namespace-syntax-introduce r))) out)
(loop))))
(set! ok? #t))
(lambda ()
(close-output-port out)
(unless ok?
(with-handlers ([void void])
(delete-file dest))))))))))
(lambda () (close-input-port in))))
dest])))

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

@ -1075,6 +1075,7 @@ enum {
MZCONFIG_USE_COMPILED_KIND,
MZCONFIG_LOAD_DIRECTORY,
MZCONFIG_WRITE_DIRECTORY,
MZCONFIG_COLLECTION_PATHS,

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

File diff suppressed because it is too large Load Diff

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

@ -1947,6 +1947,7 @@ def_error_display_proc(int argc, Scheme_Object *argv[])
max_cnt = 0x7FFFFFFF;
if (max_cnt) {
int orig_max_cnt = max_cnt;
w = scheme_get_param(config, MZCONFIG_ERROR_PRINT_WIDTH);
if (SCHEME_INTP(w))
print_width = SCHEME_INT_VAL(w);
@ -1955,16 +1956,53 @@ def_error_display_proc(int argc, Scheme_Object *argv[])
l = scheme_get_stack_trace(((Scheme_Structure *)argv[1])->slots[1]);
while (!SCHEME_NULLP(l)) {
if (!max_cnt) {
scheme_write_byte_string(" at ...\n", 9, port);
scheme_write_byte_string("...\n", 4, port);
break;
} else {
scheme_write_byte_string(" at ", 5, port);
scheme_display_w_max(SCHEME_CAR(l), port, print_width);
Scheme_Object *name, *loc;
if (max_cnt == orig_max_cnt) {
/* Starting label: */
scheme_write_byte_string("\n === context ===\n", 18, port);
}
name = SCHEME_CAR(l);
loc = SCHEME_CDR(name);
name = SCHEME_CAR(name);
if (SCHEME_TRUEP(loc)) {
Scheme_Structure *sloc = (Scheme_Structure *)loc;
scheme_display_w_max(sloc->slots[0], port, print_width);
if (SCHEME_TRUEP(sloc->slots[1])) {
/* Line + column */
scheme_write_byte_string(":", 1, port);
scheme_display_w_max(sloc->slots[1], port, print_width);
scheme_write_byte_string(":", 1, port);
scheme_display_w_max(sloc->slots[2], port, print_width);
} else {
/* Position */
scheme_write_byte_string("::", 2, port);
scheme_display_w_max(sloc->slots[3], port, print_width);
}
if (SCHEME_TRUEP(name)) {
scheme_write_byte_string(": ", 2, port);
}
}
if (SCHEME_TRUEP(name)) {
scheme_display_w_max(name, port, print_width);
}
scheme_write_byte_string("\n", 1, port);
l = SCHEME_CDR(l);
--max_cnt;
}
}
if (max_cnt != orig_max_cnt) {
/* Extra ending newline */
scheme_write_byte_string("\n", 1, port);
}
}
}

54
src/mzscheme/src/file.c
View File

@ -3758,6 +3758,60 @@ char *scheme_find_completion(char *fn)
return SCHEME_PATH_VAL(f);
}
static Scheme_Object *explode_path(Scheme_Object *p)
{
Scheme_Object *l = scheme_null, *base, *name;
int isdir;
while (1) {
name = scheme_split_path(SCHEME_PATH_VAL(p), SCHEME_PATH_LEN(p), &base, &isdir);
l = scheme_make_pair(name, l);
if (!SCHEME_PATHP(base)) {
l = scheme_make_pair(base, l);
return l;
}
p = base;
}
}
Scheme_Object *scheme_extract_relative_to(Scheme_Object *obj, Scheme_Object *dir)
{
Scheme_Object *de, *oe;
de = explode_path(dir);
oe = explode_path(obj);
while (SCHEME_PAIRP(de)
&& SCHEME_PAIRP(oe)) {
if (!scheme_equal(SCHEME_CAR(de), SCHEME_CAR(oe)))
return obj;
de = SCHEME_CDR(de);
oe = SCHEME_CDR(oe);
}
if (SCHEME_NULLP(de)) {
Scheme_Object *a[2];
if (SCHEME_NULLP(oe)) {
a[0] = same_symbol;
obj = scheme_build_path(1, a);
} else {
obj = SCHEME_CAR(oe);
oe = SCHEME_CDR(oe);
}
while (SCHEME_PAIRP(oe)) {
a[0] = obj;
a[1] = SCHEME_CAR(oe);
obj = scheme_build_path(2, a);
oe = SCHEME_CDR(oe);
}
}
return obj;
}
static Scheme_Object *filesystem_root_list(int argc, Scheme_Object *argv[])
{
Scheme_Object *first = scheme_null;

98
src/mzscheme/src/fun.c
View File

@ -765,6 +765,39 @@ Scheme_Object *scheme_source_to_name(Scheme_Object *code)
return NULL;
}
Scheme_Object *combine_name_with_srcloc(Scheme_Object *name, Scheme_Object *code, int src_based_name)
{
Scheme_Stx *cstx = (Scheme_Stx *)code;
if (((cstx->srcloc->col >= 0) || (cstx->srcloc->pos >= 0))
&& cstx->srcloc->src) {
Scheme_Object *vec;
vec = scheme_make_vector(7, NULL);
SCHEME_VEC_ELS(vec)[0] = name;
SCHEME_VEC_ELS(vec)[1] = cstx->srcloc->src;
if (cstx->srcloc->line >= 0) {
SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(cstx->srcloc->line);
SCHEME_VEC_ELS(vec)[3] = scheme_make_integer(cstx->srcloc->col-1);
} else {
SCHEME_VEC_ELS(vec)[2] = scheme_false;
SCHEME_VEC_ELS(vec)[3] = scheme_false;
}
if (cstx->srcloc->pos >= 0)
SCHEME_VEC_ELS(vec)[4] = scheme_make_integer(cstx->srcloc->pos);
else
SCHEME_VEC_ELS(vec)[4] = scheme_false;
if (cstx->srcloc->span >= 0)
SCHEME_VEC_ELS(vec)[5] = scheme_make_integer(cstx->srcloc->span);
else
SCHEME_VEC_ELS(vec)[5] = scheme_false;
SCHEME_VEC_ELS(vec)[6] = (src_based_name ? scheme_true : scheme_false);
return vec;
}
return name;
}
Scheme_Object *
scheme_make_closure_compilation(Scheme_Comp_Env *env, Scheme_Object *code,
Scheme_Compile_Info *rec, int drec)
@ -823,13 +856,18 @@ scheme_make_closure_compilation(Scheme_Comp_Env *env, Scheme_Object *code,
name = scheme_stx_property(code, scheme_inferred_name_symbol, NULL);
if (name && SCHEME_SYMBOLP(name)) {
name = combine_name_with_srcloc(name, code, 0);
data->name = name;
} else {
data->name = rec[drec].value_name;
if (!data->name || SCHEME_FALSEP(data->name)) {
name = rec[drec].value_name;
if (!name || SCHEME_FALSEP(name)) {
name = scheme_source_to_name(code);
data->name= name;
if (name)
name = combine_name_with_srcloc(name, code, 1);
} else {
name = combine_name_with_srcloc(name, code, 0);
}
data->name = name;
}
scheme_compile_rec_done_local(rec, drec);
@ -1891,12 +1929,16 @@ const char *scheme_get_proc_name(Scheme_Object *p, int *len, int for_error)
data = SCHEME_COMPILED_CLOS_CODE(p);
if (data->name) {
Scheme_Object *name;
name = data->name;
if (SCHEME_VECTORP(name))
name = SCHEME_VEC_ELS(name)[0];
if (for_error < 0) {
s = (char *)data->name;
s = (char *)name;
*len = -1;
} else {
*len = SCHEME_SYM_LEN(data->name);
s = scheme_symbol_val(data->name);
*len = SCHEME_SYM_LEN(name);
s = scheme_symbol_val(name);
}
} else
return NULL;
@ -3148,7 +3190,7 @@ extract_cc_markses(int argc, Scheme_Object *argv[])
Scheme_Object *
scheme_get_stack_trace(Scheme_Object *mark_set)
{
Scheme_Object *l, *n, *m;
Scheme_Object *l, *n, *m, *name, *loc;
Scheme_Object *a[2];
a[0] = mark_set;
@ -3163,7 +3205,7 @@ scheme_get_stack_trace(Scheme_Object *mark_set)
for (n = l; SCHEME_PAIRP(n); ) {
m = SCHEME_CDR(n);
if (SCHEME_NULLP(m))
break;
break;
if (SCHEME_CAR(m)) {
n = m;
} else {
@ -3171,6 +3213,25 @@ scheme_get_stack_trace(Scheme_Object *mark_set)
}
}
/* Make srclocs */
for (n = l; SCHEME_PAIRP(n); n = SCHEME_CDR(n)) {
name = SCHEME_CAR(n);
if (SCHEME_VECTORP(name)) {
loc = scheme_make_location(SCHEME_VEC_ELS(name)[1],
SCHEME_VEC_ELS(name)[2],
SCHEME_VEC_ELS(name)[3],
SCHEME_VEC_ELS(name)[4],
SCHEME_VEC_ELS(name)[5]);
if (SCHEME_TRUEP(SCHEME_VEC_ELS(name)[6]))
name = scheme_make_pair(scheme_false, loc);
else
name = scheme_make_pair(SCHEME_VEC_ELS(name)[0], loc);
} else {
name = scheme_make_pair(name, scheme_false);
}
SCHEME_CAR(n) = name;
}
return l;
}
@ -4034,13 +4095,32 @@ scheme_default_prompt_read_handler(int argc, Scheme_Object *argv[])
static Scheme_Object *write_compiled_closure(Scheme_Object *obj)
{
Scheme_Closure_Data *data;
Scheme_Object *name;
data = (Scheme_Closure_Data *)obj;
if (data->name) {
name = data->name;
if (SCHEME_VECTORP(name)) {
/* We can only save marshalable src names, which includes
paths, symbols, and strings: */
Scheme_Object *src;
src = SCHEME_VEC_ELS(name)[1];
if (!SCHEME_PATHP(src)
&& !SCHEME_PATHP(src)
&& !SCHEME_SYMBOLP(src)) {
/* Just keep the name */
name = SCHEME_VEC_ELS(name)[0];
}
}
} else {
name = scheme_null;
}
return CONS(scheme_make_integer(SCHEME_CLOSURE_DATA_FLAGS(data)),
CONS(scheme_make_integer(data->num_params),
CONS(scheme_make_integer(data->max_let_depth),
CONS(data->name ? data->name : scheme_null,
CONS(name,
CONS(scheme_make_svector(data->closure_size,
data->closure_map),
scheme_protect_quote(data->code))))));

34
src/mzscheme/src/portfun.c
View File

@ -99,6 +99,7 @@ static Scheme_Object *write_byte (int, Scheme_Object *[]);
static Scheme_Object *load (int, Scheme_Object *[]);
static Scheme_Object *current_load (int, Scheme_Object *[]);
static Scheme_Object *current_load_directory(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_write_directory(int argc, Scheme_Object *argv[]);
static Scheme_Object *default_load (int, Scheme_Object *[]);
static Scheme_Object *transcript_on(int, Scheme_Object *[]);
static Scheme_Object *transcript_off(int, Scheme_Object *[]);
@ -650,6 +651,11 @@ scheme_init_port_fun(Scheme_Env *env)
"current-load-relative-directory",
MZCONFIG_LOAD_DIRECTORY),
env);
scheme_add_global_constant("current-write-relative-directory",
scheme_register_parameter(current_write_directory,
"current-write-relative-directory",
MZCONFIG_WRITE_DIRECTORY),
env);
scheme_add_global_constant ("transcript-on",
scheme_make_prim_w_arity(transcript_on,
@ -4348,7 +4354,7 @@ current_load(int argc, Scheme_Object *argv[])
2, NULL, NULL, 0);
}
static Scheme_Object *abs_directory_p(int argc, Scheme_Object **argv)
static Scheme_Object *abs_directory_p(const char *name, int argc, Scheme_Object **argv)
{
Scheme_Object *d = argv[0];
@ -4367,10 +4373,11 @@ static Scheme_Object *abs_directory_p(int argc, Scheme_Object **argv)
if (!scheme_is_complete_path(s, len))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"current-load-relative-directory: not a complete path: \"%q\"",
"%s: not a complete path: \"%q\"",
name,
s);
expanded = scheme_expand_string_filename(d, "current-load-relative-directory", NULL,
expanded = scheme_expand_string_filename(d, name, NULL,
SCHEME_GUARD_FILE_EXISTS);
ed = scheme_make_sized_path(expanded, strlen(expanded), 1);
@ -4380,13 +4387,32 @@ static Scheme_Object *abs_directory_p(int argc, Scheme_Object **argv)
return scheme_false;
}
static Scheme_Object *lr_abs_directory_p(int argc, Scheme_Object **argv)
{
return abs_directory_p("current-load-relative-directory", argc, argv);
}
static Scheme_Object *
current_load_directory(int argc, Scheme_Object *argv[])
{
return scheme_param_config("current-load-relative-directory",
scheme_make_integer(MZCONFIG_LOAD_DIRECTORY),
argc, argv,
-1, abs_directory_p, "path, string, or #f", 1);
-1, lr_abs_directory_p, "path, string, or #f", 1);
}
static Scheme_Object *wr_abs_directory_p(int argc, Scheme_Object **argv)
{
return abs_directory_p("current-write-relative-directory", argc, argv);
}
static Scheme_Object *
current_write_directory(int argc, Scheme_Object *argv[])
{
return scheme_param_config("current-write-relative-directory",
scheme_make_integer(MZCONFIG_WRITE_DIRECTORY),
argc, argv,
-1, wr_abs_directory_p, "path, string, or #f", 1);
}
Scheme_Object *scheme_load(const char *file)

34
src/mzscheme/src/print.c
View File

@ -1588,7 +1588,39 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
}
else if (SCHEME_PATHP(obj))
{
if (compact || !pp->print_unreadable) {
if (compact) {
/* Needed for srclocs in procedure names */
Scheme_Object *idx;
int l;
idx = scheme_hash_get(symtab, obj);
if (idx) {
print_compact(pp, CPT_SYMREF);
l = SCHEME_INT_VAL(idx);
print_compact_number(pp, l);
} else {
Scheme_Object *dir;
/* Hash before making relative */
idx = scheme_make_integer(symtab->count);
scheme_hash_set(symtab, obj, idx);
dir = scheme_get_param(scheme_current_config(),
MZCONFIG_WRITE_DIRECTORY);
if (SCHEME_PATHP(dir)) {
obj = scheme_extract_relative_to(obj, dir);
}
print_compact(pp, CPT_PATH);
l = SCHEME_PATH_LEN(obj);
print_compact_number(pp, l);
print_this_string(pp, SCHEME_PATH_VAL(obj), 0, l);
l = SCHEME_INT_VAL(idx);
print_compact_number(pp, l);
}
} else if (!pp->print_unreadable) {
cannot_print(pp, notdisplay, obj, ht, compact);
} else {
if (notdisplay)

23
src/mzscheme/src/read.c
View File

@ -4136,6 +4136,29 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
port->symtab[l] = v;
}
break;
case CPT_PATH:
{
l = read_compact_number(port);
RANGE_CHECK_GETS(l);
s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
v = scheme_make_sized_path(s, l, l < BLK_BUF_SIZE);
l = read_compact_number(port); /* symtab index */
if (scheme_is_relative_path(SCHEME_PATH_VAL(v), SCHEME_PATH_LEN(v))) {
/* Resolve relative path using the current load-relative directory: */
Scheme_Object *dir;
dir = scheme_get_param(scheme_current_config(), MZCONFIG_LOAD_DIRECTORY);
if (SCHEME_PATHP(dir)) {
Scheme_Object *a[2];
a[0] = dir;
a[1] = v;
v = scheme_build_path(2, a);
}
}
port->symtab[l] = v;
}
break;
case CPT_SMALL_LOCAL_START:
case CPT_SMALL_LOCAL_UNBOX_START:
{

46
src/mzscheme/src/schcpt.h
View File

@ -1,6 +1,6 @@
enum {
CPT_ESCAPE,
CPT_ESCAPE, /* 0 */
CPT_SYMBOL,
CPT_SYMREF,
CPT_WEIRD_SYMBOL,
@ -10,7 +10,7 @@ enum {
CPT_CHAR,
CPT_INT,
CPT_NULL,
CPT_TRUE,
CPT_TRUE, /* 10 */
CPT_FALSE,
CPT_VOID,
CPT_BOX,
@ -20,7 +20,7 @@ enum {
CPT_HASH_TABLE,
CPT_STX,
CPT_GSTX,
CPT_MARSHALLED,
CPT_MARSHALLED, /* 20 */
CPT_QUOTE,
CPT_REFERENCE,
CPT_LOCAL,
@ -30,40 +30,40 @@ enum {
CPT_LET_ONE,
CPT_BRANCH,
CPT_MODULE_INDEX,
CPT_MODULE_VAR,
CPT_MODULE_VAR, /* 30 */
CPT_PATH,
_CPT_COUNT_
};
#define CPT_SMALL_NUMBER_START 31
#define CPT_SMALL_NUMBER_END 45
#define CPT_SMALL_NUMBER_START 32
#define CPT_SMALL_NUMBER_END 60
#define CPT_SMALL_SYMBOL_START 45
#define CPT_SMALL_SYMBOL_END 65
#define CPT_SMALL_SYMBOL_START 60
#define CPT_SMALL_SYMBOL_END 80
#define CPT_SMALL_MARSHALLED_START 65
#define CPT_SMALL_MARSHALLED_END 77
#define CPT_SMALL_MARSHALLED_START 80
#define CPT_SMALL_MARSHALLED_END 92
#define _SMALL_LIST_MAX_ 50
#define _SMALL_LIST_MAX_ 65
#define CPT_SMALL_PROPER_LIST_START 77
#define CPT_SMALL_PROPER_LIST_START 92
#define CPT_SMALL_PROPER_LIST_END (CPT_SMALL_PROPER_LIST_START + _SMALL_LIST_MAX_)
#define CPT_SMALL_LIST_START CPT_SMALL_PROPER_LIST_END
#define CPT_SMALL_LIST_END (CPT_SMALL_LIST_START + _SMALL_LIST_MAX_)
#define CPT_SMALL_LOCAL_START 177
#define CPT_SMALL_LOCAL_END 192
#define CPT_SMALL_LOCAL_UNBOX_START 192
#define CPT_SMALL_LOCAL_UNBOX_END 207
#define CPT_SMALL_LOCAL_START 192
#define CPT_SMALL_LOCAL_END 207
#define CPT_SMALL_LOCAL_UNBOX_START 207
#define CPT_SMALL_LOCAL_UNBOX_END 222
#define CPT_SMALL_SVECTOR_START 207
#define CPT_SMALL_SVECTOR_END 232
#define CPT_SMALL_SVECTOR_START 222
#define CPT_SMALL_SVECTOR_END 247
#define CPT_SMALL_APPLICATION_START 232
#define CPT_SMALL_APPLICATION_END 240
#define CPT_SMALL_APPLICATION2 233
#define CPT_SMALL_APPLICATION3 234
#define CPT_SMALL_APPLICATION_START 247
#define CPT_SMALL_APPLICATION_END 255
#define CPT_SMALL_APPLICATION2 248
#define CPT_SMALL_APPLICATION3 249
#define CPT_BETWEEN(x, s) ((x >= CPT_ ## s ## _START) && (x < CPT_ ## s ## _END))
#define CPT_RANGE(s) (CPT_ ## s ## _END - CPT_ ## s ## _START)

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

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 851
#define EXPECTED_PRIM_COUNT 852
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

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

@ -2114,6 +2114,8 @@ char *scheme_get_exec_path(void);
Scheme_Object *scheme_get_fd_identity(Scheme_Object *port, long fd);
Scheme_Object *scheme_extract_relative_to(Scheme_Object *obj, Scheme_Object *dir);
#ifdef DOS_FILE_SYSTEM
# define WIDE_PATH(s) scheme_convert_to_wchar(s, 0)
# define WIDE_PATH_COPY(s) scheme_convert_to_wchar(s, 1)

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 300
#define MZSCHEME_VERSION_MINOR 2
#define MZSCHEME_VERSION_MINOR 3
#define MZSCHEME_VERSION "300.2" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "300.3" _MZ_SPECIAL_TAG