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

sync to trunk

Browse Source 
svn: r14751
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-08 20:11:35 +00:00
commit 1911b762eb
13 changed files with 394 additions and 202 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
src/README
View File

@ -63,8 +63,23 @@ the Unix instructions below, but note the following:
Quick instructions:
The usual `./configure', `make', and `make install' sequence
typically works fine.
From this directory (where the `README' and `configure' files are),
run the following commands:
mkdir build
cd build
../configure
make
make install
This will create an in-place installation of PLT Scheme and store the
results of C/C++ compilation in a separate `build' subdirectory,
which is useful if you need to update your sources, delete the build,
and start from scratch.
You can also run the typical `./configure && make && make install' if
you don't anticipate updating/rebuilding, but it will be harder to
restart from scratch should you need to.
Detailed instructions:
@ -86,29 +101,19 @@ Detailed instructions:
`make'. If the build fails with another variant of `make', please
try using GNU `make'.
1. Run the script `configure' (which is in the same directory as this
README), possibly with a --prefix=TARGETDIR command-line argument
and optionally with --enable-shared.
For example, if you want to install into /usr/local/plt using
dynamic libraries, then run
[here]configure --prefix=/usr/local/plt --enable-shared
where "[here]" is the directory path containing the `configure'
script (possibly unnecessary, or possibly just "./", depending on
your shell and PATH setting).
1. Select (or create) a build directory.
It's better to run the build in a directory other than the one
contianing `configure', especially if you're getting sources via
Subversion. Also, `svn update' ignores a subdirectory next to
`configure' called "build", so a better and more common way to
configure a Subversion-based build is as follows:
containing `configure', especially if you're getting sources via
Subversion. A common way to start a Subversion-based build is:
cd [here]
mkdir build
cd build
../configure
where "[here]" is the directory containing this `README' file and
the `configure' script. The Subversion repository is configured
to support this convention by ignoring `build' in this directory.
A separate build directory is better in case the Makefile
organization changes, or in case the Makefiles lack some
@ -116,6 +121,21 @@ Detailed instructions:
you can just delete and re-create "build" without mangling your
source tree.
2. From your build directory, run the script `configure' (which is in
the same directory as this README), with optional command-line
arguments --prefix=TARGETDIR or --enable-shared (or both).
For example, if you want to install into /usr/local/plt using
dynamic libraries, then run:
[here]configure --prefix=/usr/local/plt --enable-shared
Again, "[here]" is the directory path containing the `configure'
script. If you follow the convention of running from a "build"
subdirectory, "[here]" is just "../". If you build from the
current directory, "[here]" is possibly unnecessary, or possibly
just "./", depending on your shell and PATH setting.
If the --prefix flag is omitted, the binaries are built for an
in-place installation (i.e., the parent of the directory
containing this README will be used directly). Unless
@ -160,7 +180,7 @@ Detailed instructions:
build directory (but the same source) for each platform or
configuration.
2. Run `make'. [As noted in step 0, this must be GNU `make'.]
3. Run `make'. [As noted in step 0, this must be GNU `make'.]
With Cygwin, you may need to use `make --unix'.
@ -168,7 +188,7 @@ Detailed instructions:
directory. For example, the `mzscheme' binary appears in the
`mzscheme' directory.
3. Run `make install'.
4. Run `make install'.
This step copies binaries and libraries into place within the
target installation. For example, the `mzscheme' binary is copied
@ -193,11 +213,11 @@ Detailed instructions:
If the installation fails because the target directory cannot be
created, or because the target directory is not the one you
wanted, then you can try repeating step 3 after runing `configure'
want, then you can try repeating step 4 after running `configure'
again with a new --prefix value. That is, sometimes it is not
necessary to repeat steps 1 or 2 (so try it and find out). On
other platforms and configurations, it is necessary to start with
a clean build directory when changing the --prefix value, because
necessary to repeat step 3 (so try it and find out). On other
platforms and configurations, it is necessary to start with a
clean build directory when changing the --prefix value, because
the path gets wired into shared objects.
If you build frequently from the Subversion-based sources, beware

10
src/mzscheme/gc2/newgc.c
View File

