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

fix bytecode validation for LHS of a define-values created for lifting

Browse Source 
svn: r3936
This commit is contained in:
Matthew Flatt 2006-08-02 19:20:40 +00:00
parent cd03877fae
commit cbae980a66
3 changed files with 84 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -3642,84 +3642,83 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
SCHEME_EXPAND_OBSERVE_ENTER_CHECK(rec[drec].observer, first);
check_top:
*current_val = NULL;
if (SCHEME_STX_PAIRP(first)) {
name = SCHEME_STX_CAR(first);
need_cert = 1;
} else {
name = first;
need_cert = 0;
}
if (!SCHEME_STX_SYMBOLP(name)) {
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first);
return first;
}
while (1) {
*current_val = NULL;
if (need_cert) {
/* While resolving name, we need certs from `first' */
scheme_init_expand_recs(rec, drec, &erec1, 1);
scheme_rec_add_certs(&erec1, 0, first);
certs = erec1.certs;
} else
certs = rec[drec].certs;
val = scheme_lookup_binding(name, env,
SCHEME_NULL_FOR_UNBOUND
+ SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
+ ((rec[drec].comp && rec[drec].dont_mark_local_use)
? SCHEME_DONT_MARK_USE
: 0)
+ ((rec[drec].comp && rec[drec].resolve_module_ids)
? SCHEME_RESOLVE_MODIDS
: 0),
certs, env->in_modidx,
&menv, NULL);
if (SCHEME_STX_PAIRP(first))
*current_val = val;
if (!val) {
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first);
return first;
} else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) {
if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(val)), scheme_id_macro_type)) {
/* It's a rename. Look up the target name and try again. */
name = scheme_stx_cert(SCHEME_PTR_VAL(SCHEME_PTR_VAL(val)), scheme_false, menv, name, NULL, 1);
menv = NULL;
SCHEME_USE_FUEL(1);
} else {
/* It's a normal macro; expand once. Also, extend env to indicate
an internal-define position, if necessary. */
if (!xenv) {
if (internel_def_pos) {
xenv = scheme_new_compilation_frame(0, SCHEME_INTDEF_FRAME, env, NULL);
if (ctx)
xenv->intdef_name = ctx;
if (_xenv)
*_xenv = xenv;
} else
xenv = env;
}
{
scheme_init_expand_recs(rec, drec, &erec1, 1);
erec1.depth = 1;
erec1.value_name = rec[drec].value_name;
first = scheme_expand_expr(first, xenv, &erec1, 0);
}
break; /* break to outer loop */
}
if (SCHEME_STX_PAIRP(first)) {
name = SCHEME_STX_CAR(first);
need_cert = 1;
} else {
name = first;
need_cert = 0;
}
if (!SCHEME_STX_SYMBOLP(name)) {
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first);
return first;
}
}
goto check_top;
while (1) {
if (need_cert) {
/* While resolving name, we need certs from `first' */
scheme_init_expand_recs(rec, drec, &erec1, 1);
scheme_rec_add_certs(&erec1, 0, first);
certs = erec1.certs;
} else
certs = rec[drec].certs;
val = scheme_lookup_binding(name, env,
SCHEME_NULL_FOR_UNBOUND
+ SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
+ ((rec[drec].comp && rec[drec].dont_mark_local_use)
? SCHEME_DONT_MARK_USE
: 0)
+ ((rec[drec].comp && rec[drec].resolve_module_ids)
? SCHEME_RESOLVE_MODIDS
: 0),
certs, env->in_modidx,
&menv, NULL);
if (SCHEME_STX_PAIRP(first))
*current_val = val;
if (!val) {
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first);
return first;
} else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) {
if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(val)), scheme_id_macro_type)) {
/* It's a rename. Look up the target name and try again. */
name = scheme_stx_cert(SCHEME_PTR_VAL(SCHEME_PTR_VAL(val)), scheme_false, menv, name, NULL, 1);
menv = NULL;
SCHEME_USE_FUEL(1);
} else {
/* It's a normal macro; expand once. Also, extend env to indicate
an internal-define position, if necessary. */
if (!xenv) {
if (internel_def_pos) {
xenv = scheme_new_compilation_frame(0, SCHEME_INTDEF_FRAME, env, NULL);
if (ctx)
xenv->intdef_name = ctx;
if (_xenv)
*_xenv = xenv;
} else
xenv = env;
}
{
scheme_init_expand_recs(rec, drec, &erec1, 1);
erec1.depth = 1;
erec1.value_name = rec[drec].value_name;
first = scheme_expand_expr(first, xenv, &erec1, 0);
}
break; /* break to outer loop */
}
} else {
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first);
return first;
}
}
}
}
static Scheme_Object *
@ -7951,7 +7950,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int delta,
int num_toplevels, int num_stxes, int num_lifts)
int num_toplevels, int num_stxes, int num_lifts,
int skip_refs_check)
{
if (!SAME_TYPE(scheme_toplevel_type, SCHEME_TYPE(expr)))
scheme_ill_formed_code(port);
@ -7959,7 +7959,7 @@ void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port,
scheme_validate_expr(port, expr, stack, ht, tls,
depth, delta, delta,
num_toplevels, num_stxes, num_lifts,
NULL, 0);
NULL, skip_refs_check ? 1 : 0);
}
void scheme_validate_boxenv(int p, Mz_CPort *port, char *stack, int depth, int delta)

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

@ -2017,7 +2017,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int delta,
int num_toplevels, int num_stxes, int num_lifts);
int num_toplevels, int num_stxes, int num_lifts,
int skip_refs_check);
void scheme_validate_boxenv(int pos, Mz_CPort *port,
char *stack, int depth, int delta);

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

@ -809,7 +809,8 @@ static void define_values_validate(Scheme_Object *data, Mz_CPort *port,
for (; SCHEME_PAIRP(vars); vars = SCHEME_CDR(vars)) {
scheme_validate_toplevel(SCHEME_CAR(vars), port, stack, ht, tls, depth, delta,
num_toplevels, num_stxes, num_lifts);
num_toplevels, num_stxes, num_lifts,
1);
}
if (!SCHEME_NULLP(vars))
@ -1361,7 +1362,8 @@ static void set_validate(Scheme_Object *data, Mz_CPort *port,
num_toplevels, num_stxes, num_lifts,
NULL, 0);
scheme_validate_toplevel(tl, port, stack, ht, tls, depth, delta,
num_toplevels, num_stxes, num_lifts);
num_toplevels, num_stxes, num_lifts,
0);
}
static Scheme_Object *
@ -1678,7 +1680,8 @@ static void ref_validate(Scheme_Object *tl, Mz_CPort *port,
int num_toplevels, int num_stxes, int num_lifts)
{
scheme_validate_toplevel(tl, port, stack, ht, tls, depth, delta,
num_toplevels, num_stxes, num_lifts);
num_toplevels, num_stxes, num_lifts,
0);
}
static Scheme_Object *
@ -4232,7 +4235,9 @@ static void do_define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port,
scheme_ill_formed_code(port);
}
scheme_validate_toplevel(dummy, port, stack, ht, tls, depth, delta, num_toplevels, num_stxes, num_lifts);
scheme_validate_toplevel(dummy, port, stack, ht, tls, depth, delta,
num_toplevels, num_stxes, num_lifts,
0);
if (!for_stx) {
scheme_validate_code(port, val, ht, sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts);