Add procedure-impersonator*?.

Mostly useful to determine whether using `unsafe-chaperone-procedure` is ok.

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "6.5.0.3")
+(define version "6.5.0.4")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-doc/scribblings/reference/chaperones.scrbl

@@ -167,6 +167,18 @@ will be considered reachable as long as the result ephemeron is
 reachable in addition to any value that @racket[v] impersonates
 (including itself).}
 
+@defproc[(procedure-impersonator*? [v any/c]) boolean?]{
+
+chaperone-procedure*?
+returns #t for any impersonator of a value produced by
+impersonate-procedure* or chaperone-procedure* (or something like that).
+
+Returns @racket[#t] for any procedure impersonator that either was produced by
+@racket[impersonate-procedure*] or @racket[chaperone-procedure*], or is
+an impersonator/chaperone of a value that was created with
+@racket[impersonate-procedure*] or @racket[chaperone-procedure*]
+(possibly transitively).}
+
 @; ------------------------------------------------------------
 @section{Impersonator Constructors}
 

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

@@ -889,7 +889,11 @@
           (test 'green green-ref p2)))
       
       (err/rt-test (chaperone-struct 10 struct-info void))
-      (err/rt-test (chaperone-struct 10 struct-info void prop:blue 'blue))))
+      (err/rt-test (chaperone-struct 10 struct-info void prop:blue 'blue))
+
+      ;; struct chaperones cannot be procedure-impersonator*?
+      (test #f procedure-impersonator*? (chaperone-struct (specific) struct:specific prop:blue 'blue))
+      ))
 
 ;; test to see if the guard is actually called even when impersonated
 (let ()
@@ -2529,4 +2533,18 @@
 
 ;; ----------------------------------------
 
+(test #f procedure-impersonator*? 3)
+(test #f procedure-impersonator*? (impersonate-procedure values values))
+(test #t procedure-impersonator*? (impersonate-procedure* values values))
+(test #t procedure-impersonator*? (impersonate-procedure* (impersonate-procedure* values values) values))
+(test #t procedure-impersonator*? (impersonate-procedure* (impersonate-procedure values values) values))
+(test #f procedure-impersonator*? (impersonate-procedure (impersonate-procedure values values) values))
+(test #f procedure-impersonator*? (chaperone-procedure values values))
+(test #t procedure-impersonator*? (chaperone-procedure* values values))
+(test #t procedure-impersonator*? (chaperone-procedure* (chaperone-procedure* values values) values))
+(test #t procedure-impersonator*? (chaperone-procedure* (chaperone-procedure values values) values))
+(test #f procedure-impersonator*? (chaperone-procedure (chaperone-procedure values values) values))
+
+;; ----------------------------------------
+
 (report-errs)

racket/src/racket/src/bool.c

@@ -48,6 +48,7 @@ static Scheme_Object *equal_prim (int argc, Scheme_Object *argv[]);
 static Scheme_Object *equalish_prim (int argc, Scheme_Object *argv[]);
 static Scheme_Object *chaperone_p (int argc, Scheme_Object *argv[]);
 static Scheme_Object *impersonator_p (int argc, Scheme_Object *argv[]);
+static Scheme_Object *procedure_impersonator_star_p (int argc, Scheme_Object *argv[]);
 static Scheme_Object *chaperone_of (int argc, Scheme_Object *argv[]);
 static Scheme_Object *impersonator_of (int argc, Scheme_Object *argv[]);
 
@@ -128,6 +129,9 @@ void scheme_init_bool (Scheme_Env *env)
   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
                                                             | SCHEME_PRIM_IS_OMITABLE);
   scheme_add_global_constant("impersonator?", p, env);
+  p = scheme_make_immed_prim(procedure_impersonator_star_p, "procedure-impersonator*?", 1, 1);
+  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE);
+  scheme_add_global_constant("procedure-impersonator*?", p, env);
 
   scheme_add_global_constant("chaperone-of?",
                              scheme_make_prim_w_arity(chaperone_of, "chaperone-of?", 2, 2),
@@ -987,6 +991,21 @@ static Scheme_Object *impersonator_p(int argc, Scheme_Object *argv[])
   return (SCHEME_CHAPERONEP(argv[0]) ? scheme_true : scheme_false);
 }
 
+/* Was this value created with `impersonate-procedure*` or `chaperone-procedure*`? */
+static Scheme_Object *procedure_impersonator_star_p(int argc, Scheme_Object *argv[])
+{
+  Scheme_Vector *redirects;
+  if (SCHEME_CHAPERONEP(argv[0])) {
+    redirects = (Scheme_Vector *)(((Scheme_Chaperone *)(argv[0]))->redirects);
+    if ((SCHEME_VEC_SIZE(redirects) % 2 == 1) /* odd size => procedure chaperone */
+        && ((SCHEME_VEC_SIZE(redirects) == 5) /* size 5 => we are a chap/imp* */
+            || SCHEME_IMMUTABLEP(redirects))) { /* immutable => chap/imp* in our ancestry */
+      return scheme_true;
+    }
+  }
+  return scheme_false;
+}
+
 static Scheme_Object *chaperone_of(int argc, Scheme_Object *argv[])
 {
   return (scheme_chaperone_of(argv[0], argv[1]) ? scheme_true : scheme_false);

racket/src/racket/src/schminc.h

@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1146
+#define EXPECTED_PRIM_COUNT 1147
 #define EXPECTED_UNSAFE_COUNT 126
 #define EXPECTED_FLFXNUM_COUNT 69
 #define EXPECTED_EXTFL_COUNT 45

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "6.5.0.3"
+#define MZSCHEME_VERSION "6.5.0.4"
 
 #define MZSCHEME_VERSION_X 6
 #define MZSCHEME_VERSION_Y 5
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 3
+#define MZSCHEME_VERSION_W 4
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)