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

fix bytecode validator to accept letrec-bound flonum-consuming functions

Browse Source 
Closes PR 11009
This commit is contained in:
Matthew Flatt 2010-06-30 22:02:44 -06:00
parent e4cd5329fb
commit 159daa43aa
4 changed files with 119 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

92
src/racket/src/eval.c
View File

@ -11723,7 +11723,7 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code,
depth, delta, delta, depth, delta, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, NULL, 0, 0,
vc, 1, 0); vc, 1, 0, NULL);
} }
} else { } else {
scheme_validate_expr(port, code, scheme_validate_expr(port, code,
@ -11731,7 +11731,7 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code,
depth, delta, delta, depth, delta, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, NULL, 0, 0,
vc, 1, 0); vc, 1, 0, NULL);
} }
} }
@ -11744,6 +11744,7 @@ static Scheme_Object *validate_k(void)
int *args = (int *)(((void **)p->ku.k.p5)[0]); int *args = (int *)(((void **)p->ku.k.p5)[0]);
Scheme_Object *app_rator = (Scheme_Object *)(((void **)p->ku.k.p5)[1]); Scheme_Object *app_rator = (Scheme_Object *)(((void **)p->ku.k.p5)[1]);
Validate_TLS tls = (Validate_TLS)(((void **)p->ku.k.p5)[2]); Validate_TLS tls = (Validate_TLS)(((void **)p->ku.k.p5)[2]);
Scheme_Hash_Tree *procs = (Scheme_Hash_Tree *)(((void **)p->ku.k.p5)[3]);
struct Validate_Clearing *vc = (struct Validate_Clearing *)p->ku.k.p4; struct Validate_Clearing *vc = (struct Validate_Clearing *)p->ku.k.p4;
p->ku.k.p1 = NULL; p->ku.k.p1 = NULL;
@ -11756,11 +11757,14 @@ static Scheme_Object *validate_k(void)
args[0], args[1], args[2], args[0], args[1], args[2],
args[3], args[4], args[5], args[3], args[4], args[5],
app_rator, args[6], args[7], vc, args[8], app_rator, args[6], args[7], vc, args[8],
args[9]); args[9], procs);
return scheme_true; return scheme_true;
} }
/* FIXME: need to validate that a flonum is provided when a
procedure expects a flonum */
int scheme_validate_rator_wants_box(Scheme_Object *app_rator, int pos, int scheme_validate_rator_wants_box(Scheme_Object *app_rator, int pos,
int hope, int hope,
Validate_TLS tls, Validate_TLS tls,
@ -11862,7 +11866,7 @@ static int argument_to_arity_error(Scheme_Object *app_rator, int proc_with_refs_
void scheme_validate_closure(Mz_CPort *port, Scheme_Object *expr, void scheme_validate_closure(Mz_CPort *port, Scheme_Object *expr,
char *closure_stack, Validate_TLS tls, char *closure_stack, Validate_TLS tls,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
int self_pos_in_closure) int self_pos_in_closure, Scheme_Hash_Tree *procs)
{ {
Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr; Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr;
int i, sz, cnt, base, base2; int i, sz, cnt, base, base2;
@ -11904,21 +11908,29 @@ void scheme_validate_closure(Mz_CPort *port, Scheme_Object *expr,
} }
scheme_validate_expr(port, data->code, new_stack, tls, sz, sz, base, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, data->code, new_stack, tls, sz, sz, base, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 1, 0); NULL, 0, 0, vc, 1, 0, procs);
} }
static Scheme_Hash_Tree *as_nonempty_procs(Scheme_Hash_Tree *procs)
{
if (!procs)
procs = scheme_make_hash_tree(0);
return procs;
}
static void validate_unclosed_procedure(Mz_CPort *port, Scheme_Object *expr, static void validate_unclosed_procedure(Mz_CPort *port, Scheme_Object *expr,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int delta, int depth, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
Scheme_Object *app_rator, int proc_with_refs_ok, Scheme_Object *app_rator, int proc_with_refs_ok,
int self_pos) int self_pos, Scheme_Hash_Tree *procs)
{ {
Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr; Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr;
int i, cnt, q, p, sz, base, vld, self_pos_in_closure = -1, typed_arg = 0; int i, cnt, q, p, sz, base, stack_delta, vld, self_pos_in_closure = -1, typed_arg = 0;
mzshort *map; mzshort *map;
char *closure_stack; char *closure_stack;
Scheme_Object *proc;
Scheme_Hash_Tree *new_procs = NULL;
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) {
sz = data->closure_size + data->num_params; sz = data->closure_size + data->num_params;
@ -11953,6 +11965,7 @@ static void validate_unclosed_procedure(Mz_CPort *port, Scheme_Object *expr,
cnt = data->closure_size; cnt = data->closure_size;
base = base - cnt; base = base - cnt;
stack_delta = data->max_let_depth - sz;
for (i = 0; i < cnt; i++) { for (i = 0; i < cnt; i++) {
q = map[i]; q = map[i];
@ -11979,6 +11992,14 @@ static void validate_unclosed_procedure(Mz_CPort *port, Scheme_Object *expr,
vld = VALID_NOT; vld = VALID_NOT;
closure_stack[i + base] = vld; closure_stack[i + base] = vld;
if (procs) {
proc = scheme_hash_tree_get(procs, scheme_make_integer(p));
if (proc)
new_procs = scheme_hash_tree_set(as_nonempty_procs(new_procs),
scheme_make_integer(i + base + stack_delta),
proc);
}
} }
if (typed_arg) { if (typed_arg) {
@ -11990,7 +12011,7 @@ static void validate_unclosed_procedure(Mz_CPort *port, Scheme_Object *expr,
if (SCHEME_RPAIRP(data->code)) { if (SCHEME_RPAIRP(data->code)) {
/* Delay validation */ /* Delay validation */
Scheme_Object *vec; Scheme_Object *vec;
vec = scheme_make_vector(7, NULL); vec = scheme_make_vector(8, NULL);
SCHEME_VEC_ELS(vec)[0] = SCHEME_CAR(data->code); SCHEME_VEC_ELS(vec)[0] = SCHEME_CAR(data->code);
SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)closure_stack; SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)closure_stack;
SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)tls; SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)tls;
@ -11998,9 +12019,11 @@ static void validate_unclosed_procedure(Mz_CPort *port, Scheme_Object *expr,
SCHEME_VEC_ELS(vec)[4] = scheme_make_integer(num_stxes); SCHEME_VEC_ELS(vec)[4] = scheme_make_integer(num_stxes);
SCHEME_VEC_ELS(vec)[5] = scheme_make_integer(num_lifts); SCHEME_VEC_ELS(vec)[5] = scheme_make_integer(num_lifts);
SCHEME_VEC_ELS(vec)[6] = scheme_make_integer(self_pos_in_closure); SCHEME_VEC_ELS(vec)[6] = scheme_make_integer(self_pos_in_closure);
SCHEME_VEC_ELS(vec)[7] = new_procs ? (Scheme_Object *)new_procs : scheme_false;
SCHEME_CAR(data->code) = vec; SCHEME_CAR(data->code) = vec;
} else } else
scheme_validate_closure(port, expr, closure_stack, tls, num_toplevels, num_stxes, num_lifts, self_pos_in_closure); scheme_validate_closure(port, expr, closure_stack, tls, num_toplevels, num_stxes, num_lifts,
self_pos_in_closure, new_procs);
} }
static void check_self_call_valid(Scheme_Object *rator, Mz_CPort *port, struct Validate_Clearing *vc, static void check_self_call_valid(Scheme_Object *rator, Mz_CPort *port, struct Validate_Clearing *vc,
@ -12047,7 +12070,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
Scheme_Object *app_rator, int proc_with_refs_ok, Scheme_Object *app_rator, int proc_with_refs_ok,
int result_ignored, int result_ignored,
struct Validate_Clearing *vc, int tailpos, struct Validate_Clearing *vc, int tailpos,
int need_flonum) int need_flonum, Scheme_Hash_Tree *procs)
{ {
Scheme_Type type; Scheme_Type type;
int did_one = 0, vc_merge = 0, vc_merge_start = 0; int did_one = 0, vc_merge = 0, vc_merge_start = 0;
@ -12077,10 +12100,11 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
args[8] = tailpos; args[8] = tailpos;
args[9] = need_flonum; args[9] = need_flonum;
pr = MALLOC_N(void*, 3); pr = MALLOC_N(void*, 4);
pr[0] = (void *)args; pr[0] = (void *)args;
pr[1] = (void *)app_rator; pr[1] = (void *)app_rator;
pr[2] = (void *)tls; pr[2] = (void *)tls;
pr[3] = (void *)procs;
p->ku.k.p5 = (void *)pr; p->ku.k.p5 = (void *)pr;
@ -12197,6 +12221,11 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
stack[p] = VALID_VAL_NOCLEAR; stack[p] = VALID_VAL_NOCLEAR;
} }
} }
if (procs && !proc_with_refs_ok) {
if (scheme_hash_tree_get(procs, scheme_make_integer(p)))
scheme_ill_formed_code(port);
}
} }
break; break;
case scheme_local_unbox_type: case scheme_local_unbox_type:
@ -12237,7 +12266,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
f = scheme_syntax_validaters[p]; f = scheme_syntax_validaters[p];
f((Scheme_Object *)SCHEME_IPTR_VAL(expr), port, stack, tls, depth, letlimit, delta, f((Scheme_Object *)SCHEME_IPTR_VAL(expr), port, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, vc, tailpos); num_toplevels, num_stxes, num_lifts, vc, tailpos, procs);
} }
break; break;
case scheme_application_type: case scheme_application_type:
@ -12256,7 +12285,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
for (i = 0; i < n; i++) { for (i = 0; i < n; i++) {
scheme_validate_expr(port, app->args[i], stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, app->args[i], stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
i ? app->args[0] : NULL, i + 1, 0, vc, 0, 0); i ? app->args[0] : NULL, i + 1, 0, vc, 0, 0, procs);
} }
if (tailpos) if (tailpos)
@ -12275,9 +12304,9 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
stack[delta] = VALID_NOT; stack[delta] = VALID_NOT;
scheme_validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 1, 0, vc, 0, 0); NULL, 1, 0, vc, 0, 0, procs);
scheme_validate_expr(port, app->rand, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, app->rand, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
app->rator, 2, 0, vc, 0, 0); app->rator, 2, 0, vc, 0, 0, procs);
if (tailpos) if (tailpos)
check_self_call_valid(app->rator, port, vc, delta, stack); check_self_call_valid(app->rator, port, vc, delta, stack);
@ -12296,11 +12325,11 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
stack[delta+1] = VALID_NOT; stack[delta+1] = VALID_NOT;
scheme_validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 1, 0, vc, 0, 0); NULL, 1, 0, vc, 0, 0, procs);
scheme_validate_expr(port, app->rand1, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, app->rand1, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
app->rator, 2, 0, vc, 0, 0); app->rator, 2, 0, vc, 0, 0, procs);
scheme_validate_expr(port, app->rand2, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, app->rand2, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
app->rator, 3, 0, vc, 0, 0); app->rator, 3, 0, vc, 0, 0, procs);
if (tailpos) if (tailpos)
check_self_call_valid(app->rator, port, vc, delta, stack); check_self_call_valid(app->rator, port, vc, delta, stack);
@ -12318,7 +12347,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
for (i = 0; i < cnt - 1; i++) { for (i = 0; i < cnt - 1; i++) {
scheme_validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 1, vc, 0, 0); NULL, 0, 1, vc, 0, 0, procs);
} }
expr = seq->array[cnt - 1]; expr = seq->array[cnt - 1];
@ -12334,7 +12363,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
b = (Scheme_Branch_Rec *)expr; b = (Scheme_Branch_Rec *)expr;
scheme_validate_expr(port, b->test, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, b->test, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0, 0); NULL, 0, 0, vc, 0, 0, procs);
/* This is where letlimit is useful. It prevents let-assignment in the /* This is where letlimit is useful. It prevents let-assignment in the
"then" branch that could permit bad code in the "else" branch (or the "then" branch that could permit bad code in the "else" branch (or the
same thing with either branch affecting later code in a sequence). */ same thing with either branch affecting later code in a sequence). */
@ -12342,7 +12371,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
vc_pos = vc->stackpos; vc_pos = vc->stackpos;
vc_ncpos = vc->ncstackpos; vc_ncpos = vc->ncstackpos;
scheme_validate_expr(port, b->tbranch, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, b->tbranch, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, result_ignored, vc, tailpos, 0); NULL, 0, result_ignored, vc, tailpos, 0, procs);
/* Rewind clears and noclears, but also save the clears, /* Rewind clears and noclears, but also save the clears,
so that the branches' effects can be merged. */ so that the branches' effects can be merged. */
@ -12379,9 +12408,9 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
no_flo(need_flonum, port); no_flo(need_flonum, port);
scheme_validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0, 0); NULL, 0, 0, vc, 0, 0, procs);
scheme_validate_expr(port, wcm->val, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, wcm->val, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0, 0); NULL, 0, 0, vc, 0, 0, procs);
expr = wcm->body; expr = wcm->body;
goto top; goto top;
} }
@ -12408,7 +12437,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
no_flo(need_flonum, port); no_flo(need_flonum, port);
validate_unclosed_procedure(port, expr, stack, tls, validate_unclosed_procedure(port, expr, stack, tls,
depth, delta, num_toplevels, num_stxes, num_lifts, depth, delta, num_toplevels, num_stxes, num_lifts,
app_rator, proc_with_refs_ok, -1); app_rator, proc_with_refs_ok, -1, procs);
} }
break; break;
case scheme_let_value_type: case scheme_let_value_type:
@ -12417,7 +12446,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
int q, p, c, i; int q, p, c, i;
scheme_validate_expr(port, lv->value, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, lv->value, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0, 0); NULL, 0, 0, vc, 0, 0, procs);
/* memset(stack, VALID_NOT, delta); <-- seems unnecessary (and slow) */ /* memset(stack, VALID_NOT, delta); <-- seems unnecessary (and slow) */
c = lv->count; c = lv->count;
@ -12489,12 +12518,17 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
scheme_ill_formed_code(port); scheme_ill_formed_code(port);
#endif #endif
stack[delta + i] = VALID_VAL; stack[delta + i] = VALID_VAL;
if (SCHEME_CLOSURE_DATA_FLAGS(((Scheme_Closure_Data *)l->procs[i])) & CLOS_HAS_TYPED_ARGS) {
procs = scheme_hash_tree_set(as_nonempty_procs(procs),
scheme_make_integer(delta + i),
l->procs[i]);
}
} }
for (i = 0; i < c; i++) { for (i = 0; i < c; i++) {
validate_unclosed_procedure(port, l->procs[i], stack, tls, validate_unclosed_procedure(port, l->procs[i], stack, tls,
depth, delta, num_toplevels, num_stxes, num_lifts, depth, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, i); NULL, 1, i, procs);
} }
expr = l->body; expr = l->body;
@ -12511,7 +12545,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
stack[delta] = VALID_UNINIT; stack[delta] = VALID_UNINIT;
scheme_validate_expr(port, lo->value, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, lo->value, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0, SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM); NULL, 0, 0, vc, 0, SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM, procs);
#if !CAN_RESET_STACK_SLOT #if !CAN_RESET_STACK_SLOT
if (stack[delta] != VALID_UNINIT) if (stack[delta] != VALID_UNINIT)
@ -12553,7 +12587,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
for (i = 0; i < seq->count; i++) { for (i = 0; i < seq->count; i++) {
scheme_validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, scheme_validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0, 0); NULL, 0, 0, vc, 0, 0, procs);
} }
} else if (need_flonum) { } else if (need_flonum) {
if (!SCHEME_FLOATP(expr)) if (!SCHEME_FLOATP(expr))
@ -12590,7 +12624,7 @@ void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port,
depth, delta, delta, depth, delta, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, skip_refs_check ? 1 : 0, 0, NULL, skip_refs_check ? 1 : 0, 0,
make_clearing_stack(), 0, 0); make_clearing_stack(), 0, 0, NULL);
} }
void scheme_validate_boxenv(int p, Mz_CPort *port, char *stack, int depth, int delta, int letlimit) void scheme_validate_boxenv(int p, Mz_CPort *port, char *stack, int depth, int delta, int letlimit)