@ -746,13 +746,15 @@ inline static void *fast_malloc_one_small_tagged(size_t sizeb, int dirty)
}
}
#define PAIR_SIZE_IN_BYTES ALIGN_BYTES_SIZE(gcWORDS_TO_BYTES(gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object))) + WORD_SIZE)
void *GC_malloc_pair(void *car, void *cdr)
{
unsigned long ptr, newptr;
size_t sizeb;
void *retval;
sizeb = ALIGN_BYTES_SIZE(gcWORDS_TO_BYTES(gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object))) + WORD_SIZE);
sizeb = PAIR_SIZE_IN_BYTES;
ptr = GC_gen0_alloc_page_ptr;
newptr = GC_gen0_alloc_page_ptr + sizeb;
@ -1887,7 +1889,11 @@ void GC_mark(const void *const_p)
/* transfer the object */
ohead->mark = 1; /* mark is copied to newplace, too */
memcpy(newplace, (const void *)ohead, size);
if (size == PAIR_SIZE_IN_BYTES)
/* pairs are common, and compiler tends to inline constant-size memcpys */
memcpy(newplace, ohead, PAIR_SIZE_IN_BYTES);
else
memcpy(newplace, ohead, size);
/* mark the old location as marked and moved, and the new location
as marked */
ohead->moved = 1;

4
src/mzscheme/src/env.c
View File

