diff --git a/collects/tests/racket/chaperone.rktl b/collects/tests/racket/chaperone.rktl index 7b06cf1423..a5de9e727b 100644 --- a/collects/tests/racket/chaperone.rktl +++ b/collects/tests/racket/chaperone.rktl @@ -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 diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index c759a79a3d..f6d5deaaa3 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -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 */ diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index 73bd0f2ea6..4eb1443a99 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -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) { diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index ca985d53ba..0863121e84 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -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;