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

v300.2

Browse Source 
svn: r1682
This commit is contained in:
Matthew Flatt 2005-12-24 22:44:59 +00:00
parent fda6fa36ae
commit d32cebfadf
18 changed files with 2952 additions and 2624 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1062,6 +1062,7 @@ enum {
MZCONFIG_HONU_MODE,
MZCONFIG_ERROR_PRINT_WIDTH,
MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH,
MZCONFIG_ERROR_ESCAPE_HANDLER,

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

File diff suppressed because it is too large Load Diff

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

@ -42,6 +42,7 @@ long scheme_misc_count;
/* locals */
static Scheme_Object *error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_user_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_syntax_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_type_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_mismatch_error(int argc, Scheme_Object *argv[]);
@ -50,6 +51,7 @@ static Scheme_Object *error_display_handler(int, Scheme_Object *[]);
static Scheme_Object *error_value_string_handler(int, Scheme_Object *[]);
static Scheme_Object *exit_handler(int, Scheme_Object *[]);
static Scheme_Object *error_print_width(int, Scheme_Object *[]);
static Scheme_Object *error_print_context_length(int, Scheme_Object *[]);
static Scheme_Object *error_print_srcloc(int, Scheme_Object *[]);
static Scheme_Object *def_error_escape_proc(int, Scheme_Object *[]);
static Scheme_Object *def_error_display_proc(int, Scheme_Object *[]);
@ -471,6 +473,11 @@ void scheme_init_error(Scheme_Env *env)
"error",
1, -1),
env);
scheme_add_global_constant("raise-user-error",
scheme_make_prim_w_arity(raise_user_error,
"raise-user-error",
1, -1),
env);
scheme_add_global_constant("raise-syntax-error",
scheme_make_prim_w_arity(raise_syntax_error,
"raise-syntax-error",
@ -511,6 +518,11 @@ void scheme_init_error(Scheme_Env *env)
"error-print-width",
MZCONFIG_ERROR_PRINT_WIDTH),
env);
scheme_add_global_constant("error-print-context-length",
scheme_register_parameter(error_print_context_length,
"error-print-context-length",
MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH),
env);
scheme_add_global_constant("error-print-source-location",
scheme_register_parameter(error_print_srcloc,
"error-print-source-location",
@ -665,6 +677,8 @@ static long get_print_width(void)
w = scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_WIDTH);
if (SCHEME_INTP(w))
print_width = SCHEME_INT_VAL(w);
else if (SCHEME_BIGNUMP(w))
print_width = 0x7FFFFFFF;
else
print_width = 10000;
@ -1669,7 +1683,7 @@ char *scheme_make_provided_string(Scheme_Object *o, int count, int *lenout)
return error_write_to_string_w_max(o, len, lenout);
}
static Scheme_Object *error(int argc, Scheme_Object *argv[])
static Scheme_Object *do_error(int for_user, int argc, Scheme_Object *argv[])
{
Scheme_Object *newargs[2];
@ -1732,7 +1746,7 @@ static Scheme_Object *error(int argc, Scheme_Object *argv[])
#ifndef NO_SCHEME_EXNS
newargs[1] = TMP_CMARK_VALUE;
do_raise(scheme_make_struct_instance(exn_table[MZEXN_FAIL].type,
do_raise(scheme_make_struct_instance(exn_table[for_user ? MZEXN_FAIL_USER : MZEXN_FAIL].type,
2, newargs),
0, 1);
@ -1745,6 +1759,16 @@ static Scheme_Object *error(int argc, Scheme_Object *argv[])
#endif
}
static Scheme_Object *error(int argc, Scheme_Object *argv[])
{
return do_error(0, argc, argv);
}
static Scheme_Object *raise_user_error(int argc, Scheme_Object *argv[])
{
return do_error(1, argc, argv);
}
static Scheme_Object *raise_syntax_error(int argc, Scheme_Object *argv[])
{
const char *who;
@ -1841,9 +1865,15 @@ static Scheme_Object *raise_mismatch_error(int argc, Scheme_Object *argv[])
static Scheme_Object *good_print_width(int c, Scheme_Object **argv)
{
return ((SCHEME_INTP(argv[0]) || (SCHEME_BIGNUMP(argv[0])))
? scheme_true
: scheme_false);
int ok;
ok = (SCHEME_INTP(argv[0])
? (SCHEME_INT_VAL(argv[0]) > 3)
: (SCHEME_BIGNUMP(argv[0])
? SCHEME_BIGPOS(argv[0])
: 0));
return ok ? scheme_true : scheme_false;
}
static Scheme_Object *error_print_width(int argc, Scheme_Object *argv[])
@ -1854,6 +1884,27 @@ static Scheme_Object *error_print_width(int argc, Scheme_Object *argv[])
-1, good_print_width, "integer greater than three", 0);
}
static Scheme_Object *good_print_context_length(int c, Scheme_Object **argv)
{
int ok;
ok = (SCHEME_INTP(argv[0])
? (SCHEME_INT_VAL(argv[0]) >= 0)
: (SCHEME_BIGNUMP(argv[0])
? SCHEME_BIGPOS(argv[0])
: 0));
return ok ? scheme_true : scheme_false;
}
static Scheme_Object *error_print_context_length(int argc, Scheme_Object *argv[])
{
return scheme_param_config("error-print-context-length",
scheme_make_integer(MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH),
argc, argv,
-1, good_print_context_length, "non-negative integer", 0);
}
static Scheme_Object *error_print_srcloc(int argc, Scheme_Object *argv[])
{
return scheme_param_config("error-print-source-location",
@ -1882,6 +1933,41 @@ def_error_display_proc(int argc, Scheme_Object *argv[])
port);
scheme_write_byte_string("\n", 1, port);
/* Print context, if available */
if (SCHEME_STRUCTP(argv[1])
&& scheme_is_struct_instance(exn_table[MZEXN].type, argv[1])
&& !scheme_is_struct_instance(exn_table[MZEXN_FAIL_USER].type, argv[1])) {
Scheme_Object *l, *w;
int print_width = 1024, max_cnt = 16;
w = scheme_get_param(config, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH);
if (SCHEME_INTP(w))
max_cnt = SCHEME_INT_VAL(w);
else
max_cnt = 0x7FFFFFFF;
if (max_cnt) {
w = scheme_get_param(config, MZCONFIG_ERROR_PRINT_WIDTH);
if (SCHEME_INTP(w))
print_width = SCHEME_INT_VAL(w);
else
print_width = 0x7FFFFFFF;
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);
break;
} else {
scheme_write_byte_string(" at ", 5, port);
scheme_display_w_max(SCHEME_CAR(l), port, print_width);
scheme_write_byte_string("\n", 1, port);
l = SCHEME_CDR(l);
--max_cnt;
}
}
}
}
return scheme_void;
}

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