@ -4436,7 +4436,7 @@ id_intdef_remove(int argc, Scheme_Object *argv[])
Scheme_Object *l, *res, *skips;
if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0])))
scheme_wrong_type("identifier-from-from-definition-context",
scheme_wrong_type("identifier-remove-from-definition-context",
"syntax identifier", 0, argc, argv);
l = argv[1];
@ -4515,6 +4515,8 @@ local_module_introduce(int argc, Scheme_Object *argv[])
if (SCHEME_FALSEP(v)) {
if (env->genv->rename_set)
s = scheme_add_rename(s, env->genv->rename_set);
if (env->genv->post_ex_rename_set)
s = scheme_add_rename(s, env->genv->post_ex_rename_set);
}
return s;

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

@ -2564,6 +2564,53 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
return (Scheme_Object *)app;
}
static Scheme_Object *lookup_constant_proc(Optimize_Info *info, Scheme_Object *rand)
{
Scheme_Object *c = NULL;
if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(rand)))
c = rand;
if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) {
int offset;
Scheme_Object *expr;
expr = scheme_optimize_reverse(info, SCHEME_LOCAL_POS(rand), 0);
c = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(expr), &offset, NULL);
}
if (SAME_TYPE(SCHEME_TYPE(rand), scheme_compiled_toplevel_type)) {
if (info->top_level_consts) {
int pos;
while (1) {
pos = SCHEME_TOPLEVEL_POS(rand);
c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos));
if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_compiled_toplevel_type))
rand = c;
else
break;
}
}
}
if (c && SAME_TYPE(scheme_noninline_proc_type, SCHEME_TYPE(c))) {
c = SCHEME_BOX_VAL(c);
while (SAME_TYPE(SCHEME_TYPE(c), scheme_compiled_let_void_type)) {
/* This must be (let ([x <proc>]) <proc>); see scheme_is_statically_proc() */
Scheme_Let_Header *lh = (Scheme_Let_Header *)c;
Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body;
c = lv->body;
}
}
if (c
&& (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(c))
|| (SAME_TYPE(scheme_compiled_syntax_type, SCHEME_TYPE(c))
&& (SCHEME_PINT_VAL(c) == CASE_LAMBDA_EXPD))))
return c;
return NULL;
}
static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *info)
{
Scheme_App2_Rec *app;
@ -2598,21 +2645,11 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
}
if (SAME_OBJ(scheme_procedure_p_proc, app->rator)) {
if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(app->rand))) {
if (lookup_constant_proc(info, app->rand)) {
info->preserves_marks = 1;
info->single_result = 1;
return scheme_true;
}
if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type)) {
int offset;
Scheme_Object *expr;
expr = scheme_optimize_reverse(info, SCHEME_LOCAL_POS(app->rand), 0);
if (scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(expr), &offset, NULL)) {
info->preserves_marks = 1;
info->single_result = 1;
return scheme_true;
}
}
}
if ((SAME_OBJ(scheme_values_func, app->rator)
@ -2702,6 +2739,53 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
}
}
if (SAME_OBJ(scheme_procedure_arity_includes_proc, app->rator)) {
if (SCHEME_INTP(app->rand2)) {
Scheme_Object *proc;
Scheme_Case_Lambda *cl;
int i, cnt;
proc = lookup_constant_proc(info, app->rand1);
if (proc) {
if (SAME_TYPE(SCHEME_TYPE(proc), scheme_compiled_unclosed_procedure_type)) {
cnt = 1;
cl = NULL;
} else {
cl = (Scheme_Case_Lambda *)SCHEME_IPTR_VAL(proc);
cnt = cl->count;
}
for (i = 0; i < cnt; i++) {
if (cl) proc = cl->array[i];
if (SAME_TYPE(SCHEME_TYPE(proc), scheme_compiled_unclosed_procedure_type)) {
Scheme_Closure_Data *data = (Scheme_Closure_Data *)proc;
int n = SCHEME_INT_VAL(app->rand2), ok;
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) {
ok = ((data->num_params - 1) <= n);
} else {
ok = (data->num_params == n);
}
if (ok) {
info->preserves_marks = 1;
info->single_result = 1;
return scheme_true;
}
} else {
break;
}
}
if (i == cnt) {
info->preserves_marks = 1;
info->single_result = 1;
return scheme_false;
}
}
}
}
info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
if (rator_flags & CLOS_RESULT_TENTATIVE) {

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

@ -81,6 +81,7 @@ int scheme_defining_primitives; /* set to 1 during start-up */
Scheme_Object scheme_void[1]; /* the void constant */
Scheme_Object *scheme_values_func; /* the function bound to `values' */
Scheme_Object *scheme_procedure_p_proc;
Scheme_Object *scheme_procedure_arity_includes_proc;
Scheme_Object *scheme_void_proc;
Scheme_Object *scheme_call_with_values_proc; /* the function bound to `call-with-values' */
Scheme_Object *scheme_reduced_procedure_struct;
@ -226,6 +227,7 @@ scheme_init_fun (Scheme_Env *env)
REGISTER_SO(cached_dv_stx);
REGISTER_SO(cached_ds_stx);
REGISTER_SO(scheme_procedure_p_proc);
REGISTER_SO(scheme_procedure_arity_includes_proc);
REGISTER_SO(offstack_cont);
REGISTER_SO(offstack_overflow);
@ -488,11 +490,14 @@ scheme_init_fun (Scheme_Env *env)
"procedure-arity?",
1, 1, 1),
env);
scheme_procedure_arity_includes_proc = scheme_make_folding_prim(procedure_arity_includes,
"procedure-arity-includes?",
2, 2, 1);
scheme_add_global_constant("procedure-arity-includes?",
scheme_make_folding_prim(procedure_arity_includes,
"procedure-arity-includes?",
2, 2, 1),
scheme_procedure_arity_includes_proc,
env);
scheme_add_global_constant("procedure-reduce-arity",
scheme_make_prim_w_arity(procedure_reduce_arity,
"procedure-reduce-arity",

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

@ -4983,7 +4983,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
simultaneous definitions: */
if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_syntax_type)
&& (SCHEME_PINT_VAL(e) == DEFINE_VALUES_EXPD)) {
int n;
int n, cnst = 0, sproc = 0;
e = (Scheme_Object *)SCHEME_IPTR_VAL(e);
@ -4993,7 +4993,16 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
n = scheme_list_length(vars);
cont = scheme_omittable_expr(e, n, -1, 0, info);
if ((n == 1) && scheme_compiled_propagate_ok(e, info)) {
if (n == 1) {
if (scheme_compiled_propagate_ok(e, info))
cnst = 1;
else if (scheme_is_statically_proc(e, info)) {
cnst = 1;
sproc = 1;
}
}
if (cnst) {
Scheme_Toplevel *tl;
tl = (Scheme_Toplevel *)SCHEME_CAR(vars);
@ -5001,7 +5010,9 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) {
Scheme_Object *e2;
if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_unclosed_procedure_type)) {
if (sproc) {
e2 = scheme_make_noninline_proc(e);
} else if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_unclosed_procedure_type)) {
e2 = scheme_optimize_clone(1, e, info, 0, 0);
if (e2) {
Scheme_Object *pr;
@ -5011,7 +5022,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
else
cl_first = pr;
cl_last = pr;
}
} else
e2 = scheme_make_noninline_proc(e);
} else {
e2 = e;
}
@ -5102,6 +5114,9 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
if (rpos) {
e = (Scheme_Object *)SCHEME_IPTR_VAL(e);
e = SCHEME_CDR(e);
if (!scheme_compiled_propagate_ok(e, info)
&& scheme_is_statically_proc(e, info))
e = scheme_make_noninline_proc(e);
scheme_hash_set(info->top_level_consts, rpos, e);
}
}
@ -5540,6 +5555,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
if (rec[drec].comp || (rec[drec].depth != -2)) {
/* rename tables no longer needed; NULL them out */
menv->rename_set = NULL;
menv->post_ex_rename_set = NULL;
}
LOG_END_EXPAND(m);
@ -6005,6 +6021,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
post_ex_rn_set = scheme_make_module_rename_set(mzMOD_RENAME_MARKED, rn_set);
post_ex_rn = scheme_get_module_rename_from_set(post_ex_rn_set, scheme_make_integer(0), 1);
post_ex_et_rn = scheme_get_module_rename_from_set(post_ex_rn_set, scheme_make_integer(1), 1);
env->genv->post_ex_rename_set = post_ex_rn_set;
/* For syntax-local-context, etc., in a d-s RHS: */
rhs_env = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME);
@ -9083,14 +9100,11 @@ static void check_dup_require(Scheme_Object *prnt_name, Scheme_Object *name,
}
static Scheme_Object *
top_level_require_execute(Scheme_Object *data)
do_require_execute(Scheme_Env *env, Scheme_Object *form)
{
Scheme_Hash_Table *ht;
Scheme_Object *rn_set, *modidx;
Scheme_Object *form = SCHEME_CDR(data), *rest;
Scheme_Env *env;
env = scheme_environment_from_dummy(SCHEME_CAR(data));
Scheme_Object *rest;
if (env->module)
modidx = env->module->self_modidx;
@ -9132,6 +9146,13 @@ top_level_require_execute(Scheme_Object *data)
return scheme_void;
}
static Scheme_Object *
top_level_require_execute(Scheme_Object *data)
{
do_require_execute(scheme_environment_from_dummy(SCHEME_CAR(data)),
SCHEME_CDR(data));
}
static Scheme_Object *
top_level_require_jit(Scheme_Object *data)
{
@ -9237,7 +9258,7 @@ Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path,
form = make_require_form(module_path, phase, mark);
do_require(form, cenv, NULL, 0);
do_require_execute(cenv->genv, form);
return form;
}

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