5
src/racket/src/fun.c
View File

@ -983,7 +983,10 @@ void scheme_delay_load_closure(Scheme_Closure_Data *data)
SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[3]), SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[3]),
SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[4]), SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[4]),
SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[5]), SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[5]),
SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[6])); SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[6]),
(SCHEME_TRUEP(SCHEME_VEC_ELS(vinfo)[7])
? (Scheme_Hash_Tree *)SCHEME_VEC_ELS(vinfo)[7]
: NULL));
} }
} }
} }

7
src/racket/src/schpriv.h
View File

@ -2117,7 +2117,8 @@ typedef void (*Scheme_Syntax_Validater)(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos); struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs);
typedef struct Scheme_Object *(*Scheme_Syntax_Executer)(struct Scheme_Object *data); typedef struct Scheme_Object *(*Scheme_Syntax_Executer)(struct Scheme_Object *data);
@ -2676,7 +2677,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
Scheme_Object *app_rator, int proc_with_refs_ok, Scheme_Object *app_rator, int proc_with_refs_ok,
int result_ignored, struct Validate_Clearing *vc, int result_ignored, struct Validate_Clearing *vc,
int tailpos, int need_flonum); int tailpos, int need_flonum, Scheme_Hash_Tree *procs);
void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port, void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int delta, int depth, int delta,
@ -2693,7 +2694,7 @@ int scheme_validate_rator_wants_box(Scheme_Object *app_rator, int pos,
void scheme_validate_closure(Mz_CPort *port, Scheme_Object *expr, void scheme_validate_closure(Mz_CPort *port, Scheme_Object *expr,
char *new_stack, Validate_TLS tls, char *new_stack, Validate_TLS tls,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
int self_pos_in_closure); int self_pos_in_closure, Scheme_Hash_Tree *procs);
#define TRACK_ILL_FORMED_CATCH_LINES 1 #define TRACK_ILL_FORMED_CATCH_LINES 1
#if TRACK_ILL_FORMED_CATCH_LINES #if TRACK_ILL_FORMED_CATCH_LINES

76
src/racket/src/syntax.c
View File

@ -163,52 +163,62 @@ static void define_values_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos); struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs);
static void ref_validate(Scheme_Object *data, Mz_CPort *port, static void ref_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos); struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs);
static void set_validate(Scheme_Object *data, Mz_CPort *port, static void set_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos); struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs);
static void define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, static void define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos); struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs);
static void define_for_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, static void define_for_syntaxes_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos); struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs);
static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos); struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs);
static void begin0_validate(Scheme_Object *data, Mz_CPort *port, static void begin0_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos); struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs);
static void apply_values_validate(Scheme_Object *data, Mz_CPort *port, static void apply_values_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos); struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs);
static void splice_validate(Scheme_Object *data, Mz_CPort *port, static void splice_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos); struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs);
static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port, static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos); struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs);
static Scheme_Object *define_values_jit(Scheme_Object *data); static Scheme_Object *define_values_jit(Scheme_Object *data);
static Scheme_Object *ref_jit(Scheme_Object *data); static Scheme_Object *ref_jit(Scheme_Object *data);
@ -885,7 +895,8 @@ static void define_values_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos) struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs)
{ {
int i, size; int i, size;
Scheme_Object *val, *only_var; Scheme_Object *val, *only_var;
@ -993,7 +1004,7 @@ static void define_values_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, val, stack, tls, scheme_validate_expr(port, val, stack, tls,
depth, letlimit, delta, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, !!only_var, 0, vc, 0, 0); NULL, !!only_var, 0, vc, 0, 0, NULL);
} }
static Scheme_Object * static Scheme_Object *
@ -1524,7 +1535,8 @@ static void set_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos) struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs)
{ {
Scheme_Object *val, *tl; Scheme_Object *val, *tl;
@ -1538,7 +1550,7 @@ static void set_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, val, stack, tls, depth, letlimit, delta, scheme_validate_expr(port, val, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0, 0); NULL, 0, 0, vc, 0, 0, procs);
scheme_validate_toplevel(tl, port, stack, tls, depth, delta, scheme_validate_toplevel(tl, port, stack, tls, depth, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
0); 0);
@ -1885,7 +1897,8 @@ static void ref_validate(Scheme_Object *tl, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos) struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs)
{ {
scheme_validate_toplevel(tl, port, stack, tls, depth, delta, scheme_validate_toplevel(tl, port, stack, tls, depth, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
@ -2160,7 +2173,8 @@ static void apply_values_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos) struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs)
{ {
Scheme_Object *f, *e; Scheme_Object *f, *e;
@ -2170,11 +2184,11 @@ static void apply_values_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, f, stack, tls, scheme_validate_expr(port, f, stack, tls,
depth, letlimit, delta, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0, 0); NULL, 0, 0, vc, 0, 0, procs);
scheme_validate_expr(port, e, stack, tls, scheme_validate_expr(port, e, stack, tls,
depth, letlimit, delta, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0, 0); NULL, 0, 0, vc, 0, 0, procs);
} }
/**********************************************************************/ /**********************************************************************/
@ -2324,7 +2338,8 @@ static Scheme_Object *case_lambda_jit(Scheme_Object *expr)
static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos) struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs)
{ {
Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)data; Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)data;
Scheme_Object *e; Scheme_Object *e;
@ -2340,7 +2355,7 @@ static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stac
scheme_ill_formed_code(port); scheme_ill_formed_code(port);
scheme_validate_expr(port, e, stack, tls, depth, letlimit, delta, scheme_validate_expr(port, e, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0, 0); NULL, 0, 0, vc, 0, 0, procs);
} }
} }
@ -2723,7 +2738,8 @@ static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos) struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs)
{ {
if (!SCHEME_PAIRP(data)) if (!SCHEME_PAIRP(data))
scheme_ill_formed_code(port); scheme_ill_formed_code(port);
@ -2732,7 +2748,7 @@ static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, SCHEME_CDR(data), stack, tls, depth, letlimit, delta, scheme_validate_expr(port, SCHEME_CDR(data), stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, tailpos, 0); NULL, 0, 0, vc, tailpos, 0, procs);
} }
/**********************************************************************/ /**********************************************************************/
@ -4923,7 +4939,8 @@ static void begin0_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos) struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs)
{ {
Scheme_Sequence *seq = (Scheme_Sequence *)data; Scheme_Sequence *seq = (Scheme_Sequence *)data;
int i; int i;
@ -4936,7 +4953,7 @@ static void begin0_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, seq->array[i], stack, tls, scheme_validate_expr(port, seq->array[i], stack, tls,
depth, letlimit, delta, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, i > 0, vc, 0, 0); NULL, 0, i > 0, vc, 0, 0, procs);
} }
} }
@ -5279,12 +5296,13 @@ static void splice_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos) struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs)
{ {
scheme_validate_expr(port, data, stack, tls, scheme_validate_expr(port, data, stack, tls,
depth, letlimit, delta, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0, 0); NULL, 0, 0, vc, 0, 0, procs);
} }
/**********************************************************************/ /**********************************************************************/
@ -5607,7 +5625,8 @@ static void define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos) struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs)
{ {
do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta, do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, 0); num_toplevels, num_stxes, num_lifts, 0);
@ -5617,7 +5636,8 @@ static void define_for_syntaxes_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
struct Validate_Clearing *vc, int tailpos) struct Validate_Clearing *vc, int tailpos,
Scheme_Hash_Tree *procs)
{ {
do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta, do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, 1); num_toplevels, num_stxes, num_lifts, 1);