make impersonator properties sensitive to prop:impersonator-of

When a structure type has `prop:inpersonator-of`, follow it
when attemptng to access imperonator properties.

This change fixes a problem with `impersonate-procedure` as
reported by Scott Moore.

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

@@ -595,9 +595,19 @@ otherwise the result is a value for which the original structure is an
 impersonator (so the original structure is an @racket[impersonator-of?] and
 @racket[equal?] to the result value). The result value must have the
 same @racket[prop:impersonator-of] and @racket[prop:equal+hash] property
-values as the original structure, and the property values must be
+values as the original structure, if any, and the property values must be
 inherited from the same structure type (which ensures some consistency
-between @racket[impersonator-of?] and @racket[equal?]).}
+between @racket[impersonator-of?] and @racket[equal?]).
+
+@tech{Impersonator property} predicates and accessors applied to a
+structure with the @racket[prop:impersonator-of] property first check
+for the property on the immediate structure, and if it is not found,
+the value produced by the @racket[prop:impersonator-of] procedure is
+checked (recursively).
+
+@history[#:changed "6.1.1.8" @elem{Made @tech{impersonator property}
+                                   predicates and accessors sensitive
+                                   to @racket[prop:impersonator-of].}]}
 
 @; ------------------------------------------------------------
 @section{Chaperone Constructors}

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

@@ -299,6 +299,15 @@
                              (lambda (kws kw-args self . args)
                                (keyword-apply b kws kw-args args)))))
 