@ -2090,6 +2090,7 @@ static int namespace_val_MARK(void *p) {
gcMARK(e->rename_set);
gcMARK(e->temp_marked_names);
gcMARK(e->post_ex_rename_set);
gcMARK(e->syntax);
gcMARK(e->exp_env);
@ -2128,6 +2129,7 @@ static int namespace_val_FIXUP(void *p) {
gcFIXUP(e->rename_set);
gcFIXUP(e->temp_marked_names);
gcFIXUP(e->post_ex_rename_set);
gcFIXUP(e->syntax);
gcFIXUP(e->exp_env);

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

@ -833,6 +833,7 @@ namespace_val {
gcMARK(e->rename_set);
gcMARK(e->temp_marked_names);
gcMARK(e->post_ex_rename_set);
gcMARK(e->syntax);
gcMARK(e->exp_env);

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

@ -4362,6 +4362,52 @@ static Scheme_Object *read_compact_svector(CPort *port, int l)
return o;
}
static Scheme_Object *read_compact_escape(CPort *port)
{
#if defined(MZ_PRECISE_GC)
# define ESC_BLK_BUF_SIZE 32
char buffer[ESC_BLK_BUF_SIZE];
#endif
int len;
Scheme_Object *ep;
char *s;
ReadParams params;
len = read_compact_number(port);
RANGE_CHECK_GETS((unsigned)len);
#if defined(MZ_PRECISE_GC)
s = read_compact_chars(port, buffer, ESC_BLK_BUF_SIZE, len);
if (s != buffer)
len = -len; /* no alloc in sized_byte_string_input_port */
#else
s = (char *)port->start + port->pos;
port->pos += len;
len = -len; /* no alloc in sized_byte_string_input_port */
#endif
ep = scheme_make_sized_byte_string_input_port(s, len);
params.can_read_compiled = 1;
params.can_read_pipe_quote = 1;
params.can_read_box = 1;
params.can_read_graph = 1;
/* Use startup value of case sensitivity so legacy code will work. */
params.case_sensitive = scheme_case_sensitive;
params.square_brackets_are_parens = 1;
params.curly_braces_are_parens = 1;
params.read_decimal_inexact = 1;
params.can_read_dot = 1;
params.can_read_infix_dot = 1;
params.can_read_quasi = 1;
params.honu_mode = 0;
params.skip_zo_vers_check = 0;
params.table = NULL;
return read_inner(ep, NULL, port->ht, scheme_null, &params, 0);
}
static unsigned char cpt_branch[256];
static Scheme_Object *read_compact(CPort *port, int use_stack);
@ -4402,46 +4448,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
switch(cpt_branch[ch]) {
case CPT_ESCAPE:
{
int len;
Scheme_Object *ep;
char *s;
ReadParams params;
len = read_compact_number(port);
RANGE_CHECK_GETS((unsigned)len);
#if defined(MZ_PRECISE_GC)
s = read_compact_chars(port, buffer, BLK_BUF_SIZE, len);
if (s != buffer)
len = -len; /* no alloc in sized_byte_string_input_port */
#else
s = (char *)port->start + port->pos;
port->pos += len;
len = -len; /* no alloc in sized_byte_string_input_port */
#endif
ep = scheme_make_sized_byte_string_input_port(s, len);
params.can_read_compiled = 1;
params.can_read_pipe_quote = 1;
params.can_read_box = 1;
params.can_read_graph = 1;
/* Use startup value of case sensitivity so legacy code will work. */
params.case_sensitive = scheme_case_sensitive;
params.square_brackets_are_parens = 1;
params.curly_braces_are_parens = 1;
params.read_decimal_inexact = 1;
params.can_read_dot = 1;
params.can_read_infix_dot = 1;
params.can_read_quasi = 1;
params.honu_mode = 0;
params.skip_zo_vers_check = 0;
params.table = NULL;
v = read_inner(ep, NULL, port->ht, scheme_null, &params, 0);
}
v = read_compact_escape(port);
break;
case CPT_SYMBOL:
l = read_compact_number(port);
@ -4512,22 +4519,22 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
break;
case CPT_CHAR:
l = read_compact_number(port);
v = scheme_make_character(l);
return scheme_make_character(l);
break;
case CPT_INT:
v = scheme_make_integer(read_compact_number(port));
return scheme_make_integer(read_compact_number(port));
break;
case CPT_NULL:
v = scheme_null;
return scheme_null;
break;
case CPT_TRUE:
v = scheme_true;
return scheme_true;
break;
case CPT_FALSE:
v = scheme_false;
return scheme_false;
break;
case CPT_VOID:
v = scheme_void;
return scheme_void;
break;
case CPT_BOX:
v = scheme_box(read_compact(port, 0));
@ -4535,21 +4542,17 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
break;
case CPT_PAIR:
{
Scheme_Object *car, *cdr;
car = read_compact(port, 0);
cdr = read_compact(port, 0);
v = scheme_make_pair(car, cdr);
v = read_compact(port, 0);
return scheme_make_pair(v, read_compact(port, 0));
}
break;
case CPT_LIST:
l = read_compact_number(port);
if (l == 1) {
Scheme_Object *car, *cdr;
car = read_compact(port, 0);
cdr = read_compact(port, 0);
v = scheme_make_pair(car, cdr);
v = read_compact(port, 0);
return scheme_make_pair(v, read_compact(port, 0));
} else
v = read_compact_list(l, 0, 0, port);
return read_compact_list(l, 0, 0, port);
break;
case CPT_VECTOR:
{
@ -4560,27 +4563,26 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
vec = scheme_make_vector(l, NULL);
for (i = 0; i < l; i++) {
Scheme_Object *cv;
cv = read_compact(port, 0);
SCHEME_VEC_ELS(vec)[i] = cv;
v = read_compact(port, 0);
SCHEME_VEC_ELS(vec)[i] = v;
}
SCHEME_SET_IMMUTABLE(vec);
v = vec;
return vec;
}
break;
case CPT_HASH_TABLE:
{
Scheme_Object *l;
int kind, len;
Scheme_Object *k;
kind = read_compact_number(port);
len = read_compact_number(port);
l = scheme_null;
while (len--) {
Scheme_Object *k, *v;
k = read_compact(port, 0);
v = read_compact(port, 0);
/* We can't always hash directly, because a key or value
@ -4653,7 +4655,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
case CPT_REFERENCE:
l = read_compact_number(port);
RANGE_CHECK(l, < EXPECTED_PRIM_COUNT);
v = variable_references[l];
return variable_references[l];
break;
case CPT_LOCAL:
{
@ -4664,7 +4666,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
flags = read_compact_number(port);
} else
flags = 0;
v = scheme_make_local(scheme_local_type, p, flags);
return scheme_make_local(scheme_local_type, p, flags);
}
break;
case CPT_LOCAL_UNBOX:
@ -4676,7 +4678,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
flags = read_compact_number(port);
} else
flags = 0;
v = scheme_make_local(scheme_local_unbox_type, p, flags);
return scheme_make_local(scheme_local_unbox_type, p, flags);
}
break;
case CPT_SVECTOR:
@ -4700,7 +4702,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
}
scheme_finish_application(a);
v = (Scheme_Object *)a;
return (Scheme_Object *)a;
}
break;
case CPT_LET_ONE:
@ -4718,7 +4720,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
et = scheme_get_eval_type(lo->value);
SCHEME_LET_EVAL_TYPE(lo) = et;
v = (Scheme_Object *)lo;
return (Scheme_Object *)lo;
}
break;
case CPT_BRANCH:
@ -4727,7 +4729,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
test = read_compact(port, 1);
tbranch = read_compact(port, 1);
fbranch = read_compact(port, 1);
v = scheme_make_branch(test, tbranch, fbranch);
return scheme_make_branch(test, tbranch, fbranch);
}
break;
case CPT_MODULE_INDEX:
@ -4737,7 +4739,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
path = read_compact(port, 0);
base = read_compact(port, 0);
v = scheme_make_modidx(path, base, scheme_false);
return scheme_make_modidx(path, base, scheme_false);
}
break;
case CPT_MODULE_VAR:
@ -4764,7 +4766,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
} else
mv->pos = pos;
v = (Scheme_Object *)mv;
return (Scheme_Object *)mv;
}
break;
case CPT_PATH:
@ -4799,7 +4801,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
return NULL;
}
cl->code = ((Scheme_Closure *)v)->code;
v = (Scheme_Object *)cl;
return (Scheme_Object *)cl;
break;
}
case CPT_DELAY_REF:
@ -4821,6 +4823,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
port->symtab[l] = v;
}
}
return v;
break;
}
case CPT_PREFAB:
@ -4851,7 +4854,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
type = scheme_local_type;
ch -= CPT_SMALL_LOCAL_START;
}
v = scheme_make_local(type, ch, 0);
return scheme_make_local(type, ch, 0);
}
break;
case CPT_SMALL_MARSHALLED_START:
@ -4874,7 +4877,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
case CPT_SMALL_NUMBER_START:
{
l = ch - CPT_SMALL_NUMBER_START;
v = scheme_make_integer(l);
return scheme_make_integer(l);
}
break;
case CPT_SMALL_SVECTOR_START:
@ -4889,14 +4892,14 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
int ppr = CPT_BETWEEN(ch, SMALL_PROPER_LIST);
l = ch - (ppr ? CPT_SMALL_PROPER_LIST_START : CPT_SMALL_LIST_START);
if (l == 1) {
Scheme_Object *car, *cdr;
car = read_compact(port, 0);
Scheme_Object *cdr;
v = read_compact(port, 0);
cdr = (ppr
? scheme_null
: read_compact(port, 0));
v = scheme_make_pair(car, cdr);
return scheme_make_pair(v, cdr);
} else
v = read_compact_list(l, ppr, /* use_stack */ 0, port);
return read_compact_list(l, ppr, /* use_stack */ 0, port);
}
break;
case CPT_SMALL_APPLICATION_START:
@ -4914,7 +4917,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
scheme_finish_application(a);
v = (Scheme_Object *)a;
return (Scheme_Object *)a;
}
break;
case CPT_SMALL_APPLICATION2:
@ -4935,7 +4938,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
et += scheme_get_eval_type(app->rator);
SCHEME_APPN_FLAGS(app) = et;
v = (Scheme_Object *)app;
return (Scheme_Object *)app;
}
break;
case CPT_SMALL_APPLICATION3:
@ -4960,7 +4963,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
et += scheme_get_eval_type(app->rator);
SCHEME_APPN_FLAGS(app) = et;
v = (Scheme_Object *)app;
return (Scheme_Object *)app;
}
break;
default:
@ -4968,6 +4971,8 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
break;
}
/* Some cases where v != NULL return directly */
if (!v)
scheme_ill_formed_code(port);
}

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

