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

350.5

Browse Source 
svn: r3673
This commit is contained in:
Matthew Flatt 2006-07-10 17:15:58 +00:00
parent 5d7ad6afd9
commit c2eec31714
15 changed files with 739 additions and 622 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -473,6 +473,7 @@ scheme_caddr
scheme_vector_to_list
scheme_list_to_vector
scheme_append
scheme_reverse
scheme_box
scheme_unbox
scheme_set_box

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

@ -481,6 +481,7 @@ scheme_caddr
scheme_vector_to_list
scheme_list_to_vector
scheme_append
scheme_reverse
scheme_box
scheme_unbox
scheme_set_box

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

@ -465,6 +465,7 @@ EXPORTS
scheme_vector_to_list
scheme_list_to_vector
scheme_append
scheme_reverse
scheme_box
scheme_unbox
scheme_set_box

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

File diff suppressed because it is too large Load Diff

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

@ -83,6 +83,7 @@ static Scheme_Object *local_module_introduce(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_get_shadower(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_certify(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_expr(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_end_statement(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_introducer(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_set_transformer(int argc, Scheme_Object *argv[]);
static Scheme_Object *set_transformer_p(int argc, Scheme_Object *argv[]);
@ -558,6 +559,12 @@ static void make_init_env(void)
1, 1),
env);
scheme_add_global_constant("syntax-local-lift-module-end-declaration",
scheme_make_prim_w_arity(local_lift_end_statement,
"syntax-local-lift-module-end-declaration",
1, 1),
env);
{
Scheme_Object *sym;
sym = scheme_intern_symbol("mzscheme");
@ -1222,7 +1229,7 @@ scheme_add_compilation_binding(int index, Scheme_Object *val, Scheme_Comp_Env *f
frame->skip_table = NULL;
}
void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data)
void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data, Scheme_Object *end_stmts)
{
Scheme_Lift_Capture_Proc *pp;
Scheme_Object *vec;
@ -1230,10 +1237,11 @@ void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc
pp = (Scheme_Lift_Capture_Proc *)scheme_malloc_atomic(sizeof(Scheme_Lift_Capture_Proc));
*pp = cp;
vec = scheme_make_vector(3, NULL);
vec = scheme_make_vector(4, NULL);
SCHEME_VEC_ELS(vec)[0] = scheme_null;
SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)pp;
SCHEME_VEC_ELS(vec)[2] = data;
SCHEME_VEC_ELS(vec)[3] = end_stmts;
COMPILE_DATA(env)->lifts = vec;
}
@ -1243,6 +1251,11 @@ Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env)
return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0];
}
Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env)
{
return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3];
}
void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env)
{
Scheme_Object **ns, **vs;
@ -3771,6 +3784,43 @@ local_lift_expr(int argc, Scheme_Object *argv[])
return id;
}
static Scheme_Object *
local_lift_end_statement(int argc, Scheme_Object *argv[])
{
Scheme_Comp_Env *env;
Scheme_Object *local_mark, *expr, *pr;
expr = argv[0];
if (!SCHEME_STXP(expr))
scheme_wrong_type("syntax-local-lift-module-end-declaration", "syntax", 0, argc, argv);
env = scheme_current_thread->current_local_env;
local_mark = scheme_current_thread->current_local_mark;
if (!env)
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"syntax-local-lift-module-end-declaration: not currently transforming");
while (env) {
if ((COMPILE_DATA(env)->lifts)
&& SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3]))
break;
env = env->next;
}
if (!env)
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"syntax-local-lift-module-end-declaration: not currently transforming"
" a run-time expression in a module declaration");
expr = scheme_add_remove_mark(expr, local_mark);
pr = scheme_make_pair(expr, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3]);
SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3] = pr;
return scheme_void;
}
static Scheme_Object *
make_set_transformer(int argc, Scheme_Object *argv[])
{

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

@ -3068,7 +3068,7 @@ static void *compile_k(void)
find one, break it up to eval first expression
before the rest. */
while (1) {
scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv));
scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), scheme_false);
form = scheme_check_immediate_macro(form,
cenv, &rec, 0,
0, &gval, NULL, NULL);
@ -3105,7 +3105,7 @@ static void *compile_k(void)
Scheme_Object *l, *prev_o = NULL;
while (1) {
scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv));
scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), scheme_false);
scheme_init_compile_recs(&rec, 0, &rec2, 1);
@ -4013,7 +4013,7 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
ip = MALLOC_N(Scheme_Comp_Env *, 1);
*ip = inserted;
scheme_frame_captures_lifts(inserted, pair_lifted, (Scheme_Object *)ip);
scheme_frame_captures_lifts(inserted, pair_lifted, (Scheme_Object *)ip, scheme_false);
if (rec[drec].comp) {
scheme_init_compile_recs(rec, drec, recs, 2);
@ -6085,7 +6085,7 @@ static void *expand_k(void)
erec1.certs = certs;
if (catch_lifts)
scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env));
scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false);
if (just_to_top) {
Scheme_Object *gval;

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

@ -935,6 +935,13 @@ scheme_append (Scheme_Object *lst1, Scheme_Object *lst2)
return first;
}
Scheme_Object *scheme_reverse(Scheme_Object *l)
{
Scheme_Object *a[1];
a[0] = l;
return reverse_prim(1, a);
}
static Scheme_Object *
scheme_append_bang (Scheme_Object *lst1, Scheme_Object *lst2)
{

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

@ -3674,6 +3674,11 @@ static Scheme_Object *stx_sym(Scheme_Object *name, Scheme_Object *_genv)
return scheme_tl_id_sym((Scheme_Env *)_genv, name, NULL, 2);
}
static Scheme_Object *add_a_rename(Scheme_Object *fm, Scheme_Object *post_ex_rn)
{
return scheme_add_rename(fm, post_ex_rn);
}
static Scheme_Object *add_req(Scheme_Object *imods, Scheme_Object *requires)
{
for (; !SCHEME_NULLP(imods); imods = SCHEME_CDR(imods)) {
@ -3743,6 +3748,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
int excount, exvcount, exicount;
int reprovide_kernel;
int all_simple_renames = 1, et_all_simple_renames = 1, tt_all_simple_renames = 1;
int maybe_has_lifts = 0;
Scheme_Object *redef_modname;
if (!(env->flags & SCHEME_MODULE_FRAME))
@ -3897,10 +3903,12 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
form = scheme_add_rename(form, post_ex_rn);
form = scheme_add_rename(form, post_ex_et_rn);
form = scheme_add_rename(form, post_ex_tt_rn);
maybe_has_lifts = 0;
/* Partially expand all expressions, and process definitions, requires,
and provides. Also, flatten top-level `begin' expressions: */
for (fm = SCHEME_STX_CDR(form); !SCHEME_STX_NULLP(fm); fm = SCHEME_STX_CDR(fm)) {
for (fm = SCHEME_STX_CDR(form); !SCHEME_STX_NULLP(fm); ) {
Scheme_Object *e;
int normal;
@ -3909,7 +3917,11 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
e = SCHEME_STX_CAR(fm);
scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv));
p = (maybe_has_lifts
? scheme_frame_get_end_statement_lifts(xenv)
: scheme_null);
scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv), p);
maybe_has_lifts = 1;
{
Scheme_Expand_Info erec1;
@ -3925,7 +3937,12 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/* Expansion lifted expressions, so add them to
the front and try again. */
fm = SCHEME_STX_CDR(fm);
/* Why don't we need post_ex renames on fst and e? */
e = scheme_add_rename(e, post_ex_rn);
e = scheme_add_rename(e, post_ex_et_rn);
e = scheme_add_rename(e, post_ex_tt_rn);
fm = scheme_named_map_1(NULL, add_a_rename, fm, post_ex_rn);
fm = scheme_named_map_1(NULL, add_a_rename, fm, post_ex_et_rn);
fm = scheme_named_map_1(NULL, add_a_rename, fm, post_ex_tt_rn);
fm = scheme_append(fst, scheme_make_pair(e, fm));
} else {
/* No lifts added... */
@ -3941,8 +3958,13 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
e = scheme_add_rename(e, post_ex_tt_rn);
fm = scheme_flatten_begin(e, fm);
if (SCHEME_STX_NULLP(fm)) {
e = NULL;
break;
fm = scheme_frame_get_end_statement_lifts(xenv);
fm = scheme_reverse(fm);
maybe_has_lifts = 0;
if (SCHEME_NULLP(fm)) {
e = NULL;
break;
}
}
} else
break;
@ -4470,6 +4492,15 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
first = p;
last = p;
}
fm = SCHEME_STX_CDR(fm);
/* If we're out of declarations, check for lifted-to-end: */
if (SCHEME_STX_NULLP(fm) && maybe_has_lifts) {
fm = scheme_frame_get_end_statement_lifts(xenv);
fm = scheme_reverse(fm);
maybe_has_lifts = 0;
}
}
/* first = a list of (cons semi-expanded-expression normal?) */
@ -4485,6 +4516,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
SCHEME_VEC_ELS(lift_data)[1] = self_modidx;
SCHEME_VEC_ELS(lift_data)[2] = rn;
maybe_has_lifts = 0;
prev_p = NULL;
for (p = first; !SCHEME_NULLP(p); ) {
Scheme_Object *e, *l, *ll;
@ -4494,7 +4527,11 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
normal = SCHEME_TRUEP(SCHEME_CDR(e));
e = SCHEME_CAR(e);
if (normal) {
scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data);
l = (maybe_has_lifts
? scheme_frame_get_end_statement_lifts(cenv)
: scheme_null);
scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l);
maybe_has_lifts = 1;
if (rec[drec].comp) {
Scheme_Compile_Info crec1;
@ -4534,6 +4571,22 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
prev_p = p;
p = SCHEME_CDR(p);
}
/* If we're out of declarations, check for lifted-to-end: */
if (SCHEME_NULLP(p) && maybe_has_lifts) {
p = scheme_frame_get_end_statement_lifts(cenv);
p = scheme_reverse(p);
for (ll = p; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) {
e = scheme_make_pair(SCHEME_CAR(ll), scheme_true);
SCHEME_CAR(ll) = e;
}
maybe_has_lifts = 0;
if (prev_p) {
SCHEME_CDR(prev_p) = p;
} else {
first = p;
}
}
}
/* first = a list of expanded/compiled expressions */

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

