unsafe-{chaperone,impersonate}-procedure: fix name on bad arity

When a procedure created by `unsafe-{chaperone,impersonate}-procedure`
is given the wrong number of arguments, the original procedure's name
should be used in the error message.

pkgs/racket-test-core/tests/racket/chaperone.rktl

@@ -2380,6 +2380,12 @@
     (struct s (f) #:property prop:procedure 0)
     (test #t s? (unsafe-chaperone-procedure (s add1) (λ (x) x)))))
 
+;; Check name in arity error message:
+(let ()
+  (define (pf x) x)
+  (define cf (unsafe-chaperone-procedure pf (lambda (x) x)))
+  (err/rt-test (cf) (λ (x) (regexp-match #rx"^pf:" (exn-message x)))))
+
 ;; ----------------------------------------
 
 (let ()

racket/src/racket/src/fun.c

@@ -3604,15 +3604,9 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
      A size of 5 (instead of 3) indicates that the wrapper
      procedure accepts a "self" argument
 
-     If the known-good arity is a boolean, this means the chaperone
+     If the known-good arity is #f, this means the chaperone
-     wrapper defers directly to SCHEME_VEC_ELES(r)[0], instead of
+     wrapper defers directly to SCHEME_VEC_ELES(r)[0] and no
-     following the actual chaperone procedure.
+     arity check is needed.
-
-     If the boolean is #f, that means the interposition proc was #f
-     originally and SCHEME_VEC_ELES(r)[0] is the original procedure.
-
-     If the boolean is #t, that means that this chaperone was created
-     via unsafe-{chaperone,impersonate}-procedure.
   */
   r = scheme_make_vector((pass_self ? 5 : 3), scheme_make_integer(-1));
 
@@ -3620,8 +3614,6 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
     SCHEME_VEC_ELS(r)[0] = argv[0];
   else
     SCHEME_VEC_ELS(r)[0] = argv[1];
-  if (is_unsafe)
-    SCHEME_VEC_ELS(r)[1] = scheme_true;
   if (SCHEME_FALSEP(argv[1]))
     SCHEME_VEC_ELS(r)[1] = scheme_false;
   SCHEME_VEC_ELS(r)[2] = app_mark;
@@ -3630,6 +3622,8 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
 
   if (is_impersonator)
     SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
+  if (is_unsafe || SCHEME_FALSEP(argv[1]))
+    SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_PROC_CHAPERONE_CALL_DIRECT;
 
   return (Scheme_Object *)px;
 }
@@ -3869,7 +3863,25 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
       self_proc = o;
   }
 
-  if (SCHEME_BOOLP(SCHEME_VEC_ELS(px->redirects)[1])) {
+  /* Ensure that the original procedure accepts `argc' arguments: */
+  if (!SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[1]) /* check not needed for props-only mode */
+      && (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
+         `argc' arguments (in addition to the original procedure's arity)
+         in case the methodness of the original procedure is different
+         from the chaperone, or in case the procedures have different names. */
+      (void)_scheme_apply_multi(px->prev, argc, argv);
+      scheme_signal_error("internal error: unexpected success applying chaperoned/proxied procedure");
+      return NULL;
+    }
+    /* record that argc is ok, on the grounds that the function is likely
+       to be applied to argc arguments again */
+    SCHEME_VEC_ELS(px->redirects)[1] = scheme_make_integer(argc);
+  }
+
+  if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_PROC_CHAPERONE_CALL_DIRECT) {
     simple_call = SCHEME_VEC_ELS(px->redirects)[0];
     /* no redirection procedure */
     if (SCHEME_CHAPERONEP(simple_call)) {
@@ -3907,23 +3919,6 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
     }
   }
 
-  /* Ensure that the original procedure accepts `argc' arguments: */
-  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
-         `argc' arguments (in addition to the original procedure's arity)
-         in case the methodness of the original procedure is different
-         from the chaperone, or in case the procedures have different names. */
-      (void)_scheme_apply_multi(px->prev, argc, argv);
-      scheme_signal_error("internal error: unexpected success applying chaperoned/proxied procedure");
-      return NULL;
-    }
-    /* record that argc is ok, on the grounds that the function is likely
-       to be applied to argc arguments again */
-    SCHEME_VEC_ELS(px->redirects)[1] = scheme_make_integer(argc);
-  }
-
   app_mark = SCHEME_VEC_ELS(px->redirects)[2];
   if (SCHEME_FALSEP(app_mark))
     app_mark = NULL;

racket/src/racket/src/jitcall.c

@@ -65,13 +65,24 @@ static Scheme_Object *clear_runstack(Scheme_Object **rs, intptr_t amt, Scheme_Ob
 
 static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands, GC_CAN_IGNORE jit_insn *refagain)
 {
-  GC_CAN_IGNORE jit_insn *ref2, *refz1, *refz2, *refz3, *refz4, *refz5;
+  GC_CAN_IGNORE jit_insn *ref2, *ref3, *refz1, *refz2, *refz3, *refz4, *refz5;
-  GC_CAN_IGNORE jit_insn *refz6, *refz7, *refz8;
+  GC_CAN_IGNORE jit_insn *refz6, *refz7, *refz8, *refz9, *ref9;
 
   ref2 = jit_bnei_i(jit_forward(), JIT_R1, scheme_proc_struct_type);
+
+  /* This is an applicable struct. But if it's for reducing arity,
+     then we can't just apply the struct's procedure. */
   jit_ldxi_p(JIT_R1, JIT_V1, &((Scheme_Structure *)0x0)->stype);
   jit_ldi_p(JIT_R2, &scheme_reduced_procedure_struct);
-  refz3 = jit_beqr_p(jit_forward(), JIT_R1, JIT_R2);
+  ref3 = jit_bner_p(jit_forward(), JIT_R1, JIT_R2);
+
+  /* Matches reduced arity in a simple way? */
+  jit_ldxi_p(JIT_R2, JIT_V1, &((Scheme_Structure *)0x0)->slots[1]);
+  refz3 = jit_bnei_p(jit_forward(), JIT_R2, scheme_make_integer(num_rands));
+
+  mz_patch_branch(ref3);
+  /* It's an applicable struct that is not an arity reduce or the
+     arity matches. We can extract the procedure if it's in a field: */
   jit_ldxi_p(JIT_R1, JIT_R1, &((Scheme_Struct_Type *)0x0)->proc_attr);
   refz1 = jit_bmci_i(jit_forward(), JIT_R1, 0x1);
   CHECK_LIMIT();
@@ -81,6 +92,7 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
   jit_lshi_ul(JIT_R1, JIT_R1, JIT_LOG_WORD_SIZE);
   jit_addi_p(JIT_R1, JIT_R1, &((Scheme_Structure *)0x0)->slots);
   jit_ldxr_p(JIT_R1, JIT_V1, JIT_R1);
+  CHECK_LIMIT();
 
   /* JIT_R1 now has the wrapped procedure */
   refz4 = jit_bmsi_i(jit_forward(), JIT_R1, 0x1);
@@ -118,16 +130,23 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
   refz6 = mz_bnei_t(jit_forward(), JIT_R1, scheme_vector_type, JIT_R2);
   (void)jit_ldxi_l(JIT_R2, JIT_R1, &SCHEME_VEC_SIZE(0x0));
   refz7 = jit_bmci_i(jit_forward(), JIT_R2, 0x1);
-  /* if  &(SCHEME_VEC_ELS(0x0)[1]) is a boolean, we have the fast
+  /* Flag is set for a property-only or unsafe chaperone: */
-     path; it can only otherwise be a fixnum, so just check that */
+  jit_ldxi_s(JIT_R2, JIT_V1, &SCHEME_CHAPERONE_FLAGS(((Scheme_Chaperone *)0x0)));
-  (void)jit_ldxi_l(JIT_R2, JIT_R1, &(SCHEME_VEC_ELS(0x0)[1]));
+  refz8 = jit_bmci_ul(jit_forward(), JIT_R2, SCHEME_PROC_CHAPERONE_CALL_DIRECT);
-  refz8 = jit_bmsi_ul(jit_forward(), JIT_R2, 0x1);
+  /* In the case of an unsafe chaperone, we can only make a direct
+     call if the arity-check will succeed, otherwise the error message
+     will use the wrong name. */
+  jit_ldxi_p(JIT_R2, JIT_R1, &(SCHEME_VEC_ELS(0x0)[1]));
+  ref9 = jit_beqi_p(jit_forward(), JIT_R2, scheme_false);
+  refz9 = jit_bnei_p(jit_forward(), JIT_R2, scheme_make_integer(num_rands));
+  mz_patch_branch(ref9);
   /* Position [0] in SCHEME_VEC_ELS contains either the
      unwrapped function (if chaperone-procedure got #f
      for the proc argument) or the unsafe-chaperone
      replacement-proc argument; either way, just call it */
   jit_ldxi_p(JIT_V1, JIT_R1, &(SCHEME_VEC_ELS(0x0)[0]));
   (void)jit_jmpi(refagain);
+  CHECK_LIMIT();
 
   mz_patch_branch(refz1);
   mz_patch_branch(refz2);
@@ -137,6 +156,7 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
   mz_patch_branch(refz6);
   mz_patch_branch(refz7);
   mz_patch_branch(refz8);
+  mz_patch_branch(refz9);
 
   return ref2;
 }

racket/src/racket/src/schnapp.inc

@@ -62,10 +62,13 @@ Scheme_Object *PRIM_APPLY_NAME(Scheme_Object *rator,
 
     if ((t == scheme_proc_chaperone_type)
         && SCHEME_VECTORP(((Scheme_Chaperone *)rator)->redirects)
-        && (SCHEME_VEC_SIZE(((Scheme_Chaperone *)rator)->redirects) & 0x1)) {
+        && (SCHEME_VEC_SIZE(((Scheme_Chaperone *)rator)->redirects) & 0x1)
-      if (SCHEME_BOOLP(SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[1])) {
+        && (SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)rator) == SCHEME_PROC_CHAPERONE_CALL_DIRECT)) {
+      if (SCHEME_FALSEP(SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[1])
+          || SCHEME_INT_VAL(SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[1]) == argc) {
         /* No redirection proc, i.e, chaperone is just for
-	   properties or unsafe-chaperone-procedure result */
+	   properties or produced by unsafe-chaperone-procedure result -- and in the
+           latter case, the arity is right.. */
         rator = SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[0];
         t = _SCHEME_TYPE(rator);
       } else

racket/src/racket/src/schpriv.h

@@ -1063,6 +1063,7 @@ typedef struct Scheme_Chaperone {
 
 #define SCHEME_CHAPERONE_FLAGS(c) MZ_OPT_HASH_KEY(&(c)->iso)
 #define SCHEME_CHAPERONE_IS_IMPERSONATOR 0x1
+#define SCHEME_PROC_CHAPERONE_CALL_DIRECT 0x2
 
 #define SCHEME_CHAPERONE_VAL(obj) (((Scheme_Chaperone *)obj)->val)