chaperones: allow procedure chaperones that supplies no redirection

The same as the change for structure chaperones, but for procedures.

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

@@ -116,7 +116,7 @@ Otherwise, impersonators within @racket[v2] must be intact within
 
       ]}
 
- @item{If a part of @racket[v2] is a structure impersonator that was
+ @item{If a part of @racket[v2] is a structure or procedure impersonator that was
        created with no redirection procedures (i.e, @racket[#f] in
        place of all redirection procedures for specified operations),
        then the impersonated value is considered in place of that part
@@ -141,7 +141,7 @@ except that the mutability of vectors and boxes with @racket[v1] and
 Otherwise, chaperones within @racket[v2] must be intact within
 @racket[v1] analogous to way that @racket[impersonator-of?] requires
 that impersonators are preserved, except that @racket[prop:impersonator-of]
-has no analog for @racket[chaperone-of].}
+has no analog for @racket[chaperone-of?].}
 
 
 @defproc[(impersonator-ephemeron [v any/c]) ephemeron?]{
@@ -158,14 +158,15 @@ reachable in addition to any value that @racket[v] impersonates
 @section{Impersonator Constructors}
 
 @defproc[(impersonate-procedure [proc procedure?]
-                                [wrapper-proc procedure?]
+                                [wrapper-proc (or/c procedure? #f)]
                                 [prop impersonator-property?]
                                 [prop-val any] ... ...)
          (and/c procedure? impersonator?)]{
 
 Returns an impersonator procedure that has the same arity, name, and
 other attributes as @racket[proc]. When the impersonator procedure is
-applied, the arguments are first passed to @racket[wrapper-proc], and
+applied, the arguments are first passed to @racket[wrapper-proc]
+(when it is not @racket[#f]), and
 then the results from @racket[wrapper-proc] are passed to
 @racket[proc]. The @racket[wrapper-proc] can also supply a procedure
 that processes the results of @racket[proc].
@@ -194,6 +195,11 @@ impersonator (i.e., not counting optional arguments that were
 not supplied). The arguments must be ordered according to the sorted
 order of the supplied arguments' keywords.
 
+If @racket[wrapper] is @racket[#f], then applying the resulting
+impersonator is the same as applying @racket[proc]. If
+@racket[wrapper] is @racket[#f] and no @racket[prop] is provided, then
+the result is @racket[proc] unimpersonated.
+
 Pairs of @racket[prop] and @racket[prop-val] (the number of arguments
 to @racket[procedure-impersonator] must be even) add impersonator properties
 or override impersonator-property values of @racket[proc].
@@ -550,7 +556,7 @@ between @racket[impersonator-of?] and @racket[equal?]).}
 @section{Chaperone Constructors}
 
 @defproc[(chaperone-procedure [proc procedure?]
-                              [wrapper-proc procedure?]
+                              [wrapper-proc (or/c procedure? #f)]
                               [prop impersonator-property?]
                               [prop-val any] ... ...)
          (and/c procedure? chaperone?)]{

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

@@ -1529,6 +1529,7 @@
      (λ (kwds kwd-args . args)
         (apply values kwd-args args))
      (λ args (apply values args))))
+  (define-values (prop:blue blue? blue-ref) (make-impersonator-property 'blue))
   
   (define g1 (chaperone-procedure f1 wrapper))
   (define g2 (chaperone-procedure f2 wrapper))
@@ -1542,6 +1543,21 @@
   (test #t chaperone-of? g3 f2)
   (test #f chaperone-of? g3 g2)
 
+  (test #t chaperone-of? g1 (chaperone-procedure g1 #f prop:blue 'color))
+  (test #t chaperone-of? g2 (chaperone-procedure g2 #f prop:blue 'color))
+  (test #t chaperone-of? g3 (chaperone-procedure g3 #f prop:blue 'color))
+  (test #t chaperone-of? f3 (chaperone-procedure f3 #f prop:blue 'color))
+  (test #f chaperone-of? f3 (chaperone-procedure g3 #f prop:blue 'color))
+
+  (test #t eq? f1 (chaperone-procedure f1 #f))
+  (test #t eq? f3 (chaperone-procedure f3 #f))
+  (test #f eq? f3 (chaperone-procedure f3 #f prop:blue 'color))
+  (test #f eq? f1 (chaperone-procedure f1 #f impersonator-prop:application-mark 'x))
+  (test #f eq? f1 (chaperone-procedure f1 #f impersonator-prop:application-mark (cons 1 2)))
+  (test 8 (chaperone-procedure f2 #f prop:blue 'color) #:key 8)
+  (test 88 (chaperone-procedure f3 #f prop:blue 'color) #:key 88)
+  (test 'color blue-ref (chaperone-procedure f3 #f prop:blue 'color))
+
   (test #t equal? g1 f1)
   (test #t equal? g2 f2)
   (test #t equal? g3 f2)

racket/src/racket/src/fun.c

@@ -3382,20 +3382,24 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
 
   if (!SCHEME_PROCP(val))
     scheme_wrong_contract(name, "procedure?", 0, argc, argv);
-  if (!SCHEME_PROCP(argv[1]))
+  if (!SCHEME_FALSEP(argv[1]) && !SCHEME_PROCP(argv[1]))
-    scheme_wrong_contract(name, "procedure?", 1, argc, argv);
+    scheme_wrong_contract(name, "(or/c procedure? #f)", 1, argc, argv);
 
   orig = get_or_check_arity(val, -1, NULL, 1);
-  naya = get_or_check_arity(argv[1], -1, NULL, 1);
+  if (SCHEME_FALSEP(argv[1]))
+    naya = scheme_false;
+  else {
+    naya = get_or_check_arity(argv[1], -1, NULL, 1);
 
-  if (!is_subarity(orig, naya))
+    if (!is_subarity(orig, naya))
-    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
+      scheme_raise_exn(MZEXN_FAIL_CONTRACT,
-                     "%s: arity of wrapper procedure does not cover arity of original procedure\n"
+                       "%s: arity of wrapper procedure does not cover arity of original procedure\n"
-                     "  wrapper: %V\n"
+                       "  wrapper: %V\n"
-                     "  original: %V",
+                       "  original: %V",
-                     name,
+                       name,
-                     argv[1],
+                       argv[1],
-                     argv[0]);
+                       argv[0]);
+  }
 
   props = scheme_parse_chaperone_props(name, 2, argc, argv);
   if (props) {
@@ -3406,14 +3410,18 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
         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;
 
+  if (SCHEME_FALSEP(argv[1]) && SCHEME_FALSEP(app_mark) && !props)
+    return argv[0];
+
+  /* app_mark should be (cons mark val) */
+  if (SCHEME_FALSEP(app_mark) && !SCHEME_PAIRP(app_mark))
+    app_mark = scheme_false;
+  
   px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
   px->iso.so.type = scheme_proc_chaperone_type;
   px->val = val;
@@ -3561,6 +3569,11 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
   else
     what = "impersonator";
 
+  if (SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[0])) {
+    /* no redirection procedure */
+    return _scheme_tail_apply(px->prev, argc, argv);
+  }
+
   /* Ensure that the original procedure accepts `argc' arguments: */
   if (argc != SCHEME_INT_VAL(SCHEME_VEC_ELS(px->redirects)[1])) {
     a[0] = px->prev;

racket/src/racket/src/struct.c

@@ -2237,8 +2237,12 @@ int scheme_is_noninterposing_chaperone(Scheme_Object *o)
   if (!SCHEME_VECTORP(px->redirects))
     return 0;
 
-  if (SCHEME_VEC_SIZE(px->redirects) & 1)
+  if (SCHEME_VEC_SIZE(px->redirects) & 1) {
-    return 0;
+    /* procedure chaperone */
+    if (SCHEME_TRUEP(SCHEME_VEC_ELS(px->redirects)[0]))
+      return 0;
+    return 1;
+  }
 
   if (SCHEME_TRUEP(SCHEME_VEC_ELS(px->redirects)[0]))
     return 0;