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

fix mark handling for impersonatored procedures to match docs

Browse Source 
Using an impersonator property to represent an application mark was
a bad choice. The property gets propagated, so it is also on any later
chaperone layer, and then things go bad: the docs say that special
treatment is triggered by supplying an argument to `impersonate-property',
but it was actually triggered by the chaperone having the property.

Change the implementation to match the documentation. Using an
impersonator property to supply the mark should be regarded as a hack,
but now the implementaiton is at least consistent with the documentaiton.
This commit is contained in:
Matthew Flatt 2013-03-03 09:52:32 -07:00
parent 8c3eb7dcb4
commit 5e20f51415
4 changed files with 65 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/tests/racket/chaperone.rktl
View File

@ -1226,6 +1226,26 @@
(test (list 11 '(11)) j 10)
(test '(12 #f 9 #f) values saved))
;; Make sure that `impersonator-prop:application-mark'
;; is not propagated to further wrapping chaperones:
(let ()
(define msgs '())
(define f
(chaperone-procedure
(λ (x) 'wrong)
(λ (x)
(call-with-immediate-continuation-mark
'key
(λ (m)
(set! msgs (cons m msgs))
(values x))))
impersonator-prop:application-mark
(cons 'key 'skip-this-check)))
(void ((chaperone-procedure f (lambda (x) x)) 42)
(f 42))
(test '(#f #f) values msgs))
;; ----------------------------------------
;; Check that supplying a procedure `to make-keyword-procedure' that

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

@ -2946,7 +2946,8 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
the chaperone may guard access to the function as a field inside
the struct. We'll need to keep track of the original object
as we unwrap to discover procedure chaperones. */
&& (SCHEME_VECTORP(((Scheme_Chaperone *)obj)->redirects)))
&& (SCHEME_VECTORP(((Scheme_Chaperone *)obj)->redirects))
&& !(SCHEME_VEC_SIZE(((Scheme_Chaperone *)obj)->redirects) & 1))
/* A raw pair is from scheme_apply_chaperone(), propagating the
original object for an applicable structure. */
|| (type == scheme_raw_pair_type)) {
@ -3016,7 +3017,8 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
goto apply_top;
} else {
if (SCHEME_VECTORP(((Scheme_Chaperone *)obj)->redirects))
if (SCHEME_VECTORP(((Scheme_Chaperone *)obj)->redirects)
&& !(SCHEME_VEC_SIZE(((Scheme_Chaperone *)obj)->redirects) & 1))
obj = ((Scheme_Chaperone *)obj)->prev;
else if (SAME_TYPE(SCHEME_TYPE(((Scheme_Chaperone *)obj)->redirects), scheme_nack_guard_evt_type))
/* Chaperone is for evt, not function arguments */

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

@ -3237,7 +3237,7 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
int is_impersonator, int argc, Scheme_Object *argv[])
{
Scheme_Chaperone *px;
Scheme_Object *val = argv[0], *orig, *naya, *r;
Scheme_Object *val = argv[0], *orig, *naya, *r, *app_mark;
Scheme_Hash_Tree *props;
if (SCHEME_CHAPERONEP(val))
@ -3261,14 +3261,35 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
argv[0]);
props = scheme_parse_chaperone_props(name, 2, argc, argv);
if (props) {
app_mark = scheme_hash_tree_get(props, scheme_app_mark_impersonator_property);
if (app_mark) {
/* don't need to keep the property */
if (props->count == 1)
props = NULL;
else
props = scheme_hash_tree_set(props, scheme_app_mark_impersonator_property, NULL);
/* app_mark should be (cons mark val) */
if (!SCHEME_PAIRP(app_mark))
app_mark = scheme_false;
} else
app_mark = scheme_false;
} else
app_mark = scheme_false;
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->iso.so.type = scheme_proc_chaperone_type;
px->val = val;
px->prev = argv[0];
px->props = props;
/* put procedure with known-good arity (to speed checking) in a mutable pair: */
r = scheme_make_mutable_pair(argv[1], scheme_make_integer(-1));
/* put procedure with known-good arity (to speed checking) in a vector: */
r = scheme_make_vector(3, scheme_make_integer(-1));
SCHEME_VEC_ELS(r)[0] = argv[1];
SCHEME_VEC_ELS(r)[2] = app_mark;
/* Vector of odd size for redirects means a procedure chaperone,
vector with even slots means a structure chaperone. */
px->redirects = r;
if (is_impersonator)
@ -3372,7 +3393,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
Scheme_Cont_Frame_Data cframe;
if (argv == MZ_RUNSTACK) {
/* Pushing onto the runstack ensures that `(mcar px->redirects)' won't
/* Pushing onto the runstack ensures that `(vector-ref px->redirects 0)' won't
modify argv. */
if (MZ_RUNSTACK > MZ_RUNSTACK_START) {
--MZ_RUNSTACK;
@ -3404,7 +3425,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
what = "impersonator";
/* Ensure that the original procedure accepts `argc' arguments: */
if (argc != SCHEME_INT_VAL(SCHEME_CDR(px->redirects))) {
if (argc != SCHEME_INT_VAL(SCHEME_VEC_ELS(px->redirects)[1])) {
a[0] = px->prev;
if (!scheme_check_proc_arity(NULL, argc, 0, 0, a)) {
/* Apply the original procedure, in case the chaperone would accept
@ -3417,15 +3438,11 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
}
/* record that argc is ok, on the grounds that the function is likely
to be applied to argc arguments again */
SCHEME_CDR(px->redirects) = scheme_make_integer(argc);
SCHEME_VEC_ELS(px->redirects)[1] = scheme_make_integer(argc);
}
if (px->props) {
app_mark = scheme_hash_tree_get(px->props, scheme_app_mark_impersonator_property);
/* app_mark should be (cons mark val) */
if (app_mark && !SCHEME_PAIRP(app_mark))
app_mark = NULL;
} else
app_mark = SCHEME_VEC_ELS(px->redirects)[2];
if (SCHEME_FALSEP(app_mark))
app_mark = NULL;
if (app_mark) {
@ -3440,7 +3457,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
} else
need_pop_mark = 0;
v = SCHEME_CAR(px->redirects);
v = SCHEME_VEC_ELS(px->redirects)[0];
if (SAME_TYPE(SCHEME_TYPE(v), scheme_native_closure_type))
v = _apply_native(v, argc, argv);
else
@ -3500,7 +3517,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
" expected: %d or %d\n"
" received: %d",
what,
SCHEME_CAR(px->redirects),
SCHEME_VEC_ELS(px->redirects)[0],
argc, argc + 1,
c);
return NULL;
@ -3556,7 +3573,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
" wrapper: %V\n"
" received: %V",
what,
SCHEME_CAR(px->redirects),
SCHEME_VEC_ELS(px->redirects)[0],
post);
if (app_mark) {

11
src/racket/src/struct.c
View File

@ -185,6 +185,8 @@ static Scheme_Object *make_chaperone_property_from_c(Scheme_Object *name);
static Scheme_Object *is_liberal_def_ctx(int argc, Scheme_Object **argv, Scheme_Object *self);
/* This needs to be even, so that structure chaperones are
distingiushed from procedure chaperones: */
#define PRE_REDIRECTS 2
#ifdef MZ_PRECISE_GC
@ -1054,6 +1056,7 @@ static Scheme_Object *do_chaperone_prop_accessor(const char *who, Scheme_Object
}
if (!SCHEME_VECTORP(px->redirects)
|| (SCHEME_VEC_SIZE(px->redirects) & 1)
|| SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[0]))
arg = px->prev;
else {
@ -1972,6 +1975,7 @@ static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *o, in
Scheme_Object *a[2], *red, *orig;
if (!SCHEME_VECTORP(px->redirects)
|| (SCHEME_VEC_SIZE(px->redirects) & 1)
|| SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[PRE_REDIRECTS + i])) {
o = px->prev;
} else {
@ -2025,7 +2029,8 @@ static void chaperone_struct_set(const char *who, Scheme_Object *o, int i, Schem
int half;
o = px->prev;
if (SCHEME_VECTORP(px->redirects)) {
if (SCHEME_VECTORP(px->redirects)
&& !(SCHEME_VEC_SIZE(px->redirects) & 1)) {
half = (SCHEME_VEC_SIZE(px->redirects) - PRE_REDIRECTS) >> 1;
red = SCHEME_VEC_ELS(px->redirects)[PRE_REDIRECTS + half + i];
if (SCHEME_TRUEP(red)) {
@ -2560,7 +2565,8 @@ static Scheme_Object *struct_info_chaperone(Scheme_Object *o, Scheme_Object *si,
while (SCHEME_CHAPERONEP(o)) {
px = (Scheme_Chaperone *)o;
if (SCHEME_VECTORP(px->redirects)) {
if (SCHEME_VECTORP(px->redirects)
&& !(SCHEME_VEC_SIZE(px->redirects) & 1)) {
proc = SCHEME_VEC_ELS(px->redirects)[1];
if (SCHEME_TRUEP(proc)) {
if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
@ -5314,6 +5320,7 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
if (SCHEME_STRUCTP(val)) {
stype = ((Scheme_Structure *)val)->stype;
/* vector size needs to be even to distinguish it from procedure chaperones: */
redirects = scheme_make_vector(PRE_REDIRECTS + 2 * stype->num_slots, scheme_false);
} else {
stype = NULL;