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

359.2, core changes

Browse Source 
svn: r5142
This commit is contained in:
Matthew Flatt 2006-12-20 00:47:32 +00:00
parent 586b47c0dd
commit 2274cc9f65
37 changed files with 4860 additions and 3408 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/mred/wxs/wxs_medi.cxx
View File

@ -2143,7 +2143,7 @@ static Scheme_Object *os_wxMediaBufferInsertPort(int n, Scheme_Object *p[])
VAR_STACK_PUSH(1, x0);
x0 = (SCHEME_INPORTP(p[POFFSET+0]) ? p[POFFSET+0] : (scheme_wrong_type(METHODNAME("editor<%>","insert-port"), "input port", -1, 1, &p[POFFSET+0]), (Scheme_Object *)NULL));
x0 = (SCHEME_INPUT_PORTP(p[POFFSET+0]) ? p[POFFSET+0] : (scheme_wrong_type(METHODNAME("editor<%>","insert-port"), "input port", -1, 1, &p[POFFSET+0]), (Scheme_Object *)NULL));
if (n > (POFFSET+1)) {
x1 = WITH_VAR_STACK(unbundle_symset_fileType(p[POFFSET+1], "insert-port in editor<%>"));
} else
@ -2177,7 +2177,7 @@ static Scheme_Object *os_wxMediaBufferSavePort(int n, Scheme_Object *p[])
VAR_STACK_PUSH(1, x0);
x0 = (SCHEME_OUTPORTP(p[POFFSET+0]) ? p[POFFSET+0] : (scheme_wrong_type(METHODNAME("editor<%>","save-port"), "output port", -1, 1, &p[POFFSET+0]), (Scheme_Object *)NULL));
x0 = (SCHEME_OUTPUT_PORTP(p[POFFSET+0]) ? p[POFFSET+0] : (scheme_wrong_type(METHODNAME("editor<%>","save-port"), "output port", -1, 1, &p[POFFSET+0]), (Scheme_Object *)NULL));
if (n > (POFFSET+1)) {
x1 = WITH_VAR_STACK(unbundle_symset_fileType(p[POFFSET+1], "save-port in editor<%>"));
} else

8
src/mred/wxs/wxs_medi.xc
View File

@ -49,10 +49,10 @@ static void *wxbDCToBuffer(wxMediaBuffer *b, double x, double y)
@MACRO rFALSE = return FALSE;
@MACRO rZERO = return 0;
@MACRO ubiPort[who] = (SCHEME_INPORTP({x}) ? {x} : (scheme_wrong_type(METHODNAME("editor<%>",<who>), "input port", -1, 1, &{x}), (Scheme_Object *)NULL))
@MACRO ciPort = SCHEME_INPORTP({x})
@MACRO uboPort[who] = (SCHEME_OUTPORTP({x}) ? {x} : (scheme_wrong_type(METHODNAME("editor<%>",<who>), "output port", -1, 1, &{x}), (Scheme_Object *)NULL))
@MACRO coPort = SCHEME_OUTPORTP({x})
@MACRO ubiPort[who] = (SCHEME_INPUT_PORTP({x}) ? {x} : (scheme_wrong_type(METHODNAME("editor<%>",<who>), "input port", -1, 1, &{x}), (Scheme_Object *)NULL))
@MACRO ciPort = SCHEME_INPUT_PORTP({x})
@MACRO uboPort[who] = (SCHEME_OUTPUT_PORTP({x}) ? {x} : (scheme_wrong_type(METHODNAME("editor<%>",<who>), "output port", -1, 1, &{x}), (Scheme_Object *)NULL))
@MACRO coPort = SCHEME_OUTPUT_PORTP({x})
@INCLUDE wxs_eds.xci

8
src/mzscheme/cmdline.inc
View File