+(define (check-proc-prop f mk)
+  (let-values ([(prop:blue blue? blue-ref) (make-impersonator-property 'blue)])
+    (define f1 (chaperone-procedure f #f prop:blue "blue"))
+    (test #t blue? f1)
+    (test "blue" blue-ref f1)
+    (define f2 (mk f1))
+    (test #t blue? f2)
+    (test "blue" blue-ref f2)))
+
 ;; Single argument, no post filter:
 (as-chaperone-or-impersonator
  ([chaperone-procedure impersonate-procedure
@@ -306,15 +315,18 @@
                        impersonate-procedure**])
  (let* ([f (lambda (x) (list x x))]
         [in #f]
-        [f2 (chaperone-procedure 
+        [mk (lambda (f)
+              (chaperone-procedure 
                f 
                (lambda (x) 
                  (set! in x)
-               x))])
+                 x)))]
+        [f2 (mk f)])
    (test '(110 110) f 110)
    (test #f values in)
    (test '(111 111) f2 111)
-   (test 111 values in)))
+   (test 111 values in)
+   (check-proc-prop f mk)))
 
 ;; Multiple arguments, no post filter:
 (as-chaperone-or-impersonator
@@ -323,15 +335,18 @@
                        impersonate-procedure**])
  (let* ([f (lambda (x y) (list x y))]
         [in #f]
-        [f2 (chaperone-procedure 
+        [mk (lambda (f)
+              (chaperone-procedure 
                f 
                (lambda (x y) 
                  (set! in (vector x y))
-               (values x y)))])
+                 (values x y))))]
+        [f2 (mk f)])
    (test '(1100 1101) f 1100 1101)
    (test #f values in)
    (test '(1110 1111) f2 1110 1111)
-   (test (vector 1110 1111) values in)))
+   (test (vector 1110 1111) values in)
+   (check-proc-prop f mk)))
 
 ;; Single argument, post filter on single value:
 (as-chaperone-or-impersonator
@@ -341,20 +356,23 @@
  (let* ([f (lambda (x) (list x x))]
         [in #f]
         [out #f]
-        [f2 (chaperone-procedure 
+        [mk (lambda (f)
+              (chaperone-procedure 
                f 
                (lambda (x) 
                  (set! in x)
                  (values (lambda (y)
                            (set! out y)
                            y)
-                       x)))])
+                         x))))]
+        [f2 (mk f)])
    (test '(10 10) f 10)
    (test #f values in)
    (test #f values out)
    (test '(11 11) f2 11)
    (test 11 values in)
-   (test '(11 11) values out)))
+   (test '(11 11) values out)
+   (check-proc-prop f mk)))
 
 ;; Multiple arguments, post filter on multiple values:
 (as-chaperone-or-impersonator
@@ -364,20 +382,23 @@
  (let* ([f (lambda (x y z) (values y (list x z)))]
         [in #f]
         [out #f]
-        [f2 (chaperone-procedure 
+        [mk (lambda (f)
+              (chaperone-procedure 
                f 
                (lambda (x y z)
                  (set! in (vector x y z))
                  (values (lambda (y z)
                            (set! out (vector y z))
                            (values y z))
-                       x y z)))])
+                         x y z))))]
+        [f2 (mk f)])
    (test-values '(b (a c)) (lambda () (f 'a 'b 'c)))
    (test #f values in)
    (test #f values out)
    (test-values '(b (a c)) (lambda () (f2 'a 'b 'c)))
    (test (vector 'a 'b 'c) values in)
-   (test (vector 'b '(a c)) values out)))
+   (test (vector 'b '(a c)) values out)
+   (check-proc-prop f mk)))
 
 ;; Optional keyword arguments:
 (as-chaperone-or-impersonator
@@ -386,7 +407,8 @@
                        impersonate-procedure**/kw])
  (let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))]
         [in #f]
-        [f2 (chaperone-procedure
+        [mk (lambda (f)
+              (chaperone-procedure
                f
                (lambda (x #:a [a 'nope] #:b [b 'nope])
                  (if (and (eq? a 'nope) (eq? b 'nope))
@@ -395,7 +417,8 @@
                       (append 
                        (if (eq? a 'nope) null (list a))
                        (if (eq? b 'nope) null (list b)))
-                    x))))])
+                      x)))))]
+        [f2 (mk f)])
    (test '(1 a b) f 1)
    (test '(1 a b) f2 1)
    (test '(1 2 b) f 1 #:a 2)
@@ -406,7 +429,8 @@
    (test '(1 2 3) f2 1 #:a 2 #:b 3)
    (test 1 procedure-arity f2)
    (test 'f object-name f2)
-   (test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2)))))
+   (test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2)))
+   (check-proc-prop f mk)))
 
 ;; Optional keyword arguments with result chaperone:
 (as-chaperone-or-impersonator
@@ -416,7 +440,8 @@
  (let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))]
         [in #f]
         [out #f]
-        [f2 (chaperone-procedure
+        [mk (lambda (f)
+              (chaperone-procedure
                f
                (lambda (x #:a [a 'nope] #:b [b 'nope])
                  (set! in (list x a b))
@@ -427,7 +452,8 @@
                       (append 
                        (if (eq? a 'nope) null (list a))
                        (if (eq? b 'nope) null (list b)))
-                    x))))])
+                      x)))))]
+        [f2 (mk f)])
    (test '(1 a b) f 1)
    (test '(#f #f) list in out)
    (test '(1 a b) f2 1)
@@ -441,7 +467,8 @@
    (test '(1 2 3) f2 1 #:a 2 #:b 3)
    (test 1 procedure-arity f2)
    (test 'f object-name f2)
-   (test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2)))))
+   (test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2)))
+   (check-proc-prop f mk)))
 
 ;; Required keyword arguments:
 (as-chaperone-or-impersonator
@@ -450,7 +477,8 @@
                        impersonate-procedure**/kw])
  (let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))]
         [in #f]
-        [f2 (chaperone-procedure
+        [mk (lambda (f)
+              (chaperone-procedure
                f
                (lambda (x #:a [a 'nope] #:b [b 'nope])
                  (if (and (eq? a 'nope) (eq? b 'nope))
@@ -459,7 +487,8 @@
                       (append 
                        (if (eq? a 'nope) null (list a))
                        (if (eq? b 'nope) null (list b)))
-                    x))))])
+                      x)))))]
+        [f2 (mk f)])
    (err/rt-test (f 1))
    (err/rt-test (f2 1))
    (err/rt-test (f 1 #:a 2))
@@ -470,7 +499,8 @@
    (test '(1 2 3) f2 1 #:a 2 #:b 3)
    (test 1 procedure-arity f2)
    (test 'f object-name f2)
-   (test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2)))))
+   (test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2)))
+   (check-proc-prop f mk)))
 
 ;; Required keyword arguments:
 (as-chaperone-or-impersonator
@@ -480,7 +510,8 @@
  (let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))]
         [in #f]
         [out #f]
-        [f2 (chaperone-procedure
+        [mk (lambda (f)
+              (chaperone-procedure
                f
                (lambda (x #:a [a 'nope] #:b [b 'nope])
                  (set! in (list x a b))
@@ -491,7 +522,8 @@
                       (append 
                        (if (eq? a 'nope) null (list a))
                        (if (eq? b 'nope) null (list b)))
-                    x))))])
+                      x)))))]
+        [f2 (mk f)])
    (err/rt-test (f 1))
    (err/rt-test (f2 1))
    (err/rt-test (f 1 #:a 2))
@@ -503,7 +535,8 @@
    (test '(1 2 3) f2 1 #:a 2 #:b 3)
    (test 1 procedure-arity f2)
    (test 'f object-name f2)
-   (test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2)))))
+   (test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2)))
+   (check-proc-prop f mk)))
 
 (err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y))) 1))
 (err/rt-test ((impersonate-procedure (lambda (x) x) (lambda (y) (values y y))) 1))
@@ -1693,6 +1726,10 @@
 
     (test #t impersonator-of? (make-pre-a 17 1) (chaperone-struct (make-pre-a 17 1) pre-a-y #f prop:blue 'color))
     (test #f impersonator-of? (make-pre-a 17 1) (chaperone-struct a-pre-a pre-a-y #f prop:blue 'color))
+
+    (test #t blue? (make-a (chaperone-struct a1 struct:a prop:blue 'color) 2))
+    (test 'color blue-ref (make-a (chaperone-struct a1 struct:a prop:blue 'color) 2))
+    
     (void)))
 
 ;; ----------------------------------------