@ -267,6 +267,7 @@ void scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym,
extern Scheme_Object *scheme_values_func;
extern Scheme_Object *scheme_procedure_p_proc;
extern Scheme_Object *scheme_procedure_arity_includes_proc;
extern Scheme_Object *scheme_void_proc;
extern Scheme_Object *scheme_cons_proc;
extern Scheme_Object *scheme_mcons_proc;
@ -2206,6 +2207,8 @@ Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e,
int scheme_compiled_duplicate_ok(Scheme_Object *o);
int scheme_compiled_propagate_ok(Scheme_Object *o, Optimize_Info *info);
int scheme_is_statically_proc(Scheme_Object *value, Optimize_Info *info);
Scheme_Object *scheme_make_noninline_proc(Scheme_Object *e);
Scheme_Object *scheme_resolve_expr(Scheme_Object *, Resolve_Info *);
Scheme_Object *scheme_resolve_list(Scheme_Object *, Resolve_Info *);
@ -2549,6 +2552,7 @@ struct Scheme_Env {
Scheme_Object *rename_set;
Scheme_Hash_Table *temp_marked_names; /* used to correlate imports with re-exports */
Scheme_Object *post_ex_rename_set; /* during module expansion */
Scheme_Bucket_Table *syntax;
struct Scheme_Env *exp_env;

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

@ -169,84 +169,85 @@ enum {
scheme_log_reader_type, /* 151 */
scheme_free_id_info_type, /* 152 */
scheme_rib_delimiter_type, /* 153 */
scheme_noninline_proc_type, /* 154 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 154 */
_scheme_last_normal_type_, /* 155 */
scheme_rt_weak_array, /* 155 */
scheme_rt_weak_array, /* 156 */
scheme_rt_comp_env, /* 156 */
scheme_rt_constant_binding, /* 157 */
scheme_rt_resolve_info, /* 158 */
scheme_rt_optimize_info, /* 159 */
scheme_rt_compile_info, /* 160 */
scheme_rt_cont_mark, /* 161 */
scheme_rt_saved_stack, /* 162 */
scheme_rt_reply_item, /* 163 */
scheme_rt_closure_info, /* 164 */
scheme_rt_overflow, /* 165 */
scheme_rt_overflow_jmp, /* 166 */
scheme_rt_meta_cont, /* 167 */
scheme_rt_dyn_wind_cell, /* 168 */
scheme_rt_dyn_wind_info, /* 169 */
scheme_rt_dyn_wind, /* 170 */
scheme_rt_dup_check, /* 171 */
scheme_rt_thread_memory, /* 172 */
scheme_rt_input_file, /* 173 */
scheme_rt_input_fd, /* 174 */
scheme_rt_oskit_console_input, /* 175 */
scheme_rt_tested_input_file, /* 176 */
scheme_rt_tested_output_file, /* 177 */
scheme_rt_indexed_string, /* 178 */
scheme_rt_output_file, /* 179 */
scheme_rt_load_handler_data, /* 180 */
scheme_rt_pipe, /* 181 */
scheme_rt_beos_process, /* 182 */
scheme_rt_system_child, /* 183 */
scheme_rt_tcp, /* 184 */
scheme_rt_write_data, /* 185 */
scheme_rt_tcp_select_info, /* 186 */
scheme_rt_namespace_option, /* 187 */
scheme_rt_param_data, /* 188 */
scheme_rt_will, /* 189 */
scheme_rt_struct_proc_info, /* 190 */
scheme_rt_linker_name, /* 191 */
scheme_rt_param_map, /* 192 */
scheme_rt_finalization, /* 193 */
scheme_rt_finalizations, /* 194 */
scheme_rt_cpp_object, /* 195 */
scheme_rt_cpp_array_object, /* 196 */
scheme_rt_stack_object, /* 197 */
scheme_rt_preallocated_object, /* 198 */
scheme_thread_hop_type, /* 199 */
scheme_rt_srcloc, /* 200 */
scheme_rt_evt, /* 201 */
scheme_rt_syncing, /* 202 */
scheme_rt_comp_prefix, /* 203 */
scheme_rt_user_input, /* 204 */
scheme_rt_user_output, /* 205 */
scheme_rt_compact_port, /* 206 */
scheme_rt_read_special_dw, /* 207 */
scheme_rt_regwork, /* 208 */
scheme_rt_buf_holder, /* 209 */
scheme_rt_parameterization, /* 210 */
scheme_rt_print_params, /* 211 */
scheme_rt_read_params, /* 212 */
scheme_rt_native_code, /* 213 */
scheme_rt_native_code_plus_case, /* 214 */
scheme_rt_jitter_data, /* 215 */
scheme_rt_module_exports, /* 216 */
scheme_rt_delay_load_info, /* 217 */
scheme_rt_marshal_info, /* 218 */
scheme_rt_unmarshal_info, /* 219 */
scheme_rt_runstack, /* 220 */
scheme_rt_sfs_info, /* 221 */
scheme_rt_validate_clearing, /* 222 */
scheme_rt_rb_node, /* 223 */
scheme_rt_comp_env, /* 157 */
scheme_rt_constant_binding, /* 158 */
scheme_rt_resolve_info, /* 159 */
scheme_rt_optimize_info, /* 160 */
scheme_rt_compile_info, /* 161 */
scheme_rt_cont_mark, /* 162 */
scheme_rt_saved_stack, /* 163 */
scheme_rt_reply_item, /* 164 */
scheme_rt_closure_info, /* 165 */
scheme_rt_overflow, /* 166 */
scheme_rt_overflow_jmp, /* 167 */
scheme_rt_meta_cont, /* 168 */
scheme_rt_dyn_wind_cell, /* 169 */
scheme_rt_dyn_wind_info, /* 170 */
scheme_rt_dyn_wind, /* 171 */
scheme_rt_dup_check, /* 172 */
scheme_rt_thread_memory, /* 173 */
scheme_rt_input_file, /* 174 */
scheme_rt_input_fd, /* 175 */
scheme_rt_oskit_console_input, /* 176 */
scheme_rt_tested_input_file, /* 177 */
scheme_rt_tested_output_file, /* 178 */
scheme_rt_indexed_string, /* 179 */
scheme_rt_output_file, /* 180 */
scheme_rt_load_handler_data, /* 181 */
scheme_rt_pipe, /* 182 */
scheme_rt_beos_process, /* 183 */
scheme_rt_system_child, /* 184 */
scheme_rt_tcp, /* 185 */
scheme_rt_write_data, /* 186 */
scheme_rt_tcp_select_info, /* 187 */
scheme_rt_namespace_option, /* 188 */
scheme_rt_param_data, /* 189 */
scheme_rt_will, /* 190 */
scheme_rt_struct_proc_info, /* 191 */
scheme_rt_linker_name, /* 192 */
scheme_rt_param_map, /* 193 */
scheme_rt_finalization, /* 194 */
scheme_rt_finalizations, /* 195 */
scheme_rt_cpp_object, /* 196 */
scheme_rt_cpp_array_object, /* 197 */
scheme_rt_stack_object, /* 198 */
scheme_rt_preallocated_object, /* 199 */
scheme_thread_hop_type, /* 200 */
scheme_rt_srcloc, /* 201 */
scheme_rt_evt, /* 202 */
scheme_rt_syncing, /* 203 */
scheme_rt_comp_prefix, /* 204 */
scheme_rt_user_input, /* 205 */
scheme_rt_user_output, /* 206 */
scheme_rt_compact_port, /* 207 */
scheme_rt_read_special_dw, /* 208 */
scheme_rt_regwork, /* 209 */
scheme_rt_buf_holder, /* 210 */
scheme_rt_parameterization, /* 211 */
scheme_rt_print_params, /* 212 */
scheme_rt_read_params, /* 213 */
scheme_rt_native_code, /* 214 */
scheme_rt_native_code_plus_case, /* 215 */
scheme_rt_jitter_data, /* 216 */
scheme_rt_module_exports, /* 217 */
scheme_rt_delay_load_info, /* 218 */
scheme_rt_marshal_info, /* 219 */
scheme_rt_unmarshal_info, /* 220 */
scheme_rt_runstack, /* 221 */
scheme_rt_sfs_info, /* 222 */
scheme_rt_validate_clearing, /* 223 */
scheme_rt_rb_node, /* 224 */
#endif
scheme_place_type, /* 224 */
scheme_engine_type, /* 225 */
scheme_place_type, /* 225 */
scheme_engine_type, /* 226 */
_scheme_last_type_
};

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

@ -2837,6 +2837,46 @@ int scheme_compiled_propagate_ok(Scheme_Object *value, Optimize_Info *info)
return 0;
}
int scheme_is_statically_proc(Scheme_Object *value, Optimize_Info *info)
{
while (1) {
if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_unclosed_procedure_type))
return 1;
else if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_syntax_type)) {
if (SCHEME_PINT_VAL(value) == CASE_LAMBDA_EXPD)
return 1;
else
break;
} else if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_let_void_type)) {
/* Look for (let ([x <proc>]) <proc>), which is generated for optional arguments. */
Scheme_Let_Header *lh = (Scheme_Let_Header *)value;
if (lh->num_clauses == 1) {
Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body;
if (scheme_omittable_expr(lv->value, lv->count, 20, 0, NULL)) {
value = lv->body;
info = NULL;
} else
break;
} else
break;
} else
break;
}
return 0;
}
Scheme_Object *scheme_make_noninline_proc(Scheme_Object *e)
{
Scheme_Object *ni;
ni = scheme_alloc_small_object();
ni->type = scheme_noninline_proc_type;
SCHEME_PTR_VAL(ni) = e;
return ni;
}
static int is_values_apply(Scheme_Object *e)
{
if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) {

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

@ -621,6 +621,7 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_rt_runstack, runstack_val);
GC_REG_TRAV(scheme_rib_delimiter_type, small_object);
GC_REG_TRAV(scheme_noninline_proc_type, small_object);
}
END_XFORM_SKIP;