@ -312,7 +312,7 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
save = p->error_buf;
p->error_buf = &newbuf;
if (!scheme_setjmp(newbuf))
scheme_eval_string_all(fa->evals_and_loads[i], fa->global_env, 0);
scheme_eval_string_all_with_prompt(fa->evals_and_loads[i], fa->global_env, 0);
else {
exit_val = 1;
p->error_buf = save;
@ -327,11 +327,11 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
if (!scheme_setjmp(newbuf)) {
Scheme_Object *a[1], *m, *fn;
m = scheme_eval_string("main", fa->global_env);
m = scheme_eval_string_with_prompt("main", fa->global_env);
fn = scheme_make_locale_string(fa->evals_and_loads[i]);
SCHEME_SET_CHAR_STRING_IMMUTABLE(fn);
a[0] = scheme_make_pair(fn, scheme_vector_to_list(fa->main_args));
(void)scheme_apply(m, 1, a);
(void)scheme_apply_multi_with_prompt(m, 1, a);
} else {
exit_val = 1;
p->error_buf = save;
@ -358,7 +358,7 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
if (SAME_OBJ(f, SCHEME_MULTIPLE_VALUES)
&& (scheme_multiple_count == 2)) {
f = scheme_multiple_array[0];
_scheme_apply(f, 0, NULL);
scheme_apply_multi_with_prompt(f, 0, NULL);
}
} else {
exit_val = 1;

19
src/mzscheme/include/mzscheme.exp
View File

@ -106,6 +106,8 @@ scheme_uchar_folds
scheme_uchar_combining_classes
scheme_eval
scheme_eval_multi
scheme_eval_with_prompt
scheme_eval_multi_with_prompt
scheme_eval_compiled
scheme_eval_compiled_multi
_scheme_eval_compiled
@ -115,13 +117,24 @@ scheme_apply_multi
scheme_apply_no_eb
scheme_apply_multi_no_eb
scheme_apply_to_list
scheme_apply_with_prompt
scheme_apply_multi_with_prompt
_scheme_apply_with_prompt
_scheme_apply_multi_with_prompt
scheme_eval_string
scheme_eval_string_multi
scheme_eval_string_all
scheme_eval_string_with_prompt
scheme_eval_string_multi_with_prompt
scheme_eval_string_all_with_prompt
_scheme_apply_known_prim_closure
_scheme_apply_known_prim_closure_multi
_scheme_apply_prim_closure
_scheme_apply_prim_closure_multi
scheme_call_with_prompt
scheme_call_with_prompt_multi
_scheme_call_with_prompt
_scheme_call_with_prompt_multi
scheme_values
scheme_check_one_value
scheme_tail_apply
@ -179,6 +192,7 @@ scheme_make_hash_table
scheme_make_hash_table_equal
scheme_hash_set
scheme_hash_get
scheme_eq_hash_get
scheme_hash_table_equal
scheme_is_hash_table_equal
scheme_clone_hash_table
@ -348,6 +362,11 @@ scheme_close_output_port
scheme_write_special
scheme_write_special_nonblock
scheme_make_write_evt
scheme_port_record
scheme_input_port_record
scheme_output_port_record
scheme_is_input_port
scheme_is_output_port
scheme_make_port_type
scheme_make_input_port
scheme_make_output_port

19
src/mzscheme/include/mzscheme3m.exp
View File

@ -106,6 +106,8 @@ scheme_uchar_folds
scheme_uchar_combining_classes
scheme_eval
scheme_eval_multi
scheme_eval_with_prompt
scheme_eval_multi_with_prompt
scheme_eval_compiled
scheme_eval_compiled_multi
_scheme_eval_compiled
@ -115,13 +117,24 @@ scheme_apply_multi
scheme_apply_no_eb
scheme_apply_multi_no_eb
scheme_apply_to_list
scheme_apply_with_prompt
scheme_apply_multi_with_prompt
_scheme_apply_with_prompt
_scheme_apply_multi_with_prompt
scheme_eval_string
scheme_eval_string_multi
scheme_eval_string_all
scheme_eval_string_with_prompt
scheme_eval_string_multi_with_prompt
scheme_eval_string_all_with_prompt
_scheme_apply_known_prim_closure
_scheme_apply_known_prim_closure_multi
_scheme_apply_prim_closure
_scheme_apply_prim_closure_multi
scheme_call_with_prompt
scheme_call_with_prompt_multi
_scheme_call_with_prompt
_scheme_call_with_prompt_multi
scheme_values
scheme_check_one_value
scheme_tail_apply
@ -186,6 +199,7 @@ scheme_make_hash_table
scheme_make_hash_table_equal
scheme_hash_set
scheme_hash_get
scheme_eq_hash_get
scheme_hash_table_equal
scheme_is_hash_table_equal
scheme_clone_hash_table
@ -355,6 +369,11 @@ scheme_close_output_port
scheme_write_special
scheme_write_special_nonblock
scheme_make_write_evt
scheme_port_record
scheme_input_port_record
scheme_output_port_record
scheme_is_input_port
scheme_is_output_port
scheme_make_port_type
scheme_make_input_port
scheme_make_output_port

15
src/mzscheme/include/mzwin.def
View File

@ -108,6 +108,8 @@ EXPORTS
scheme_uchar_combining_classes
scheme_eval
scheme_eval_multi
scheme_eval_with_prompt
scheme_eval_multi_with_prompt
scheme_eval_compiled
scheme_eval_compiled_multi
scheme_apply
@ -115,9 +117,16 @@ EXPORTS
scheme_apply_no_eb
scheme_apply_multi_no_eb
scheme_apply_to_list
scheme_apply_with_prompt
scheme_apply_multi_with_prompt
scheme_eval_string
scheme_eval_string_multi
scheme_eval_string_all
scheme_eval_string_with_prompt
scheme_eval_string_multi_with_prompt
scheme_eval_string_all_with_prompt
scheme_call_with_prompt
scheme_call_with_prompt_multi
scheme_values
scheme_check_one_value
scheme_tail_apply
@ -171,6 +180,7 @@ EXPORTS
scheme_make_hash_table_equal
scheme_hash_set
scheme_hash_get
scheme_eq_hash_get
scheme_hash_table_equal
scheme_is_hash_table_equal
scheme_clone_hash_table
@ -340,6 +350,11 @@ EXPORTS
scheme_write_special
scheme_write_special_nonblock
scheme_make_write_evt
scheme_port_record
scheme_input_port_record
scheme_output_port_record
scheme_is_input_port
scheme_is_output_port
scheme_make_port_type
scheme_make_input_port
scheme_make_output_port

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

@ -441,6 +441,9 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
#define SCHEME_INPORTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_input_port_type)
#define SCHEME_OUTPORTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_output_port_type)
#define SCHEME_INPUT_PORTP(obj) scheme_is_input_port(obj)
#define SCHEME_OUTPUT_PORTP(obj) scheme_is_output_port(obj)
#define SCHEME_THREADP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_thread_type)
#define SCHEME_CUSTODIANP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_custodian_type)
#define SCHEME_SEMAP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_sema_type)
@ -936,7 +939,6 @@ typedef struct Scheme_Thread {
struct Scheme_Thread **cont_mark_stack_owner;
struct Scheme_Cont_Mark *cont_mark_stack_swapped;
struct Scheme_Prompt *barrier_prompt; /* a pseudo-prompt */
struct Scheme_Prompt *meta_prompt; /* a pseudo-prompt */
struct Scheme_Meta_Continuation *meta_continuation;
@ -957,6 +959,7 @@ typedef struct Scheme_Thread {
Scheme_Jumpup_Buf jmpup_buf; /* For jumping back to this thread */
struct Scheme_Dynamic_Wind *dw;
int next_meta; /* amount to move forward in the meta-continuaiton chain, starting with dw */
int running;
Scheme_Object *suspended_box; /* contains pointer to thread when it's suspended */
@ -1087,7 +1090,6 @@ enum {
MZCONFIG_EXIT_HANDLER,
MZCONFIG_EXN_HANDLER,
MZCONFIG_INIT_EXN_HANDLER,
MZCONFIG_EVAL_HANDLER,

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

File diff suppressed because it is too large Load Diff

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

@ -631,9 +631,8 @@ call_error(char *buffer, int len, Scheme_Object *exn)
scheme_make_pair(v, exn),
"nested-exception-handler",
1, 1);
config = scheme_extend_config(orig_config,
MZCONFIG_EXN_HANDLER,
v);
config = orig_config;
if (SAME_OBJ(display_handler, default_display_handler))
config = scheme_extend_config(config,
MZCONFIG_ERROR_DISPLAY_HANDLER,
@ -645,6 +644,7 @@ call_error(char *buffer, int len, Scheme_Object *exn)
scheme_push_continuation_frame(&cframe);
scheme_install_config(config);
scheme_set_cont_mark(scheme_exn_handler_key, v);
scheme_push_break_enable(&cframe2, 0, 0);
p[0] = scheme_make_immutable_sized_utf8_string(buffer, len);
@ -656,9 +656,7 @@ call_error(char *buffer, int len, Scheme_Object *exn)
scheme_make_pair(v, exn),
"nested-exception-handler",
1, 1);
config = scheme_extend_config(orig_config,
MZCONFIG_EXN_HANDLER,
v);
config = scheme_extend_config(config,
MZCONFIG_ERROR_DISPLAY_HANDLER,
default_display_handler);
@ -670,6 +668,7 @@ call_error(char *buffer, int len, Scheme_Object *exn)
scheme_pop_continuation_frame(&cframe);
scheme_push_continuation_frame(&cframe);
scheme_set_cont_mark(scheme_exn_handler_key, v);
scheme_install_config(config);
scheme_push_break_enable(&cframe2, 0, 0);
@ -2236,7 +2235,17 @@ def_error_value_string_proc(int argc, Scheme_Object *argv[])
static Scheme_Object *
def_error_escape_proc(int argc, Scheme_Object *argv[])
{
{
Scheme_Object *prompt;
Scheme_Thread *p = scheme_current_thread;
prompt = scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(scheme_default_prompt_tag));
if (prompt) {
p->cjs.jumping_to_continuation = prompt;
p->cjs.num_vals = 1;
p->cjs.val = scheme_void_proc;
}
scheme_longjmp(scheme_error_buf, 1);
return scheme_void; /* Never get here */
@ -2416,19 +2425,10 @@ def_exn_handler(int argc, Scheme_Object *argv[])
return scheme_void;
}
static Scheme_Object *
exn_handler(int argc, Scheme_Object *argv[])
{
return scheme_param_config("current-exception-handler",
scheme_make_integer(MZCONFIG_EXN_HANDLER),
argc, argv,
1, NULL, NULL, 0);
}
static Scheme_Object *
init_exn_handler(int argc, Scheme_Object *argv[])
{
return scheme_param_config("initial-exception-handler",
return scheme_param_config("uncaught-exception-handler",
scheme_make_integer(MZCONFIG_INIT_EXN_HANDLER),
argc, argv,
1, NULL, NULL, 0);
@ -2486,7 +2486,6 @@ static Scheme_Object *
do_raise(Scheme_Object *arg, int return_ok, int need_debug)
{
Scheme_Object *v, *p[1], *h;
Scheme_Config *config;
Scheme_Cont_Frame_Data cframe, cframe2;
if (scheme_current_thread->skip_error) {
@ -2499,8 +2498,10 @@ do_raise(Scheme_Object *arg, int return_ok, int need_debug)
((Scheme_Structure *)arg)->slots[1] = marks;
}
config = scheme_current_config();
h = scheme_get_param(config, MZCONFIG_EXN_HANDLER);
h = scheme_extract_one_cc_mark(NULL, scheme_exn_handler_key);
if (!h) {
h = scheme_get_param(scheme_current_config(), MZCONFIG_INIT_EXN_HANDLER);
}
v = scheme_make_byte_string_without_copying("exception handler");
v = scheme_make_closed_prim_w_arity(nested_exn_handler,
@ -2508,12 +2509,8 @@ do_raise(Scheme_Object *arg, int return_ok, int need_debug)
"nested-exception-handler",
1, 1);
config = scheme_extend_config(config,
MZCONFIG_EXN_HANDLER,
v);
scheme_push_continuation_frame(&cframe);
scheme_install_config(config);
scheme_set_cont_mark(scheme_exn_handler_key, v);
scheme_push_break_enable(&cframe2, 0, 0);
p[0] = arg;
@ -2702,15 +2699,9 @@ void scheme_init_exn(Scheme_Env *env)
}
}
scheme_add_global_constant("current-exception-handler",
scheme_register_parameter(exn_handler,
"current-exception-handler",
MZCONFIG_EXN_HANDLER),
env);
scheme_add_global_constant("initial-exception-handler",
scheme_add_global_constant("uncaught-exception-handler",
scheme_register_parameter(init_exn_handler,
"initial-exception-handler",
"uncaught-exception-handler",
MZCONFIG_INIT_EXN_HANDLER),
env);
@ -2731,7 +2722,6 @@ void scheme_init_exn_config(void)
"default-exception-handler",
1, 1);
scheme_set_root_param(MZCONFIG_EXN_HANDLER, h);
scheme_set_root_param(MZCONFIG_INIT_EXN_HANDLER, h);
}

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

@ -143,6 +143,7 @@
/* globals */
Scheme_Object *scheme_eval_waiting;
Scheme_Object *scheme_multiple_values;
int scheme_continuation_application_count;
volatile int scheme_fuel_counter;
@ -152,6 +153,7 @@ void scheme_set_startup_use_jit(int v) { scheme_startup_use_jit = v; }
static Scheme_Object *app_symbol;
static Scheme_Object *datum_symbol;
static Scheme_Object *top_symbol;
static Scheme_Object *top_level_symbol;
static Scheme_Object *app_expander;
static Scheme_Object *datum_expander;
@ -222,7 +224,6 @@ static Scheme_Object *internal_define_symbol;
static Scheme_Object *module_symbol;
static Scheme_Object *module_begin_symbol;
static Scheme_Object *expression_symbol;
static Scheme_Object *top_level_symbol;
static Scheme_Object *protected_symbol;
@ -234,6 +235,8 @@ static Scheme_Object *scheme_compile_expand_expr(Scheme_Object *form, Scheme_Com
Scheme_Compile_Expand_Info *rec, int drec,
int app_position);
static Scheme_Object *_eval_compiled_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env);
#define cons(x,y) scheme_make_pair(x,y)
typedef void (*DW_PrePost_Proc)(void *);
@ -517,6 +520,8 @@ scheme_handle_stack_overflow(Scheme_Object *(*k)(void))
Scheme_Overflow *overflow;
Scheme_Overflow_Jmp *jmp;
scheme_about_to_move_C_stack();
scheme_overflow_k = k;
scheme_overflow_count++;
@ -550,6 +555,11 @@ scheme_handle_stack_overflow(Scheme_Object *(*k)(void))
/* Jump directly to prompt: */
Scheme_Prompt *prompt = (Scheme_Prompt *)p->cjs.jumping_to_continuation;
scheme_longjmp(*prompt->prompt_buf, 1);
} else if (p->cjs.jumping_to_continuation
&& SCHEME_CONTP(p->cjs.jumping_to_continuation)) {
Scheme_Cont *c = (Scheme_Cont *)p->cjs.jumping_to_continuation;
p->cjs.jumping_to_continuation = NULL;
scheme_longjmpup(&c->buf);
} else {
/* Continue normal escape: */
scheme_longjmp(scheme_error_buf, 1);
@ -1454,7 +1464,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
if ((opt < 0) && !scheme_omittable_expr(SCHEME_CAR(seq), 1)) {
/* We can't optimize (begin0 expr cont) to expr because
exp is not in tail position in the original (so we'd mess
up continuation marks. */
up continuation marks). */
addconst = 1;
} else
return good;
@ -3574,7 +3584,6 @@ static Scheme_Object *call_compile_handler(Scheme_Object *form, int immediate_ev
return o;
}
static Scheme_Object *add_renames_unless_module(Scheme_Object *form, Scheme_Env *genv)
{
if (genv->rename) {
@ -3804,7 +3813,7 @@ static void *compile_k(void)
if (SCHEME_PAIRP(tl_queue)) {
/* This compile is interleaved with evaluation,
and we need to eval now before compiling more. */
_scheme_eval_compiled_multi((Scheme_Object *)top, genv);
_eval_compiled_multi_with_prompt((Scheme_Object *)top, genv);
form = SCHEME_CAR(tl_queue);
tl_queue = SCHEME_CDR(tl_queue);
@ -5591,28 +5600,34 @@ static void make_tail_buffer_safe()
}
static Scheme_Dynamic_Wind *intersect_dw(Scheme_Dynamic_Wind *a, Scheme_Dynamic_Wind *b,
Scheme_Object *prompt_tag, int *_common_depth)
Scheme_Object *prompt_tag, int b_has_tag, int *_common_depth)
{
int alen = 0, blen = 0;
int prompt_delta = 0;
int a_has_tag = 0, a_prompt_delta = 0, b_prompt_delta = 0;
Scheme_Dynamic_Wind *dw;
if (prompt_tag) {
Scheme_Dynamic_Wind *dw;
for (dw = a; dw && (dw->prompt_tag != prompt_tag); dw = dw->prev) {
}
if (dw)
prompt_delta = dw->depth + 1;
for (dw = a; dw && (dw->prompt_tag != prompt_tag); dw = dw->prev) {
}
if (dw) {
/* Cut off `a' below the prompt dw. */
a_prompt_delta = dw->depth;
a_has_tag = 1;
}
alen = (a ? a->depth + 1 : 0) - prompt_delta;
blen = (b ? b->depth + 1 : 0);
if (a_has_tag)
a_prompt_delta += 1;
if (b_has_tag)
b_prompt_delta += 1;
alen = (a ? a->depth + 1 : 0) - a_prompt_delta;
blen = (b ? b->depth + 1 : 0) - b_prompt_delta;
while (alen > blen) {
--alen;
a = a->prev;
}
if (!alen) {
*_common_depth = -1;
*_common_depth = b_prompt_delta - 1;
return a;
}
while (blen > alen) {
@ -5635,6 +5650,124 @@ static Scheme_Dynamic_Wind *intersect_dw(Scheme_Dynamic_Wind *a, Scheme_Dynamic_
return a;
}
static Scheme_Prompt *lookup_cont_prompt(Scheme_Cont *c,
Scheme_Meta_Continuation **_prompt_mc,
MZ_MARK_POS_TYPE *_prompt_pos,
const char *msg)
{
Scheme_Prompt *prompt;
prompt = (Scheme_Prompt *)scheme_extract_one_cc_mark_with_meta(NULL,
SCHEME_PTR_VAL(c->prompt_tag),
NULL,
_prompt_mc,
_prompt_pos);
if (!prompt && !SAME_OBJ(scheme_default_prompt_tag, c->prompt_tag)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
msg);
}
return prompt;
}
#define LOOKUP_NO_PROMPT "continuation application: no corresponding prompt in the current continuation"
static Scheme_Prompt *check_barrier(Scheme_Prompt *prompt,
Scheme_Meta_Continuation *prompt_cont, MZ_MARK_POS_TYPE prompt_pos,
Scheme_Cont *c)
/* A continuation barrier is analogous to a dynamic-wind. A jump is
allowed if no dynamic-wind-like barriers would be executed for
the jump. */
{
Scheme_Prompt *barrier_prompt, *b1, *b2;
Scheme_Meta_Continuation *barrier_cont;
MZ_MARK_POS_TYPE barrier_pos;
barrier_prompt = scheme_get_barrier_prompt(&barrier_cont, &barrier_pos);
b1 = barrier_prompt;
if (b1) {
if (!b1->is_barrier)
b1 = NULL;
else if (prompt
&& scheme_is_cm_deeper(barrier_cont, barrier_pos,
prompt_cont, prompt_pos))
b1 = NULL;
}
b2 = c->barrier_prompt;
if (b2) {
if (!b2->is_barrier)
b2 = NULL;
}
if (b1 != b2) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
"continuation application: attempt to cross a continuation barrier");
}
return barrier_prompt;
}
void scheme_recheck_prompt_and_barrier(Scheme_Cont *c)
/* Check for prompt & barrier, again. We need to
call this function like a d-w thunk, so that the meta
continuation is right in case of an error. */
{
Scheme_Prompt *prompt;
Scheme_Meta_Continuation *prompt_cont;
MZ_MARK_POS_TYPE prompt_pos;
prompt = lookup_cont_prompt(c, &prompt_cont, &prompt_pos,
LOOKUP_NO_PROMPT
" on return from `dynamic-wind' post thunk");
check_barrier(prompt, prompt_cont, prompt_pos, c);
}
static int exec_dyn_wind_posts(Scheme_Dynamic_Wind *common, Scheme_Cont *c, int common_depth)
{
int meta_depth;
Scheme_Thread *p = scheme_current_thread;
Scheme_Dynamic_Wind *dw;
int old_cac = scheme_continuation_application_count;
for (dw = p->dw;
((common && common->id) ? dw->id != common->id : dw != common);
) {
meta_depth = p->next_meta;
p->next_meta += dw->next_meta;
p->dw = dw->prev;
if (dw->post) {
if (meta_depth > 0) {
scheme_apply_dw_in_meta(dw, 1, meta_depth, c);
} else {
DW_PrePost_Proc post = dw->post;
MZ_CONT_MARK_POS = dw->envss.cont_mark_pos;
MZ_CONT_MARK_STACK = dw->envss.cont_mark_stack;
post(dw->data);
if (scheme_continuation_application_count != old_cac) {
scheme_recheck_prompt_and_barrier(c);
}
}
p = scheme_current_thread;
/* p->dw might not match dw if the post thunk captures a
continuation that is later restored in a different
meta continuation: */
dw = p->dw;
/* If any continuations were applied, then the set of dynamic
winds may be different now than before Re-compute the
intersection. */
if (scheme_continuation_application_count != old_cac) {
old_cac = scheme_continuation_application_count;
common = intersect_dw(p->dw, c->dw, c->prompt_tag, c->has_prompt_dw, &common_depth);
}
} else
dw = dw->prev;
}
return common_depth;
}
#ifdef REGISTER_POOR_MACHINE
# define USE_LOCAL_RUNSTACK 0
# define DELAY_THREAD_RUNSTACK_UPDATE 0
@ -6061,10 +6194,11 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
#endif
} else if (type == scheme_cont_type) {
Scheme_Cont *c;
Scheme_Dynamic_Wind *dw, *common;
Scheme_Dynamic_Wind *common;
Scheme_Object *value;
Scheme_Meta_Continuation *prompt_mc;
Scheme_Prompt *prompt;
MZ_MARK_POS_TYPE prompt_pos;
Scheme_Prompt *prompt, *barrier_prompt;
int common_depth;
if (num_rands != 1) {
@ -6098,85 +6232,39 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
if (c->composable) {
/* Composable continuation. Jump right in... */
scheme_continuation_application_count++;
RUNSTACK = old_runstack;
RUNSTACK_CHANGED();
UPDATE_THREAD_RSPTR();
v = scheme_compose_continuation(c, num_rands, value);
} else {
/* Aborting (Scheme-style) continuation. */
int orig_cac = scheme_continuation_application_count;
prompt = (Scheme_Prompt *)scheme_extract_one_cc_mark_with_meta(NULL,
SCHEME_PTR_VAL(c->prompt_tag),
NULL,
&prompt_mc);
if (!prompt && !SAME_OBJ(scheme_default_prompt_tag, c->prompt_tag)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
"continuation application: no corresponding prompt in the current continuation");
}
UPDATE_THREAD_RSPTR();
/* A continuation barrier is analogous to a dynamic-wind. A jump is
allowed if no dynamic-wind-like barriers would be executed for
the jump. */
{
Scheme_Prompt *b1, *b2;
scheme_about_to_move_C_stack();
b1 = p->barrier_prompt;
if (b1) {
if (!b1->is_barrier)
b1 = NULL;
else if (prompt && (prompt->depth > b1->depth))
b1 = NULL;
}
b2 = c->ss.barrier_prompt;
if (b2) {
if (!b2->is_barrier)
b2 = NULL;
else if (c->prompt_depth > b2->depth)
b2 = NULL;
}
if (b1 != b2) {
UPDATE_THREAD_RSPTR_FOR_ERROR();
scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
"continuation application: attempt to cross a continuation barrier");
}
}
prompt = lookup_cont_prompt(c, &prompt_mc, &prompt_pos, LOOKUP_NO_PROMPT);
barrier_prompt = check_barrier(prompt, prompt_mc, prompt_pos, c);
p->suspend_break++; /* restored at call/cc destination */
/* Find `common', the intersection of dynamic-wind chain for
the current continuation and the given continuation, looking
no further back in the current continuation than a prompt. */
common = intersect_dw(p->dw, c->dw, c->prompt_tag, &common_depth);
common = intersect_dw(p->dw, c->dw, c->prompt_tag, c->has_prompt_dw, &common_depth);
/* For dynamic-winds after `common' in this
continuation, execute the post-thunks */
{
int meta_depth = 0;
for (dw = p->dw;
((common && common->id) ? dw->id != common->id : dw != common);
) {
if (dw->post) {
p->dw = dw->prev;
meta_depth += dw->next_meta;
if (meta_depth) {
scheme_apply_dw_in_meta(dw, 1, meta_depth);
} else {
DW_PrePost_Proc post = dw->post;
common_depth = exec_dyn_wind_posts(common, c, common_depth);
p = scheme_current_thread;
MZ_CONT_MARK_POS = dw->envss.cont_mark_pos;
MZ_CONT_MARK_STACK = dw->envss.cont_mark_stack;
post(dw->data);
}
p = scheme_current_thread;
/* p->dw might not match dw if the post thunk captures a
continuation that is later restored in a different
meta continuation: */
dw = p->dw;
} else
dw = dw->prev;
}
if (orig_cac != scheme_continuation_application_count) {
/* We checked for a barrier in exec_dyn_wind_posts, but
get prompt & barrier again. */
prompt = lookup_cont_prompt(c, &prompt_mc, &prompt_pos, "shouldn't fail!");
barrier_prompt = scheme_get_barrier_prompt(NULL, NULL);
}
c->common_dw_depth = common_depth;
@ -6189,7 +6277,10 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
c->value = vals;
}
p->dw = common;
c->common_dw = common;
c->common_next_meta = p->next_meta;
scheme_continuation_application_count++;
if (!prompt) {
/* Invoke the continuation directly. If there's no prompt,
@ -6197,7 +6288,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
created with a new thread or a barrier prompt. */
p->meta_continuation = NULL; /* since prompt wasn't in any meta-continuation */
p->meta_prompt = NULL;
if (c->ss.barrier_prompt == p->barrier_prompt) {
if (c->barrier_prompt == barrier_prompt) {
/* Barrier determines continuation end. */
c->resume_to = NULL;
p->stack_start = c->stack_start;
@ -6211,6 +6302,32 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
p->stack_start = c->prompt_stack_start;
}
scheme_longjmpup(&c->buf);
} else if (prompt->id
&& (prompt->id == c->prompt_id)
&& !prompt_mc) {
/* The current prompt is the same as the one in place when
capturing the continuation, so we can jump directly. */
scheme_drop_prompt_meta_continuations(c->prompt_tag);
c->shortcut_prompt = prompt;
if ((!prompt->boundary_overflow_id && !p->overflow)
|| (prompt->boundary_overflow_id
&& (prompt->boundary_overflow_id == p->overflow->id))) {
scheme_longjmpup(&c->buf);
} else {
/* Need to unwind overflows... */
Scheme_Overflow *overflow;
overflow = p->overflow;
while (overflow->prev
&& (!overflow->prev->id
|| (overflow->prev->id != prompt->boundary_overflow_id))) {
overflow = overflow->prev;
}
/* Immediate destination is in scheme_handle_stack_overflow(). */
p->cjs.jumping_to_continuation = (Scheme_Object *)c;
p->overflow = overflow;
p->stack_start = overflow->stack_start;
scheme_longjmpup(&overflow->jmp->cont);
}
} else {
p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;
p->cjs.num_vals = 1;
@ -6223,18 +6340,36 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
and continue from there. Immediate destination is
in compose_continuation() in fun.c; the ultimate
destination is in scheme_finish_apply_for_prompt()
in fun.c. */
in fun.c.
We need to adjust the meta-continuation offsets in
common, based on the number that we're discarding
here. */
{
Scheme_Meta_Continuation *xmc;
int offset = 1;
for (xmc = p->meta_continuation;
xmc->prompt_tag != prompt_mc->prompt_tag;
xmc = xmc->next) {
if (xmc->overflow)
offset++;
}
c->common_next_meta -= offset;
}
p->meta_continuation = prompt_mc->next;
p->stack_start = prompt_mc->overflow->stack_start;
scheme_longjmpup(&prompt_mc->overflow->jmp->cont);
} else if ((!prompt->boundary_overflow_id && !p->overflow)
|| (prompt->boundary_overflow_id == p->overflow->id)) {
|| (prompt->boundary_overflow_id
&& (prompt->boundary_overflow_id == p->overflow->id))) {
/* Jump directly to the prompt: destination is in
scheme_finish_apply_for_prompt() in fun.c. */
scheme_drop_prompt_meta_continuations(c->prompt_tag);
scheme_longjmp(*prompt->prompt_buf, 1);
} else {
/* Need to unwind overflows to get to the prompt. */
Scheme_Overflow *overflow = p->overflow;
Scheme_Overflow *overflow;
scheme_drop_prompt_meta_continuations(c->prompt_tag);
overflow = p->overflow;
while (overflow->prev
&& (!overflow->prev->id
|| (overflow->prev->id != prompt->boundary_overflow_id))) {
@ -6955,6 +7090,34 @@ Scheme_Object *scheme_eval_multi(Scheme_Object *obj, Scheme_Env *env)
return scheme_eval_compiled_multi(scheme_compile_for_eval(obj, env), env);
}
static Scheme_Object *finish_eval_with_prompt(void *_data, int argc, Scheme_Object **argv)
{
Scheme_Object *data = (Scheme_Object *)_data;
return _scheme_eval_compiled(SCHEME_CAR(data), (Scheme_Env *)SCHEME_CDR(data));
}
Scheme_Object *scheme_eval_with_prompt(Scheme_Object *obj, Scheme_Env *env)
{
Scheme_Object *expr;
expr = scheme_compile_for_eval(obj, env);
return scheme_call_with_prompt(finish_eval_with_prompt,
scheme_make_pair(expr, (Scheme_Object *)env));
}
static Scheme_Object *finish_eval_multi_with_prompt(void *_data, int argc, Scheme_Object **argv)
{
Scheme_Object *data = (Scheme_Object *)_data;
return _scheme_eval_compiled_multi(SCHEME_CAR(data), (Scheme_Env *)SCHEME_CDR(data));
}
Scheme_Object *scheme_eval_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env)
{
Scheme_Object *expr;
expr = scheme_compile_for_eval(obj, env);
return scheme_call_with_prompt(finish_eval_multi_with_prompt,
scheme_make_pair(expr, (Scheme_Object *)env));
}
static void *eval_k(void)
{
Scheme_Thread *p = scheme_current_thread;
@ -7074,6 +7237,18 @@ Scheme_Object *_scheme_eval_compiled_multi(Scheme_Object *obj, Scheme_Env *env)
return _eval(obj, env, 0, 1, 0, 0);
}
static Scheme_Object *finish_compiled_multi_with_prompt(void *_data, int argc, Scheme_Object **argv)
{
Scheme_Object *data = (Scheme_Object *)_data;
return _eval(SCHEME_CAR(data), (Scheme_Env *)SCHEME_CDR(data), 0, 1, 0, 0);
}
Scheme_Object *_eval_compiled_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env)
{
return _scheme_call_with_prompt_multi(finish_compiled_multi_with_prompt,
scheme_make_pair(obj, (Scheme_Object *)env));
}
Scheme_Object *scheme_eval_linked_expr(Scheme_Object *obj)
{
return _eval(obj, NULL, 1, 0, 1, 0);
@ -7672,7 +7847,7 @@ expand_stx_to_top_form(int argc, Scheme_Object **argv)
return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 1, -1, 1, 1, 0, NULL);
}
Scheme_Object *scheme_eval_string_all(const char *str, Scheme_Env *env, int cont)
static Scheme_Object *do_eval_string_all(const char *str, Scheme_Env *env, int cont, int w_prompt)
{
Scheme_Object *port, *expr, *result = scheme_void;
@ -7681,23 +7856,50 @@ Scheme_Object *scheme_eval_string_all(const char *str, Scheme_Env *env, int cont
expr = scheme_read_syntax(port, scheme_false);
if (SAME_OBJ(expr, scheme_eof))
cont = 0;
else if (cont < 0)
result = scheme_eval(expr, env);
else
result = scheme_eval_multi(expr, env);
else if (cont < 0) {
if (w_prompt)
result = scheme_eval_with_prompt(expr, env);
else
result = scheme_eval(expr, env);
} else {
if (w_prompt)
result = scheme_eval_multi_with_prompt(expr, env);
else
result = scheme_eval_multi(expr, env);
}
} while (cont > 0);
return result;
}
Scheme_Object *scheme_eval_string_all(const char *str, Scheme_Env *env, int cont)
{
return do_eval_string_all(str, env, cont, 0);
}
Scheme_Object *scheme_eval_string(const char *str, Scheme_Env *env)
{
return scheme_eval_string_all(str, env, -1);
return do_eval_string_all(str, env, -1, 0);
}
Scheme_Object *scheme_eval_string_multi(const char *str, Scheme_Env *env)
{
return scheme_eval_string_all(str, env, 0);
return do_eval_string_all(str, env, 0, 0);
}
Scheme_Object *scheme_eval_string_all_with_prompt(const char *str, Scheme_Env *env, int cont)
{
return do_eval_string_all(str, env, cont, 1);
}
Scheme_Object *scheme_eval_string_with_prompt(const char *str, Scheme_Env *env)
{
return do_eval_string_all(str, env, -1, 1);
}
Scheme_Object *scheme_eval_string_multi_with_prompt(const char *str, Scheme_Env *env)
{
return do_eval_string_all(str, env, 0, 1);
}
static Scheme_Object *allow_set_undefined(int argc, Scheme_Object **argv)

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

File diff suppressed because it is too large Load Diff

11
src/mzscheme/src/hash.c
View File

@ -310,7 +310,7 @@ static Scheme_Object *do_hash_set(Scheme_Hash_Table *table, Scheme_Object *key,
return val;
}
static Scheme_Object *do_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
XFORM_NONGCING static Scheme_Object *do_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
{
Scheme_Object *tkey, **keys;
hash_v_t h, h2;
@ -368,6 +368,15 @@ Scheme_Object *scheme_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
return do_hash_get(table, key);
}
Scheme_Object *scheme_eq_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
/* Specialized to allow XFORM_NONGCING */
{
if (!table->vals)
return NULL;
else
return do_hash_get(table, key);
}
int scheme_hash_table_equal(Scheme_Hash_Table *t1, Scheme_Hash_Table *t2)
{
Scheme_Object **vals, **keys, *v;

70
src/mzscheme/src/jit.c
View File

@ -120,6 +120,7 @@ static void *struct_pred_branch_code;
static void *struct_get_code;
static void *bad_app_vals_target;
static void *app_values_slow_code, *app_values_multi_slow_code, *app_values_tail_slow_code;
static void *finish_tail_call_code, *finish_tail_call_fixup_code;
typedef struct {
MZTAG_IF_REQUIRED
@ -1280,7 +1281,9 @@ static int generate_direct_prim_tail_call(mz_jit_state *jitter, int num_rands)
}
static int generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_native, int need_set_rs)
/* If num_rands < 0, then argc is in LOCAL2 and arguments are already below RUNSTACK_BASE */
/* If num_rands < 0, then argc is in LOCAL2 and arguments are already below RUNSTACK_BASE.
If direct_native == 2, then some arguments are already in place (shallower in the runstack
than the arguments to move). */
{
int i;
GC_CAN_IGNORE jit_insn *ref, *ref2, *ref4, *ref5;
@ -1389,6 +1392,23 @@ static int generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_na
} else {
mz_get_local_p(JIT_R0, JIT_LOCAL2);
}
/* Since we've overwritten JIT_RUNSTACK, if this is not shared
code, and if this is 3m, then the runstack no longer
has a pointer to the closure for this code. To ensure that
an appropriate return point exists, jump to static code
for the rest. (This is the slow path, anyway.) */
__END_SHORT_JUMPS__(num_rands < 100);
if (direct_native > 1) {
(void)jit_jmpi(finish_tail_call_fixup_code);
} else {
(void)jit_jmpi(finish_tail_call_code);
}
return 1;
}
static int generate_finish_tail_call(mz_jit_state *jitter, int direct_native)
{
mz_prepare(3);
CHECK_LIMIT();
jit_pusharg_p(JIT_RUNSTACK);
@ -1399,14 +1419,13 @@ static int generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_na
} else {
(void)mz_finish(_scheme_tail_apply_from_native);
}
CHECK_LIMIT();
/* Pop saved runstack val and return: */
mz_get_local_p(JIT_NOT_RET, JIT_LOCAL1);
jit_sti_p(&scheme_current_runstack, JIT_NOT_RET);
mz_pop_locals();
jit_ret();
__END_SHORT_JUMPS__(num_rands < 100);
return 1;
}
@ -4113,6 +4132,11 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
END_JIT_DATA(9);
}
break;
case SPLICE_EXPD:
{
scheme_signal_error("cannot JIT a top-level splice form");
}
break;
default:
{
JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
@ -4993,6 +5017,31 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
jit_ret();
CHECK_LIMIT();
/* *** app_values_tail_slow_code *** */
/* RELIES ON jit_prolog(3) FROM ABOVE */
/* Rator in V1, arguments are in thread's multiple-values cells. */
app_values_tail_slow_code = jit_get_ip().ptr;
JIT_UPDATE_THREAD_RSPTR();
mz_prepare(1);
jit_pusharg_p(JIT_V1);
(void)mz_finish(tail_call_with_values_from_multiple_result);
jit_retval(JIT_R0);
/* Pop saved runstack val and return: */
mz_get_local_p(JIT_NOT_RET, JIT_LOCAL1);
jit_sti_p(&scheme_current_runstack, JIT_NOT_RET);
mz_pop_locals();
jit_ret();
CHECK_LIMIT();
/* *** finish_tail_call_[fixup_]code *** */
/* RELIES ON jit_prolog(3) FROM ABOVE */
finish_tail_call_code = jit_get_ip().ptr;
generate_finish_tail_call(jitter, 0);
CHECK_LIMIT();
finish_tail_call_fixup_code = jit_get_ip().ptr;
generate_finish_tail_call(jitter, 2);
CHECK_LIMIT();
/* *** get_stack_pointer_code *** */
get_stack_pointer_code = jit_get_ip().ptr;
jit_leaf(0);
@ -5066,21 +5115,6 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
CHECK_LIMIT();
}
/* *** app_values_tail_slow_code *** */
/* Rator in V1, arguments are in thread's multiple-values cells. */
app_values_tail_slow_code = jit_get_ip().ptr;
JIT_UPDATE_THREAD_RSPTR();
mz_prepare(1);
jit_pusharg_p(JIT_V1);
(void)mz_finish(tail_call_with_values_from_multiple_result);
jit_retval(JIT_R0);
/* Pop saved runstack val and return: */
mz_get_local_p(JIT_NOT_RET, JIT_LOCAL1);
jit_sti_p(&scheme_current_runstack, JIT_NOT_RET);
mz_pop_locals();
jit_ret();
CHECK_LIMIT();
/* *** {vector,string,bytes}_{ref,set}_[check_index_]code *** */
/* R0 is vector/string/bytes, R1 is index (Scheme number in check-index mode),
V1 is vector/string/bytes offset in non-check-index mode (and for

2
src/mzscheme/src/mk-uchar.ss
View File

@ -344,7 +344,7 @@
#f
;; whitespace
(or (member cat space-cats)
(member code '(#x9 #xa #xb #xc #xd)))
(member code '(#x9 #xa #xb #xc #xd #x85)))
;; control
(or (<= #x0000 code #x001F)
(<= #x007F code #x009F))

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

@ -150,6 +150,7 @@ static Scheme_Object *set_stx;
static Scheme_Object *with_continuation_mark_stx;
static Scheme_Object *letrec_syntaxes_stx;
static Scheme_Object *var_ref_stx;
static Scheme_Object *expression_stx;
static Scheme_Env *initial_modules_env;
static int num_initial_modules;
@ -483,6 +484,7 @@ void scheme_finish_kernel(Scheme_Env *env)
REGISTER_SO(with_continuation_mark_stx);
REGISTER_SO(letrec_syntaxes_stx);
REGISTER_SO(var_ref_stx);
REGISTER_SO(expression_stx);
w = scheme_sys_wraps0;
scheme_module_stx = scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, w, 0, 0);
@ -507,6 +509,7 @@ void scheme_finish_kernel(Scheme_Env *env)
with_continuation_mark_stx = scheme_datum_to_syntax(scheme_intern_symbol("with-continuation-mark"), scheme_false, w, 0, 0);
letrec_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("letrec-syntaxes+values"), scheme_false, w, 0, 0);
var_ref_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%variable-reference"), scheme_false, w, 0, 0);
expression_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%expression"), scheme_false, w, 0, 0);
REGISTER_SO(prefix_symbol);
REGISTER_SO(only_symbol);
@ -2112,7 +2115,8 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
symbol = scheme_tl_id_sym(env, symbol, NULL, 0);
if ((env == scheme_initial_env)
|| (env->module->primitive)
|| ((env->module->primitive
&& !env->module->provide_protects))
/* For now[?], we're pretending that all definitions exists for
non-0 local phase. */
|| env->mod_phase) {
@ -2129,7 +2133,8 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
int need_cert = 0;
if (position < env->module->me->num_var_provides) {
if (SCHEME_FALSEP(env->module->me->provide_srcs[position]))
if (!env->module->me->provide_srcs
|| SCHEME_FALSEP(env->module->me->provide_srcs[position]))
isym = env->module->me->provide_src_names[position];
else
isym = NULL;
@ -2203,7 +2208,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
}
if (want_pos)
return pos;
return pos;
else
return symbol;
}
@ -2779,6 +2784,8 @@ void scheme_finish_primitive_module(Scheme_Env *env)
m->me->num_provides = count;
m->me->num_var_provides = count;
qsort_provides(exs, NULL, NULL, NULL, 0, count, 1);
env->running = 1;
}
@ -2788,12 +2795,16 @@ void scheme_protect_primitive_provide(Scheme_Env *env, Scheme_Object *name)
int i;
if (!m->provide_protects) {
Scheme_Hash_Table *ht;
char *exps;
ht = scheme_make_hash_table(SCHEME_hash_ptr);
exps = MALLOC_N_ATOMIC(char, m->me->num_provides);
for (i = m->me->num_provides; i--; ) {
exps[i] = 0;
scheme_hash_set(ht, m->me->provides[i], scheme_make_integer(i));
}
m->provide_protects = exps;
m->accessible = ht;
}
if (name) {
@ -3883,7 +3894,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
{
Scheme_Object *stop;
stop = scheme_get_stop_expander();
scheme_add_local_syntax(20, xenv);
scheme_add_local_syntax(21, xenv);
scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv);
scheme_set_local_syntax(1, scheme_define_values_stx, stop, xenv);
scheme_set_local_syntax(2, scheme_define_syntaxes_stx, stop, xenv);
@ -3904,6 +3915,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
scheme_set_local_syntax(17, with_continuation_mark_stx, stop, xenv);
scheme_set_local_syntax(18, letrec_syntaxes_stx, stop, xenv);
scheme_set_local_syntax(19, var_ref_stx, stop, xenv);
scheme_set_local_syntax(20, expression_stx, stop, xenv);
}
first = scheme_null;

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

