{chaperone,impersonate}-struct: allow structure type as a witness

Also, do not allow `struct-type` as a wrapped operation in
`chaperone-stuct` without a witness.

Related to PR 14970

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

@@ -253,6 +253,7 @@ that are overridden by further impersonators, for example.
 
 
 @defproc[(impersonate-struct [v any/c]
+                             [struct-type struct-type? _unspecified]
                              [orig-proc (or/c struct-accessor-procedure?
                                               struct-mutator-procedure?
                                               struct-type-property-accessor-procedure?)]
@@ -264,7 +265,10 @@ that are overridden by further impersonators, for example.
 Returns an impersonator of @racket[v], which redirects certain
 operations on the impersonated value. The @racket[orig-proc]s
 indicate the operations to redirect, and the corresponding
-@racket[redirect-proc]s supply the redirections.
+@racket[redirect-proc]s supply the redirections. The optional
+@racket[struct-type] argument, when provided, acts as a witness for
+the representation of @racket[v], which must be an instance of
+@racket[struct-type].
 
 The protocol for a @racket[redirect-proc] depends on the corresponding
 @racket[orig-proc], where @racket[_self] refers to the value to which
@@ -306,7 +310,7 @@ to @racket[impersonate-struct] must be odd) add impersonator properties
 or override impersonator-property values of @racket[v].
 
 Each @racket[orig-proc] must indicate a distinct operation. If no
-@racket[orig-proc]s are supplied, then no @racket[prop]s must be
+@racket[struct-type] and no @racket[orig-proc]s are supplied, then no @racket[prop]s must be
 supplied. If @racket[orig-proc]s are supplied only with @racket[#f]
 @racket[redirect-proc]s and no @racket[prop]s are supplied, then
 @racket[v] is returned unimpersonated.
@@ -320,7 +324,9 @@ after @racket[redirect-proc] (in the case of a mutator).
 @history[#:changed "6.1.1.2" @elem{Changed first argument to an
                                    accessor or mutator
                                    @racket[redirect-proc] from
-                                   @racket[v] to @racket[_self].}]}
+                                   @racket[v] to @racket[_self].}
+         #:changed "6.1.1.8" @elem{Added optional @racket[struct-type]
+                                   argument.}]}
 
 
 @defproc[(impersonate-vector [vec (and/c vector? (not/c immutable?))]
@@ -632,6 +638,7 @@ an extra argument as with @racket[impersonate-procedure*].
 
 
 @defproc[(chaperone-struct [v any/c]
+                           [struct-type struct-type? _unspecified]
                            [orig-proc (or/c struct-accessor-procedure?
                                             struct-mutator-procedure?
                                             struct-type-property-accessor-procedure?
@@ -671,18 +678,24 @@ a @racket[orig-proc] is originally applied:
        must return each values or a chaperone of each value. The
        @racket[redirect-proc] is not called if @racket[struct-info]
        would return @racket[#f] as its first argument. An
-       @racket[orig-proc] can be @racket[struct-info] only if some
+       @racket[orig-proc] can be @racket[struct-info] only if
-       other @racket[orig-proc] is supplied.}
+       @racket[struct-type] or some other @racket[orig-proc] is supplied.}
 
  @item{Any accessor or mutator @racket[orig-proc] that is an
        @tech{impersonator} must be specifically a @tech{chaperone}.}
 
 ]
 
+Supplying a property accessor for @racket[orig-proc] enables
+@racket[prop] arguments, the same as supplying an accessor, mutator,
+or structure type.
+
 @history[#:changed "6.1.1.2" @elem{Changed first argument to an
                                    accessor or mutator
                                    @racket[redirect-proc] from
-                                   @racket[v] to @racket[_self].}]}
+                                   @racket[v] to @racket[_self].}
+         #:changed "6.1.1.8" @elem{Added optional @racket[struct-type]
+                                   argument.}]}
 
 
 @defproc[(chaperone-vector [vec vector?]

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

@@ -530,6 +530,12 @@
    (define-struct p (u) #:property prop:green 'green)
    (define-struct r (t) #:property prop:red 'red)
    (define-struct (q p) (v w))
+   (define-struct specific ())
+   (test #t chaperone?/impersonator (chaperone-struct (specific) struct:specific prop:blue 'blue))
+   (test #t chaperone?/impersonator (chaperone-struct (specific)
+                                                      (chaperone-struct-type struct:specific 
+                                                                             values values values)
+                                                      prop:blue 'blue))
    (test #t chaperone?/impersonator (chaperone-struct (make-a 1 2) a-x (lambda (a v) v)
                                                       set-a-x! (lambda (a v) v)))
    (test #t chaperone?/impersonator (chaperone-struct (make-b 1 2 3) a-x (lambda (a v) v)
@@ -708,7 +714,10 @@
           (test #t eq? p1 (chaperone-struct p1
                                             p-u #f))
           (test 0 p-u p2)
-          (test 'green green-ref p2)))))
+          (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))))
 
 ;; test to see if the guard is actually called even when impersonated
 (let ()

racket/collects/racket/contract/private/provide.rkt

@@ -924,6 +924,7 @@
                          (let ([struct-name
                                 (λ (constructor-args ...)
                                   (chaperone-struct (#,constructor-id constructor-args ...)
+                                                    struct:struct-name
                                                     struct-info
                                                     (λ (struct-type skipped?)
                                                       (values -struct:struct-name skipped?))))])

racket/src/racket/src/struct.c

@@ -5829,7 +5829,7 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
   const char *kind;
   Scheme_Hash_Tree *props = NULL, *red_props = NULL, *empty_red_props = NULL, *setter_positions = NULL;
   intptr_t field_pos;
-  int empty_si_chaperone = 0, *empty_redirects = NULL, has_redirect = 0;
+  int empty_si_chaperone = 0, *empty_redirects = NULL, has_redirect = 0, witnessed = 0;
 
   if (argc == 1) return argv[0];
 
@@ -5852,14 +5852,33 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
   else
     inspector = NULL;
 
-  for (i = 1; i < argc; i++) {
+  i = 1;
+
+  if ((i < argc) && (SCHEME_STRUCT_TYPEP(argv[i])
+                     || (SCHEME_NP_CHAPERONEP(argv[i])
+                         && SCHEME_STRUCT_TYPEP(SCHEME_CHAPERONE_VAL(argv[i]))))) {
+    if (!SCHEME_STRUCTP(val) || !scheme_is_struct_instance((SCHEME_NP_CHAPERONEP(argv[i])
+                                                            ? SCHEME_CHAPERONE_VAL(argv[i])
+                                                            : argv[i]),
+                                                           val)) {
+      scheme_contract_error(name,
+                            "given value is not an instance of the given structure type",
+                            "struct type", 1, argv[i],
+                            "value", 1, argv[0],
+                            NULL);
+      return NULL;
+    }
+    i++;
+    witnessed = 1;
+  }
+
+  for (; i < argc; i++) {
     proc = argv[i];
 
     if ((i > 1) && SAME_TYPE(SCHEME_TYPE(proc), scheme_chaperone_property_type)) {
       props = scheme_parse_chaperone_props(name, i, argc, argv);
       break;
     }
-    
 
     a[0] = proc;
     if (SCHEME_CHAPERONEP(proc)) proc = SCHEME_CHAPERONE_VAL(proc);
@@ -5869,21 +5888,29 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
         offset = stype->num_slots;
       else
         offset = 0;
+      witnessed = 1;
     } else if (SCHEME_TRUEP(struct_getter_p(1, a))) {
       kind = "accessor";
       offset = 0;
+      witnessed = 1;
     } else if (SCHEME_TRUEP(struct_prop_getter_p(1, a))) {
       kind = "struct-type property accessor";
       offset = -1;
+      witnessed = 1;
     } else if (!is_impersonator && SAME_OBJ(proc, struct_info_proc)) {
       kind = "struct-info";
       offset = -2;
     } else {
-      scheme_wrong_contract(name, 
+#define CHAP_PROC_CONTRACT_STR(extra)                      \
-                            "(or/c struct-accessor-procedure?\n"
+      ("(or/c " extra "struct-accessor-procedure?\n"      \
-			    "      struct-mutator-procedure?\n"
+       "      struct-mutator-procedure?\n"                 \
-                            "      struct-type-property-accessor-procedure?\n"
+       "      struct-type-property-accessor-procedure?\n"  \
-			    "      (one-of/c struct-info))",
+       "      (one-of/c struct-info))")
+      
+      scheme_wrong_contract(name,
+                            ((i == 1)
+                             ? CHAP_PROC_CONTRACT_STR("struct-type?\n      ")
+                             : CHAP_PROC_CONTRACT_STR("")),
                             i, argc, argv);
       return NULL;
     }
@@ -6075,6 +6102,18 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
 
   if (!has_redirect && !props)
     return argv[0];
+
+  if (!witnessed) {
+    scheme_contract_error(name,
+                          (is_impersonator
+                           ? "cannot impersonate value as a structure without a witness"
+                           : "cannot chaperone value as a structure without a witness"),
+                          "explanation", 0, ("a structure type, accessor, or mutator acts as a witness\n"
+                                             "   that the given value's representation can be chaperoned or impersonated"),
+                          "given value", 1, argv[0],
+                          NULL);
+    return NULL;
+  }
   
   if (!redirects) {
     /* a non-structure chaperone */