racket/collects/racket/private/kw.rkt

@@ -1708,6 +1708,8 @@
                               [(okp? n-proc)
                                (values
                                 (if is-impersonator?
+                                    ;; Can't use `impersonate-struct` here (due to the immutable field);
+                                    ;; create a new structure, but preserve properties
                                     ((if (okm? n-proc)
                                          make-optional-keyword-method-impersonator
                                          make-optional-keyword-procedure-impersonator)

racket/src/racket/src/bool.c

@@ -69,7 +69,6 @@ static int vector_equal (Scheme_Object *vec1, Scheme_Object *orig_vec1,
 static int struct_equal (Scheme_Object *s1, Scheme_Object *orig_s1, 
                          Scheme_Object *s2, Scheme_Object *orig_s2, 
                          Equal_Info *eql);
-static Scheme_Object *apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj);
 
 void scheme_init_true_false(void)
 {
@@ -699,13 +698,13 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
         else
           procs1 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st1);
         if (procs1)
-          procs1 = apply_impersonator_of(eql->for_chaperone, procs1, obj1);
+          procs1 = scheme_apply_impersonator_of(eql->for_chaperone, procs1, obj1);
         if (eql->for_chaperone)
           procs2 = NULL;
         else {
           procs2 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st2);
           if (procs2)
-            procs2 = apply_impersonator_of(eql->for_chaperone, procs2, obj2);
+            procs2 = scheme_apply_impersonator_of(eql->for_chaperone, procs2, obj2);
         }
 
         if (procs1 || procs2) {
@@ -997,7 +996,7 @@ int scheme_impersonator_of(Scheme_Object *obj1, Scheme_Object *obj2)
   return is_equal(obj1, obj2, &eql);
 }
 
-static Scheme_Object *apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj)
+Scheme_Object *scheme_apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj)
 {
   Scheme_Object *a[1], *v, *oprocs;
 

racket/src/racket/src/schpriv.h

@@ -1029,6 +1029,8 @@ Scheme_Object *scheme_chaperone_not_undefined(Scheme_Object *orig_val);
 
 int scheme_is_noninterposing_chaperone(Scheme_Object *obj);
 
+Scheme_Object *scheme_apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj);
+
 /*========================================================================*/
 /*                         syntax objects                                 */
 /*========================================================================*/

racket/src/racket/src/struct.c

@@ -1003,6 +1003,8 @@ static Scheme_Object *prop_pred(int argc, Scheme_Object **args, Scheme_Object *p
   Scheme_Chaperone *px;
 
   v = args[0];
+
+  while (1) {
     if (SCHEME_CHAPERONEP(v)) {
       /* Check for property at chaperone level: */
       px = (Scheme_Chaperone *)v;
@@ -1015,6 +1017,19 @@ static Scheme_Object *prop_pred(int argc, Scheme_Object **args, Scheme_Object *p
       v = px->val;
     }
 
+    if (SAME_TYPE(SCHEME_TYPE(prop), scheme_chaperone_property_type)) {
+      /* An impersonator property must be at the chaperone level, but can
+         be via `prop:impersonator-of`: */
+      Scheme_Object *procs;
+      procs = scheme_struct_type_property_ref(scheme_impersonator_of_property, v);
+      if (procs)
+        v = scheme_apply_impersonator_of(0, procs, v);
+      else
+        return scheme_false;
+    } else
+      break;
+  }
+
   if (SCHEME_STRUCTP(v))
     stype = ((Scheme_Structure *)v)->stype;
   else if (SAME_TYPE(SCHEME_TYPE(v), scheme_struct_type_type))
@@ -1158,18 +1173,31 @@ static Scheme_Object *do_chaperone_prop_accessor(const char *who, Scheme_Object
           return v;
         }
       }
+    } else {
+      if (SAME_TYPE(SCHEME_TYPE(prop), scheme_chaperone_property_type)) {
+        Scheme_Object *procs;
+        procs = scheme_struct_type_property_ref(scheme_impersonator_of_property, arg);
+        if (procs) {
+          arg = scheme_apply_impersonator_of(0, procs, arg);
+          /* loop to try again */
+        } else {
+          /* an impersonator property lives at the impersonator/chaperone level, only: */
+          return NULL;
+        }
       } else {
         return do_prop_accessor(prop, arg);
       }
     }
   }
+}
 
 static Scheme_Object *prop_accessor(int argc, Scheme_Object **args, Scheme_Object *prim)
 {
   Scheme_Object *v;
 
   v = args[0];
-  if (SCHEME_CHAPERONEP(v))
+  if (SCHEME_CHAPERONEP(v)
+      || SAME_TYPE(SCHEME_TYPE(SCHEME_PRIM_CLOSURE_ELS(prim)[0]), scheme_chaperone_property_type))
     v = do_chaperone_prop_accessor(((Scheme_Primitive_Proc *)prim)->name, SCHEME_PRIM_CLOSURE_ELS(prim)[0],
                                    v, v);
   else