@ -884,6 +884,7 @@ static int cont_proc_MARK(void *p) {
gcMARK(c->dw);
gcMARK(c->prompt_tag);
gcMARK(c->meta_continuation);
gcMARK(c->common_dw);
gcMARK(c->save_overflow);
gcMARK(c->runstack_copied);
gcMARK(c->runstack_owner);
@ -898,15 +899,19 @@ static int cont_proc_MARK(void *p) {
MARK_jmpup(&c->buf);
MARK_cjs(&c->cjs);
MARK_stack_state(&c->ss);
gcMARK(c->barrier_prompt);
gcMARK(c->runstack_start);
gcMARK(c->runstack_saved);
gcMARK(c->prompt_id);
/* These shouldn't actually persist across a GC, but
just in case... */
gcMARK(c->value);
gcMARK(c->resume_to);
gcMARK(c->use_next_cont);
gcMARK(c->extra_marks);
gcMARK(c->shortcut_prompt);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Cont));
@ -918,6 +923,7 @@ static int cont_proc_FIXUP(void *p) {
gcFIXUP(c->dw);
gcFIXUP(c->prompt_tag);
gcFIXUP(c->meta_continuation);
gcFIXUP(c->common_dw);
gcFIXUP(c->save_overflow);
gcFIXUP(c->runstack_copied);
gcFIXUP(c->runstack_owner);
@ -932,15 +938,19 @@ static int cont_proc_FIXUP(void *p) {
FIXUP_jmpup(&c->buf);
FIXUP_cjs(&c->cjs);
FIXUP_stack_state(&c->ss);
gcFIXUP(c->barrier_prompt);
gcFIXUP(c->runstack_start);
gcFIXUP(c->runstack_saved);
gcFIXUP(c->prompt_id);
/* These shouldn't actually persist across a GC, but
just in case... */
gcFIXUP(c->value);
gcFIXUP(c->resume_to);
gcFIXUP(c->use_next_cont);
gcFIXUP(c->extra_marks);
gcFIXUP(c->shortcut_prompt);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Cont));
@ -1090,6 +1100,7 @@ static int escaping_cont_proc_MARK(void *p) {
gcMARK(c->native_trace);
#endif
gcMARK(c->barrier_prompt);
MARK_stack_state(&c->envss);
return
@ -1103,6 +1114,7 @@ static int escaping_cont_proc_FIXUP(void *p) {
gcFIXUP(c->native_trace);
#endif
gcFIXUP(c->barrier_prompt);
FIXUP_stack_state(&c->envss);
return
@ -1574,7 +1586,6 @@ static int thread_val_MARK(void *p) {
gcMARK(pr->runstack_swapped);
pr->spare_runstack = NULL; /* just in case */
gcMARK(pr->barrier_prompt);
gcMARK(pr->meta_prompt);
gcMARK(pr->meta_continuation);
@ -1664,7 +1675,6 @@ static int thread_val_FIXUP(void *p) {
gcFIXUP(pr->runstack_swapped);
pr->spare_runstack = NULL; /* just in case */
gcFIXUP(pr->barrier_prompt);
gcFIXUP(pr->meta_prompt);
gcFIXUP(pr->meta_continuation);
@ -1740,8 +1750,9 @@ static int prompt_val_SIZE(void *p) {
static int prompt_val_MARK(void *p) {
Scheme_Prompt *pr = (Scheme_Prompt *)p;
gcMARK(pr->boundary_overflow_id);
gcMARK(pr->boundary_dw_id);
gcMARK(pr->runstack_boundary_start);
gcMARK(pr->tag);
gcMARK(pr->id);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Prompt));
}
@ -1749,8 +1760,9 @@ static int prompt_val_MARK(void *p) {
static int prompt_val_FIXUP(void *p) {
Scheme_Prompt *pr = (Scheme_Prompt *)p;
gcFIXUP(pr->boundary_overflow_id);
gcFIXUP(pr->boundary_dw_id);
gcFIXUP(pr->runstack_boundary_start);
gcFIXUP(pr->tag);
gcFIXUP(pr->id);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Prompt));
}

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

@ -331,6 +331,7 @@ cont_proc {
gcMARK(c->dw);
gcMARK(c->prompt_tag);
gcMARK(c->meta_continuation);
gcMARK(c->common_dw);
gcMARK(c->save_overflow);
gcMARK(c->runstack_copied);
gcMARK(c->runstack_owner);
@ -345,15 +346,19 @@ cont_proc {
MARK_jmpup(&c->buf);
MARK_cjs(&c->cjs);
MARK_stack_state(&c->ss);
gcMARK(c->barrier_prompt);
gcMARK(c->runstack_start);
gcMARK(c->runstack_saved);
gcMARK(c->prompt_id);
/* These shouldn't actually persist across a GC, but
just in case... */
gcMARK(c->value);
gcMARK(c->resume_to);
gcMARK(c->use_next_cont);
gcMARK(c->extra_marks);
gcMARK(c->shortcut_prompt);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Cont));
@ -417,6 +422,7 @@ escaping_cont_proc {
gcMARK(c->native_trace);
#endif
gcMARK(c->barrier_prompt);
MARK_stack_state(&c->envss);
size:
@ -610,7 +616,6 @@ thread_val {
gcMARK(pr->runstack_swapped);
pr->spare_runstack = NULL; /* just in case */
gcMARK(pr->barrier_prompt);
gcMARK(pr->meta_prompt);
gcMARK(pr->meta_continuation);
@ -678,8 +683,9 @@ prompt_val {
mark:
Scheme_Prompt *pr = (Scheme_Prompt *)p;
gcMARK(pr->boundary_overflow_id);
gcMARK(pr->boundary_dw_id);
gcMARK(pr->runstack_boundary_start);
gcMARK(pr->tag);
gcMARK(pr->id);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Prompt));
}

36
src/mzscheme/src/network.c
View File

@ -2286,15 +2286,15 @@ static Scheme_Object *tcp_addresses(int argc, Scheme_Object *argv[])
Scheme_Object *result[4];
int with_ports = 0;
if (SCHEME_OUTPORTP(argv[0])) {
if (SCHEME_OUTPUT_PORTP(argv[0])) {
Scheme_Output_Port *op;
op = (Scheme_Output_Port *)argv[0];
op = scheme_output_port_record(argv[0]);
if (op->sub_type == scheme_tcp_output_port_type)
tcp = op->port_data;
closed = op->closed;
} else if (SCHEME_INPORTP(argv[0])) {
} else if (SCHEME_INPUT_PORTP(argv[0])) {
Scheme_Input_Port *ip;
ip = (Scheme_Input_Port *)argv[0];
ip = scheme_input_port_record(argv[0]);
if (ip->sub_type == scheme_tcp_input_port_type)
tcp = ip->port_data;
closed = ip->closed;
@ -2375,9 +2375,9 @@ static Scheme_Object *tcp_addresses(int argc, Scheme_Object *argv[])
static Scheme_Object *tcp_abandon_port(int argc, Scheme_Object *argv[])
{
#ifdef USE_TCP
if (SCHEME_OUTPORTP(argv[0])) {
if (SCHEME_OUTPUT_PORTP(argv[0])) {
Scheme_Output_Port *op;
op = (Scheme_Output_Port *)argv[0];
op = scheme_output_port_record(argv[0]);
if (op->sub_type == scheme_tcp_output_port_type) {
if (!op->closed) {
((Scheme_Tcp *)op->port_data)->flags |= MZ_TCP_ABANDON_OUTPUT;
@ -2385,11 +2385,11 @@ static Scheme_Object *tcp_abandon_port(int argc, Scheme_Object *argv[])
}
return scheme_void;
}
} else if (SCHEME_INPORTP(argv[0])) {
} else if (SCHEME_INPUT_PORTP(argv[0])) {
/* Abandon is not really useful on input ports from the Schemer's
perspective, but it's here for completeness. */
Scheme_Input_Port *ip;
ip = (Scheme_Input_Port *)argv[0];
ip = scheme_input_port_record(argv[0]);
if (ip->sub_type == scheme_tcp_input_port_type) {
if (!ip->closed) {
((Scheme_Tcp *)ip->port_data)->flags |= MZ_TCP_ABANDON_INPUT;
@ -2408,12 +2408,16 @@ static Scheme_Object *tcp_abandon_port(int argc, Scheme_Object *argv[])
static Scheme_Object *tcp_port_p(int argc, Scheme_Object *argv[])
{
#ifdef USE_TCP
if (SCHEME_OUTPORTP(argv[0])) {
if (((Scheme_Output_Port *)argv[0])->sub_type == scheme_tcp_output_port_type) {
if (SCHEME_OUTPUT_PORTP(argv[0])) {
Scheme_Output_Port *op;
op = scheme_output_port_record(argv[0]);
if (op->sub_type == scheme_tcp_output_port_type) {
return scheme_true;
}
} else if (SCHEME_INPORTP(argv[0])) {
if (((Scheme_Input_Port *)argv[0])->sub_type == scheme_tcp_input_port_type) {
} else if (SCHEME_INPUT_PORTP(argv[0])) {
Scheme_Input_Port *ip;
ip = scheme_input_port_record(argv[0]);
if (ip->sub_type == scheme_tcp_input_port_type) {
return scheme_true;
}
}
@ -2462,18 +2466,18 @@ int scheme_get_port_socket(Scheme_Object *p, long *_s)
tcp_t s = 0;
int s_ok = 0;
if (SCHEME_OUTPORTP(p)) {
if (SCHEME_OUTPUT_PORTP(p)) {
Scheme_Output_Port *op;
op = (Scheme_Output_Port *)p;
op = scheme_output_port_record(p);
if (op->sub_type == scheme_tcp_output_port_type) {
if (!op->closed) {
s = ((Scheme_Tcp *)op->port_data)->tcp;
s_ok = 1;
}
}
} else if (SCHEME_INPORTP(p)) {
} else if (SCHEME_INPUT_PORTP(p)) {
Scheme_Input_Port *ip;
ip = (Scheme_Input_Port *)p;
ip = scheme_input_port_record(p);
if (ip->sub_type == scheme_tcp_input_port_type) {
if (!ip->closed) {
s = ((Scheme_Tcp *)ip->port_data)->tcp;

258
src/mzscheme/src/port.c
View File

@ -1113,7 +1113,7 @@ static int output_ready(Scheme_Object *port, Scheme_Schedule_Info *sinfo)
{
Scheme_Output_Port *op;
op = (Scheme_Output_Port *)port;
op = scheme_output_port_record(port);
if (op->closed)
return 1;
@ -1144,7 +1144,7 @@ static void output_need_wakeup (Scheme_Object *port, void *fds)
/* If this is a user output port and its evt needs a wakeup, we
shouldn't get here. The target use above will take care of it. */
op = (Scheme_Output_Port *)port;
op = scheme_output_port_record(port);
if (op->need_wakeup_fun) {
Scheme_Need_Wakeup_Output_Fun f;
f = op->need_wakeup_fun;
@ -1154,7 +1154,9 @@ static void output_need_wakeup (Scheme_Object *port, void *fds)
int scheme_byte_ready_or_user_port_ready(Scheme_Object *p, Scheme_Schedule_Info *sinfo)
{
Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
Scheme_Input_Port *ip;
ip = scheme_input_port_record(p);
if (ip->closed)
return 1;
@ -1185,7 +1187,10 @@ XFORM_NONGCING static int pipe_char_count(Scheme_Object *p)
{
if (p) {
Scheme_Pipe *pipe;
pipe = (Scheme_Pipe *)((Scheme_Input_Port *)p)->port_data;
Scheme_Input_Port *ip;
ip = (Scheme_Input_Port *)p;
pipe = (Scheme_Pipe *)ip->port_data;
if (pipe->bufstart <= pipe->bufend)
return pipe->bufend - pipe->bufstart;
@ -1357,7 +1362,7 @@ long scheme_get_byte_string_unless(const char *who,
if (!peek_skip)
peek_skip = scheme_make_integer(0);
ip = (Scheme_Input_Port *)port;
ip = scheme_input_port_record(port);
gs = ip->get_string_fun;
ps = ip->peek_string_fun;
@ -1769,7 +1774,9 @@ static void elect_new_main(Scheme_Input_Port *ip)
static void release_input_lock_and_elect_new_main(void *_ip)
{
Scheme_Input_Port *ip = (Scheme_Input_Port *)_ip;
Scheme_Input_Port *ip;
ip = scheme_input_port_record(_ip);
release_input_lock(ip);
elect_new_main(ip);
@ -1783,9 +1790,11 @@ static void check_suspended()
static void remove_extra(void *ip_v)
{
Scheme_Input_Port *ip = (Scheme_Input_Port *)SCHEME_CAR(ip_v);
Scheme_Input_Port *ip;
Scheme_Object *v = SCHEME_CDR(ip_v), *ll, *prev;
ip = scheme_input_port_record(SCHEME_CAR(ip_v));
prev = NULL;
for (ll = ip->input_extras; ll; prev = ll, ll = SCHEME_CDR(ll)) {
if (SAME_OBJ(ll, SCHEME_CDR(v))) {
@ -2040,7 +2049,7 @@ int scheme_peeked_read(Scheme_Object *port,
Scheme_Input_Port *ip;
Scheme_Peeked_Read_Fun pr;
ip = (Scheme_Input_Port *)port;
ip = scheme_input_port_record(port);
unless_evt = SCHEME_PTR2_VAL(unless_evt);
@ -2067,7 +2076,7 @@ Scheme_Object *scheme_progress_evt(Scheme_Object *port)
{
Scheme_Input_Port *ip;
ip = (Scheme_Input_Port *)port;
ip = scheme_input_port_record(port);
if (ip->progress_evt_fun) {
Scheme_Progress_Evt_Fun ce;
@ -2260,7 +2269,7 @@ long get_one_byte(const char *who,
special_is_ok = 0;
ip = (Scheme_Input_Port *)port;
ip = scheme_input_port_record(port);
CHECK_PORT_CLOSED(who, "input", port, ip->closed);
@ -2554,7 +2563,7 @@ int scheme_peekc_is_ungetc(Scheme_Object *port)
{
Scheme_Input_Port *ip;
ip = (Scheme_Input_Port *)port;
ip = scheme_input_port_record(port);
return !ip->peek_string_fun;
}
@ -2589,8 +2598,13 @@ static int rw_evt_ready(Scheme_Object *_rww, Scheme_Schedule_Info *sinfo)
}
if (rww->v) {
Scheme_Write_Special_Fun ws = ((Scheme_Output_Port *)rww->port)->write_special_fun;
v = ws((Scheme_Output_Port *)rww->port, rww->v, 1);
Scheme_Output_Port *op;
Scheme_Write_Special_Fun ws;
op = scheme_output_port_record(rww->port);
ws = op->write_special_fun;
v = ws(op, rww->v, 1);
if (v) {
scheme_set_sync_target(sinfo, scheme_true, NULL, NULL, 0, 0);
return 1;
@ -2640,7 +2654,9 @@ Scheme_Object *scheme_write_special_evt_via_write_special(Scheme_Output_Port *po
Scheme_Object *scheme_make_write_evt(const char *who, Scheme_Object *port,
Scheme_Object *special, char *str, long start, long size)
{
Scheme_Output_Port *op = (Scheme_Output_Port *)port;
Scheme_Output_Port *op;
op = scheme_output_port_record(port);
if (!special) {
if (op->write_string_evt_fun) {
@ -2666,7 +2682,7 @@ scheme_ungetc (int ch, Scheme_Object *port)
{
Scheme_Input_Port *ip;
ip = (Scheme_Input_Port *)port;
ip = scheme_input_port_record(port);
CHECK_PORT_CLOSED("#<primitive:peek-port-char>", "input", port, ip->closed);
@ -2716,7 +2732,7 @@ scheme_byte_ready (Scheme_Object *port)
Scheme_Input_Port *ip;
int retval;
ip = (Scheme_Input_Port *)port;
ip = scheme_input_port_record(port);
CHECK_PORT_CLOSED("char-ready?", "input", port, ip->closed);
@ -2756,7 +2772,7 @@ Scheme_Object *scheme_get_special(Scheme_Object *port,
SCHEME_USE_FUEL(1);
ip = (Scheme_Input_Port *)port;
ip = scheme_input_port_record(port);
/* Only `read' and similar internals should call this function. A
caller must should ensure that there are no ungotten
@ -2815,7 +2831,9 @@ static Scheme_Object *do_get_ready_special(Scheme_Object *port,
long line, col, pos;
if (!stxsrc) {
stxsrc = ((Scheme_Input_Port *)port)->name;
Scheme_Input_Port *ip;
ip = scheme_input_port_record(port);
stxsrc = ip->name;
}
/* Don't use scheme_tell_all(), because we always want the
@ -2880,7 +2898,7 @@ Scheme_Object *scheme_get_special_proc(Scheme_Object *inport)
Scheme_Object *special, **sbox;
Scheme_Input_Port *ip;
ip = (Scheme_Input_Port *)inport;
ip = scheme_input_port_record(inport);
special = ip->special;
ip->special = NULL;
@ -2896,7 +2914,7 @@ scheme_need_wakeup (Scheme_Object *port, void *fds)
{
Scheme_Input_Port *ip;
ip = (Scheme_Input_Port *)port;
ip = scheme_input_port_record(port);
if (ip->need_wakeup_fun) {
Scheme_Need_Wakeup_Input_Fun f = ip->need_wakeup_fun;
@ -2905,7 +2923,7 @@ scheme_need_wakeup (Scheme_Object *port, void *fds)
}
#define CHECK_IOPORT_CLOSED(who, port) \
if (SCHEME_INPORTP(port)) { \
if (SCHEME_INPORTP((Scheme_Object *)port)) { \
CHECK_PORT_CLOSED(who, "input", port, ((Scheme_Input_Port *)port)->closed); \
} else { \
CHECK_PORT_CLOSED(who, "output", port, ((Scheme_Output_Port *)port)->closed); \
@ -2917,9 +2935,9 @@ scheme_tell (Scheme_Object *port)
Scheme_Port *ip;
long pos;
ip = (Scheme_Port *)port;
ip = scheme_port_record(port);
CHECK_IOPORT_CLOSED("get-file-position", port);
CHECK_IOPORT_CLOSED("get-file-position", ip);
if (!ip->count_lines || (ip->position < 0))
pos = ip->position;
@ -2935,12 +2953,12 @@ scheme_tell_line (Scheme_Object *port)
Scheme_Port *ip;
long line;
ip = (Scheme_Port *)port;
ip = scheme_port_record(port);
if (!ip->count_lines || (ip->position < 0))
return -1;
CHECK_IOPORT_CLOSED("get-file-line", port);
CHECK_IOPORT_CLOSED("get-file-line", ip);
line = ip->lineNumber;
@ -2953,12 +2971,12 @@ scheme_tell_column (Scheme_Object *port)
Scheme_Port *ip;
long col;
ip = (Scheme_Port *)port;
ip = scheme_port_record(port);
if (!ip->count_lines || (ip->position < 0))
return -1;
CHECK_IOPORT_CLOSED("get-file-column", port);
CHECK_IOPORT_CLOSED("get-file-column", ip);
col = ip->column;
@ -2968,9 +2986,11 @@ scheme_tell_column (Scheme_Object *port)
void
scheme_tell_all (Scheme_Object *port, long *_line, long *_col, long *_pos)
{
Scheme_Port *ip = (Scheme_Port *)port;
Scheme_Port *ip;
long line = -1, col = -1, pos = -1;
ip = scheme_port_record(port);
if (ip->count_lines && ip->location_fun) {
Scheme_Location_Fun location_fun;
Scheme_Object *r, *a[3];
@ -3039,7 +3059,9 @@ scheme_tell_all (Scheme_Object *port, long *_line, long *_col, long *_pos)
void
scheme_count_lines (Scheme_Object *port)
{
Scheme_Port *ip = (Scheme_Port *)port;
Scheme_Port *ip;
ip = scheme_port_record(port);
if (!ip->count_lines) {
ip->count_lines = 1;
@ -3055,7 +3077,7 @@ scheme_close_input_port (Scheme_Object *port)
{
Scheme_Input_Port *ip;
ip = (Scheme_Input_Port *)port;
ip = scheme_input_port_record(port);
if (!ip->closed) {
if (ip->close_fun) {
@ -3103,11 +3125,13 @@ scheme_put_byte_string(const char *who, Scheme_Object *port,
have to deal with peeks and specials, so it's a thin wrapper on
the port's function. */
Scheme_Output_Port *op = (Scheme_Output_Port *)port;
Scheme_Output_Port *op;
Scheme_Write_String_Fun ws;
long out, llen, oout;
int enable_break;
op = scheme_output_port_record(port);
CHECK_PORT_CLOSED(who, "output", port, op->closed);
ws = op->write_string_fun;
@ -3203,7 +3227,7 @@ scheme_close_output_port(Scheme_Object *port)
{
Scheme_Output_Port *op;
op = (Scheme_Output_Port *)port;
op = scheme_output_port_record(port);
if (!op->closed) {
/* call close function first; it might raise an exception */
@ -3255,8 +3279,10 @@ scheme_file_stream_port_p (int argc, Scheme_Object *argv[])
{
Scheme_Object *p = argv[0];
if (SCHEME_INPORTP(p)) {
Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
if (SCHEME_INPUT_PORTP(p)) {
Scheme_Input_Port *ip;
ip = scheme_input_port_record(p);
if (SAME_OBJ(ip->sub_type, file_input_port_type))
return scheme_true;
@ -3264,8 +3290,10 @@ scheme_file_stream_port_p (int argc, Scheme_Object *argv[])
else if (SAME_OBJ(ip->sub_type, fd_input_port_type))
return scheme_true;
#endif
} else if (SCHEME_OUTPORTP(p)) {
Scheme_Output_Port *op = (Scheme_Output_Port *)p;
} else if (SCHEME_OUTPUT_PORTP(p)) {
Scheme_Output_Port *op;
op = scheme_output_port_record(p);
if (SAME_OBJ(op->sub_type, file_output_port_type))
return scheme_true;
@ -3285,8 +3313,10 @@ int scheme_get_port_file_descriptor(Scheme_Object *p, long *_fd)
long fd = 0;
int fd_ok = 0;
if (SCHEME_INPORTP(p)) {
Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
if (SCHEME_INPUT_PORTP(p)) {
Scheme_Input_Port *ip;
ip = scheme_input_port_record(p);
if (!ip->closed) {
if (SAME_OBJ(ip->sub_type, file_input_port_type)) {
@ -3300,8 +3330,10 @@ int scheme_get_port_file_descriptor(Scheme_Object *p, long *_fd)
}
#endif
}
} else if (SCHEME_OUTPORTP(p)) {
Scheme_Output_Port *op = (Scheme_Output_Port *)p;
} else if (SCHEME_OUTPUT_PORTP(p)) {
Scheme_Output_Port *op;
op = scheme_output_port_record(p);
if (!op->closed) {
if (SAME_OBJ(op->sub_type, file_output_port_type)) {
@ -3336,12 +3368,16 @@ Scheme_Object *scheme_file_identity(int argc, Scheme_Object *argv[])
if (!fd_ok) {
/* Maybe failed because it was closed... */
if (SCHEME_INPORTP(p)) {
Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
if (SCHEME_INPUT_PORTP(p)) {
Scheme_Input_Port *ip;
ip = scheme_input_port_record(p);
CHECK_PORT_CLOSED("port-file-identity", "input", p, ip->closed);
} else if (SCHEME_OUTPORTP(p)) {
Scheme_Output_Port *op = (Scheme_Output_Port *)p;
} else if (SCHEME_OUTPUT_PORTP(p)) {
Scheme_Output_Port *op;
op = scheme_output_port_record(p);
CHECK_PORT_CLOSED("port-file-identity", "output", p, op->closed);
}
@ -3374,8 +3410,10 @@ Scheme_Object *scheme_terminal_port_p(int argc, Scheme_Object *argv[])
p = argv[0];
if (SCHEME_INPORTP(p)) {
Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
if (SCHEME_INPUT_PORTP(p)) {
Scheme_Input_Port *ip;
ip = scheme_input_port_record(p);
if (ip->closed)
return scheme_false;
@ -3390,8 +3428,10 @@ Scheme_Object *scheme_terminal_port_p(int argc, Scheme_Object *argv[])
fd_ok = 1;
}
#endif
} else if (SCHEME_OUTPORTP(p)) {
Scheme_Output_Port *op = (Scheme_Output_Port *)p;
} else if (SCHEME_OUTPUT_PORTP(p)) {
Scheme_Output_Port *op;
op = scheme_output_port_record(p);
if (op->closed)
return scheme_false;
@ -3999,7 +4039,7 @@ scheme_file_position(int argc, Scheme_Object *argv[])
#endif
int wis;
if (!SCHEME_OUTPORTP(argv[0]) && !SCHEME_INPORTP(argv[0]))
if (!SCHEME_OUTPUT_PORTP(argv[0]) && !SCHEME_INPUT_PORTP(argv[0]))
scheme_wrong_type("file-position", "port", 0, argc, argv);
if (argc == 2) {
if (!SCHEME_EOFP(argv[1])) {
@ -4026,10 +4066,11 @@ scheme_file_position(int argc, Scheme_Object *argv[])
had_fd = 0;
#endif
if (SCHEME_OUTPORTP(argv[0])) {
if (!SCHEME_INPUT_PORTP(argv[0])) {
Scheme_Output_Port *op;
op = (Scheme_Output_Port *)argv[0];
op = scheme_output_port_record(argv[0]);
if (SAME_OBJ(op->sub_type, file_output_port_type)) {
f = ((Scheme_Output_File *)op->port_data)->f;
#ifdef MZ_FDS
@ -4042,10 +4083,11 @@ scheme_file_position(int argc, Scheme_Object *argv[])
wis = 1;
} else if (argc < 2)
return scheme_make_integer(scheme_output_tell(argv[0]));
} else if (SCHEME_INPORTP(argv[0])) {
} else {
Scheme_Input_Port *ip;
ip = (Scheme_Input_Port *)argv[0];
ip = scheme_input_port_record(argv[0]);
if (SAME_OBJ(ip->sub_type, file_input_port_type)) {
f = ((Scheme_Input_File *)ip->port_data)->f;
#ifdef MZ_FDS
@ -4057,7 +4099,7 @@ scheme_file_position(int argc, Scheme_Object *argv[])
is = (Scheme_Indexed_String *)ip->port_data;
else if (argc < 2) {
long pos;
pos = ((Scheme_Input_Port *)argv[0])->p.position;
pos = ip->p.position;
if (pos < 0) {
scheme_raise_exn(MZEXN_FAIL,
"the port's current position is not known: %v",
@ -4106,8 +4148,8 @@ scheme_file_position(int argc, Scheme_Object *argv[])
} else if (had_fd) {
long lv;
if (SCHEME_OUTPORTP(argv[0])) {
flush_fd((Scheme_Output_Port *)argv[0], NULL, 0, 0, 0, 0);
if (!SCHEME_INPUT_PORTP(argv[0])) {
flush_fd(scheme_output_port_record(argv[0]), NULL, 0, 0, 0, 0);
}
# ifdef WINDOWS_FILE_HANDLES
@ -4138,14 +4180,16 @@ scheme_file_position(int argc, Scheme_Object *argv[])
errno);
}
if (SCHEME_INPORTP(argv[0])) {
if (SCHEME_INPUT_PORTP(argv[0])) {
/* Get rid of buffered data: */
Scheme_FD *sfd;
sfd = (Scheme_FD *)((Scheme_Input_Port *)argv[0])->port_data;
Scheme_Input_Port *ip;
ip = scheme_input_port_record(argv[0]);
sfd = (Scheme_FD *)ip->port_data;
sfd->bufcount = 0;
sfd->buffpos = 0;
/* 1 means no pending eof, but can set: */
((Scheme_Input_Port *)argv[0])->pending_eof = 1;
ip->pending_eof = 1;
}
#endif
} else {
@ -4182,9 +4226,9 @@ scheme_file_position(int argc, Scheme_Object *argv[])
}
/* Remove any chars saved from peeks: */
if (SCHEME_INPORTP(argv[0])) {
if (SCHEME_INPUT_PORTP(argv[0])) {
Scheme_Input_Port *ip;
ip = (Scheme_Input_Port *)argv[0];
ip = scheme_input_port_record(argv[0]);
ip->ungotten_count = 0;
if (pipe_char_count(ip->peeked_read)) {
ip->peeked_read = NULL;
@ -4216,16 +4260,20 @@ scheme_file_position(int argc, Scheme_Object *argv[])
# endif
# endif
if (p < 0) {
if (SCHEME_INPORTP(argv[0])) {
if (SCHEME_INPUT_PORTP(argv[0])) {
p = scheme_tell(argv[0]);
} else {
p = scheme_output_tell(argv[0]);
}
} else {
if (SCHEME_OUTPORTP(argv[0])) {
p += ((Scheme_FD *)((Scheme_Output_Port *)argv[0])->port_data)->bufcount;
if (SCHEME_INPUT_PORTP(argv[0])) {
Scheme_Input_Port *ip;
ip = scheme_input_port_record(argv[0]);
p -= ((Scheme_FD *)ip->port_data)->bufcount;
} else {
p -= ((Scheme_FD *)((Scheme_Input_Port *)argv[0])->port_data)->bufcount;
Scheme_Output_Port *op;
op = scheme_output_port_record(argv[0]);
p += ((Scheme_FD *)op->port_data)->bufcount;
}
}
#endif
@ -4240,9 +4288,9 @@ scheme_file_position(int argc, Scheme_Object *argv[])
}
/* Back up for un-gotten & peeked chars: */
if (SCHEME_INPORTP(argv[0])) {
if (SCHEME_INPUT_PORTP(argv[0])) {
Scheme_Input_Port *ip;
ip = (Scheme_Input_Port *)argv[0];
ip = scheme_input_port_record(argv[0]);
p -= ip->ungotten_count;
p -= pipe_char_count(ip->peeked_read);
}
@ -4272,10 +4320,10 @@ scheme_file_buffer(int argc, Scheme_Object *argv[])
{
Scheme_Port *p = NULL;
if (!SCHEME_OUTPORTP(argv[0]) && !SCHEME_INPORTP(argv[0]))
if (!SCHEME_OUTPUT_PORTP(argv[0]) && !SCHEME_INPUT_PORTP(argv[0]))
scheme_wrong_type("file-stream-buffer-mode", "port", 0, argc, argv);
p = (Scheme_Port *)argv[0];
p = scheme_port_record(argv[0]);
if (argc == 1) {
Scheme_Buffer_Mode_Fun bm;
@ -4302,7 +4350,7 @@ scheme_file_buffer(int argc, Scheme_Object *argv[])
&& !SAME_OBJ(s, scheme_none_symbol))
scheme_wrong_type("file-stream-buffer-mode", "'none, 'line, or 'block", 1, argc, argv);
if (SCHEME_INPORTP(argv[0]) && SAME_OBJ(s, scheme_line_symbol))
if (SCHEME_INPUT_PORTP(argv[0]) && SAME_OBJ(s, scheme_line_symbol))
scheme_arg_mismatch("file-stream-buffer-mode",
"'line buffering not supported for an input port: ",
argv[0]);
@ -4393,10 +4441,13 @@ file_buffer_mode(Scheme_Port *p, int mode)
if (mode < 0)
return -1; /* unknown mode */
if (SCHEME_INPORTP(p))
f = ((Scheme_Output_File *)((Scheme_Input_Port *)p)->port_data)->f;
else
f = ((Scheme_Output_File *)((Scheme_Output_Port *)p)->port_data)->f;
if (SCHEME_INPORTP((Scheme_Object *)p)) {
Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
f = ((Scheme_Output_File *)ip->port_data)->f;
} else {
Scheme_Output_Port *op = (Scheme_Output_Port *)p;
f = ((Scheme_Output_File *)op->port_data)->f;
}
if (mode == MZ_FLUSH_NEVER)
bad = setvbuf(f, NULL, _IOFBF, 0);
@ -4945,8 +4996,9 @@ fd_need_wakeup(Scheme_Input_Port *port, void *fds)
static int fd_input_buffer_mode(Scheme_Port *p, int mode)
{
Scheme_FD *fd;
Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
fd = (Scheme_FD *)((Scheme_Input_Port *)p)->port_data;
fd = (Scheme_FD *)ip->port_data;
if (mode < 0) {
return fd->flush;
@ -5447,8 +5499,11 @@ static int
fd_flush_done(Scheme_Object *port)
{
Scheme_FD *fop;
Scheme_Output_Port *op;
fop = (Scheme_FD *)((Scheme_Output_Port *)port)->port_data;
op = scheme_output_port_record(port);
fop = (Scheme_FD *)op->port_data;
return !fop->flushing;
}
@ -5506,10 +5561,12 @@ fd_write_ready (Scheme_Object *port)
the port has been flushed. */
Scheme_FD *fop;
Scheme_Output_Port *op;
fop = (Scheme_FD *)((Scheme_Output_Port *)port)->port_data;
op = scheme_output_port_record(port);
fop = (Scheme_FD *)op->port_data;
if (fop->regfile || ((Scheme_Output_Port *)port)->closed)
if (fop->regfile || op->closed)
return 1;
#ifdef WINDOWS_FILE_HANDLES
@ -5568,6 +5625,7 @@ fd_write_ready (Scheme_Object *port)
static void
fd_write_need_wakeup(Scheme_Object *port, void *fds)
{
Scheme_Output_Port *op;
Scheme_FD *fop;
#ifdef WINDOWS_FILE_HANDLES
@ -5579,7 +5637,8 @@ fd_write_need_wakeup(Scheme_Object *port, void *fds)
# endif
#endif
fop = (Scheme_FD *)((Scheme_Output_Port *)port)->port_data;
op = scheme_output_port_record(port);
fop = (Scheme_FD *)op->port_data;
#ifdef WINDOWS_FILE_HANDLES
if (fop->oth && !fd_write_ready(port))
@ -6150,8 +6209,9 @@ fd_close_output(Scheme_Output_Port *port)
static int fd_output_buffer_mode(Scheme_Port *p, int mode)
{
Scheme_FD *fd;
fd = (Scheme_FD *)((Scheme_Output_Port *)p)->port_data;
Scheme_Output_Port *op = (Scheme_Output_Port *)p;
fd = (Scheme_FD *)op->port_data;
if (mode < 0) {
return fd->flush;
@ -6160,7 +6220,7 @@ static int fd_output_buffer_mode(Scheme_Port *p, int mode)
go = (mode > fd->flush);
fd->flush = mode;
if (go)
flush_fd((Scheme_Output_Port *)p, NULL, 0, 0, 0, 0);
flush_fd(op, NULL, 0, 0, 0, 0);
return mode;
}
}
@ -6232,8 +6292,9 @@ make_fd_output_port(int fd, Scheme_Object *name, int regfile, int win_textmode,
static void flush_if_output_fds(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data)
{
if (SCHEME_OUTPORTP(o)) {
Scheme_Output_Port *op = (Scheme_Output_Port *)o;
if (SCHEME_OUTPUT_PORTP(o)) {
Scheme_Output_Port *op;
op = scheme_output_port_record(o);
if (SAME_OBJ(op->sub_type, fd_output_port_type)) {
scheme_flush_output(o);
}
@ -6606,7 +6667,8 @@ scheme_make_redirect_output_port(Scheme_Object *port)
Scheme_Output_Port *op;
int can_write_special;
can_write_special = !!((Scheme_Output_Port *)port)->write_special_fun;
op = scheme_output_port_record(port);
can_write_special = !!op->write_special_fun;
op = scheme_make_output_port(scheme_redirect_output_port_type,
port,
@ -6959,9 +7021,11 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
if (SCHEME_TRUEP(args[0])) {
outport = args[0];
if (SCHEME_OUTPORTP(outport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &outport))) {
if (SCHEME_OUTPUT_PORTP(outport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &outport))) {
#ifdef PROCESS_FUNCTION
Scheme_Output_Port *op = (Scheme_Output_Port *)outport;
Scheme_Output_Port *op;
op = scheme_output_port_record(outport);
if (SAME_OBJ(op->sub_type, file_output_port_type)) {
int tmp;
@ -6980,9 +7044,11 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
if (SCHEME_TRUEP(args[1])) {
inport = args[1];
if (SCHEME_INPORTP(inport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &inport))) {
if (SCHEME_INPUT_PORTP(inport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &inport))) {
#ifdef PROCESS_FUNCTION
Scheme_Input_Port *ip = (Scheme_Input_Port *)inport;
Scheme_Input_Port *ip;
ip = scheme_input_port_record(inport);
if (SAME_OBJ(ip->sub_type, file_input_port_type)) {
int tmp;
@ -7001,9 +7067,11 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
if (SCHEME_TRUEP(args[2])) {
errport = args[2];
if (SCHEME_OUTPORTP(errport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &errport))) {
if (SCHEME_OUTPUT_PORTP(errport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &errport))) {
#ifdef PROCESS_FUNCTION
Scheme_Output_Port *op = (Scheme_Output_Port *)errport;
Scheme_Output_Port *op;
op = scheme_output_port_record(errport);
if (SAME_OBJ(op->sub_type, file_output_port_type)) {
int tmp;
@ -8016,7 +8084,9 @@ void scheme_start_itimer_thread(long usec)
void scheme_count_input_port(Scheme_Object *port, long *s, long *e,
Scheme_Hash_Table *ht)
{
Scheme_Input_Port *ip = (Scheme_Input_Port *)port;
Scheme_Input_Port *ip;
ip = scheme_input_port_record(port);
*e = (ht ? scheme_count_memory(ip->read_handler, ht) : 0);
*s = sizeof(Scheme_Input_Port);
@ -8053,7 +8123,9 @@ void scheme_count_input_port(Scheme_Object *port, long *s, long *e,
void scheme_count_output_port(Scheme_Object *port, long *s, long *e,
Scheme_Hash_Table *ht)
{
Scheme_Output_Port *op = (Scheme_Output_Port *)port;
Scheme_Output_Port *op;
op = scheme_output_port_record(port);
*e = 0;
*s = sizeof(Scheme_Output_Port);

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

@ -144,6 +144,8 @@ Scheme_Object *scheme_default_global_print_handler;
Scheme_Object *scheme_write_proc, *scheme_display_proc, *scheme_print_proc;
static Scheme_Object *dummy_input_port, *dummy_output_port;
#define fail_err_symbol scheme_false
/*========================================================================*/
@ -753,6 +755,98 @@ void scheme_init_port_fun_config(void)
scheme_default_global_print_handler);
}
/*========================================================================*/
/* port records */
/*========================================================================*/
Scheme_Port *scheme_port_record(Scheme_Object *port)
{
if (scheme_is_input_port(port))
return (Scheme_Port *)scheme_input_port_record(port);
else
return (Scheme_Port *)scheme_output_port_record(port);
}
Scheme_Input_Port *scheme_input_port_record(Scheme_Object *port)
{
Scheme_Object *v;
while (1) {
if (SCHEME_INPORTP(port))
return (Scheme_Input_Port *)port;
if (!SCHEME_STRUCTP(port)) {
/* Use dummy port: */
if (!dummy_input_port) {
REGISTER_SO(dummy_input_port);
dummy_input_port = scheme_make_byte_string_input_port("");
}
return (Scheme_Input_Port *)dummy_input_port;
}
v = scheme_struct_type_property_ref(scheme_input_port_property, port);
if (!v)
v = scheme_false;
else if (SCHEME_INTP(v))
v = ((Scheme_Structure *)port)->slots[SCHEME_INT_VAL(v)];
port = v;
SCHEME_USE_FUEL(1);
}
}
Scheme_Output_Port *scheme_output_port_record(Scheme_Object *port)
{
Scheme_Object *v;
while (1) {
if (SCHEME_OUTPORTP(port))
return (Scheme_Output_Port *)port;
if (!SCHEME_STRUCTP(port)) {
/* Use dummy port: */
if (!dummy_output_port) {
REGISTER_SO(dummy_output_port);
dummy_output_port = scheme_make_null_output_port(1);
}
return (Scheme_Output_Port *)dummy_output_port;
}
v = scheme_struct_type_property_ref(scheme_output_port_property, port);
if (!v)
v = scheme_false;
else if (SCHEME_INTP(v))
v = ((Scheme_Structure *)port)->slots[SCHEME_INT_VAL(v)];
port = v;
SCHEME_USE_FUEL(1);
}
}
int scheme_is_input_port(Scheme_Object *port)
{
if (SCHEME_INPORTP(port))
return 1;
if (SCHEME_STRUCTP(port))
if (scheme_struct_type_property_ref(scheme_input_port_property, port))
return 1;
return 0;
}
int scheme_is_output_port(Scheme_Object *port)
{
if (SCHEME_OUTPORTP(port))
return 1;
if (SCHEME_STRUCTP(port))
if (scheme_struct_type_property_ref(scheme_output_port_property, port))
return 1;
return 0;
}
/*========================================================================*/
/* string input ports */
/*========================================================================*/
@ -960,10 +1054,10 @@ scheme_get_sized_byte_string_output(Scheme_Object *port, long *size)
char *v;
long len;
if (!SCHEME_OUTPORTP(port))
if (!SCHEME_OUTPUT_PORTP(port))
return NULL;
op = (Scheme_Output_Port *)port;
op = scheme_output_port_record(port);
if (op->sub_type != scheme_string_output_port_type)
return NULL;
@ -1379,8 +1473,8 @@ user_close_input(Scheme_Input_Port *port)
static Scheme_Object *
user_input_location(Scheme_Port *p)
{
Scheme_Input_Port *port = (Scheme_Input_Port *)p;
User_Input_Port *uip = (User_Input_Port *)port->port_data;
Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
User_Input_Port *uip = (User_Input_Port *)ip->port_data;
return scheme_apply_multi(uip->location_proc, 0, NULL);
}
@ -1388,8 +1482,8 @@ user_input_location(Scheme_Port *p)
static void
user_input_count_lines(Scheme_Port *p)
{
Scheme_Input_Port *port = (Scheme_Input_Port *)p;
User_Input_Port *uip = (User_Input_Port *)port->port_data;
Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
User_Input_Port *uip = (User_Input_Port *)ip->port_data;
scheme_apply_multi(uip->count_lines_proc, 0, NULL);
}
@ -1438,9 +1532,9 @@ user_buffer_mode(Scheme_Object *buffer_mode_proc, int mode, int line_ok)
static int
user_input_buffer_mode(Scheme_Port *p, int mode)
{
Scheme_Input_Port *port = (Scheme_Input_Port *)p;
User_Input_Port *uip = (User_Input_Port *)port->port_data;
Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
User_Input_Port *uip = (User_Input_Port *)ip->port_data;
return user_buffer_mode(uip->buffer_mode_proc, mode, 0);
}
@ -1736,8 +1830,8 @@ user_write_special_evt (Scheme_Output_Port *port, Scheme_Object *v)
static Scheme_Object *
user_output_location(Scheme_Port *p)
{
Scheme_Output_Port *port = (Scheme_Output_Port *)p;
User_Output_Port *uop = (User_Output_Port *)port->port_data;
Scheme_Output_Port *op = (Scheme_Output_Port *)p;
User_Output_Port *uop = (User_Output_Port *)op->port_data;
return scheme_apply_multi(uop->location_proc, 0, NULL);
}
@ -1745,8 +1839,8 @@ user_output_location(Scheme_Port *p)
static void
user_output_count_lines(Scheme_Port *p)
{
Scheme_Output_Port *port = (Scheme_Output_Port *)p;
User_Output_Port *uop = (User_Output_Port *)port->port_data;
Scheme_Output_Port *op = (Scheme_Output_Port *)p;
User_Output_Port *uop = (User_Output_Port *)op->port_data;
scheme_apply_multi(uop->count_lines_proc, 0, NULL);
}
@ -1754,20 +1848,22 @@ user_output_count_lines(Scheme_Port *p)
static int
user_output_buffer_mode(Scheme_Port *p, int mode)
{
Scheme_Output_Port *port = (Scheme_Output_Port *)p;
User_Output_Port *uop = (User_Output_Port *)port->port_data;
Scheme_Output_Port *op = (Scheme_Output_Port *)p;
User_Output_Port *uop = (User_Output_Port *)op->port_data;
return user_buffer_mode(uop->buffer_mode_proc, mode, 1);
}
int scheme_is_user_port(Scheme_Object *port)
{
if (SCHEME_INPORTP(port)) {
return SAME_OBJ(scheme_user_input_port_type,
((Scheme_Input_Port *)port)->sub_type);
if (SCHEME_INPUT_PORTP(port)) {
Scheme_Input_Port *ip;
ip = scheme_input_port_record(port);
return SAME_OBJ(scheme_user_input_port_type, ip->sub_type);
} else {
return SAME_OBJ(scheme_user_output_port_type,
((Scheme_Output_Port *)port)->sub_type);
Scheme_Output_Port *op;
op = scheme_output_port_record(port);
return SAME_OBJ(scheme_user_output_port_type, op->sub_type);
}
}
@ -2267,13 +2363,15 @@ static Scheme_Object *pipe_length(int argc, Scheme_Object **argv)
int avail;
o = argv[0];
if (SCHEME_OUTPORTP(o)) {
Scheme_Output_Port *op = (Scheme_Output_Port *)o;
if (SCHEME_OUTPUT_PORTP(o)) {
Scheme_Output_Port *op;
op = scheme_output_port_record(o);
if (op->sub_type == scheme_pipe_write_port_type) {
pipe = (Scheme_Pipe *)op->port_data;
}
} else if (SCHEME_INPORTP(o)) {
Scheme_Input_Port *ip = (Scheme_Input_Port *)o;
} else if (SCHEME_INPUT_PORTP(o)) {
Scheme_Input_Port *ip;
ip = scheme_input_port_record(o);
if (ip->sub_type == scheme_pipe_read_port_type) {
pipe = (Scheme_Pipe *)ip->port_data;
}
@ -2302,34 +2400,34 @@ static Scheme_Object *pipe_length(int argc, Scheme_Object **argv)
static Scheme_Object *
input_port_p (int argc, Scheme_Object *argv[])
{
return (SCHEME_INPORTP(argv[0]) ? scheme_true : scheme_false);
return (SCHEME_INPUT_PORTP(argv[0]) ? scheme_true : scheme_false);
}
static Scheme_Object *
output_port_p (int argc, Scheme_Object *argv[])
{
return (SCHEME_OUTPORTP(argv[0]) ? scheme_true : scheme_false);
return (SCHEME_OUTPUT_PORTP(argv[0]) ? scheme_true : scheme_false);
}
static Scheme_Object *current_input_port(int argc, Scheme_Object *argv[])
{
return scheme_param_config("current-input-port", scheme_make_integer(MZCONFIG_INPUT_PORT),
argc, argv,
-1, input_port_p, "input port", 0);
-1, input_port_p, "input-port", 0);
}
static Scheme_Object *current_output_port(int argc, Scheme_Object *argv[])
{
return scheme_param_config("current-output-port", scheme_make_integer(MZCONFIG_OUTPUT_PORT),
argc, argv,
-1, output_port_p, "output port", 0);
-1, output_port_p, "output-port", 0);
}
static Scheme_Object *current_error_port(int argc, Scheme_Object *argv[])
{
return scheme_param_config("current-error-port", scheme_make_integer(MZCONFIG_ERROR_PORT),
argc, argv,
-1, output_port_p, "output port", 0);
-1, output_port_p, "output-port", 0);
}
static Scheme_Object *
@ -2630,8 +2728,8 @@ Scheme_Object *do_get_output_string(const char *who, int is_byte,
char *s;
long size;
op = (Scheme_Output_Port *)argv[0];
if (!SCHEME_OUTPORTP(argv[0])
op = scheme_output_port_record(argv[0]);
if (!SCHEME_OUTPUT_PORTP(argv[0])
|| (op->sub_type != scheme_string_output_port_type))
scheme_wrong_type(who, "string output port", 0, argc, argv);
@ -2658,20 +2756,20 @@ get_output_char_string (int argc, Scheme_Object *argv[])
static Scheme_Object *
close_input_port (int argc, Scheme_Object *argv[])
{
if (!SCHEME_INPORTP(argv[0]))
if (!SCHEME_INPUT_PORTP(argv[0]))
scheme_wrong_type("close-input-port", "input-port", 0, argc, argv);
scheme_close_input_port (argv[0]);
scheme_close_input_port(argv[0]);
return (scheme_void);
}
static Scheme_Object *
close_output_port (int argc, Scheme_Object *argv[])
{
if (!SCHEME_OUTPORTP(argv[0]))
if (!SCHEME_OUTPUT_PORTP(argv[0]))
scheme_wrong_type("close-output-port", "output-port", 0, argc, argv);
scheme_close_output_port (argv[0]);
scheme_close_output_port(argv[0]);
return (scheme_void);
}
@ -2803,7 +2901,7 @@ static Scheme_Object *sch_default_read_handler(void *ignore, int argc, Scheme_Ob
{
Scheme_Object *src;
if (!SCHEME_INPORTP(argv[0]))
if (!SCHEME_INPUT_PORTP(argv[0]))
scheme_wrong_type("default-port-read-handler", "input-port", 0, argc, argv);
if ((Scheme_Object *)argv[0] == scheme_orig_stdin_port)
@ -2844,8 +2942,9 @@ static Scheme_Object *do_read_f(const char *who, int argc, Scheme_Object *argv[]
{
Scheme_Object *port, *readtable = NULL;
int pre_char = -1;
Scheme_Input_Port *ip;
if (argc && !SCHEME_INPORTP(argv[0]))
if (argc && !SCHEME_INPUT_PORTP(argv[0]))
scheme_wrong_type(who, "input-port", 0, argc, argv);
if (argc)
@ -2857,10 +2956,12 @@ static Scheme_Object *do_read_f(const char *who, int argc, Scheme_Object *argv[]
pre_char = extract_recur_args(who, argc, argv, 0, &readtable);
}
if (((Scheme_Input_Port *)port)->read_handler && !honu_mode && !recur) {
ip = scheme_input_port_record(port);
if (ip->read_handler && !honu_mode && !recur) {
Scheme_Object *o[1];
o[0] = port;
return _scheme_apply(((Scheme_Input_Port *)port)->read_handler, 1, o);
return _scheme_apply(ip->read_handler, 1, o);
} else {
if (port == scheme_orig_stdin_port)
scheme_flush_orig_outputs();
@ -2893,8 +2994,9 @@ static Scheme_Object *do_read_syntax_f(const char *who, int argc, Scheme_Object
{
Scheme_Object *port, *readtable = NULL;
int pre_char = -1;
Scheme_Input_Port *ip;
if ((argc > 1) && !SCHEME_INPORTP(argv[1]))
if ((argc > 1) && !SCHEME_INPUT_PORTP(argv[1]))
scheme_wrong_type(who, "input-port", 1, argc, argv);
if (argc > 1)
@ -2906,12 +3008,14 @@ static Scheme_Object *do_read_syntax_f(const char *who, int argc, Scheme_Object
pre_char = extract_recur_args(who, argc, argv, 1, &readtable);
}
if (((Scheme_Input_Port *)port)->read_handler && !honu_mode && !recur) {
ip = scheme_input_port_record(port);
if (ip->read_handler && !honu_mode && !recur) {
Scheme_Object *o[2], *result;
o[0] = port;
o[1] = (argc ? argv[0] : ((Scheme_Input_Port *)port)->name);
o[1] = (argc ? argv[0] : ip->name);
result = _scheme_apply(((Scheme_Input_Port *)port)->read_handler, 2, o);
result = _scheme_apply(ip->read_handler, 2, o);
if (SCHEME_STXP(result) || SCHEME_EOFP(result))
return result;
else {
@ -2923,7 +3027,7 @@ static Scheme_Object *do_read_syntax_f(const char *who, int argc, Scheme_Object
} else {
Scheme_Object *src;
src = (argc ? argv[0] : ((Scheme_Input_Port *)port)->name);
src = (argc ? argv[0] : ip->name);
if (port == scheme_orig_stdin_port)
scheme_flush_orig_outputs();
@ -2958,7 +3062,7 @@ do_read_char(char *name, int argc, Scheme_Object *argv[], int peek, int spec, in
Scheme_Object *port;
int ch;
if (argc && !SCHEME_INPORTP(argv[0]))
if (argc && !SCHEME_INPUT_PORTP(argv[0]))
scheme_wrong_type(name, "input-port", 0, argc, argv);
if (argc)
@ -3086,7 +3190,7 @@ do_read_line (int as_bytes, const char *who, int argc, Scheme_Object *argv[])
char *buf, *oldbuf, onstack[32];
long size = 31, oldsize, i = 0;
if (argc && !SCHEME_INPORTP(argv[0]))
if (argc && !SCHEME_INPUT_PORTP(argv[0]))
scheme_wrong_type(who, "input-port", 0, argc, argv);
if (argc > 1) {
@ -3245,8 +3349,8 @@ do_general_read_bytes(int as_bytes,
delta = 0;
}
if ((argc > (1+delta)) && !SCHEME_INPORTP(argv[1+delta]))
scheme_wrong_type(who, "input port", 1+delta, argc, argv);
if ((argc > (1+delta)) && !SCHEME_INPUT_PORTP(argv[1+delta]))
scheme_wrong_type(who, "input-port", 1+delta, argc, argv);
if (alloc_mode) {
start = 0;
@ -3406,8 +3510,8 @@ peeked_read(int argc, Scheme_Object *argv[])
if (argc > 3) {
port = argv[3];
if (!SCHEME_INPORTP(port))
scheme_wrong_type("port-commit-peeked", "input port", 3, argc, argv);
if (!SCHEME_INPUT_PORTP(port))
scheme_wrong_type("port-commit-peeked", "input-port", 3, argc, argv);
} else
port = CURRENT_INPUT_PORT(scheme_current_config());
@ -3477,8 +3581,8 @@ progress_evt(int argc, Scheme_Object *argv[])
Scheme_Object *port, *v;
if (argc) {
if (!SCHEME_INPORTP(argv[0])) {
scheme_wrong_type("port-progress-evt", "input port", 0, argc, argv);
if (!SCHEME_INPUT_PORTP(argv[0])) {
scheme_wrong_type("port-progress-evt", "input-port", 0, argc, argv);
return NULL;
}
port = argv[0];
@ -3511,7 +3615,7 @@ do_write_bytes_avail(int as_bytes, const char *who,
return NULL;
} else
str = argv[0];
if ((argc > 1) && !SCHEME_OUTPORTP(argv[1]))
if ((argc > 1) && !SCHEME_OUTPUT_PORTP(argv[1]))
scheme_wrong_type(who, "output-port", 1, argc, argv);
scheme_get_substring_indices(who, str,
@ -3581,22 +3685,25 @@ write_bytes_avail_evt(int argc, Scheme_Object *argv[])
static Scheme_Object *
do_write_special(const char *name, int argc, Scheme_Object *argv[], int nonblock, int get_evt)
{
Scheme_Output_Port *op;
Scheme_Object *port;
int ok;
if (argc > 1) {
if (!SCHEME_OUTPORTP(argv[1]))
if (!SCHEME_OUTPUT_PORTP(argv[1]))
scheme_wrong_type(name, "output-port", 1, argc, argv);
port = argv[1];
} else
port = CURRENT_OUTPUT_PORT(scheme_current_config());
if (((Scheme_Output_Port *)port)->write_special_fun) {
op = scheme_output_port_record(port);
if (op->write_special_fun) {
if (get_evt) {
return scheme_make_write_evt(name, port, argv[0], NULL, 0, 0);
} else {
Scheme_Write_Special_Fun ws = ((Scheme_Output_Port *)port)->write_special_fun;
ok = ws((Scheme_Output_Port *)port, argv[0], nonblock);
Scheme_Write_Special_Fun ws = op->write_special_fun;
ok = ws(op, argv[0], nonblock);
}
} else {
scheme_arg_mismatch(name,
@ -3606,7 +3713,8 @@ do_write_special(const char *name, int argc, Scheme_Object *argv[], int nonblock
}
if (ok) {
Scheme_Port *ip = (Scheme_Port *)port;
Scheme_Port *ip;
ip = scheme_port_record(port);
if (ip->position >= 0)
ip->position += 1;
if (ip->count_lines) {
@ -3622,10 +3730,13 @@ do_write_special(const char *name, int argc, Scheme_Object *argv[], int nonblock
static Scheme_Object *can_write_atomic(int argc, Scheme_Object *argv[])
{
if (!SCHEME_OUTPORTP(argv[0]))
scheme_wrong_type("port-writes-atomic?", "output port", 0, argc, argv);
Scheme_Output_Port *op;
if (((Scheme_Output_Port *)argv[0])->write_string_evt_fun)
if (!SCHEME_OUTPUT_PORTP(argv[0]))
scheme_wrong_type("port-writes-atomic?", "output-port", 0, argc, argv);
op = scheme_output_port_record(argv[0]);
if (op->write_string_evt_fun)
return scheme_true;
else
return scheme_false;
@ -3633,10 +3744,14 @@ static Scheme_Object *can_write_atomic(int argc, Scheme_Object *argv[])
static Scheme_Object *can_provide_progress_evt(int argc, Scheme_Object *argv[])
{
if (!SCHEME_INPORTP(argv[0]))
scheme_wrong_type("port-provides-progress-evt?", "input port", 0, argc, argv);
Scheme_Input_Port *ip;
if (((Scheme_Input_Port *)argv[0])->progress_evt_fun)
if (!SCHEME_INPUT_PORTP(argv[0]))
scheme_wrong_type("port-provides-progress-evt?", "input-port", 0, argc, argv);
ip = scheme_input_port_record(argv[0]);
if (ip->progress_evt_fun)
return scheme_true;
else
return scheme_false;
@ -3645,10 +3760,14 @@ static Scheme_Object *can_provide_progress_evt(int argc, Scheme_Object *argv[])
static Scheme_Object *
can_write_special(int argc, Scheme_Object *argv[])
{
if (!SCHEME_OUTPORTP(argv[0]))
scheme_wrong_type("port-writes-special?", "output port", 0, argc, argv);
Scheme_Output_Port *op;
if (((Scheme_Output_Port *)argv[0])->write_special_fun)
if (!SCHEME_OUTPUT_PORTP(argv[0]))
scheme_wrong_type("port-writes-special?", "output-port", 0, argc, argv);
op = scheme_output_port_record(argv[0]);
if (op->write_special_fun)
return scheme_true;
else
return scheme_false;
@ -3699,8 +3818,8 @@ char_ready_p (int argc, Scheme_Object *argv[])
{
Scheme_Object *port;
if (argc && !SCHEME_INPORTP(argv[0]))
scheme_wrong_type("char-ready?", "input port", 0, argc, argv);
if (argc && !SCHEME_INPUT_PORTP(argv[0]))
scheme_wrong_type("char-ready?", "input-port", 0, argc, argv);
if (argc)
port = argv[0];
@ -3715,8 +3834,8 @@ byte_ready_p (int argc, Scheme_Object *argv[])
{
Scheme_Object *port;
if (argc && !SCHEME_INPORTP(argv[0]))
scheme_wrong_type("byte-ready?", "input port", 0, argc, argv);
if (argc && !SCHEME_INPUT_PORTP(argv[0]))
scheme_wrong_type("byte-ready?", "input-port", 0, argc, argv);
if (argc)
port = argv[0];
@ -3728,7 +3847,7 @@ byte_ready_p (int argc, Scheme_Object *argv[])
static Scheme_Object *sch_default_display_handler(int argc, Scheme_Object *argv[])
{
if (!SCHEME_OUTPORTP(argv[1]))
if (!SCHEME_OUTPUT_PORTP(argv[1]))
scheme_wrong_type("default-port-display-handler", "output-port", 1, argc, argv);
scheme_internal_display(argv[0], argv[1]);
@ -3738,7 +3857,7 @@ static Scheme_Object *sch_default_display_handler(int argc, Scheme_Object *argv[
static Scheme_Object *sch_default_write_handler(int argc, Scheme_Object *argv[])
{
if (!SCHEME_OUTPORTP(argv[1]))
if (!SCHEME_OUTPUT_PORTP(argv[1]))
scheme_wrong_type("default-port-write-handler", "output-port", 1, argc, argv);
scheme_internal_write(argv[0], argv[1]);
@ -3748,7 +3867,7 @@ static Scheme_Object *sch_default_write_handler(int argc, Scheme_Object *argv[])
static Scheme_Object *sch_default_print_handler(int argc, Scheme_Object *argv[])
{
if (!SCHEME_OUTPORTP(argv[1]))
if (!SCHEME_OUTPUT_PORTP(argv[1]))
scheme_wrong_type("default-port-print-handler", "output-port", 1, argc, argv);
return _scheme_apply(scheme_get_param(scheme_current_config(),
@ -3758,7 +3877,7 @@ static Scheme_Object *sch_default_print_handler(int argc, Scheme_Object *argv[])
static Scheme_Object *sch_default_global_port_print_handler(int argc, Scheme_Object *argv[])
{
if (!SCHEME_OUTPORTP(argv[1]))
if (!SCHEME_OUTPUT_PORTP(argv[1]))
scheme_wrong_type("default-global-port-print-handler", "output-port", 1, argc, argv);
scheme_internal_print(argv[0], argv[1]);
@ -3771,17 +3890,20 @@ display_write(char *name,
int argc, Scheme_Object *argv[], int escape)
{
Scheme_Object *port;
Scheme_Output_Port *op;
if (argc > 1) {
if (!SCHEME_OUTPORTP(argv[1]))
if (!SCHEME_OUTPUT_PORTP(argv[1]))
scheme_wrong_type(name, "output-port", 1, argc, argv);
port = argv[1];
} else
port = CURRENT_OUTPUT_PORT(scheme_current_config());
op = scheme_output_port_record(port);
if (escape > 0) {
/* display */
if (!((Scheme_Output_Port *)port)->display_handler) {
if (!op->display_handler) {
Scheme_Object *v = argv[0];
if (SCHEME_BYTE_STRINGP(v)) {
scheme_put_byte_string(name, port,
@ -3801,13 +3923,13 @@ display_write(char *name,
Scheme_Object *a[2];
a[0] = argv[0];
a[1] = port;
_scheme_apply_multi(((Scheme_Output_Port *)port)->display_handler, 2, a);
_scheme_apply_multi(op->display_handler, 2, a);
}
} else if (!escape) {
/* write */
Scheme_Object *h;
h = ((Scheme_Output_Port *)port)->write_handler;
h = op->write_handler;
if (!h)
scheme_internal_write(argv[0], port);
@ -3825,7 +3947,7 @@ display_write(char *name,
a[0] = argv[0];
a[1] = port;
h = ((Scheme_Output_Port *)port)->print_handler;
h = op->print_handler;
if (!h)
sch_default_print_handler(2, a);
@ -3859,7 +3981,7 @@ newline (int argc, Scheme_Object *argv[])
{
Scheme_Object *port;
if (argc && !SCHEME_OUTPORTP(argv[0]))
if (argc && !SCHEME_OUTPUT_PORTP(argv[0]))
scheme_wrong_type("newline", "output-port", 0, argc, argv);
if (argc)
@ -3886,7 +4008,7 @@ write_byte (int argc, Scheme_Object *argv[])
scheme_wrong_type("write-byte", "exact integer in [0,255]", 0, argc, argv);
if (argc > 1) {
if (!SCHEME_OUTPORTP(argv[1]))
if (!SCHEME_OUTPUT_PORTP(argv[1]))
scheme_wrong_type("write-byte", "output-port", 1, argc, argv);
port = argv[1];
} else
@ -3912,7 +4034,7 @@ write_char (int argc, Scheme_Object *argv[])
if (argc && !SCHEME_CHARP(argv[0]))
scheme_wrong_type("write-char", "character", 0, argc, argv);
if (argc > 1) {
if (!SCHEME_OUTPORTP(argv[1]))
if (!SCHEME_OUTPUT_PORTP(argv[1]))
scheme_wrong_type("write-char", "output-port", 1, argc, argv);
port = argv[1];
} else
@ -3932,10 +4054,10 @@ static Scheme_Object *port_read_handler(int argc, Scheme_Object *argv[])
{
Scheme_Input_Port *ip;
if (!SCHEME_INPORTP(argv[0]))
scheme_wrong_type("port-read-handler", "input port", 0, argc, argv);
if (!SCHEME_INPUT_PORTP(argv[0]))
scheme_wrong_type("port-read-handler", "input-port", 0, argc, argv);
ip = (Scheme_Input_Port *)argv[0];
ip = scheme_input_port_record(argv[0]);
if (argc == 1) {
if (ip->read_handler)
return ip->read_handler;
@ -3962,10 +4084,10 @@ static Scheme_Object *port_display_handler(int argc, Scheme_Object *argv[])
{
Scheme_Output_Port *op;
if (!SCHEME_OUTPORTP(argv[0]))
if (!SCHEME_OUTPUT_PORTP(argv[0]))
scheme_wrong_type("port-display-handler", "output-port", 0, argc, argv);
op = (Scheme_Output_Port *)argv[0];
op = scheme_output_port_record(argv[0]);
if (argc == 1) {
if (op->display_handler)
return op->display_handler;
@ -3986,10 +4108,10 @@ static Scheme_Object *port_write_handler(int argc, Scheme_Object *argv[])
{
Scheme_Output_Port *op;
if (!SCHEME_OUTPORTP(argv[0]))
if (!SCHEME_OUTPUT_PORTP(argv[0]))
scheme_wrong_type("port-write-handler", "output-port", 0, argc, argv);
op = (Scheme_Output_Port *)argv[0];
op = scheme_output_port_record(argv[0]);
if (argc == 1) {
if (op->write_handler)
return op->write_handler;
@ -4010,10 +4132,10 @@ static Scheme_Object *port_print_handler(int argc, Scheme_Object *argv[])
{
Scheme_Output_Port *op;
if (!SCHEME_OUTPORTP(argv[0]))
if (!SCHEME_OUTPUT_PORTP(argv[0]))
scheme_wrong_type("port-print-handler", "output-port", 0, argc, argv);
op = (Scheme_Output_Port *)argv[0];
op = scheme_output_port_record(argv[0]);
if (argc == 1) {
if (op->print_handler)
return op->print_handler;
@ -4040,7 +4162,7 @@ static Scheme_Object *global_port_print_handler(int argc, Scheme_Object *argv[])
static Scheme_Object *port_count_lines(int argc, Scheme_Object *argv[])
{
if (!SCHEME_INPORTP(argv[0]) && !SCHEME_OUTPORTP(argv[0]))
if (!SCHEME_INPUT_PORTP(argv[0]) && !SCHEME_OUTPUT_PORTP(argv[0]))
scheme_wrong_type("port-count-lines!", "port", 0, argc, argv);
scheme_count_lines(argv[0]);
@ -4060,7 +4182,7 @@ static Scheme_Object *port_next_location(int argc, Scheme_Object *argv[])
Scheme_Object *a[3];
long line, col, pos;
if (!SCHEME_INPORTP(argv[0]) && !SCHEME_OUTPORTP(argv[0]))
if (!SCHEME_INPUT_PORTP(argv[0]) && !SCHEME_OUTPUT_PORTP(argv[0]))
scheme_wrong_type("port-next-location", "port", 0, argc, argv);
scheme_tell_all(argv[0], &line, &col, &pos);
@ -4161,11 +4283,15 @@ static Scheme_Object *do_load_handler(void *data)
other = scheme_make_sized_byte_string(s, len + slen + 1, 0);
}
scheme_raise_exn(MZEXN_FAIL,
"default-load-handler: expected a `module' declaration for `%S', found: %T in: %V",
lhd->expected_module,
other,
((Scheme_Input_Port *)port)->name);
{
Scheme_Input_Port *ip;
ip = scheme_input_port_record(port);
scheme_raise_exn(MZEXN_FAIL,
"default-load-handler: expected a `module' declaration for `%S', found: %T in: %V",
lhd->expected_module,
other,
ip->name);
}
return NULL;
}
@ -4173,10 +4299,13 @@ static Scheme_Object *do_load_handler(void *data)
/* Check no more expressions: */
d = scheme_internal_read(port, lhd->stxsrc, 1, 0, 0, 0, -1, NULL, NULL, NULL);
if (!SCHEME_EOFP(d)) {
Scheme_Input_Port *ip;
ip = scheme_input_port_record(port);
scheme_raise_exn(MZEXN_FAIL,
"default-load-handler: expected only a `module' declaration for `%S', but found an extra expression in: %V",
"default-load-handler: expected only a `module' declaration for `%S',"
" but found an extra expression in: %V",
lhd->expected_module,
((Scheme_Input_Port *)port)->name);
ip->name);
return NULL;
}
@ -4189,6 +4318,11 @@ static Scheme_Object *do_load_handler(void *data)
d = scheme_make_immutable_pair(a, d);
obj = scheme_datum_to_syntax(d, obj, scheme_false, 0, 1);
}
} else {
/* Add #%top-interaction, since we're in non-module mode: */
Scheme_Object *a;
a = scheme_make_pair(scheme_intern_symbol("#%top-interaction"), obj);
obj = scheme_datum_to_syntax(a, obj, scheme_false, 0, 0);
}
/* ... end special support for module loading ... */
@ -4201,8 +4335,8 @@ static Scheme_Object *do_load_handler(void *data)
if (genv->template_env && genv->template_env->rename)
obj = scheme_add_rename(obj, genv->template_env->rename);
last_val = _scheme_apply_multi(scheme_get_param(config, MZCONFIG_EVAL_HANDLER),
1, &obj);
last_val = _scheme_apply_multi_with_prompt(scheme_get_param(config, MZCONFIG_EVAL_HANDLER),
1, &obj);
/* If multi, we must save then: */
if (last_val == SCHEME_MULTIPLE_VALUES) {
@ -4218,10 +4352,12 @@ static Scheme_Object *do_load_handler(void *data)
}
if (SCHEME_SYMBOLP(lhd->expected_module) && !got_one) {
Scheme_Input_Port *ip;
ip = scheme_input_port_record(port);
scheme_raise_exn(MZEXN_FAIL,
"default-load-handler: expected a `module' declaration for `%S', but found end-of-file in: %V",
lhd->expected_module,
((Scheme_Input_Port *)port)->name);
ip->name);
return NULL;
}
@ -4313,7 +4449,7 @@ static Scheme_Object *default_load(int argc, Scheme_Object *argv[])
lhd->p = p;
lhd->config = config;
lhd->port = port;
name = ((Scheme_Input_Port *)port)->name;
name = scheme_input_port_record(port)->name;
lhd->stxsrc = name;
lhd->expected_module = expected_module;
@ -4457,7 +4593,7 @@ Scheme_Object *scheme_load(const char *file)
val = NULL;
} else {
val = scheme_apply_multi(scheme_make_prim((Scheme_Prim *)load),
1, p);
1, p);
}
scheme_current_thread->error_buf = savebuf;
@ -4490,7 +4626,7 @@ flush_output(int argc, Scheme_Object *argv[])
{
Scheme_Object *op;
if (argc && !SCHEME_OUTPORTP(argv[0]))
if (argc && !SCHEME_OUTPUT_PORTP(argv[0]))
scheme_wrong_type("flush-output", "output-port", 0, argc, argv);
if (argc)

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

@ -2765,7 +2765,7 @@ static Scheme_Object *custom_recur(int notdisplay, void *_vec, int argc, Scheme_
if (!SCHEME_OUTPORTP(argv[1])) {
scheme_wrong_type(notdisplay ? "write/recusrive" : "display/recursive",
"output port", 1, argc, argv);
"output-port", 1, argc, argv);
return NULL;
}

8
src/mzscheme/src/regexp.c
View File

@ -4845,13 +4845,13 @@ static Scheme_Object *gen_compare(char *name, int pos,
&& !SCHEME_CHAR_STRINGP(argv[0]))
scheme_wrong_type(name, "regexp, byte-regexp, string, or byte string", 0, argc, argv);
if ((peek || (!SCHEME_BYTE_STRINGP(argv[1]) && !SCHEME_CHAR_STRINGP(argv[1])))
&& !SCHEME_INPORTP(argv[1]))
&& !SCHEME_INPUT_PORTP(argv[1]))
scheme_wrong_type(name, peek ? "input-port" : "string, byte string, or input port", 1, argc, argv);
if (SCHEME_CHAR_STRINGP(argv[1])) {
iport = NULL;
endset = SCHEME_CHAR_STRLEN_VAL(argv[1]);
} else if (SCHEME_INPORTP(argv[1])) {
} else if (SCHEME_INPUT_PORTP(argv[1])) {
iport = argv[1];
endset = -2;
} else {
@ -4917,8 +4917,8 @@ static Scheme_Object *gen_compare(char *name, int pos,
}
} else {
if (SCHEME_TRUEP(argv[4])) {
if (!SCHEME_OUTPORTP(argv[4]))
scheme_wrong_type(name, "output-port or #f", 4, argc, argv);
if (!SCHEME_OUTPUT_PORTP(argv[4]))
scheme_wrong_type(name, "output port or #f", 4, argc, argv);
oport = argv[4];
}
}

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

@ -240,6 +240,8 @@ MZ_EXTERN unsigned char scheme_uchar_combining_classes[];
MZ_EXTERN Scheme_Object *scheme_eval(Scheme_Object *obj, Scheme_Env *env);
MZ_EXTERN Scheme_Object *scheme_eval_multi(Scheme_Object *obj, Scheme_Env *env);
MZ_EXTERN Scheme_Object *scheme_eval_with_prompt(Scheme_Object *obj, Scheme_Env *env);
MZ_EXTERN Scheme_Object *scheme_eval_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env);
MZ_EXTERN Scheme_Object *scheme_eval_compiled(Scheme_Object *obj, Scheme_Env *env);
MZ_EXTERN Scheme_Object *scheme_eval_compiled_multi(Scheme_Object *obj, Scheme_Env *env);
@ -251,9 +253,16 @@ MZ_EXTERN Scheme_Object *scheme_apply_multi(Scheme_Object *rator, int num_rands,
MZ_EXTERN Scheme_Object *scheme_apply_no_eb(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
MZ_EXTERN Scheme_Object *scheme_apply_multi_no_eb(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
MZ_EXTERN Scheme_Object *scheme_apply_to_list(Scheme_Object *rator, Scheme_Object *argss);
MZ_EXTERN Scheme_Object *scheme_apply_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
MZ_EXTERN Scheme_Object *scheme_apply_multi_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
MZ_EXTERN Scheme_Object *_scheme_apply_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
MZ_EXTERN Scheme_Object *_scheme_apply_multi_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
MZ_EXTERN Scheme_Object *scheme_eval_string(const char *str, Scheme_Env *env);
MZ_EXTERN Scheme_Object *scheme_eval_string_multi(const char *str, Scheme_Env *env);
MZ_EXTERN Scheme_Object *scheme_eval_string_all(const char *str, Scheme_Env *env, int all);
MZ_EXTERN Scheme_Object *scheme_eval_string_with_prompt(const char *str, Scheme_Env *env);
MZ_EXTERN Scheme_Object *scheme_eval_string_multi_with_prompt(const char *str, Scheme_Env *env);
MZ_EXTERN Scheme_Object *scheme_eval_string_all_with_prompt(const char *str, Scheme_Env *env, int all);
MZ_EXTERN Scheme_Object *_scheme_apply_known_prim_closure(Scheme_Object *rator, int argc,
Scheme_Object **argv);
@ -264,6 +273,11 @@ MZ_EXTERN Scheme_Object *_scheme_apply_prim_closure(Scheme_Object *rator, int ar
MZ_EXTERN Scheme_Object *_scheme_apply_prim_closure_multi(Scheme_Object *rator, int argc,
Scheme_Object **argv);
MZ_EXTERN Scheme_Object *scheme_call_with_prompt(Scheme_Closed_Prim f, void *data);
MZ_EXTERN Scheme_Object *scheme_call_with_prompt_multi(Scheme_Closed_Prim f, void *data);
MZ_EXTERN Scheme_Object *_scheme_call_with_prompt(Scheme_Closed_Prim f, void *data);
MZ_EXTERN Scheme_Object *_scheme_call_with_prompt_multi(Scheme_Closed_Prim f, void *data);
MZ_EXTERN Scheme_Object *scheme_values(int c, Scheme_Object **v);
MZ_EXTERN Scheme_Object *scheme_check_one_value(Scheme_Object *v);
@ -384,6 +398,7 @@ MZ_EXTERN Scheme_Hash_Table *scheme_make_hash_table(int type);
MZ_EXTERN Scheme_Hash_Table *scheme_make_hash_table_equal();
MZ_EXTERN void scheme_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val);
MZ_EXTERN Scheme_Object *scheme_hash_get(Scheme_Hash_Table *table, Scheme_Object *key);
XFORM_NONGCING MZ_EXTERN Scheme_Object *scheme_eq_hash_get(Scheme_Hash_Table *table, Scheme_Object *key);
MZ_EXTERN int scheme_hash_table_equal(Scheme_Hash_Table *t1, Scheme_Hash_Table *t2);
MZ_EXTERN int scheme_is_hash_table_equal(Scheme_Object *o);
MZ_EXTERN Scheme_Hash_Table *scheme_clone_hash_table(Scheme_Hash_Table *bt);
@ -704,6 +719,12 @@ MZ_EXTERN Scheme_Object *scheme_write_special_nonblock(int argc, Scheme_Object *
MZ_EXTERN Scheme_Object *scheme_make_write_evt(const char *who, Scheme_Object *port,
Scheme_Object *special, char *str, long start, long size);
MZ_EXTERN Scheme_Port *scheme_port_record(Scheme_Object *port);
MZ_EXTERN Scheme_Input_Port *scheme_input_port_record(Scheme_Object *port);
MZ_EXTERN Scheme_Output_Port *scheme_output_port_record(Scheme_Object *port);
XFORM_NONGCING MZ_EXTERN int scheme_is_input_port(Scheme_Object *port);
XFORM_NONGCING MZ_EXTERN int scheme_is_output_port(Scheme_Object *port);
MZ_EXTERN Scheme_Object *scheme_make_port_type(const char *name);
MZ_EXTERN Scheme_Input_Port *scheme_make_input_port(Scheme_Object *subtype, void *data,
Scheme_Object *name,
@ -911,7 +932,7 @@ MZ_EXTERN void scheme_struct_set(Scheme_Object *s, int pos, Scheme_Object *v);
MZ_EXTERN Scheme_Object *scheme_make_struct_type_property(Scheme_Object *name);
MZ_EXTERN Scheme_Object *scheme_make_struct_type_property_w_guard(Scheme_Object *name, Scheme_Object *guard);
MZ_EXTERN Scheme_Object *scheme_struct_type_property_ref(Scheme_Object *prop, Scheme_Object *s);
XFORM_NONGCING MZ_EXTERN Scheme_Object *scheme_struct_type_property_ref(Scheme_Object *prop, Scheme_Object *s);
MZ_EXTERN Scheme_Object *scheme_make_location(Scheme_Object *src,
Scheme_Object *line,

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

@ -193,6 +193,8 @@ unsigned char *scheme_uchar_combining_classes;
/*========================================================================*/
Scheme_Object *(*scheme_eval)(Scheme_Object *obj, Scheme_Env *env);
Scheme_Object *(*scheme_eval_multi)(Scheme_Object *obj, Scheme_Env *env);
Scheme_Object *(*scheme_eval_with_prompt)(Scheme_Object *obj, Scheme_Env *env);
Scheme_Object *(*scheme_eval_multi_with_prompt)(Scheme_Object *obj, Scheme_Env *env);
Scheme_Object *(*scheme_eval_compiled)(Scheme_Object *obj, Scheme_Env *env);
Scheme_Object *(*scheme_eval_compiled_multi)(Scheme_Object *obj, Scheme_Env *env);
Scheme_Object *(*_scheme_eval_compiled)(Scheme_Object *obj, Scheme_Env *env);
@ -202,9 +204,16 @@ Scheme_Object *(*scheme_apply_multi)(Scheme_Object *rator, int num_rands, Scheme
Scheme_Object *(*scheme_apply_no_eb)(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
Scheme_Object *(*scheme_apply_multi_no_eb)(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
Scheme_Object *(*scheme_apply_to_list)(Scheme_Object *rator, Scheme_Object *argss);
Scheme_Object *(*scheme_apply_with_prompt)(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
Scheme_Object *(*scheme_apply_multi_with_prompt)(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
Scheme_Object *(*_scheme_apply_with_prompt)(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
Scheme_Object *(*_scheme_apply_multi_with_prompt)(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
Scheme_Object *(*scheme_eval_string)(const char *str, Scheme_Env *env);
Scheme_Object *(*scheme_eval_string_multi)(const char *str, Scheme_Env *env);
Scheme_Object *(*scheme_eval_string_all)(const char *str, Scheme_Env *env, int all);
Scheme_Object *(*scheme_eval_string_with_prompt)(const char *str, Scheme_Env *env);
Scheme_Object *(*scheme_eval_string_multi_with_prompt)(const char *str, Scheme_Env *env);
Scheme_Object *(*scheme_eval_string_all_with_prompt)(const char *str, Scheme_Env *env, int all);
Scheme_Object *(*_scheme_apply_known_prim_closure)(Scheme_Object *rator, int argc,
Scheme_Object **argv);
Scheme_Object *(*_scheme_apply_known_prim_closure_multi)(Scheme_Object *rator, int argc,
@ -213,6 +222,10 @@ Scheme_Object *(*_scheme_apply_prim_closure)(Scheme_Object *rator, int argc,
Scheme_Object **argv);
Scheme_Object *(*_scheme_apply_prim_closure_multi)(Scheme_Object *rator, int argc,
Scheme_Object **argv);
Scheme_Object *(*scheme_call_with_prompt)(Scheme_Closed_Prim f, void *data);
Scheme_Object *(*scheme_call_with_prompt_multi)(Scheme_Closed_Prim f, void *data);
Scheme_Object *(*_scheme_call_with_prompt)(Scheme_Closed_Prim f, void *data);
Scheme_Object *(*_scheme_call_with_prompt_multi)(Scheme_Closed_Prim f, void *data);
Scheme_Object *(*scheme_values)(int c, Scheme_Object **v);
Scheme_Object *(*scheme_check_one_value)(Scheme_Object *v);
/* Tail calls - only use these when you're writing new functions/syntax */
@ -310,6 +323,7 @@ Scheme_Hash_Table *(*scheme_make_hash_table)(int type);
Scheme_Hash_Table *(*scheme_make_hash_table_equal)();
void (*scheme_hash_set)(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val);
Scheme_Object *(*scheme_hash_get)(Scheme_Hash_Table *table, Scheme_Object *key);
Scheme_Object *(*scheme_eq_hash_get)(Scheme_Hash_Table *table, Scheme_Object *key);
int (*scheme_hash_table_equal)(Scheme_Hash_Table *t1, Scheme_Hash_Table *t2);
int (*scheme_is_hash_table_equal)(Scheme_Object *o);
Scheme_Hash_Table *(*scheme_clone_hash_table)(Scheme_Hash_Table *bt);
@ -588,6 +602,11 @@ Scheme_Object *(*scheme_write_special)(int argc, Scheme_Object *argv[]);
Scheme_Object *(*scheme_write_special_nonblock)(int argc, Scheme_Object *argv[]);
Scheme_Object *(*scheme_make_write_evt)(const char *who, Scheme_Object *port,
Scheme_Object *special, char *str, long start, long size);
Scheme_Port *(*scheme_port_record)(Scheme_Object *port);
Scheme_Input_Port *(*scheme_input_port_record)(Scheme_Object *port);
Scheme_Output_Port *(*scheme_output_port_record)(Scheme_Object *port);
int (*scheme_is_input_port)(Scheme_Object *port);
int (*scheme_is_output_port)(Scheme_Object *port);
Scheme_Object *(*scheme_make_port_type)(const char *name);
Scheme_Input_Port *(*scheme_make_input_port)(Scheme_Object *subtype, void *data,
Scheme_Object *name,

19
src/mzscheme/src/schemex.inc
View File

@ -114,6 +114,8 @@
scheme_extension_table->scheme_uchar_combining_classes = scheme_uchar_combining_classes;
scheme_extension_table->scheme_eval = scheme_eval;
scheme_extension_table->scheme_eval_multi = scheme_eval_multi;
scheme_extension_table->scheme_eval_with_prompt = scheme_eval_with_prompt;
scheme_extension_table->scheme_eval_multi_with_prompt = scheme_eval_multi_with_prompt;
scheme_extension_table->scheme_eval_compiled = scheme_eval_compiled;
scheme_extension_table->scheme_eval_compiled_multi = scheme_eval_compiled_multi;
scheme_extension_table->_scheme_eval_compiled = _scheme_eval_compiled;
@ -123,13 +125,24 @@
scheme_extension_table->scheme_apply_no_eb = scheme_apply_no_eb;
scheme_extension_table->scheme_apply_multi_no_eb = scheme_apply_multi_no_eb;
scheme_extension_table->scheme_apply_to_list = scheme_apply_to_list;
scheme_extension_table->scheme_apply_with_prompt = scheme_apply_with_prompt;
scheme_extension_table->scheme_apply_multi_with_prompt = scheme_apply_multi_with_prompt;
scheme_extension_table->_scheme_apply_with_prompt = _scheme_apply_with_prompt;
scheme_extension_table->_scheme_apply_multi_with_prompt = _scheme_apply_multi_with_prompt;
scheme_extension_table->scheme_eval_string = scheme_eval_string;
scheme_extension_table->scheme_eval_string_multi = scheme_eval_string_multi;
scheme_extension_table->scheme_eval_string_all = scheme_eval_string_all;
scheme_extension_table->scheme_eval_string_with_prompt = scheme_eval_string_with_prompt;
scheme_extension_table->scheme_eval_string_multi_with_prompt = scheme_eval_string_multi_with_prompt;
scheme_extension_table->scheme_eval_string_all_with_prompt = scheme_eval_string_all_with_prompt;
scheme_extension_table->_scheme_apply_known_prim_closure = _scheme_apply_known_prim_closure;
scheme_extension_table->_scheme_apply_known_prim_closure_multi = _scheme_apply_known_prim_closure_multi;
scheme_extension_table->_scheme_apply_prim_closure = _scheme_apply_prim_closure;
scheme_extension_table->_scheme_apply_prim_closure_multi = _scheme_apply_prim_closure_multi;
scheme_extension_table->scheme_call_with_prompt = scheme_call_with_prompt;
scheme_extension_table->scheme_call_with_prompt_multi = scheme_call_with_prompt_multi;
scheme_extension_table->_scheme_call_with_prompt = _scheme_call_with_prompt;
scheme_extension_table->_scheme_call_with_prompt_multi = _scheme_call_with_prompt_multi;
scheme_extension_table->scheme_values = scheme_values;
scheme_extension_table->scheme_check_one_value = scheme_check_one_value;
scheme_extension_table->scheme_tail_apply = scheme_tail_apply;
@ -207,6 +220,7 @@
scheme_extension_table->scheme_make_hash_table_equal = scheme_make_hash_table_equal;
scheme_extension_table->scheme_hash_set = scheme_hash_set;
scheme_extension_table->scheme_hash_get = scheme_hash_get;
scheme_extension_table->scheme_eq_hash_get = scheme_eq_hash_get;
scheme_extension_table->scheme_hash_table_equal = scheme_hash_table_equal;
scheme_extension_table->scheme_is_hash_table_equal = scheme_is_hash_table_equal;
scheme_extension_table->scheme_clone_hash_table = scheme_clone_hash_table;
@ -393,6 +407,11 @@
scheme_extension_table->scheme_write_special = scheme_write_special;
scheme_extension_table->scheme_write_special_nonblock = scheme_write_special_nonblock;
scheme_extension_table->scheme_make_write_evt = scheme_make_write_evt;
scheme_extension_table->scheme_port_record = scheme_port_record;
scheme_extension_table->scheme_input_port_record = scheme_input_port_record;
scheme_extension_table->scheme_output_port_record = scheme_output_port_record;
scheme_extension_table->scheme_is_input_port = scheme_is_input_port;
scheme_extension_table->scheme_is_output_port = scheme_is_output_port;
scheme_extension_table->scheme_make_port_type = scheme_make_port_type;
scheme_extension_table->scheme_make_input_port = scheme_make_input_port;
scheme_extension_table->scheme_make_output_port = scheme_make_output_port;

19
src/mzscheme/src/schemexm.h
View File

@ -114,6 +114,8 @@
#define scheme_uchar_combining_classes (scheme_extension_table->scheme_uchar_combining_classes)
#define scheme_eval (scheme_extension_table->scheme_eval)
#define scheme_eval_multi (scheme_extension_table->scheme_eval_multi)
#define scheme_eval_with_prompt (scheme_extension_table->scheme_eval_with_prompt)
#define scheme_eval_multi_with_prompt (scheme_extension_table->scheme_eval_multi_with_prompt)
#define scheme_eval_compiled (scheme_extension_table->scheme_eval_compiled)
#define scheme_eval_compiled_multi (scheme_extension_table->scheme_eval_compiled_multi)
#define _scheme_eval_compiled (scheme_extension_table->_scheme_eval_compiled)
@ -123,13 +125,24 @@
#define scheme_apply_no_eb (scheme_extension_table->scheme_apply_no_eb)
#define scheme_apply_multi_no_eb (scheme_extension_table->scheme_apply_multi_no_eb)
#define scheme_apply_to_list (scheme_extension_table->scheme_apply_to_list)
#define scheme_apply_with_prompt (scheme_extension_table->scheme_apply_with_prompt)
#define scheme_apply_multi_with_prompt (scheme_extension_table->scheme_apply_multi_with_prompt)
#define _scheme_apply_with_prompt (scheme_extension_table->_scheme_apply_with_prompt)
#define _scheme_apply_multi_with_prompt (scheme_extension_table->_scheme_apply_multi_with_prompt)
#define scheme_eval_string (scheme_extension_table->scheme_eval_string)
#define scheme_eval_string_multi (scheme_extension_table->scheme_eval_string_multi)
#define scheme_eval_string_all (scheme_extension_table->scheme_eval_string_all)
#define scheme_eval_string_with_prompt (scheme_extension_table->scheme_eval_string_with_prompt)
#define scheme_eval_string_multi_with_prompt (scheme_extension_table->scheme_eval_string_multi_with_prompt)
#define scheme_eval_string_all_with_prompt (scheme_extension_table->scheme_eval_string_all_with_prompt)
#define _scheme_apply_known_prim_closure (scheme_extension_table->_scheme_apply_known_prim_closure)
#define _scheme_apply_known_prim_closure_multi (scheme_extension_table->_scheme_apply_known_prim_closure_multi)
#define _scheme_apply_prim_closure (scheme_extension_table->_scheme_apply_prim_closure)
#define _scheme_apply_prim_closure_multi (scheme_extension_table->_scheme_apply_prim_closure_multi)
#define scheme_call_with_prompt (scheme_extension_table->scheme_call_with_prompt)
#define scheme_call_with_prompt_multi (scheme_extension_table->scheme_call_with_prompt_multi)
#define _scheme_call_with_prompt (scheme_extension_table->_scheme_call_with_prompt)
#define _scheme_call_with_prompt_multi (scheme_extension_table->_scheme_call_with_prompt_multi)
#define scheme_values (scheme_extension_table->scheme_values)
#define scheme_check_one_value (scheme_extension_table->scheme_check_one_value)
#define scheme_tail_apply (scheme_extension_table->scheme_tail_apply)
@ -207,6 +220,7 @@
#define scheme_make_hash_table_equal (scheme_extension_table->scheme_make_hash_table_equal)
#define scheme_hash_set (scheme_extension_table->scheme_hash_set)
#define scheme_hash_get (scheme_extension_table->scheme_hash_get)
#define scheme_eq_hash_get (scheme_extension_table->scheme_eq_hash_get)
#define scheme_hash_table_equal (scheme_extension_table->scheme_hash_table_equal)
#define scheme_is_hash_table_equal (scheme_extension_table->scheme_is_hash_table_equal)
#define scheme_clone_hash_table (scheme_extension_table->scheme_clone_hash_table)
@ -393,6 +407,11 @@
#define scheme_write_special (scheme_extension_table->scheme_write_special)
#define scheme_write_special_nonblock (scheme_extension_table->scheme_write_special_nonblock)
#define scheme_make_write_evt (scheme_extension_table->scheme_make_write_evt)
#define scheme_port_record (scheme_extension_table->scheme_port_record)
#define scheme_input_port_record (scheme_extension_table->scheme_input_port_record)
#define scheme_output_port_record (scheme_extension_table->scheme_output_port_record)
#define scheme_is_input_port (scheme_extension_table->scheme_is_input_port)
#define scheme_is_output_port (scheme_extension_table->scheme_is_output_port)
#define scheme_make_port_type (scheme_extension_table->scheme_make_port_type)
#define scheme_make_input_port (scheme_extension_table->scheme_make_input_port)
#define scheme_make_output_port (scheme_extension_table->scheme_make_output_port)

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

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 885
#define EXPECTED_PRIM_COUNT 887
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

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

@ -92,6 +92,7 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]);
extern long scheme_total_gc_time;
extern int scheme_cont_capture_count;
extern int scheme_continuation_application_count;
int scheme_num_types(void);
@ -266,6 +267,8 @@ extern Scheme_Object *scheme_default_prompt_tag;
extern Scheme_Object *scheme_system_idle_channel;
extern Scheme_Object *scheme_input_port_property, *scheme_output_port_property;
/*========================================================================*/
/* thread state and maintenance */
/*========================================================================*/
@ -402,6 +405,7 @@ struct Scheme_Config {
};
extern Scheme_Object *scheme_parameterization_key;
extern Scheme_Object *scheme_exn_handler_key;
extern Scheme_Object *scheme_break_enabled_key;
extern void scheme_flatten_config(Scheme_Config *c);
@ -940,7 +944,6 @@ typedef struct Scheme_Stack_State {
long runstack_offset;
MZ_MARK_POS_TYPE cont_mark_pos;
MZ_MARK_STACK_TYPE cont_mark_stack;
struct Scheme_Prompt *barrier_prompt;
} Scheme_Stack_State;
typedef struct Scheme_Dynamic_Wind {
@ -952,29 +955,25 @@ typedef struct Scheme_Dynamic_Wind {
void (*pre)(void *);
void (*post)(void *);
mz_jmp_buf *saveerr;
int next_meta; /* amount to move forward in the meta-continuation chain */
int next_meta; /* amount to move forward in the meta-continuation chain, starting with next */
struct Scheme_Stack_State envss;
struct Scheme_Dynamic_Wind *prev;
} Scheme_Dynamic_Wind;
typedef struct Scheme_Cont {
Scheme_Object so;
short composable;
Scheme_Object *value; /* Set just before jump */
struct Scheme_Overflow *resume_to; /* Set just before jump */
struct Scheme_Cont *use_next_cont; /* Set just before jump */
int common_dw_depth; /* Set just before jump; id common dw record */
Scheme_Object *extra_marks; /* Set just before jump; vector extra keys and marks to add to meta-cont */
char composable, has_prompt_dw;
struct Scheme_Meta_Continuation *meta_continuation;
Scheme_Jumpup_Buf buf;
Scheme_Dynamic_Wind *dw;
int next_meta;
Scheme_Continuation_Jump_State cjs;
Scheme_Stack_State ss;
struct Scheme_Prompt *barrier_prompt; /* NULL if no barrier between cont and prompt */
Scheme_Object **runstack_start;
long runstack_size;
Scheme_Saved_Stack *runstack_saved;
Scheme_Object *prompt_tag;
int prompt_depth;
mz_jmp_buf *prompt_buf; /* needed for meta-prompt */
MZ_MARK_POS_TYPE meta_tail_pos; /* to recognize opportunity for meta-tail calls */
MZ_MARK_POS_TYPE cont_mark_pos_bottom; /* to splice cont mark values with meta-cont */
@ -985,6 +984,7 @@ typedef struct Scheme_Cont {
Scheme_Thread **cont_mark_stack_owner;
long cont_mark_shareable, cont_mark_offset;
void *stack_start;
Scheme_Object *prompt_id; /* allows direct-jump optimization */
Scheme_Config *init_config;
Scheme_Object *init_break_cell;
#ifdef MZ_USE_JIT
@ -992,11 +992,22 @@ typedef struct Scheme_Cont {
#endif
struct Scheme_Overflow *save_overflow;
mz_jmp_buf *savebuf; /* save old error buffer here */
/* Arguments passed to a continuation invocation to the continuation restorer: */
Scheme_Object *value; /* argument(s) to continuation */
struct Scheme_Overflow *resume_to; /* meta-continuation return */
struct Scheme_Cont *use_next_cont; /* more meta-continuation return */
int common_dw_depth; /* id for common dw record */
Scheme_Dynamic_Wind *common_dw; /* shared part with source cont */
int common_next_meta; /* for common_dw */
Scheme_Object *extra_marks; /* vector of extra keys and marks to add to meta-cont */
struct Scheme_Prompt *shortcut_prompt; /* prompt common to save and restore enabling shortcut */
} Scheme_Cont;
typedef struct Scheme_Escaping_Cont {
Scheme_Object so;
struct Scheme_Stack_State envss;
struct Scheme_Prompt *barrier_prompt;
#ifdef MZ_USE_JIT
Scheme_Object *native_trace;
#endif
@ -1009,12 +1020,10 @@ int scheme_escape_continuation_ok(Scheme_Object *);
#define scheme_save_env_stack_w_thread(ss, p) \
(ss.runstack_offset = MZ_RUNSTACK - MZ_RUNSTACK_START, \
ss.cont_mark_stack = MZ_CONT_MARK_STACK, ss.cont_mark_pos = MZ_CONT_MARK_POS, \
ss.barrier_prompt = p->barrier_prompt)
ss.cont_mark_stack = MZ_CONT_MARK_STACK, ss.cont_mark_pos = MZ_CONT_MARK_POS)
#define scheme_restore_env_stack_w_thread(ss, p) \
(MZ_RUNSTACK = MZ_RUNSTACK_START + ss.runstack_offset, \
MZ_CONT_MARK_STACK = ss.cont_mark_stack, MZ_CONT_MARK_POS = ss.cont_mark_pos, \
p->barrier_prompt = ss.barrier_prompt)
MZ_CONT_MARK_STACK = ss.cont_mark_stack, MZ_CONT_MARK_POS = ss.cont_mark_pos)
#define scheme_save_env_stack(ss) \
scheme_save_env_stack_w_thread(ss, scheme_current_thread)
#define scheme_restore_env_stack(ss) \
@ -1052,6 +1061,7 @@ typedef struct Scheme_Meta_Continuation {
char cm_caches; /* cached info in copied cm */
char cm_shared; /* cm is shared, so copy before setting cache entries */
int copy_after_captured; /* for mutating a meta-continuation in set_cont_stack_mark */
int depth;
Scheme_Object *prompt_tag;
/* The C stack: */
Scheme_Overflow *overflow;
@ -1068,15 +1078,15 @@ typedef struct Scheme_Meta_Continuation {
typedef struct Scheme_Prompt {
Scheme_Object so;
char is_barrier, is_captured;
int depth;
char is_barrier;
Scheme_Object *tag;
Scheme_Object *id; /* created as needed; allows direct-jump optimization for cont app */
void *stack_boundary; /* where to stop copying the C stack */
void *boundary_overflow_id; /* indicates the C stack segment */
MZ_MARK_STACK_TYPE mark_boundary; /* where to stop copying cont marks */
MZ_MARK_POS_TYPE boundary_mark_pos; /* mark position of prompt */
Scheme_Object **runstack_boundary_start; /* which stack has runstack_boundary */
long runstack_boundary_offset; /* where to stop copying the Scheme stack */
void *boundary_dw_id; /* where to stop copying the dynamic-wind stack */
mz_jmp_buf *prompt_buf; /* to jump directly to the prompt */
long runstack_size; /* needed for restore */
} Scheme_Prompt;
@ -1087,12 +1097,23 @@ typedef struct Scheme_Prompt {
Scheme_Object *scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set,
Scheme_Object *key,
Scheme_Object *prompt_tag,
Scheme_Meta_Continuation **meta_cont);
Scheme_Meta_Continuation **_meta_cont,
MZ_MARK_POS_TYPE *_pos);
Scheme_Object *scheme_compose_continuation(Scheme_Cont *c, int num_rands, Scheme_Object *value);
Scheme_Overflow *scheme_get_thread_end_overflow(void);
void scheme_end_current_thread(void);
void scheme_ensure_dw_id(Scheme_Dynamic_Wind *dw);
void scheme_apply_dw_in_meta(Scheme_Dynamic_Wind *dw, int post, int mc_depth);
void scheme_apply_dw_in_meta(Scheme_Dynamic_Wind *dw, int post, int mc_depth, struct Scheme_Cont *recheck);
void scheme_drop_prompt_meta_continuations(Scheme_Object *prompt_tag);
struct Scheme_Prompt *scheme_get_barrier_prompt(struct Scheme_Meta_Continuation **_meta_cont,
MZ_MARK_POS_TYPE *_pos);
int scheme_is_cm_deeper(struct Scheme_Meta_Continuation *m1, MZ_MARK_POS_TYPE p1,
struct Scheme_Meta_Continuation *m2, MZ_MARK_POS_TYPE p2);
void scheme_recheck_prompt_and_barrier(struct Scheme_Cont *c);
void scheme_about_to_move_C_stack(void);
/*========================================================================*/
/* semaphores and locks */
@ -1850,7 +1871,8 @@ int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env);
#define DEFINE_FOR_SYNTAX_EXPD 9
#define REF_EXPD 10
#define APPVALS_EXPD 11
#define _COUNT_EXPD_ 12
#define SPLICE_EXPD 12
#define _COUNT_EXPD_ 13
#define scheme_register_syntax(i, fo, fr, fv, fe, fj, cl, sh, pa) \
(scheme_syntax_optimizers[i] = fo, \

2
src/mzscheme/src/schuchar.inc
View File

@ -44,7 +44,7 @@ static unsigned short udata[] = {
0x8a80, 0xa80, 0x8a80, 0x8a80, 0x8a80, 0x8a80, 0x8a80, 0x8a80, 0x8a80, 0x8a80, 0x8a80, 0x804, 0x804, 0x804, 0x1802, 0x804,
0x1802, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80,
0x8c80, 0xc80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x804, 0x802, 0x804, 0x802, 0x8,
0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8,
0x8, 0x8, 0x8, 0x8, 0x8, 0x18, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8,
0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8,
0x4011, 0x804, 0x802, 0x802, 0x802, 0x802, 0x802, 0x802, 0xd802, 0x802, 0x4c80, 0x804, 0x802, 0x1000, 0x802, 0x5802,
0x802, 0x802, 0x4000, 0x4000, 0x5802, 0x4c80, 0x802, 0x1804, 0x5802, 0x4000, 0x4c80, 0x804, 0x4000, 0x4000, 0x4000, 0x804,

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 369
#define MZSCHEME_VERSION_MINOR 1
#define MZSCHEME_VERSION_MINOR 2
#define MZSCHEME_VERSION "369.1" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "369.2" _MZ_SPECIAL_TAG

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

@ -1619,10 +1619,7 @@
"(-define(catch-ellipsis-error thunk sexp sloc)"
"((let/ec esc"
"(with-continuation-mark"
" parameterization-key"
"(extend-parameterization"
"(continuation-mark-set-first #f parameterization-key)"
" current-exception-handler"
" exception-handler-key"
"(lambda(exn)"
"(esc"
"(lambda()"
@ -1632,7 +1629,7 @@
" 'syntax"
" \"incompatible ellipsis match counts for template\""
" sexp"
" sloc))))))"
" sloc)))))"
"(let((v(thunk)))"
"(lambda() v))))))"
"(-define substitute-stop 'dummy)"
@ -2730,6 +2727,7 @@
"(unless(continuation-prompt-available? handler-prompt-key) "
"(error 'with-handlers"
" \"exception handler used out of context\")))"
"(define handler-prompt-key(make-continuation-prompt-tag))"
"(define-syntaxes(with-handlers with-handlers*)"
"(let((wh "
"(lambda(disable-break?)"
@ -2743,8 +2741,7 @@
"(syntax->list #'(handler ...))))))"
"(quasisyntax/loc stx"
"(let((pred-name pred) ..."
"(handler-name handler) ..."
"(handler-prompt-key(make-continuation-prompt-tag)))"
"(handler-name handler) ...)"
"(let((bpz(continuation-mark-set-first #f break-enabled-key)))"
"(with-continuation-mark"
" break-enabled-key"
@ -2754,9 +2751,9 @@
"(with-continuation-mark "
" break-enabled-key"
" bpz"
"(parameterize((current-exception-handler"
"(with-continuation-mark "
" exception-handler-key"
"(lambda(e)"
"(check-with-handlers-in-context handler-prompt-key)"
"(abort-current-continuation"
" handler-prompt-key"
"(lambda()"
@ -2764,11 +2761,17 @@
" #'select-handler/no-breaks"
" #'select-handler/breaks-as-is)"
" e bpz"
"(list(cons pred-name handler-name) ...)))))))"
" expr1 expr ...)))"
"(list(cons pred-name handler-name) ...)))))"
"(let()"
" expr1 expr ...))))"
" handler-prompt-key"
"(lambda(thunk)(thunk))))))))))))))"
"(values(wh #t)(wh #f))))"
"(define(call-with-exception-handler exnh thunk)"
"(with-continuation-mark"
" exception-handler-key"
" exnh"
"(thunk)))"
"(define-syntax set!-values"
"(lambda(stx)"
"(syntax-case stx()"
@ -2838,7 +2841,8 @@
"(provide case do delay force promise?"
" parameterize current-parameterization call-with-parameterization"
" parameterize-break current-break-parameterization call-with-break-parameterization"
" with-handlers with-handlers* set!-values"
" with-handlers with-handlers* call-with-exception-handler"
" set!-values"
" let/cc let-struct fluid-let time))"
);
EVAL_ONE_STR(
@ -2921,26 +2925,25 @@
"((negative? lo)(-(find-between(- hi)(- lo))))"
"(else(find-between lo hi)))))))"
"(define(read-eval-print-loop)"
"(let*((jump-key(gensym))"
"(repl-error-escape-handler"
"(lambda()"
"(let((jump-k(continuation-mark-set-first #f jump-key)))"
"(if jump-k"
"(jump-k)"
" (error 'repl-error-escape-handler \"used out of context\"))))))"
"(parameterize((error-escape-handler repl-error-escape-handler))"
"(let/ec done-k"
"(let repl-loop()"
"(let/ec k"
"(with-continuation-mark jump-key k"
"(call-with-continuation-prompt"
"(lambda()"
"(let((v((current-prompt-read))))"
"(when(eof-object? v)(done-k(void)))"
"(unless(eof-object? v)"
"(call-with-values"
"(lambda()((current-eval)(if(syntax? v)"
"(namespace-syntax-introduce v)"
" v)))"
"(lambda results(for-each(current-print) results))))))"
"(repl-loop))))))"
"(lambda() "
"(call-with-continuation-prompt"
"(lambda()"
"(let((w(cons '#%top-interaction v)))"
"((current-eval)(if(syntax? v)"
"(namespace-syntax-introduce "
"(datum->syntax-object #f w v))"
" w))))"
"(default-continuation-prompt-tag)))"
"(lambda results(for-each(current-print) results)))"
"(abort-current-continuation(default-continuation-prompt-tag)))))"
"(default-continuation-prompt-tag)"
"(lambda args(repl-loop)))))"
"(define load/cd"
"(lambda(n)"
"(unless(path-string? n)"
@ -3544,7 +3547,17 @@
"(stx-cdr stx))"
" stx)"
" (raise-syntax-error #f \"bad syntax\" stx))))"
"(provide mzscheme-in-stx-module-begin))"
"(define-syntax #%top-interaction"
"(lambda(stx)"
"(if(eq? 'top-level(syntax-local-context))"
" 'ok"
"(raise-syntax-error"
" #f"
" \"not at top level\""
" stx))"
"(datum->syntax-object stx(stx-cdr stx) stx stx)))"
"(provide mzscheme-in-stx-module-begin"
" #%top-interaction))"
);
EVAL_ONE_STR(
"(module mzscheme #%kernel"
@ -3563,6 +3576,7 @@
"(all-from #%qqstx)"
"(all-from #%define)"
"(all-from-except #%kernel #%module-begin)"
" #%top-interaction"
"(rename mzscheme-in-stx-module-begin #%module-begin)"
"(rename #%module-begin #%plain-module-begin)))"
);
@ -3603,7 +3617,7 @@
"(rename r5rs:letrec letrec)"
" let* begin lambda quote set!"
" define-syntax let-syntax letrec-syntax"
" #%app #%datum #%top))"
" #%app #%datum #%top #%top-interaction))"
);
EVAL_ONE_STR(
"(require(only mzscheme namespace-require/copy))"

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

@ -1906,20 +1906,17 @@
(-define (catch-ellipsis-error thunk sexp sloc)
((let/ec esc
(with-continuation-mark
parameterization-key
(extend-parameterization
(continuation-mark-set-first #f parameterization-key)
current-exception-handler
(lambda (exn)
(esc
(lambda ()
(if (exn:break? exn)
(raise exn)
(raise-syntax-error
'syntax
"incompatible ellipsis match counts for template"
sexp
sloc))))))
exception-handler-key
(lambda (exn)
(esc
(lambda ()
(if (exn:break? exn)
(raise exn)
(raise-syntax-error
'syntax
"incompatible ellipsis match counts for template"
sexp
sloc)))))
(let ([v (thunk)])
(lambda () v))))))
@ -3142,6 +3139,8 @@
(error 'with-handlers
"exception handler used out of context")))
(define handler-prompt-key (make-continuation-prompt-tag))
(define-syntaxes (with-handlers with-handlers*)
(let ([wh
(lambda (disable-break?)
@ -3155,8 +3154,7 @@
(syntax->list #'(handler ...))))])
(quasisyntax/loc stx
(let ([pred-name pred] ...
[handler-name handler] ...
[handler-prompt-key (make-continuation-prompt-tag)])
[handler-name handler] ...)
;; Capture current break parameterization, so we can use it to
;; evaluate the body
(let ([bpz (continuation-mark-set-first #f break-enabled-key)])
@ -3176,24 +3174,31 @@
(with-continuation-mark
break-enabled-key
bpz
(parameterize ([current-exception-handler
(lambda (e)
(check-with-handlers-in-context handler-prompt-key)
;; Deliver a thunk to the escape handler:
(abort-current-continuation
handler-prompt-key
(lambda ()
(#,(if disable-break?
#'select-handler/no-breaks
#'select-handler/breaks-as-is)
e bpz
(list (cons pred-name handler-name) ...)))))])
expr1 expr ...)))
(with-continuation-mark
exception-handler-key
(lambda (e)
;; Deliver a thunk to the escape handler:
(abort-current-continuation
handler-prompt-key
(lambda ()
(#,(if disable-break?
#'select-handler/no-breaks
#'select-handler/breaks-as-is)
e bpz
(list (cons pred-name handler-name) ...)))))
(let ()
expr1 expr ...))))
handler-prompt-key
;; On escape, apply the handler thunk
(lambda (thunk) (thunk))))))))])))])
(values (wh #t) (wh #f))))
(define (call-with-exception-handler exnh thunk)
(with-continuation-mark
exception-handler-key
exnh
(thunk)))
(define-syntax set!-values
(lambda (stx)
(syntax-case stx ()
@ -3268,7 +3273,8 @@
(provide case do delay force promise?
parameterize current-parameterization call-with-parameterization
parameterize-break current-break-parameterization call-with-break-parameterization
with-handlers with-handlers* set!-values
with-handlers with-handlers* call-with-exception-handler
set!-values
let/cc let-struct fluid-let time))
;;----------------------------------------------------------------------
@ -3360,30 +3366,30 @@
[else (find-between lo hi)])))))
(define (read-eval-print-loop)
(let* ([jump-key (gensym)]
[repl-error-escape-handler
(lambda ()
(let ([jump-k (continuation-mark-set-first #f jump-key)])
(if jump-k
(jump-k)
(error 'repl-error-escape-handler "used out of context"))))])
;; This parameterize is outside the loop so that
;; expressions evaluated in the REPL can set the
;; error escape handler. That's why we communicate the
;; actual escape target through a continuation mark.
(parameterize ([error-escape-handler repl-error-escape-handler])
(let/ec done-k
(let repl-loop ()
(let/ec k
(with-continuation-mark jump-key k
(let ([v ((current-prompt-read))])
(when (eof-object? v) (done-k (void)))
(call-with-values
(lambda () ((current-eval) (if (syntax? v)
(namespace-syntax-introduce v)
v)))
(lambda results (for-each (current-print) results))))))
(repl-loop))))))
(let repl-loop ()
;; This prompt catches all error escapes, including from read and print.
(call-with-continuation-prompt
(lambda ()
(let ([v ((current-prompt-read))])
(unless (eof-object? v)
(call-with-values
(lambda ()
;; This prompt catches escapes during evaluation.
;; Unlike the outer prompt, the handler prints
;; the results.
(call-with-continuation-prompt
(lambda ()
(let ([w (cons '#%top-interaction v)])
((current-eval) (if (syntax? v)
(namespace-syntax-introduce
(datum->syntax-object #f w v))
w))))
(default-continuation-prompt-tag)))
(lambda results (for-each (current-print) results)))
;; Abort to loop. (Calling `repl-loop' directory would not be a tail call.)
(abort-current-continuation (default-continuation-prompt-tag)))))
(default-continuation-prompt-tag)
(lambda args (repl-loop)))))
(define load/cd
(lambda (n)
@ -4046,7 +4052,18 @@
stx)
(raise-syntax-error #f "bad syntax" stx))))
(provide mzscheme-in-stx-module-begin))
(define-syntax #%top-interaction
(lambda (stx)
(if (eq? 'top-level (syntax-local-context))
'ok
(raise-syntax-error
#f
"not at top level"
stx))
(datum->syntax-object stx (stx-cdr stx) stx stx)))
(provide mzscheme-in-stx-module-begin
#%top-interaction))
;;----------------------------------------------------------------------
;; mzscheme: provide everything
@ -4068,6 +4085,7 @@
(all-from #%qqstx)
(all-from #%define)
(all-from-except #%kernel #%module-begin)
#%top-interaction
(rename mzscheme-in-stx-module-begin #%module-begin)
(rename #%module-begin #%plain-module-begin)))
@ -4116,7 +4134,7 @@
;; We have to include the following MzScheme-isms to do anything,
;; but they're not legal R5RS names, anyway.
#%app #%datum #%top))
#%app #%datum #%top #%top-interaction))
;;----------------------------------------------------------------------
;; init namespace

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

@ -1835,7 +1835,7 @@ sch_printf(int argc, Scheme_Object *argv[])
static Scheme_Object *
sch_fprintf(int argc, Scheme_Object *argv[])
{
if (!SCHEME_OUTPORTP(argv[0]))
if (!SCHEME_OUTPUT_PORTP(argv[0]))
scheme_wrong_type("fprintf", "output-port", 0, argc, argv);
scheme_do_format("fprintf", argv[0], NULL, 0, 1, 2, argc, argv);

312
src/mzscheme/src/struct.c
View File

@ -26,6 +26,7 @@
Scheme_Object *scheme_arity_at_least, *scheme_date;
Scheme_Object *scheme_make_arity_at_least;
Scheme_Object *scheme_source_property;
Scheme_Object *scheme_input_port_property, *scheme_output_port_property;
/* locals */
@ -60,6 +61,8 @@ static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[])
static Scheme_Object *struct_type_property_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_write_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_input_port_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_output_port_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_struct_type(int argc, Scheme_Object *argv[]);
@ -99,6 +102,8 @@ static Scheme_Object *evt_property;
static int evt_struct_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo);
static int is_evt_struct(Scheme_Object *);
static Scheme_Object *proc_property;
static int wrapped_evt_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo);
static int nack_guard_evt_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo);
static int nack_evt_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo);
@ -229,7 +234,7 @@ scheme_init_struct (Scheme_Env *env)
{
Scheme_Object *guard, *a[2], *pred, *access;
guard = scheme_make_prim_w_arity(check_write_property_value_ok,
"prop:custom-write-guard",
"guard-for-prop:custom-write",
2, 2);
a[0] = scheme_intern_symbol("custom-write");
@ -247,10 +252,10 @@ scheme_init_struct (Scheme_Env *env)
{
Scheme_Object *guard;
guard = scheme_make_prim_w_arity(check_evt_property_value_ok,
"prop:evt-guard",
"guard-for-prop:evt",
2, 2);
evt_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("evt"),
guard);
guard);
scheme_add_global_constant("prop:evt", evt_property, env);
scheme_add_evt(scheme_structure_type,
@ -259,6 +264,33 @@ scheme_init_struct (Scheme_Env *env)
is_evt_struct, 1);
}
{
REGISTER_SO(proc_property);
proc_property = scheme_make_struct_type_property(scheme_intern_symbol("procedure"));
scheme_add_global_constant("prop:procedure", proc_property, env);
}
{
Scheme_Object *guard;
REGISTER_SO(scheme_input_port_property);
REGISTER_SO(scheme_output_port_property);
guard = scheme_make_prim_w_arity(check_input_port_property_value_ok,
"guard-for-prop:input-port",
2, 2);
scheme_input_port_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("input-port"),
guard);
guard = scheme_make_prim_w_arity(check_output_port_property_value_ok,
"guard-for-prop:output-port",
2, 2);
scheme_output_port_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("output-port"),
guard);
scheme_add_global_constant("prop:input-port", scheme_input_port_property, env);
scheme_add_global_constant("prop:output-port", scheme_output_port_property, env);
}
REGISTER_SO(scheme_recur_symbol);
REGISTER_SO(scheme_display_symbol);
REGISTER_SO(scheme_write_special_symbol);
@ -451,7 +483,7 @@ scheme_init_struct (Scheme_Env *env)
{
Scheme_Object *guard;
guard = scheme_make_prim_w_arity(check_exn_source_property_value_ok,
"prop:exn:srclocs-guard",
"guard-for-prop:exn:srclocs",
2, 2);
scheme_source_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("prop:exn:srclocs"),
guard);
@ -587,7 +619,7 @@ static Scheme_Object *prop_pred(int argc, Scheme_Object **args, Scheme_Object *p
return scheme_false;
}
static Scheme_Object *do_prop_accessor(Scheme_Object *prop, Scheme_Object *arg, int error_ok, const char *name)
XFORM_NONGCING static Scheme_Object *do_prop_accessor(Scheme_Object *prop, Scheme_Object *arg)
{
Scheme_Struct_Type *stype;
@ -601,7 +633,7 @@ static Scheme_Object *do_prop_accessor(Scheme_Object *prop, Scheme_Object *arg,
if (stype) {
if (stype->num_props < 0) {
Scheme_Object *v;
v = (Scheme_Object *)scheme_hash_get((Scheme_Hash_Table *)stype->props, prop);
v = (Scheme_Object *)scheme_eq_hash_get((Scheme_Hash_Table *)stype->props, prop);
if (v)
return v;
} else {
@ -613,17 +645,21 @@ static Scheme_Object *do_prop_accessor(Scheme_Object *prop, Scheme_Object *arg,
}
}
if (error_ok) /* hack; see scheme_struct_type_property_ref */
scheme_wrong_type(name ? name : "property accessor",
"struct or struct-type with property",
0, 1, (Scheme_Object **)&arg);
return NULL;
}
static Scheme_Object *prop_accessor(int argc, Scheme_Object **args, Scheme_Object *prim)
{
return do_prop_accessor(SCHEME_PRIM_CLOSURE_ELS(prim)[0], args[0], 1,
((Scheme_Primitive_Proc *)prim)->name);
Scheme_Object *v;
v = do_prop_accessor(SCHEME_PRIM_CLOSURE_ELS(prim)[0], args[0]);
if (!v)
scheme_wrong_type(((Scheme_Primitive_Proc *)prim)->name,
"struct or struct-type with property",
0, 1, args);
return v;
}
static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[])
@ -693,7 +729,7 @@ Scheme_Object *scheme_make_struct_type_property(Scheme_Object *name)
Scheme_Object *scheme_struct_type_property_ref(Scheme_Object *prop, Scheme_Object *s)
{
return do_prop_accessor(prop, s, 0, NULL);
return do_prop_accessor(prop, s);
}
static Scheme_Object *struct_type_property_p(int argc, Scheme_Object *argv[])
@ -726,10 +762,20 @@ static Scheme_Object *guard_property(Scheme_Object *prop, Scheme_Object *v, Sche
/* evt structs */
/*========================================================================*/
static int extract_accessor_offset(Scheme_Object *acc)
{
Struct_Proc_Info *i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(acc)[0];
if (i->struct_type->name_pos)
return i->struct_type->parent_types[i->struct_type->name_pos - 1]->num_slots;
else
return 0;
}
static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[])
/* This is the guard for prop:evt */
{
Scheme_Object *v, *l;
Scheme_Object *v, *l, *acc;
int pos, num_islots;
v = argv[0];
@ -742,7 +788,7 @@ static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[
if (!((SCHEME_INTP(v) && (SCHEME_INT_VAL(v) >= 0))
|| (SCHEME_BIGNUMP(v) && SCHEME_BIGPOS(v))))
scheme_arg_mismatch("prop:evt-guard",
scheme_arg_mismatch("guard-for-prop:evt",
"property value is not a evt, procedure (arity 1), or exact non-negative integer: ",
v);
@ -751,6 +797,7 @@ static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[
num_islots = SCHEME_INT_VAL(SCHEME_CAR(l));
l = SCHEME_CDR(l);
l = SCHEME_CDR(l);
acc = SCHEME_CAR(l);
l = SCHEME_CDR(l);
l = SCHEME_CDR(l);
l = SCHEME_CAR(l);
@ -761,7 +808,7 @@ static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[
pos = SCHEME_INT_VAL(v);
if (pos >= num_islots) {
scheme_arg_mismatch("evt-property-guard",
scheme_arg_mismatch("guard-for-prop:evt",
"field index >= initialized-field count for structure type: ",
v);
}
@ -772,11 +819,14 @@ static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[
}
if (!SCHEME_PAIRP(l)) {
scheme_arg_mismatch("evt-property-guard",
scheme_arg_mismatch("guard-for-prop:evt",
"field index not declared immutable: ",
v);
}
pos += extract_accessor_offset(acc);
v = scheme_make_integer(pos);
return v;
}
@ -786,6 +836,17 @@ static int evt_struct_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo)
v = scheme_struct_type_property_ref(evt_property, o);
if (!v) {
/* Must be an input or output port: */
if (SCHEME_INPUT_PORTP(o)) {
v = (Scheme_Object *)scheme_input_port_record(o);
} else {
v = (Scheme_Object *)scheme_output_port_record(o);
}
scheme_set_sync_target(sinfo, v, NULL, NULL, 0, 1);
return 0;
}
if (SCHEME_INTP(v))
v = ((Scheme_Structure *)o)->slots[SCHEME_INT_VAL(v)];
@ -825,7 +886,85 @@ static int evt_struct_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo)
static int is_evt_struct(Scheme_Object *o)
{
return !!scheme_struct_type_property_ref(evt_property, o);
if (scheme_struct_type_property_ref(evt_property, o))
return 1;
if (scheme_struct_type_property_ref(scheme_input_port_property, o))
return 1;
if (scheme_struct_type_property_ref(scheme_output_port_property, o))
return 1;
return 0;
}
/*========================================================================*/
/* port structs */
/*========================================================================*/
static Scheme_Object *check_port_property_value_ok(const char *name, int input, int argc, Scheme_Object *argv[])
/* This is the guard for prop:input-port and prop:output-port */
{
Scheme_Object *v, *l, *acc;
int pos, num_islots;
v = argv[0];
if ((input && SCHEME_INPUT_PORTP(v))
|| (!input && SCHEME_OUTPUT_PORTP(v)))
return v;
if (!((SCHEME_INTP(v) && (SCHEME_INT_VAL(v) >= 0))
|| (SCHEME_BIGNUMP(v) && SCHEME_BIGPOS(v))))
scheme_arg_mismatch(name,
(input
? "property value is not an input port or exact non-negative integer: "
: "property value is not an output port or exact non-negative integer: "),
v);
l = argv[1];
l = SCHEME_CDR(l);
num_islots = SCHEME_INT_VAL(SCHEME_CAR(l));
l = SCHEME_CDR(l);
l = SCHEME_CDR(l);
acc = SCHEME_CAR(l);
l = SCHEME_CDR(l);
l = SCHEME_CDR(l);
l = SCHEME_CAR(l);
if (SCHEME_BIGNUMP(v))
pos = num_islots; /* too big */
else
pos = SCHEME_INT_VAL(v);
if (pos >= num_islots) {
scheme_arg_mismatch(name,
"field index >= initialized-field count for structure type: ",
v);
}
for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
if (SCHEME_INT_VAL(SCHEME_CAR(l)) == pos)
break;
}
if (!SCHEME_PAIRP(l)) {
scheme_arg_mismatch(name,
"field index not declared immutable: ",
v);
}
pos += extract_accessor_offset(acc);
v = scheme_make_integer(pos);
return v;
}
static Scheme_Object *check_input_port_property_value_ok(int argc, Scheme_Object *argv[])
{
return check_port_property_value_ok("guard-for-prop:input-port", 1, argc, argv);
}
static Scheme_Object *check_output_port_property_value_ok(int argc, Scheme_Object *argv[])
{
return check_port_property_value_ok("guard-for-prop:output-port", 0, argc, argv);
}
/*========================================================================*/
@ -839,7 +978,7 @@ static Scheme_Object *check_write_property_value_ok(int argc, Scheme_Object *arg
v = argv[0];
if (!scheme_check_proc_arity(NULL, 3, 0, argc, argv)) {
scheme_arg_mismatch("prop:custom-write-guard",
scheme_arg_mismatch("guard-for-prop:custom-write",
"not a procedure of arity 3: ",
v);
}
@ -2255,14 +2394,15 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
{
Scheme_Struct_Type *struct_type, *parent_type;
int j, depth;
int props_delta = 0, prop_needs_const = 0;
parent_type = (Scheme_Struct_Type *)parent;
depth = parent_type ? (1 + parent_type->name_pos) : 0;
struct_type =(Scheme_Struct_Type *)scheme_malloc_tagged(sizeof(Scheme_Struct_Type)
+ (depth
* sizeof(Scheme_Struct_Type *)));
struct_type = (Scheme_Struct_Type *)scheme_malloc_tagged(sizeof(Scheme_Struct_Type)
+ (depth
* sizeof(Scheme_Struct_Type *)));
/* defeats optimizer bug in gcc 2.7.2.3: */
depth = parent_type ? (1 + parent_type->name_pos) : 0;
@ -2317,23 +2457,43 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
}
/* In principle, we should check for duplicate properties here
to keep the mismatch exceptions in the right order. */
to keep the mismatch exceptions in the right order. */
if (!uninit_val)
uninit_val = scheme_false;
struct_type->uninit_val = uninit_val;
if (props) {
Scheme_Object *l;
for (l = props; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
if (SAME_OBJ(SCHEME_CAAR(l), proc_property)) {
if (proc_attr) {
scheme_arg_mismatch("make-struct-type",
"given both a prop:procedure property value and a procedure specification: ",
proc_attr);
}
proc_attr = SCHEME_CDR(SCHEME_CAR(l));
if (SCHEME_INTP(proc_attr))
prop_needs_const = 1;
props_delta = 1;
break;
}
}
}
if (proc_attr) {
if (SCHEME_INTP(proc_attr) || SCHEME_BIGNUMP(proc_attr)) {
Scheme_Object *pa = proc_attr;
if (SCHEME_INTP(pa) || SCHEME_BIGNUMP(pa)) {
long pos;
if (SCHEME_INTP(proc_attr))
pos = SCHEME_INT_VAL(proc_attr);
if (SCHEME_INTP(pa))
pos = SCHEME_INT_VAL(pa);
else
pos = struct_type->num_slots; /* too big */
if (pos >= struct_type->num_islots) {
scheme_arg_mismatch("make-struct-type", "index for procedure >= initialized-field count: ", proc_attr);
scheme_arg_mismatch("make-struct-type", "index for procedure >= initialized-field count: ", pa);
return NULL;
}
@ -2341,16 +2501,16 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
if (parent_type->proc_attr) {
scheme_arg_mismatch("make-struct-type",
"parent type already has procedure specification, new one disallowed: ",
proc_attr);
pa);
return NULL;
}
pos += parent_type->num_slots;
proc_attr = scheme_make_integer(pos);
pa = scheme_make_integer(pos);
}
}
struct_type->proc_attr = proc_attr;
struct_type->proc_attr = pa;
}
if ((struct_type->proc_attr && SCHEME_INTP(struct_type->proc_attr))
@ -2365,12 +2525,9 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
ims = (char *)scheme_malloc_atomic(n);
memset(ims, 0, n);
if (SCHEME_INTP(struct_type->proc_attr)) {
p = SCHEME_INT_VAL(struct_type->proc_attr);
if (parent_type)
p -= parent_type->num_slots;
if (p >= 0)
ims[p] = 1;
if (proc_attr && SCHEME_INTP(proc_attr) && !prop_needs_const) {
p = SCHEME_INT_VAL(proc_attr);
ims[p] = 1;
}
for (l = immutable_pos_list; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
@ -2396,6 +2553,15 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
ims[p] = 1;
}
if (proc_attr && SCHEME_INTP(proc_attr) && prop_needs_const) {
p = SCHEME_INT_VAL(proc_attr);
if (!ims[p]) {
scheme_arg_mismatch("make-struct-type",
"field is not specified as immutable for a prop:procedure index: ",
proc_attr);
}
}
struct_type->immutables = ims;
}
@ -2410,7 +2576,7 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
can_override = scheme_make_hash_table(SCHEME_hash_ptr);
num_props = scheme_list_length(props);
num_props = scheme_list_length(props) - props_delta;
if ((struct_type->num_props < 0) || (struct_type->num_props + num_props > PROP_USE_HT_COUNT)) {
Scheme_Hash_Table *ht;
@ -2438,17 +2604,24 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
for (l = props; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
prop = SCHEME_CAR(a);
if (scheme_hash_get(ht, prop)) {
/* Property is already in the superstruct_type */
if (!scheme_hash_get(can_override, prop))
break;
/* otherwise we override */
scheme_hash_set(can_override, prop, NULL);
}
propv = guard_property(prop, SCHEME_CDR(a), struct_type);
scheme_hash_set(ht, prop, propv);
if (SAME_OBJ(prop, proc_property)) {
if (props_delta)
props_delta = 0;
else
break;
} else {
if (scheme_hash_get(ht, prop)) {
/* Property is already in the superstruct_type */
if (!scheme_hash_get(can_override, prop))
break;
/* otherwise we override */
scheme_hash_set(can_override, prop, NULL);
}
propv = guard_property(prop, SCHEME_CDR(a), struct_type);
scheme_hash_set(ht, prop, propv);
}
}
struct_type->props = (Scheme_Object **)ht;
@ -2474,25 +2647,32 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
prop = SCHEME_CAR(a);
/* Check whether already in table: */
for (j = 0; j < num_props; j++) {
if (SAME_OBJ(SCHEME_CAR(pa[j]), prop))
break;
}
if (j < num_props) {
/* already there */
if (!scheme_hash_get(can_override, prop))
break;
/* overriding it: */
scheme_hash_set(can_override, prop, NULL);
} else {
num_props++;
}
if (SAME_OBJ(prop, proc_property)) {
if (props_delta)
props_delta = 0;
else
break;
} else {
/* Check whether already in table: */
for (j = 0; j < num_props; j++) {
if (SAME_OBJ(SCHEME_CAR(pa[j]), prop))
break;
}
if (j < num_props) {
/* already there */
if (!scheme_hash_get(can_override, prop))
break;
/* overriding it: */
scheme_hash_set(can_override, prop, NULL);
} else {
num_props++;
}
propv = guard_property(prop, SCHEME_CDR(a), struct_type);
propv = guard_property(prop, SCHEME_CDR(a), struct_type);
a = scheme_make_pair(prop, propv);
pa[j] = a;
a = scheme_make_pair(prop, propv);
pa[j] = a;
}
}
struct_type->num_props = num_props;
@ -2849,7 +3029,7 @@ static Scheme_Object *exn_source_get(int argc, Scheme_Object **argv)
static Scheme_Object *check_exn_source_property_value_ok(int argc, Scheme_Object *argv[])
/* This is the guard for prop:exn:srclocs */
{
scheme_check_proc_arity("prop:exn:srclocs-guard", 1, 0, argc, argv);
scheme_check_proc_arity("guard-for-prop:exn:srclocs", 1, 0, argc, argv);
return argv[0];
}

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

@ -74,6 +74,8 @@ static Scheme_Object *begin_syntax (Scheme_Object *form, Scheme_Comp_Env *env, S
static Scheme_Object *begin_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
static Scheme_Object *begin0_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
static Scheme_Object *begin0_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
static Scheme_Object *expression_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
static Scheme_Object *expression_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
static Scheme_Object *unquote_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
static Scheme_Object *unquote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
@ -98,6 +100,7 @@ static Scheme_Object *define_for_syntaxes_execute(Scheme_Object *expr);
static Scheme_Object *case_lambda_execute(Scheme_Object *expr);
static Scheme_Object *begin0_execute(Scheme_Object *data);
static Scheme_Object *apply_values_execute(Scheme_Object *data);
static Scheme_Object *splice_execute(Scheme_Object *data);
static Scheme_Object *bangboxenv_execute(Scheme_Object *data);
static Scheme_Object *bangboxvalue_execute(Scheme_Object *data);
@ -110,16 +113,19 @@ static Scheme_Object *define_for_syntaxes_optimize(Scheme_Object *expr, Optimize
static Scheme_Object *case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info);
static Scheme_Object *begin0_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *apply_values_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *splice_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *begin0_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
static Scheme_Object *set_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
static Scheme_Object *apply_values_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
static Scheme_Object *splice_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
static Scheme_Object *begin0_shift(Scheme_Object *data, int delta, int after_depth);
static Scheme_Object *set_shift(Scheme_Object *data, int delta, int after_depth);
static Scheme_Object *ref_shift(Scheme_Object *data, int delta, int after_depth);
static Scheme_Object *case_lambda_shift(Scheme_Object *data, int delta, int after_depth);
static Scheme_Object *apply_values_shift(Scheme_Object *data, int delta, int after_depth);
static Scheme_Object *splice_shift(Scheme_Object *data, int delta, int after_depth);
static Scheme_Object *define_values_resolve(Scheme_Object *data, Resolve_Info *info);
static Scheme_Object *ref_resolve(Scheme_Object *data, Resolve_Info *info);
@ -129,6 +135,7 @@ static Scheme_Object *define_for_syntaxes_resolve(Scheme_Object *expr, Resolve_I
static Scheme_Object *case_lambda_resolve(Scheme_Object *expr, Resolve_Info *info);
static Scheme_Object *begin0_resolve(Scheme_Object *data, Resolve_Info *info);
static Scheme_Object *apply_values_resolve(Scheme_Object *data, Resolve_Info *info);
static Scheme_Object *splice_resolve(Scheme_Object *data, Resolve_Info *info);
static void define_values_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
@ -162,6 +169,10 @@ static void apply_values_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts);
static void splice_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts);
static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta,
@ -179,6 +190,7 @@ static Scheme_Object *define_for_syntaxes_jit(Scheme_Object *expr);
static Scheme_Object *case_lambda_jit(Scheme_Object *expr);
static Scheme_Object *begin0_jit(Scheme_Object *data);
static Scheme_Object *apply_values_jit(Scheme_Object *data);
static Scheme_Object *splice_jit(Scheme_Object *data);
static Scheme_Object *bangboxvalue_jit(Scheme_Object *data);
static Scheme_Object *expand_lam(int argc, Scheme_Object **argv);
@ -293,6 +305,12 @@ scheme_init_syntax (Scheme_Env *env)
apply_values_execute, apply_values_jit,
apply_values_clone, apply_values_shift, 1);
scheme_register_syntax(SPLICE_EXPD,
splice_optimize,
splice_resolve, splice_validate,
splice_execute, splice_jit,
splice_clone, splice_shift, 0);
scheme_register_syntax(BOXENV_EXPD,
NULL, NULL, bangboxenv_validate,
bangboxenv_execute, NULL,
@ -357,6 +375,11 @@ scheme_init_syntax (Scheme_Env *env)
ref_expand),
env);
scheme_add_global_keyword("#%expression",
scheme_make_compiled_syntax(expression_syntax,
expression_expand),
env);
scheme_add_global_keyword("case-lambda",
scheme_make_compiled_syntax(case_lambda_syntax,
case_lambda_expand),
@ -4186,6 +4209,12 @@ do_begin_syntax(char *name,
forms = scheme_make_sequence_compilation(body, zero ? -1 : 1);
if (!zero
&& SAME_TYPE(SCHEME_TYPE(forms), scheme_sequence_type)
&& scheme_is_toplevel(env)) {
return scheme_make_syntax_compiled(SPLICE_EXPD, forms);
}
if (!zero || (NOT_SAME_TYPE(SCHEME_TYPE(forms), scheme_begin0_sequence_type)))
return forms;
@ -4291,6 +4320,134 @@ begin0_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *ere
return do_begin_expand("begin0", form, env, erec, drec, 1);
}
/**********************************************************************/
/* top-level splicing begin */
/**********************************************************************/
static Scheme_Object *splice_one_expr(void *expr, int argc, Scheme_Object **argv)
{
return _scheme_eval_linked_expr_multi((Scheme_Object *)expr);
}
static Scheme_Object *splice_execute(Scheme_Object *data)
{
Scheme_Sequence *seq = (Scheme_Sequence *)data;
int i, cnt = seq->count - 1;
for (i = 0; i < cnt; i++) {
(void)_scheme_call_with_prompt_multi(splice_one_expr, seq->array[i]);
}
return _scheme_eval_linked_expr_multi(seq->array[cnt]);
}
static Scheme_Object *splice_jit(Scheme_Object *data)
{
return scheme_jit_expr(data);
}
static Scheme_Object *
splice_optimize(Scheme_Object *data, Optimize_Info *info)
{
data = scheme_optimize_expr(data, info);
if (SCHEME_TYPE(data) != scheme_sequence_type)
return data;
return scheme_make_syntax_compiled(SPLICE_EXPD, data);
}
static Scheme_Object *
splice_resolve(Scheme_Object *data, Resolve_Info *rslv)
{
return scheme_make_syntax_resolved(SPLICE_EXPD,
scheme_resolve_expr(data, rslv));
}
static Scheme_Object *
splice_shift(Scheme_Object *data, int delta, int after_depth)
{
return scheme_make_syntax_compiled(SPLICE_EXPD,
scheme_optimize_shift(data, delta, after_depth));
}
static Scheme_Object *
splice_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth)
{
data = scheme_optimize_clone(dup_ok, data, info, delta, closure_depth);
if (!data) return NULL;
return scheme_make_syntax_compiled(SPLICE_EXPD, data);
}
static void splice_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts)
{
scheme_validate_expr(port, data, stack, ht, tls,
depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts,
NULL, 0);
}
/**********************************************************************/
/* #%non-module and #%expression */
/**********************************************************************/
static Scheme_Object *check_single(Scheme_Object *form, Scheme_Comp_Env *top_only)
{
Scheme_Object *rest;
check_form(form, form);
rest = SCHEME_STX_CDR(form);
if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest))))
scheme_wrong_syntax(NULL, NULL, form, "bad syntax (wrong number of parts)");
if (top_only && !scheme_is_toplevel(top_only))
scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)");
return SCHEME_STX_CAR(rest);
}
static Scheme_Object *
single_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, int top_only)
{
return scheme_compile_expr(check_single(form, top_only ? env: NULL), env, rec, drec);
}
static Scheme_Object *
single_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec,
int top_only, int simplify)
{
Scheme_Object *expr, *form_name;
expr = check_single(form, top_only ? env : NULL);
expr = scheme_expand_expr(expr, env, erec, drec);
if (simplify && (erec[drec].depth == -1)) {
return expr;
}
form_name = SCHEME_STX_CAR(form);
return scheme_datum_to_syntax(icons(form_name, icons(expr, scheme_null)),
form, form,
0, 2);
}
static Scheme_Object *expression_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
{
return single_syntax(form, scheme_no_defines(env), rec, drec, 0);
}
static Scheme_Object *expression_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
return single_expand(form, scheme_no_defines(env), erec, drec, 0,
!scheme_is_toplevel(env));
}
/**********************************************************************/
/* unquote, unquote-splicing */
/**********************************************************************/

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

@ -178,6 +178,7 @@ static Scheme_Custodian *last_custodian;
static Scheme_Object *scheduled_kills;
Scheme_Object *scheme_parameterization_key;
Scheme_Object *scheme_exn_handler_key;
Scheme_Object *scheme_break_enabled_key;
long scheme_total_gc_time;
@ -754,8 +755,10 @@ void scheme_init_parameterization(Scheme_Env *env)
Scheme_Object *v;
Scheme_Env *newenv;
REGISTER_SO(scheme_exn_handler_key);
REGISTER_SO(scheme_parameterization_key);
REGISTER_SO(scheme_break_enabled_key);
scheme_exn_handler_key = scheme_make_symbol("exnh");
scheme_parameterization_key = scheme_make_symbol("paramz");
scheme_break_enabled_key = scheme_make_symbol("break-on?");
@ -765,6 +768,9 @@ void scheme_init_parameterization(Scheme_Env *env)
v = scheme_intern_symbol("#%paramz");
newenv = scheme_primitive_module(v, env);
scheme_add_global_constant("exception-handler-key",
scheme_exn_handler_key,
newenv);
scheme_add_global_constant("parameterization-key",
scheme_parameterization_key,
newenv);
@ -786,6 +792,7 @@ void scheme_init_parameterization(Scheme_Env *env)
scheme_finish_primitive_module(newenv);
scheme_protect_primitive_provide(newenv, NULL);
}
static Scheme_Object *collect_garbage(int c, Scheme_Object *p[])
@ -2526,11 +2533,6 @@ static Scheme_Object *make_subprocess(Scheme_Object *child_thunk,
maybe_recycle_cell = NULL;
}
config = scheme_init_error_escape_proc(config);
config = scheme_extend_config(config, MZCONFIG_EXN_HANDLER,
scheme_get_thread_param(config, cells,
MZCONFIG_INIT_EXN_HANDLER));
child = make_thread(config, cells, break_cell, mgr);
/* Use child_thunk name, if any, for the thread name: */
@ -2884,15 +2886,6 @@ Scheme_Object *scheme_call_as_nested_thread(int argc, Scheme_Object *argv[], voi
{
Scheme_Config *config;
config = scheme_current_config();
config = scheme_init_error_escape_proc(config);
if (!nested_exn_handler) {
REGISTER_SO(nested_exn_handler);
nested_exn_handler = scheme_make_prim_w_arity(def_nested_exn_handler,
"nested-thread-exception-handler",
1, 1);
}
config = scheme_extend_config(config, MZCONFIG_EXN_HANDLER, nested_exn_handler);
np->init_config = config;
}
{
@ -2946,6 +2939,14 @@ Scheme_Object *scheme_call_as_nested_thread(int argc, Scheme_Object *argv[], voi
if (p != scheme_main_thread)
scheme_weak_suspend_thread(p);
if (!nested_exn_handler) {
REGISTER_SO(nested_exn_handler);
nested_exn_handler = scheme_make_prim_w_arity(def_nested_exn_handler,
"nested-thread-exception-handler",
1, 1);
}
scheme_set_cont_mark(scheme_exn_handler_key, nested_exn_handler);
/* Call thunk, catch escape: */
np->error_buf = &newbuf;
if (scheme_setjmp(newbuf)) {
@ -3969,6 +3970,11 @@ void scheme_weak_resume_thread(Scheme_Thread *r)
}
}
void scheme_about_to_move_C_stack(void)
{
wait_until_suspend_ok();
}
static Scheme_Object *
sch_sleep(int argc, Scheme_Object *args[])
{
@ -5533,7 +5539,19 @@ static Scheme_Object *do_param(void *data, int argc, Scheme_Object *argv[]);
Scheme_Config *scheme_current_config()
{
return (Scheme_Config *)scheme_extract_one_cc_mark(NULL, scheme_parameterization_key);
Scheme_Object *v;
v = scheme_extract_one_cc_mark(NULL, scheme_parameterization_key);
if (!SAME_TYPE(scheme_config_type, SCHEME_TYPE(v))) {
/* Someone has grabbed parameterization-key out of #%paramz
and misused it.
Printing an error message requires consulting parameters,
so just escape. */
scheme_longjmp(scheme_error_buf, 1);
}
return (Scheme_Config *)v;
}
static Scheme_Config *do_extend_config(Scheme_Config *c, Scheme_Object *key, Scheme_Object *cell)

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

@ -355,12 +355,10 @@ static void FIXUP_cjs(Scheme_Continuation_Jump_State *cjs)
static void MARK_stack_state(Scheme_Stack_State *ss)
{
gcMARK(ss->barrier_prompt);
}
static void FIXUP_stack_state(Scheme_Stack_State *ss)
{
gcFIXUP(ss->barrier_prompt);
}
static void MARK_jmpup(Scheme_Jumpup_Buf *buf)