@ -141,6 +141,8 @@ static Scheme_Object *quick_stx;
static int quick_stx_in_use;
static int taking_shortcut;
Scheme_Object *scheme_stack_dump_key;
/* locals */
static Scheme_Object *eval(int argc, Scheme_Object *argv[]);
static Scheme_Object *compile(int argc, Scheme_Object *argv[]);
@ -297,6 +299,9 @@ scheme_init_eval (Scheme_Env *env)
REGISTER_SO(protected_symbol);
protected_symbol = scheme_intern_symbol("protected");
REGISTER_SO(scheme_stack_dump_key);
scheme_stack_dump_key = scheme_make_symbol("stk"); /* uninterned! */
scheme_install_type_writer(scheme_application_type, write_application);
scheme_install_type_reader(scheme_application_type, read_application);
scheme_install_type_writer(scheme_application2_type, write_application);
@ -3115,7 +3120,7 @@ void scheme_pop_continuation_frame(Scheme_Cont_Frame_Data *d)
MZ_CONT_MARK_STACK = d->cont_mark_stack;
}
void scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val)
void *scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Cont_Mark *cm = NULL;
@ -3137,7 +3142,7 @@ void scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val)
/* Assume that we'll mutate rather than allocate a new mark record. */
/* This is a bad assumption for a nasty program that repeatedly
creates a new key for the same frame, but it's good enough. */
find->cached_chain = NULL;
find->cache = NULL;
}
}
}
@ -3173,7 +3178,9 @@ void scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val)
cm->key = key;
cm->val = val;
cm->pos = MZ_CONT_MARK_POS; /* always odd */
cm->cached_chain = NULL;
cm->cache = NULL;
return cm;
}
void scheme_temp_dec_mark_depth()
@ -3343,6 +3350,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
#if USE_LOCAL_RUNSTACK
GC_MAYBE_IGNORE_INTERIOR Scheme_Object **runstack;
#endif
GC_MAYBE_IGNORE_INTERIOR Scheme_Cont_Mark *pm = NULL;
# define p scheme_current_thread
#ifdef DO_STACK_CHECK
@ -3394,6 +3402,8 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
#define UPDATE_THREAD_RSPTR_FOR_GC() UPDATE_THREAD_RSPTR()
#define UPDATE_THREAD_RSPTR_FOR_ERROR() UPDATE_THREAD_RSPTR()
#define UPDATE_THREAD_RSPTR_FOR_PROC_MARK() UPDATE_THREAD_RSPTR()
MZ_CONT_MARK_POS += 2;
old_runstack = RUNSTACK;
old_cont_mark_stack = MZ_CONT_MARK_STACK;
@ -3612,6 +3622,35 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
obj = data->code;
if (pm) {
if (!pm->cache)
pm->val = data->name;
else {
/* Need to clear caches and/or update pm, so do it the slow way */
UPDATE_THREAD_RSPTR_FOR_PROC_MARK();
pm = (Scheme_Cont_Mark *)scheme_set_cont_mark(scheme_stack_dump_key, data->name);
}
} else {
/* Allocate a new mark record: */
long segpos = ((long)MZ_CONT_MARK_STACK) >> SCHEME_LOG_MARK_SEGMENT_SIZE;
if (segpos >= p->cont_mark_seg_count) {
UPDATE_THREAD_RSPTR_FOR_PROC_MARK();
pm = (Scheme_Cont_Mark *)scheme_set_cont_mark(scheme_stack_dump_key, data->name);
} else {
long pos = ((long)MZ_CONT_MARK_STACK) & SCHEME_MARK_SEGMENT_MASK;
GC_CAN_IGNORE Scheme_Cont_Mark *seg;
seg = p->cont_mark_stack_segments[segpos];
pm = seg + pos;
MZ_CONT_MARK_STACK++;
pm->key = scheme_stack_dump_key;
pm->val = data->name;
pm->pos = MZ_CONT_MARK_POS;
pm->cache = NULL;
}
}
goto eval_top;
} else if (type == scheme_closed_prim_type) {
GC_CAN_IGNORE Scheme_Closed_Primitive_Proc *prim;

3
src/mzscheme/src/exnsrc.ss
View File

@ -37,7 +37,8 @@ propeties (the latter in curly braces), strings are contracts/comments.
(version [] "version mismatch loading an extension"))
(network [] "TCP and UDP errors")
(out-of-memory [] "out of memory")
(unsupported [] "unsupported feature"))
(unsupported [] "unsupported feature")
(user [] "for end users"))
(break [break_field_check
(continuation "escape continuation" "resumes from the break")]

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

@ -80,6 +80,8 @@ int scheme_cont_capture_count;
static Scheme_Object *certify_mode_symbol, *transparent_symbol, *transparent_binding_symbol, *opaque_symbol;
static Scheme_Object *null_val_key;
/* locals */
static Scheme_Object *procedure_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *apply (int argc, Scheme_Object *argv[]);
@ -96,6 +98,7 @@ static Scheme_Object *cont_marks (int argc, Scheme_Object *argv[]);
static Scheme_Object *cc_marks_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *extract_cc_marks (int argc, Scheme_Object *argv[]);
static Scheme_Object *extract_cc_markses (int argc, Scheme_Object *argv[]);
static Scheme_Object *extract_cc_proc_marks (int argc, Scheme_Object *argv[]);
static Scheme_Object *extract_one_cc_mark (int argc, Scheme_Object *argv[]);
static Scheme_Object *void_func (int argc, Scheme_Object *argv[]);
static Scheme_Object *void_p (int argc, Scheme_Object *argv[]);
@ -297,6 +300,11 @@ scheme_init_fun (Scheme_Env *env)
"continuation-mark-set?",
1, 1),
env);
scheme_add_global_constant("continuation-mark-set->context",
scheme_make_prim_w_arity(extract_cc_proc_marks,
"continuation-mark-set->context",
1, 1),
env);
REGISTER_SO(scheme_void_proc);
scheme_void_proc = scheme_make_folding_prim(void_func,
@ -729,7 +737,6 @@ Scheme_Object *scheme_source_to_name(Scheme_Object *code)
char buf[50], src[20];
Scheme_Object *name;
src[0] = 0;
if (cstx->srcloc->src && SCHEME_PATHP(cstx->srcloc->src)) {
if (SCHEME_BYTE_STRLEN_VAL(cstx->srcloc->src) < 20)
memcpy(src, SCHEME_BYTE_STR_VAL(cstx->srcloc->src), SCHEME_BYTE_STRLEN_VAL(cstx->srcloc->src) + 1);
@ -739,6 +746,8 @@ Scheme_Object *scheme_source_to_name(Scheme_Object *code)
src[1] = '.';
src[2] = '.';
}
} else {
return NULL;
}
if (cstx->srcloc->line >= 0) {
@ -2668,6 +2677,19 @@ call_cc (int argc, Scheme_Object *argv[])
msaved = copy_out_mark_stack(p, MZ_CONT_MARK_STACK);
cont->cont_mark_stack_copied = msaved;
/* Remember the original mark-stack segments. */
{
long cnt;
Scheme_Cont_Mark **orig;
if (!MZ_CONT_MARK_STACK)
cnt = 0;
else
cnt = (((long)MZ_CONT_MARK_STACK - 1) >> SCHEME_LOG_MARK_SEGMENT_SIZE) + 1;
orig = (Scheme_Cont_Mark **)scheme_malloc(cnt * sizeof(Scheme_Cont_Mark*));
memcpy(orig, p->cont_mark_stack_segments, cnt * sizeof(Scheme_Cont_Mark*));
cont->orig_mark_segments = orig;
}
cont->runstack_owner = p->runstack_owner;
cont->cont_mark_stack_owner = p->cont_mark_stack_owner;
@ -2753,7 +2775,7 @@ call_cc (int argc, Scheme_Object *argv[])
/* In case there's a GC before we copy in marks: */
MZ_CONT_MARK_STACK = 0;
}
/* For dynamic-winds after the "common" intersection
(see eval.c), execute the pre thunks. Make a list
of these first because they have to be done in the
@ -2800,7 +2822,36 @@ call_cc (int argc, Scheme_Object *argv[])
MZ_CONT_MARK_STACK = cont->ss.cont_mark_stack;
copy_in_mark_stack(p, cont->cont_mark_stack_copied,
MZ_CONT_MARK_STACK, copied_cms);
/* If any mark-stack segment is different now than before, then
set the cache field of the *original* mark segment. Setting the
cache field ensures that any `pm' pointer in scheme_do_eval
will get reset to point to the new segment. */
{
long cnt, i, j;
Scheme_Cont_Mark *cm;
if (!MZ_CONT_MARK_STACK)
cnt = 0;
else
cnt = (((long)MZ_CONT_MARK_STACK - 1) >> SCHEME_LOG_MARK_SEGMENT_SIZE) + 1;
for (i = 0; i < cnt; i++) {
if (cont->orig_mark_segments[i] != p->cont_mark_stack_segments[i]) {
if (i + 1 == cnt) {
j = ((long)MZ_CONT_MARK_STACK) & SCHEME_MARK_SEGMENT_MASK;
} else {
j = SCHEME_MARK_SEGMENT_SIZE;
}
while (j--) {
cm = cont->orig_mark_segments[i] + j;
if (SAME_OBJ(cm->key, scheme_stack_dump_key)) {
cm->cache = scheme_false;
}
}
}
}
}
/* We may have just re-activated breaking: */
scheme_check_break_now();
@ -2876,6 +2927,7 @@ static Scheme_Object *continuation_marks(Scheme_Thread *p,
Scheme_Cont *cont = (Scheme_Cont *)_cont;
Scheme_Cont_Mark_Chain *first = NULL, *last = NULL;
Scheme_Cont_Mark_Set *set;
Scheme_Object *cache;
long findpos;
long cmpos;
@ -2907,24 +2959,36 @@ static Scheme_Object *continuation_marks(Scheme_Thread *p,
find = seg;
}
if (find[pos].cached_chain) {
cache = find[pos].cache;
if (cache) {
if (SCHEME_FALSEP(cache))
cache = NULL;
else if (SCHEME_VECTORP(cache)) {
cache = SCHEME_VEC_ELS(cache)[0];
}
}
if (cache) {
if (last)
last->next = find[pos].cached_chain;
last->next = (Scheme_Cont_Mark_Chain *)cache;
else
first = find[pos].cached_chain;
first = (Scheme_Cont_Mark_Chain *)cache;
break;
} else {
Scheme_Cont_Mark_Chain *pr;
pr = MALLOC_ONE_RT(Scheme_Cont_Mark_Chain);
#ifdef MZTAG_REQUIRED
pr->type = scheme_rt_cont_mark_chain;
#endif
pr->so.type = scheme_cont_mark_chain_type;
pr->key = find[pos].key;
pr->val = find[pos].val;
pr->pos = find[pos].pos;
pr->next = NULL;
find[pos].cached_chain = pr;
cache = find[pos].cache;
if (cache && !SCHEME_FALSEP(cache)) {
SCHEME_VEC_ELS(cache)[0] = (Scheme_Object *)pr;
} else {
find[pos].cache = (Scheme_Object *)pr;
}
if (last)
last->next = pr;
else
@ -3081,24 +3145,148 @@ extract_cc_markses(int argc, Scheme_Object *argv[])
return first;
}
Scheme_Object *
scheme_get_stack_trace(Scheme_Object *mark_set)
{
Scheme_Object *l, *n, *m;
Scheme_Object *a[2];
a[0] = mark_set;
a[1] = scheme_stack_dump_key;
l = extract_cc_marks(2, a);
/* Filter out NULLs */
while (SCHEME_PAIRP(l) && !SCHEME_CAR(l)) {
l = SCHEME_CDR(l);
}
for (n = l; SCHEME_PAIRP(n); ) {
m = SCHEME_CDR(n);
if (SCHEME_NULLP(m))
break;
if (SCHEME_CAR(m)) {
n = m;
} else {
SCHEME_CDR(n) = SCHEME_CDR(m);
}
}
return l;
}
static Scheme_Object *
extract_cc_proc_marks(int argc, Scheme_Object *argv[])
{
if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
scheme_wrong_type("continuation-mark-set->context", "continuation-mark-set", 0, argc, argv);
return NULL;
}
return scheme_get_stack_trace(argv[0]);
}
Scheme_Object *
scheme_extract_one_cc_mark(Scheme_Object *mark_set, Scheme_Object *key)
{
Scheme_Cont_Mark_Chain *chain;
if (mark_set) {
Scheme_Cont_Mark_Chain *chain;
chain = ((Scheme_Cont_Mark_Set *)mark_set)->chain;
while (chain) {
if (chain->key == key)
return chain->val;
else
chain = chain->next;
}
} else {
chain = (Scheme_Cont_Mark_Chain *)continuation_marks(scheme_current_thread, NULL, NULL, 1);
long findpos;
long pos;
Scheme_Object *val = NULL;
Scheme_Object *cache;
GC_CAN_IGNORE Scheme_Cont_Mark *seg;
Scheme_Thread *p = scheme_current_thread;
findpos = (long)MZ_CONT_MARK_STACK;
if (!p->cont_mark_stack_segments)
findpos = 0;
/* Search mark stack, checking caches along the way: */
while (findpos--) {
seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
pos = findpos & SCHEME_MARK_SEGMENT_MASK;
if (SAME_OBJ(seg[pos].key, key)) {
val = seg[pos].val;
break;
} else {
cache = seg[pos].cache;
if (cache && SCHEME_VECTORP(cache)) {
/* If slot 1 has a key, this cache has just one key--value
pair. Otherwise, slot 2 is a hash table. */
if (SCHEME_VEC_ELS(cache)[1]) {
if (SAME_OBJ(SCHEME_VEC_ELS(cache)[1], key)) {
val = SCHEME_VEC_ELS(cache)[2];
break;
}
} else {
Scheme_Hash_Table *ht;
ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(cache)[2];
val = scheme_hash_get(ht, key);
if (val) {
/* In the hash table, null_val_key is used to indicate
that there's no value for the key. */
if (SAME_OBJ(val, null_val_key))
val = NULL;
break;
}
}
}
}
}
pos = (long)MZ_CONT_MARK_STACK - findpos;
if (pos > 16) {
pos >>= 1;
findpos = findpos + pos;
seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
pos = findpos & SCHEME_MARK_SEGMENT_MASK;
cache = seg[pos].cache;
if (!cache || !SCHEME_VECTORP(cache)) {
/* No cache so far, so map one key */
cache = scheme_make_vector(3, NULL);
if (seg[pos].cache && !SCHEME_FALSEP(seg[pos].cache))
SCHEME_VEC_ELS(cache)[0] = seg[pos].cache;
SCHEME_VEC_ELS(cache)[1] = key;
SCHEME_VEC_ELS(cache)[2] = val;
seg[pos].cache = cache;
} else {
if (!null_val_key) {
REGISTER_SO(null_val_key);
null_val_key = scheme_make_symbol("nul");
}
if (SCHEME_VEC_ELS(cache)[1]) {
/* More than one cached key, now; create hash table */
Scheme_Hash_Table *ht;
Scheme_Object *v2;
ht = scheme_make_hash_table(SCHEME_hash_ptr);
scheme_hash_set(ht, key, val ? val : null_val_key);
v2 = SCHEME_VEC_ELS(cache)[2];
scheme_hash_set(ht, SCHEME_VEC_ELS(cache)[1], v2 ? v2 : null_val_key);
SCHEME_VEC_ELS(cache)[1] = NULL;
SCHEME_VEC_ELS(cache)[2] = (Scheme_Object *)ht;
} else {
/* Already have a hash table */
Scheme_Hash_Table *ht;
ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(cache)[2];
scheme_hash_set(ht, key, val ? val : null_val_key);
}
}
}
if (val)
return val;
}
while (chain) {
if (chain->key == key)
return chain->val;
else
chain = chain->next;
}
if (key == scheme_parameterization_key) {
return (Scheme_Object *)scheme_current_thread->init_config;
}
@ -3931,7 +4119,7 @@ static void register_traversers(void)
GC_REG_TRAV(scheme_rt_closure_info, mark_closure_info);
GC_REG_TRAV(scheme_rt_dyn_wind_cell, mark_dyn_wind_cell);
GC_REG_TRAV(scheme_rt_dyn_wind_info, mark_dyn_wind_info);
GC_REG_TRAV(scheme_rt_cont_mark_chain, mark_cont_mark_chain);
GC_REG_TRAV(scheme_cont_mark_chain_type, mark_cont_mark_chain);
}
END_XFORM_SKIP;

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

@ -1749,6 +1749,7 @@ static Scheme_Ephemeron *ephemerons, *done_ephemerons; /* not registered as a ro
# define GC_is_marked(p) GC_base(p)
# define GC_did_mark_stack_overflow() 0
#else
extern MZ_DLLIMPORT void *GC_base(void *);
extern MZ_DLLIMPORT int GC_is_marked(void *);
extern MZ_DLLIMPORT int GC_did_mark_stack_overflow(void);
#endif

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

@ -868,6 +868,7 @@ int cont_proc_MARK(void *p) {
gcMARK(c->runstack_owner);
gcMARK(c->cont_mark_stack_copied);
gcMARK(c->cont_mark_stack_owner);
gcMARK(c->orig_mark_segments);
gcMARK(c->init_config);
gcMARK(c->init_break_cell);
@ -890,6 +891,7 @@ int cont_proc_FIXUP(void *p) {
gcFIXUP(c->runstack_owner);
gcFIXUP(c->cont_mark_stack_copied);
gcFIXUP(c->cont_mark_stack_owner);
gcFIXUP(c->orig_mark_segments);
gcFIXUP(c->init_config);
gcFIXUP(c->init_break_cell);

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

@ -329,6 +329,7 @@ cont_proc {
gcMARK(c->runstack_owner);
gcMARK(c->cont_mark_stack_copied);
gcMARK(c->cont_mark_stack_owner);
gcMARK(c->orig_mark_segments);
gcMARK(c->init_config);
gcMARK(c->init_break_cell);

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

@ -274,7 +274,7 @@ MZ_EXTERN Scheme_Object *scheme_tail_eval_expr(Scheme_Object *obj);
MZ_EXTERN void scheme_set_tail_buffer_size(int s);
MZ_EXTERN Scheme_Object *scheme_force_value(Scheme_Object *);
MZ_EXTERN void scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val);
MZ_EXTERN void *scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val);
MZ_EXTERN void scheme_push_continuation_frame(Scheme_Cont_Frame_Data *);
MZ_EXTERN void scheme_pop_continuation_frame(Scheme_Cont_Frame_Data *);
MZ_EXTERN void scheme_temp_dec_mark_depth();

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

@ -219,7 +219,7 @@ Scheme_Object *(*scheme_tail_apply_to_list)(Scheme_Object *f, Scheme_Object *l);
Scheme_Object *(*scheme_tail_eval_expr)(Scheme_Object *obj);
void (*scheme_set_tail_buffer_size)(int s);
Scheme_Object *(*scheme_force_value)(Scheme_Object *);
void (*scheme_set_cont_mark)(Scheme_Object *key, Scheme_Object *val);
void *(*scheme_set_cont_mark)(Scheme_Object *key, Scheme_Object *val);
void (*scheme_push_continuation_frame)(Scheme_Cont_Frame_Data *);
void (*scheme_pop_continuation_frame)(Scheme_Cont_Frame_Data *);
void (*scheme_temp_dec_mark_depth)();

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

@ -20,6 +20,7 @@ enum {
MZEXN_FAIL_NETWORK,
MZEXN_FAIL_OUT_OF_MEMORY,
MZEXN_FAIL_UNSUPPORTED,
MZEXN_FAIL_USER,
MZEXN_BREAK,
MZEXN_OTHER
};
@ -49,6 +50,7 @@ static exn_rec exn_table[] = {
{ 2, NULL, NULL, 0, NULL, 1 },
{ 2, NULL, NULL, 0, NULL, 1 },
{ 2, NULL, NULL, 0, NULL, 1 },
{ 2, NULL, NULL, 0, NULL, 1 },
{ 3, NULL, NULL, 0, NULL, 0 }
};
#else
@ -78,6 +80,7 @@ static exn_rec *exn_table;
exn_table[MZEXN_FAIL_NETWORK].args = 2;
exn_table[MZEXN_FAIL_OUT_OF_MEMORY].args = 2;
exn_table[MZEXN_FAIL_UNSUPPORTED].args = 2;
exn_table[MZEXN_FAIL_USER].args = 2;
exn_table[MZEXN_BREAK].args = 3;
#endif
@ -119,6 +122,7 @@ static const char *MZEXN_BREAK_FIELDS[1] = { "continuation" };
SETUP_STRUCT(MZEXN_FAIL_NETWORK, EXN_PARENT(MZEXN_FAIL), "exn:fail:network", 0, NULL, scheme_null, NULL)
SETUP_STRUCT(MZEXN_FAIL_OUT_OF_MEMORY, EXN_PARENT(MZEXN_FAIL), "exn:fail:out-of-memory", 0, NULL, scheme_null, NULL)
SETUP_STRUCT(MZEXN_FAIL_UNSUPPORTED, EXN_PARENT(MZEXN_FAIL), "exn:fail:unsupported", 0, NULL, scheme_null, NULL)
SETUP_STRUCT(MZEXN_FAIL_USER, EXN_PARENT(MZEXN_FAIL), "exn:fail:user", 0, NULL, scheme_null, NULL)
SETUP_STRUCT(MZEXN_BREAK, EXN_PARENT(MZEXN), "exn:break", 1, MZEXN_BREAK_FIELDS, scheme_null, scheme_make_prim(break_field_check))
#endif

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

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

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

@ -245,6 +245,8 @@ extern Scheme_Object *scheme_recur_symbol, *scheme_display_symbol, *scheme_write
extern Scheme_Object *scheme_none_symbol, *scheme_line_symbol, *scheme_block_symbol;
extern Scheme_Object *scheme_stack_dump_key;
/*========================================================================*/
/* thread state and maintenance */
/*========================================================================*/
@ -837,12 +839,12 @@ typedef struct Scheme_Cont_Mark {
is a pointer, then allocate with GC_malloc_allow_interior */
Scheme_Object *key;
Scheme_Object *val;
struct Scheme_Cont_Mark_Chain *cached_chain;
Scheme_Object *cache; /* chain and/or shortcut */
MZ_MARK_POS_TYPE pos; /* Odd numbers - so they look like non-pointers */
} Scheme_Cont_Mark;
typedef struct Scheme_Cont_Mark_Chain {
MZTAG_IF_REQUIRED
Scheme_Object so;
Scheme_Object *key;
Scheme_Object *val;
MZ_MARK_POS_TYPE pos;
@ -894,6 +896,7 @@ typedef struct Scheme_Cont {
Scheme_Thread **runstack_owner;
Scheme_Cont_Mark *cont_mark_stack_copied;
Scheme_Thread **cont_mark_stack_owner;
Scheme_Cont_Mark **orig_mark_segments;
void *stack_start;
void *o_start;
Scheme_Config *init_config;
@ -2066,6 +2069,8 @@ extern int scheme_exiting_result;
Scheme_Object *scheme_special_comment_value(Scheme_Object *o);
Scheme_Object *scheme_get_stack_trace(Scheme_Object *mark_set);
/*========================================================================*/
/* filesystem utilities */
/*========================================================================*/

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

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

24
src/mzscheme/src/stypes.h
View File

@ -148,21 +148,21 @@ enum {
scheme_lexical_rib_type, /* 130 */
scheme_thread_cell_values_type, /* 131 */
scheme_global_ref_type, /* 132 */
scheme_cont_mark_chain_type, /* 133 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 133 */
_scheme_last_normal_type_, /* 134 */
scheme_rt_comp_env, /* 134 */
scheme_rt_constant_binding, /* 135 */
scheme_rt_resolve_info, /* 136 */
scheme_rt_compile_info, /* 137 */
scheme_rt_cont_mark, /* 138 */
scheme_rt_saved_stack, /* 139 */
scheme_rt_reply_item, /* 140 */
scheme_rt_closure_info, /* 141 */
scheme_rt_overflow, /* 142 */
scheme_rt_dyn_wind_cell, /* 143 */
scheme_rt_cont_mark_chain, /* 144 */
scheme_rt_comp_env, /* 135 */
scheme_rt_constant_binding, /* 136 */
scheme_rt_resolve_info, /* 137 */
scheme_rt_compile_info, /* 138 */
scheme_rt_cont_mark, /* 139 */
scheme_rt_saved_stack, /* 140 */
scheme_rt_reply_item, /* 141 */
scheme_rt_closure_info, /* 142 */
scheme_rt_overflow, /* 143 */
scheme_rt_dyn_wind_cell, /* 144 */
scheme_rt_dyn_wind_info, /* 145 */
scheme_rt_dyn_wind, /* 146 */
scheme_rt_dup_check, /* 147 */

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

@ -5872,6 +5872,7 @@ static void make_initial_config(Scheme_Thread *p)
? scheme_true : scheme_false));
init_param(cells, paramz, MZCONFIG_ERROR_PRINT_WIDTH, scheme_make_integer(100));
init_param(cells, paramz, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH, scheme_make_integer(16));
init_param(cells, paramz, MZCONFIG_ERROR_PRINT_SRCLOC, scheme_true);
REGISTER_SO(main_custodian);

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

@ -173,6 +173,7 @@ scheme_init_type (Scheme_Env *env)
set_name(scheme_custodian_type, "<custodian>");
set_name(scheme_cont_mark_set_type, "<continuation-mark-set>");
set_name(scheme_cont_mark_chain_type, "<chain>");
set_name(scheme_inspector_type, "<inspector>");