fix mark handling for impersonatored procedures to match docs

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.

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 

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 */

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_VEC_ELS(px->redirects)[2];
-    app_mark = scheme_hash_tree_get(px->props, scheme_app_mark_impersonator_property);
+  if (SCHEME_FALSEP(app_mark))
-    /* app_mark should be (cons mark val) */
-    if (app_mark && !SCHEME_PAIRP(app_mark))
-      app_mark = NULL;
-  } else
     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) {

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;