@ -951,6 +951,7 @@ MZ_EXTERN Scheme_Object *scheme_vector_to_list(Scheme_Object *vec);
MZ_EXTERN Scheme_Object *scheme_list_to_vector(Scheme_Object *list);
MZ_EXTERN Scheme_Object *scheme_append(Scheme_Object *lstx, Scheme_Object *lsty);
MZ_EXTERN Scheme_Object *scheme_reverse(Scheme_Object *l);
MZ_EXTERN Scheme_Object *scheme_box(Scheme_Object *v);
MZ_EXTERN Scheme_Object *scheme_unbox(Scheme_Object *obj);

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

@ -782,6 +782,7 @@ Scheme_Object *(*scheme_caddr)(Scheme_Object *pair);
Scheme_Object *(*scheme_vector_to_list)(Scheme_Object *vec);
Scheme_Object *(*scheme_list_to_vector)(Scheme_Object *list);
Scheme_Object *(*scheme_append)(Scheme_Object *lstx, Scheme_Object *lsty);
Scheme_Object *(*scheme_reverse)(Scheme_Object *l);
Scheme_Object *(*scheme_box)(Scheme_Object *v);
Scheme_Object *(*scheme_unbox)(Scheme_Object *obj);
void (*scheme_set_box)(Scheme_Object *b, Scheme_Object *v);

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

@ -525,6 +525,7 @@
scheme_extension_table->scheme_vector_to_list = scheme_vector_to_list;
scheme_extension_table->scheme_list_to_vector = scheme_list_to_vector;
scheme_extension_table->scheme_append = scheme_append;
scheme_extension_table->scheme_reverse = scheme_reverse;
scheme_extension_table->scheme_box = scheme_box;
scheme_extension_table->scheme_unbox = scheme_unbox;
scheme_extension_table->scheme_set_box = scheme_set_box;

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

@ -525,6 +525,7 @@
#define scheme_vector_to_list (scheme_extension_table->scheme_vector_to_list)
#define scheme_list_to_vector (scheme_extension_table->scheme_list_to_vector)
#define scheme_append (scheme_extension_table->scheme_append)
#define scheme_reverse (scheme_extension_table->scheme_reverse)
#define scheme_box (scheme_extension_table->scheme_box)
#define scheme_unbox (scheme_extension_table->scheme_unbox)
#define scheme_set_box (scheme_extension_table->scheme_set_box)

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

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 864
#define EXPECTED_PRIM_COUNT 865
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

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

@ -1696,8 +1696,9 @@ Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env,
Scheme_Object *scheme_env_frame_uid(Scheme_Comp_Env *env);
typedef Scheme_Object *(*Scheme_Lift_Capture_Proc)(Scheme_Object *, Scheme_Object **, Scheme_Object *, Scheme_Comp_Env *);
void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data);
void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data, Scheme_Object *end_stmts);
Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env);
Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env);
void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env);
void scheme_set_local_syntax(int pos, Scheme_Object *name, Scheme_Object *val,

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 350
#define MZSCHEME_VERSION_MINOR 4
#define MZSCHEME_VERSION_MINOR 5
#define MZSCHEME_VERSION "350.4" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "350.5" _MZ_SPECIAL_TAG