add prop:proxy-of'; Fix chaperone-of' on keyword-accepting procedures

collects/racket/private/kw.rkt

@@ -27,10 +27,18 @@
   
   ;; ----------------------------------------
 
+  (define-values (prop:keyword-proxy keyword-proxy? keyword-proxy-ref) 
+    (make-struct-type-property 'keyword-proxy))
+  (define (keyword-procedure-proxy-of v)
+    (cond
+     [(keyword-proxy? v) ((keyword-proxy-ref v) v)]
+     [else #f]))
+
   (define-values (struct:keyword-procedure mk-kw-proc keyword-procedure?
                                            keyword-procedure-ref keyword-procedure-set!)
     (make-struct-type 'keyword-procedure #f 4 0 #f
-                      (list (cons prop:checked-procedure #t))
+                      (list (cons prop:checked-procedure #t)
+                            (cons prop:proxy-of keyword-procedure-proxy-of))
                       (current-inspector)
                       #f
                       '(0 1 2 3)))
@@ -123,12 +131,16 @@
   ;;  is used for each evaluation of a keyword lambda.)
   ;; The `procedure' property is a per-type method that has exactly
   ;;  the right arity, and that sends all arguments to `missing-kw'.
-  (define (make-required name fail-proc method?)
+  (define (make-required name fail-proc method? proxy?)
     (let-values ([(s: mk ? -ref -set!)
                   (make-struct-type (or name 'unknown)
-                                    (if method?
+                                    (if proxy?
-                                        struct:keyword-method
+                                        (if method?
-                                        struct:keyword-procedure)
+                                            struct:keyword-method-proxy
+                                            struct:keyword-procedure-proxy)
+                                        (if method?
+                                            struct:keyword-method
+                                            struct:keyword-procedure))
                                     0 0 #f
                                     (list (cons prop:arity-string 
                                                 generate-arity-string)
@@ -141,7 +153,30 @@
   (define-values (new-prop:procedure new-procedure? new-procedure-ref)
     (make-struct-type-property 'procedure #f
                                (list (cons prop:procedure values))))
+
   
+  ;; Proxies
+  (define-values (struct:keyword-procedure-proxy make-kpp keyword-procedure-proxy? kpp-ref kpp-set!)
+    (make-struct-type 'procedure
+                      struct:keyword-procedure
+                      1 0 #f
+                      (list (cons prop:keyword-proxy (lambda (v) (kpp-ref v 0))))))
+  (define-values (struct:keyword-method-proxy make-kmp keyword-method-proxy? kmp-ref kmp-set!)
+    (make-struct-type 'procedure
+                      struct:keyword-method
+                      1 0 #f
+                      (list (cons prop:keyword-proxy (lambda (v) (kmp-ref v 0))))))
+  (define-values (struct:okpp make-optional-keyword-procedure-proxy okpp? okpp-ref okpp-set!)
+    (make-struct-type 'procedure
+                      struct:okp
+                      1 0 #f
+                      (list (cons prop:keyword-proxy (lambda (v) (okpp-ref v 0))))))
+  (define-values (struct:okmp make-optional-keyword-method-proxy okmp? okmp-ref okmp-set!)
+    (make-struct-type 'procedure
+                      struct:okp
+                      1 0 #f
+                      (list (cons prop:keyword-proxy (lambda (v) (okmp-ref v 0))))))
+
   ;; ----------------------------------------
 
   (define make-keyword-procedure
@@ -487,7 +522,7 @@
                                                  [mk-id (with-syntax ([n (syntax-local-infer-name stx)]
                                                                       [call-fail (mk-kw-arity-stub)])
                                                           (syntax-local-lift-expression
-                                                           #'(make-required 'n call-fail method?)))])
+                                                           #'(make-required 'n call-fail method? #F)))])
                                      (syntax/loc stx
                                        (mk-id
                                         (lambda (given-kws given-argc)
@@ -1063,7 +1098,8 @@
                                  missing-kw
                                  (inc-arity arity 1))
                                 (or (okm? proc)
-                                    (keyword-method? proc)))
+                                    (keyword-method? proc))
+                                #f)
                  kw-checker
                  new-kw-proc
                  req-kw
@@ -1099,7 +1135,7 @@
                    ;; Constructor must be from `make-required', but not a method.
                    ;; Make a new variant that's a method:
                    (let* ([name+fail (keyword-procedure-name+fail proc)]
-                          [mk (make-required (car name+fail) (cdr name+fail) #t)])
+                          [mk (make-required (car name+fail) (cdr name+fail) #t #f)])
                      (mk
                       (keyword-procedure-checker proc)
                       (keyword-procedure-proc proc)
@@ -1129,7 +1165,7 @@
                   [else
                    ;; Constructor must be from `make-required':
                    (let* ([name+fail (keyword-procedure-name+fail proc)]
-                          [mk (make-required name (cdr name+fail) (keyword-method? proc))])
+                          [mk (make-required name (cdr name+fail) (keyword-method? proc) #f)])
                      (mk
                       (keyword-procedure-checker proc)
                       (keyword-procedure-proc proc)
@@ -1140,14 +1176,14 @@
   (define new:chaperone-procedure
     (let ([chaperone-procedure 
            (lambda (proc wrap-proc . props)
-             (do-chaperone-procedure #t chaperone-procedure 'chaperone-procedure proc wrap-proc props))])
+             (do-chaperone-procedure #f chaperone-procedure 'chaperone-procedure proc wrap-proc props))])
-      chaperone-procedure ))
+      chaperone-procedure))
 
   (define new:proxy-procedure
-    (let ([chaperone-procedure 
+    (let ([proxy-procedure 
            (lambda (proc wrap-proc . props)
-             (do-chaperone-procedure #f proxy-procedure 'proxy-procedure proc wrap-proc props))])
+             (do-chaperone-procedure #t proxy-procedure 'proxy-procedure proc wrap-proc props))])
-      chaperone-procedure ))
+      proxy-procedure))
 
   (define (do-chaperone-procedure is-proxy? chaperone-procedure name proc wrap-proc props)
     (if (or (not (keyword-procedure? proc))
@@ -1240,23 +1276,43 @@
                  [new-proc
                   (cond
                    [(okp? proc)
-                    (make-optional-keyword-procedure
+                    (if is-proxy?
-                     (keyword-procedure-checker proc)
+                        ((if (okm? proc)
-                     (chaperone-procedure (keyword-procedure-proc proc)
+                             make-optional-keyword-method-proxy
-                                          kw-chaperone)
+                             make-optional-keyword-procedure-proxy)
-                     (keyword-procedure-required proc)
+                         (keyword-procedure-checker proc)
-                     (keyword-procedure-allowed proc)
+                         (chaperone-procedure (keyword-procedure-proc proc)
-                     (chaperone-procedure (okp-ref proc 0)
+                                              kw-chaperone)
-                                          (okp-ref wrap-proc 0)))]
+                         (keyword-procedure-required proc)
+                         (keyword-procedure-allowed proc)
+                         (chaperone-procedure (okp-ref proc 0)
+                                              (okp-ref wrap-proc 0))
+                         proc)
+                        (chaperone-struct
+                         proc
+                         keyword-procedure-proc
+                         (lambda (self proc)
+                           (chaperone-procedure proc kw-chaperone))
+                         (make-struct-field-accessor okp-ref 0)
+                         (lambda (self proc)
+                           (chaperone-procedure proc
+                                                (okp-ref wrap-proc 0)))))]
                    [else
-                    ;; Constructor must be from `make-required':
+                    (if is-proxy?
-                    (let* ([name+fail (keyword-procedure-name+fail proc)]
+                        ;; Constructor must be from `make-required':
-                           [mk (make-required (car name+fail) (cdr name+fail) (keyword-method? proc))])
+                        (let* ([name+fail (keyword-procedure-name+fail proc)]
-                      (mk
+                               [mk (make-required (car name+fail) (cdr name+fail) (keyword-method? proc) #t)])
-                       (keyword-procedure-checker proc)
+                          (mk
-                       (chaperone-procedure (keyword-procedure-proc proc) kw-chaperone)
+                           (keyword-procedure-checker proc)
-                       (keyword-procedure-required proc)
+                           (chaperone-procedure (keyword-procedure-proc proc) kw-chaperone)
-                       (keyword-procedure-allowed proc)))])])
+                           (keyword-procedure-required proc)
+                           (keyword-procedure-allowed proc)
+                           proc))
+                        (chaperone-struct
+                         proc
+                         keyword-procedure-proc
+                         (lambda (self proc)
+                           (chaperone-procedure proc kw-chaperone))))])])
             (if (null? props)
                 new-proc
                 (apply chaperone-struct new-proc 

collects/scribblings/reference/booleans.scrbl

@@ -44,7 +44,7 @@ strings, byte strings, numbers, pairs, mutable pairs, vectors, boxes, hash
 tables, and inspectable structures. In the last five cases, equality
 is recursively defined; if both @scheme[v1] and @scheme[v2] contain
 reference cycles, they are equal when the infinite unfoldings of the
-values would be equal. See also @scheme[prop:equal+hash].
+values would be equal. See also @scheme[prop:equal+hash] and @racket[prop:proxy-of].
 
 @examples[
 (equal? 'yes 'yes)
@@ -183,7 +183,10 @@ transparent structures, @scheme[equal-hash-code] and
 values. For opaque structure types, @scheme[equal?] is the same as
 @scheme[eq?], and @scheme[equal-hash-code] and
 @scheme[equal-secondary-hash-code] results are based only on
-@scheme[eq-hash-code].
+@scheme[eq-hash-code]. If a structure has a @racket[prop:proxy-of]
+property, then the @racket[prop:proxy-of] property takes precedence over
+@racket[prop:equal+hash] if the property value's procedure returns a
+non-@racket[#f] value when applied to the structure.
 
 @examples[
 (define (farm=? farm1 farm2 recursive-equal?)

collects/scribblings/reference/chaperones.scrbl

@@ -88,7 +88,9 @@ be considered proxies of each other if they are @scheme[equal?].
 Otherwise, all proxies of @scheme[v2] must be intact in @scheme[v1],
 in the sense that parts of @scheme[v2] must be derived from
 @scheme[v1] through one of the proxy constructors (e.g.,
-@scheme[proxy-procedure] or @racket[chaperone-procedure]).}
+@scheme[proxy-procedure] or @racket[chaperone-procedure]).
+
+See also @racket[prop:proxy-of].}
 
 
 @defproc[(chaperone-of? [v1 any/c] [v2 any/c]) boolean?]{
@@ -301,6 +303,25 @@ Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
 to @scheme[proxy-hash] must be odd) add proxy properties
 or override proxy-property values of @scheme[hash].}
 
+
+@defthing[prop:proxy-of struct-type-property?]{
+
+A @tech{structure type property} (see @secref["structprops"]) that
+supplies a procedure for extracting a proxied value from a structure
+that represents a proxy. The property is used for @racket[proxy-of]
+as well as @racket[equal?].
+
+The property value must be a procedure of one argument, which is a
+structure whose structure type has the property. The result can be
+@scheme[#f] to indicate the structure does not represent a proxy,
+otherwise the result is a value for which the original structure is a
+proxy (so the original structure is a @racket[proxy-of?] and it is
+@racket[equal?] to the result value). The result value must have the
+same @racket[prop:proxy-of] and @racket[prop:equal+hash] property
+values as the original structure, and the property values must be
+inherited from the same structure type (which ensures some consistency
+between @racket[proxy-of?] and @racket[equal?]).}
+
 @; ------------------------------------------------------------
 @section{Chaperone Constructors}
 

collects/tests/racket/chaperone.rktl

@@ -1047,4 +1047,91 @@
 
 ;; ----------------------------------------
 
+(let ()
+  (define (a-proxy-of v) (a-x v))
+  (define a-equal+hash (list
+                        (lambda (v1 v2 equal?)
+                          (equal? (a-y v1) (a-y v2)))
+                        (lambda (v1 hash)
+                          (hash (a-y v1)))
+                        (lambda (v2 hash)
+                          (hash (a-y v2)))))
+  (define-struct a (x y)
+    #:property prop:proxy-of a-proxy-of
+    #:property prop:equal+hash a-equal+hash)
+  (define-struct (a-more a) (z))
+  (define-struct (a-new-proxy a) ()
+    #:property prop:proxy-of a-proxy-of)
+  (define-struct (a-new-equal a) ()
+    #:property prop:equal+hash a-equal+hash)
+
+  (let ([a1 (make-a #f 2)])
+    (test #t equal? (make-a #f 2) a1)
+    (test #t equal? (make-a-more #f 2 7) a1)
+    (test #t equal? (make-a-new-proxy #f 2) a1)
+    (test #f equal? (make-a-new-equal #f 2) a1)
+    (test #f equal? (make-a #f 3) a1)
+    (test #f proxy-of? (make-a #f 2) a1)
+    (test #t proxy-of? (make-a a1 3) a1)
+    (test #t proxy-of? (make-a-more a1 3 8) a1)
+    (test #f chaperone-of? (make-a a1 3) a1)
+    (test #t equal? (make-a a1 3) a1)
+    (test #t equal? (make-a-more a1 3 9) a1)
+    (err/rt-test (equal? (make-a 0 1) (make-a 0 1)))
+    (err/rt-test (proxy-of? (make-a-new-proxy a1 1) a1))
+    (err/rt-test (proxy-of? (make-a-new-equal a1 1) a1))
+    (err/rt-test (equal? (make-a-new-equal a1 1) a1))
+    (void)))
+
+;; ----------------------------------------
+
+(let ()
+  (define f1 (λ (k) k))
+  (define f2 (λ (#:key k) k))
+  (define f3 (λ (#:key [k 0]) k))
+  (define wrapper
+    (make-keyword-procedure
+     (λ (kwds kwd-args . args)
+        (apply values kwd-args args))
+     (λ args (apply values args))))
+  
+  (define g1 (chaperone-procedure f1 wrapper))
+  (define g2 (chaperone-procedure f2 wrapper))
+  (define g3 (chaperone-procedure f2 wrapper))
+  (define h1 (proxy-procedure f1 wrapper))
+  (define h2 (proxy-procedure f2 wrapper))
+  (define h3 (proxy-procedure f2 wrapper))
+
+  (test #t chaperone-of? g1 f1)
+  (test #t chaperone-of? g2 f2)
+  (test #t chaperone-of? g3 f2)
+  (test #f chaperone-of? g3 g2)
+
+  (test #t equal? g1 f1)
+  (test #t equal? g2 f2)
+  (test #t equal? g3 f2)
+  (test #t equal? g3 g2)
+
+  (test #t proxy-of? h1 f1)
+  (test #t proxy-of? h2 f2)
+  (test #t proxy-of? h3 f2)
+  (test #f proxy-of? h3 h2)
+
+  (test #t equal? h1 f1)
+  (test #t equal? h2 f2)
+  (test #t equal? h3 f2)
+  (test #t equal? h3 h2)
+
+  (test #t equal? h1 g1)
+  (test #t equal? h2 g2)
+  (test #t equal? h3 g3)
+  (test #t equal? h3 g2)
+
+  (test #f equal? h1 f3)
+  (test #f equal? h2 f1)
+  (test #f equal? h3 f1))
+  
+
+;; ----------------------------------------
+
 (report-errs)

doc/release-notes/racket/HISTORY.txt

@@ -1,3 +1,6 @@
+Version 5.0.1.6
+Added prop:proxy-of
+
 Version 5.0.1.5
 Added proxies to go with chaperones, and renamed chaperone property
  as proxy property

src/racket/src/bool.c

@@ -63,6 +63,7 @@ typedef struct Equal_Info {
 static int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql);
 static int vector_equal (Scheme_Object *vec1, Scheme_Object *vec2, Equal_Info *eql);
 static int struct_equal (Scheme_Object *s1, Scheme_Object *s2, Equal_Info *eql);
+static Scheme_Object *apply_proxy_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj);
 
 void scheme_init_true_false(void)
 {
@@ -470,71 +471,92 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
     st1 = SCHEME_STRUCT_TYPE(obj1);
     st2 = SCHEME_STRUCT_TYPE(obj2);
 
-    if (eql->for_chaperone) {
+    if (eql->for_chaperone == 1)
       procs1 = NULL;
-    } else {
+    else
-      procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1);
+      procs1 = scheme_struct_type_property_ref(scheme_proxy_of_property, (Scheme_Object *)st1);
-      if (procs1 && (st1 != st2)) {
+    if (procs1)
-        procs2 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st2);
+      procs1 = apply_proxy_of(eql->for_chaperone, procs1, obj1);
-        if (!procs2
+    if (eql->for_chaperone)
-            || !SAME_OBJ(SCHEME_VEC_ELS(procs1)[0], SCHEME_VEC_ELS(procs2)[0]))
+      procs2 = NULL;
-          procs1 = NULL;
+    else {
-      }
+      procs2 = scheme_struct_type_property_ref(scheme_proxy_of_property, (Scheme_Object *)st2);
+      if (procs2)
+        procs2 = apply_proxy_of(eql->for_chaperone, procs2, obj2);
     }
 
-    if (procs1) {
+    if (procs1 || procs2) {
-      /* Has an equality property: */
+      /* proxy-of property trumps other forms of checking */
-      Scheme_Object *a[3], *recur;
+      if (procs1) obj1 = procs1;
-      Equal_Info *eql2;
+      if (procs2) obj2 = procs2;
+      goto top;
+    } else {
+      if (eql->for_chaperone) {
+        procs1 = NULL;
+      } else {
+        procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1);
+        if (procs1 && (st1 != st2)) {
+          procs2 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st2);
+          if (!procs2
+              || !SAME_OBJ(SCHEME_VEC_ELS(procs1)[0], SCHEME_VEC_ELS(procs2)[0]))
+            procs1 = NULL;
+        }
+      }
+
+      if (procs1) {
+        /* Has an equality property: */
+        Scheme_Object *a[3], *recur;
+        Equal_Info *eql2;
 #     include "mzeqchk.inc"
 
-      if (union_check(obj1, obj2, eql))
-        return 1;
-
-      /* Create/cache closure to use for recursive equality checks: */
-      if (eql->recur) {
-        recur = eql->recur;
-        eql2 = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(recur)[0];
-      } else {
-        eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info));
-        a[0] = (Scheme_Object *)eql2;
-        recur = scheme_make_prim_closure_w_arity(equal_recur,
-                                                 1, a,
-                                                 "equal?/recur",
-                                                 2, 2);
-        eql->recur = recur;
-      }
-      memcpy(eql2, eql, sizeof(Equal_Info));
-
-      a[0] = obj1;
-      a[1] = obj2;
-      a[2] = recur;
-
-      procs1 = SCHEME_VEC_ELS(procs1)[1];
-
-      recur = _scheme_apply(procs1, 3, a);
-
-      memcpy(eql, eql2, sizeof(Equal_Info));
-
-      return SCHEME_TRUEP(recur);
-    } else if (st1 != st2) {
-      return 0;
-    } else if ((eql->for_chaperone == 1)
-               && !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
-      return 0;
-    } else {
-      /* Same types, but doesn't have an equality property
-         (or checking for chaperone), so check transparency: */
-      Scheme_Object *insp;
-      insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
-      if (scheme_inspector_sees_part(obj1, insp, -2)
-	  && scheme_inspector_sees_part(obj2, insp, -2)) {
-#       include "mzeqchk.inc"
         if (union_check(obj1, obj2, eql))
           return 1;
-	return struct_equal(obj1, obj2, eql);
+
-      } else
+        /* Create/cache closure to use for recursive equality checks: */
-	return 0;
+        if (eql->recur) {
+          recur = eql->recur;
+          eql2 = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(recur)[0];
+        } else {
+          eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info));
+          a[0] = (Scheme_Object *)eql2;
+          recur = scheme_make_prim_closure_w_arity(equal_recur,
+                                                   1, a,
+                                                   "equal?/recur",
+                                                   2, 2);
+          eql->recur = recur;
+        }
+        memcpy(eql2, eql, sizeof(Equal_Info));
+
+        a[0] = obj1;
+        a[1] = obj2;
+        a[2] = recur;
+
+        procs1 = SCHEME_VEC_ELS(procs1)[1];
+
+        recur = _scheme_apply(procs1, 3, a);
+
+        memcpy(eql, eql2, sizeof(Equal_Info));
+
+        return SCHEME_TRUEP(recur);
+      } else if (st1 != st2) {
+        return 0;
+      } else if ((eql->for_chaperone == 1)
+                 && !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
+        return 0;
+      } else {
+        /* Same types, but doesn't have an equality property
+           (or checking for chaperone), so check transparency: */
+        Scheme_Object *insp;
+        insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
+        if (scheme_inspector_sees_part(obj1, insp, -2)
+            && scheme_inspector_sees_part(obj2, insp, -2)) {
+#       include "mzeqchk.inc"
+          if (union_check(obj1, obj2, eql))
+            return 1;
+          return struct_equal(obj1, obj2, eql);
+        } else
+          return 0;
+      }
     }
   } else if (SCHEME_BOXP(obj1)) {
     SCHEME_USE_FUEL(1);
@@ -689,3 +711,31 @@ int scheme_proxy_of(Scheme_Object *obj1, Scheme_Object *obj2)
 
   return is_equal(obj1, obj2, &eql);
 }
+
+static Scheme_Object *apply_proxy_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj)
+{
+  Scheme_Object *a[1], *v, *oprocs;
+
+  a[0] = obj;
+  v = _scheme_apply(SCHEME_CDR(procs), 1, a);
+  
+  if (SCHEME_FALSEP(v))
+    return NULL;
+  
+  oprocs = scheme_struct_type_property_ref(scheme_proxy_of_property, v);  
+  if (!oprocs || !SAME_OBJ(SCHEME_CAR(oprocs), SCHEME_CAR(procs)))
+    scheme_arg_mismatch((for_chaperone ? "proxy-of?" : "equal?"),
+                        "proxy-of property procedure returned a value with a different prop:proxy-of source: ",
+                        v);
+
+  procs = scheme_struct_type_property_ref(scheme_equal_property, obj);
+  oprocs = scheme_struct_type_property_ref(scheme_equal_property, v);  
+  if (procs || oprocs)
+    if (!procs || !oprocs || !SAME_OBJ(SCHEME_VEC_ELS(oprocs)[0], 
+                                       SCHEME_VEC_ELS(procs)[0]))
+      scheme_arg_mismatch((for_chaperone ? "proxy-of?" : "equal?"),
+                          "proxy-of property procedure returned a value with a different prop:equal+hash source: ",
+                          v);
+
+  return v;
+}

src/racket/src/eval.c

@@ -9494,61 +9494,113 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
       UPDATE_THREAD_RSPTR();
       scheme_escape_to_continuation(obj, num_rands, rands, NULL);
       return NULL;
-    } else if (type == scheme_proc_struct_type) {
+    } else if ((type == scheme_proc_struct_type)
+               || ((type == scheme_proc_chaperone_type)
+                   /* Chaperone is for struct fields, not function arguments --- but
+                      the chaperone may guard access to the function as a field inside
+                      the struct. We'll need to keep track of the original object
+                      as we unwrap to discover procedure chaperones. */
+                   && (SCHEME_VECTORP(((Scheme_Chaperone *)obj)->redirects)))
+               /* A raw pair is from scheme_apply_chaperone(), propagating the
+                  original object for an applicable structure. */
+               || (type == scheme_raw_pair_type)) {
       int is_method;
       int check_rands = num_rands;
+      Scheme_Object *orig_obj;
 
-      do {
+      if (SCHEME_RPAIRP(obj)) {
-        VACATE_TAIL_BUFFER_USE_RUNSTACK();
+        orig_obj = SCHEME_CDR(obj);
+        obj = SCHEME_CAR(obj);
+      } else {
+        orig_obj = obj;
+      }
 
-        UPDATE_THREAD_RSPTR_FOR_ERROR(); /* in case */
+      while (1) {
+        /* Like the apply loop around this one, but we need
+           to keep track of orig_obj until we get down to the
+           structure. */
 
-        v = obj;
+        type = SCHEME_TYPE(obj);
-        obj = scheme_extract_struct_procedure(obj, check_rands, rands, &is_method);
+        if (type == scheme_proc_struct_type) {
-        if (is_method) {
+          do {
-          /* Have to add an extra argument to the front of rands */
+            VACATE_TAIL_BUFFER_USE_RUNSTACK();
-          if ((rands == RUNSTACK) && (RUNSTACK != RUNSTACK_START)){
-            /* Common case: we can just push self onto the front: */
-            rands = PUSH_RUNSTACK(p, RUNSTACK, 1);
-            rands[0] = v;
-          } else {
-            int i;
-            Scheme_Object **a;
 
-            if (p->tail_buffer && (num_rands < p->tail_buffer_size)) {
+            UPDATE_THREAD_RSPTR_FOR_ERROR(); /* in case */
-              /* Use tail-call buffer. Shift in such a way that this works if
+
-                 rands == p->tail_buffer */
+            v = obj;
-              a = p->tail_buffer;
+            obj = scheme_extract_struct_procedure(orig_obj, check_rands, rands, &is_method);
+            if (is_method) {
+              /* Have to add an extra argument to the front of rands */
+              if ((rands == RUNSTACK) && (RUNSTACK != RUNSTACK_START)){
+                /* Common case: we can just push self onto the front: */
+                rands = PUSH_RUNSTACK(p, RUNSTACK, 1);
+                rands[0] = v;
+              } else {
+                int i;
+                Scheme_Object **a;
+
+                if (p->tail_buffer && (num_rands < p->tail_buffer_size)) {
+                  /* Use tail-call buffer. Shift in such a way that this works if
+                     rands == p->tail_buffer */
+                  a = p->tail_buffer;
+                } else {
+                  /* Uncommon general case --- allocate an array */
+                  UPDATE_THREAD_RSPTR_FOR_GC();
+                  a = MALLOC_N(Scheme_Object *, num_rands + 1);
+                }
+
+                for (i = num_rands; i--; ) {
+                  a[i + 1] = rands[i];
+                }
+                a[0] = v;
+                rands = a;
+              }
+              num_rands++;
+            }
+
+            /* After we check arity once, no need to check again
+               (which would lead to O(n^2) checking for nested
+               struct procs): */
+            check_rands = -1;
+
+            DO_CHECK_FOR_BREAK(p, UPDATE_THREAD_RSPTR_FOR_GC(); if (rands == p->tail_buffer) make_tail_buffer_safe(););
+
+            break;
+          } while (SAME_TYPE(scheme_proc_struct_type, SCHEME_TYPE(obj)));
+
+          goto apply_top;
+        } else {
+          if (SCHEME_VECTORP(((Scheme_Chaperone *)obj)->redirects))
+            obj = ((Scheme_Chaperone *)obj)->prev;
+          else if (SAME_TYPE(SCHEME_TYPE(((Scheme_Chaperone *)obj)->redirects), scheme_nack_guard_evt_type))
+            /* Chaperone is for evt, not function arguments */
+            obj = ((Scheme_Chaperone *)obj)->prev;
+          else {
+            /* Chaperone is for function arguments */
+            VACATE_TAIL_BUFFER_USE_RUNSTACK();
+            UPDATE_THREAD_RSPTR();
+            v = scheme_apply_chaperone(scheme_make_raw_pair(obj, orig_obj), num_rands, rands, NULL);
+            
+            if (SAME_OBJ(v, SCHEME_TAIL_CALL_WAITING)) {
+              /* Need to stay in this loop, because a tail-call result must
+                 be a tail call to an unwrapped layer, so we'll eventually
+                 need to use orig_obj. */
+              obj = p->ku.apply.tail_rator;
+              num_rands = p->ku.apply.tail_num_rands;
+              if (check_rands != -1) check_rands = num_rands;
+              rands = p->ku.apply.tail_rands;
+              p->ku.apply.tail_rator = NULL;
+              p->ku.apply.tail_rands = NULL;
+              RUNSTACK = old_runstack;
+              RUNSTACK_CHANGED();
             } else {
-              /* Uncommon general case --- allocate an array */
+              break;
-              UPDATE_THREAD_RSPTR_FOR_GC();
-              a = MALLOC_N(Scheme_Object *, num_rands + 1);
             }
-
-            for (i = num_rands; i--; ) {
-              a[i + 1] = rands[i];
-            }
-            a[0] = v;
-            rands = a;
           }
-          num_rands++;
         }
-
+      }
-        /* After we check arity once, no need to check again
-           (which would lead to O(n^2) checking for nested
-           struct procs): */
-        check_rands = -1;
-
-        DO_CHECK_FOR_BREAK(p, UPDATE_THREAD_RSPTR_FOR_GC(); if (rands == p->tail_buffer) make_tail_buffer_safe(););
-      } while (SAME_TYPE(scheme_proc_struct_type, SCHEME_TYPE(obj)));
-
-      goto apply_top;
     } else if (type == scheme_proc_chaperone_type) {
-      if (SCHEME_VECTORP(((Scheme_Chaperone *)obj)->redirects)) {
+      if (SAME_TYPE(SCHEME_TYPE(((Scheme_Chaperone *)obj)->redirects), scheme_nack_guard_evt_type)) {
-        /* Chaperone is for struct fields, not function arguments */
-        obj = ((Scheme_Chaperone *)obj)->prev;
-        goto apply_top;
-      } else if (SAME_TYPE(SCHEME_TYPE(((Scheme_Chaperone *)obj)->redirects), scheme_nack_guard_evt_type)) {
         /* Chaperone is for evt, not function arguments */
         obj = ((Scheme_Chaperone *)obj)->prev;
         goto apply_top;

src/racket/src/fun.c

@@ -4173,8 +4173,8 @@ static Scheme_Object *do_apply_chaperone(Scheme_Object *o, int argc, Scheme_Obje
 Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val)
 {
   const char *what;
-  Scheme_Chaperone *px = (Scheme_Chaperone *)o;
+  Scheme_Chaperone *px;
-  Scheme_Object *v, *a[1], *a2[3], **argv2, *post, *result_v;
+  Scheme_Object *v, *a[1], *a2[3], **argv2, *post, *result_v, *orig_obj;
   int c, i, need_restore = 0;
 
   if (argv == MZ_RUNSTACK) {
@@ -4192,6 +4192,18 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
     }
   }
 
+  if (SCHEME_RPAIRP(o)) {
+    /* An applicable struct, where a layout of struct chaperones
+       has been removed from the object to apply, but we will
+       eventually need to extract the procedure from the original
+       object. */
+    orig_obj = SCHEME_CDR(o);
+    o = SCHEME_CAR(o);
+  } else {
+    orig_obj = NULL;
+  }
+  px = (Scheme_Chaperone *)o;
+
   if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
     what = "chaperone";
   else
@@ -4272,7 +4284,12 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
       else
         return argv2[0];
     } else {
-      return scheme_tail_apply(px->prev, c, argv2);
+      if (orig_obj)
+        /* A raw pair tells apply to extract a procedure from orig_obj */
+        orig_obj = scheme_make_raw_pair(px->prev, orig_obj);
+      else
+        orig_obj = px->prev;
+      return scheme_tail_apply(orig_obj, c, argv2);
     }
   } else {
     /* First element is a filter for the result(s) */
@@ -4289,7 +4306,12 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
         result_v = argv2[0];
       v = auto_val;
     } else {
-      v = _scheme_apply_multi(px->prev, argc, argv2);
+      if (orig_obj)
+        /* A raw pair tells apply to extract a procedure from orig_obj */
+        orig_obj = scheme_make_raw_pair(px->prev, orig_obj);
+      else
+        orig_obj = px->prev;
+      v = _scheme_apply_multi(orig_obj, argc, argv2);
       result_v = NULL;
     }
     if (v == SCHEME_MULTIPLE_VALUES) {

src/racket/src/schminc.h

@@ -13,7 +13,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1010
+#define EXPECTED_PRIM_COUNT 1011
 #define EXPECTED_UNSAFE_COUNT 69
 #define EXPECTED_FLFXNUM_COUNT 60
 #define EXPECTED_FUTURES_COUNT 5

src/racket/src/schpriv.h

@@ -384,6 +384,7 @@ THREAD_LOCAL_DECL(extern Scheme_Object *scheme_system_idle_channel);
 extern Scheme_Object *scheme_input_port_property, *scheme_output_port_property;
 
 extern Scheme_Object *scheme_equal_property;
+extern Scheme_Object *scheme_proxy_of_property;
 
 extern Scheme_Object *scheme_reduced_procedure_struct;
 

src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.0.1.5"
+#define MZSCHEME_VERSION "5.0.1.6"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 0
 #define MZSCHEME_VERSION_Z 1
-#define MZSCHEME_VERSION_W 5
+#define MZSCHEME_VERSION_W 6
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

src/racket/src/struct.c

@@ -32,6 +32,7 @@ READ_ONLY Scheme_Object *scheme_source_property;
 READ_ONLY Scheme_Object *scheme_input_port_property;
 READ_ONLY Scheme_Object *scheme_output_port_property;
 READ_ONLY Scheme_Object *scheme_equal_property;
+READ_ONLY Scheme_Object *scheme_proxy_of_property;
 READ_ONLY Scheme_Object *scheme_make_struct_type_proc;
 READ_ONLY Scheme_Object *scheme_current_inspector_proc;
 READ_ONLY Scheme_Object *scheme_recur_symbol;
@@ -87,6 +88,7 @@ static Scheme_Object *struct_type_property_p(int argc, Scheme_Object *argv[]);
 static Scheme_Object *chaperone_property_p(int argc, Scheme_Object *argv[]);
 static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[]);
 static Scheme_Object *check_equal_property_value_ok(int argc, Scheme_Object *argv[]);
+static Scheme_Object *check_proxy_of_property_value_ok(int argc, Scheme_Object *argv[]);
 static Scheme_Object *check_write_property_value_ok(int argc, Scheme_Object *argv[]);
 static Scheme_Object *check_print_attribute_property_value_ok(int argc, Scheme_Object *argv[]);
 static Scheme_Object *check_input_port_property_value_ok(int argc, Scheme_Object *argv[]);
@@ -345,6 +347,16 @@ scheme_init_struct (Scheme_Env *env)
     scheme_add_global_constant("prop:equal+hash", scheme_equal_property, env);
   }
 
+  {
+    guard = scheme_make_prim_w_arity(check_proxy_of_property_value_ok,
+				     "guard-for-prop:proxy-of",
+				     2, 2);
+    REGISTER_SO(scheme_proxy_of_property);
+    scheme_proxy_of_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("proxy-of"),
+                                                                        guard);
+    scheme_add_global_constant("prop:proxy-of", scheme_proxy_of_property, env);
+  }
+
   {
     REGISTER_SO(scheme_input_port_property);
     REGISTER_SO(scheme_output_port_property);
@@ -1490,6 +1502,25 @@ static Scheme_Object *check_equal_property_value_ok(int argc, Scheme_Object *arg
   return v;
 }
 
+static Scheme_Object *check_proxy_of_property_value_ok(int argc, Scheme_Object *argv[])
+{
+  /* This is the guard for prop:proxy-of */
+  Scheme_Object *v;
+
+  v = argv[0];
+
+  if (!scheme_check_proc_arity(NULL, 1, 0, argc, argv)) {
+    scheme_arg_mismatch("guard-for-prop:proxy-of",
+			"not a procedure of arity 1: ",
+			v); 
+  }
+
+  /* Add a tag to track origin of the proxy-of property: */
+  v = scheme_make_pair(scheme_make_symbol("tag"), v);
+
+  return v;
+}
+
 /*========================================================================*/
 /*                          writeable structs                             */
 /*========================================================================*/
@@ -4821,15 +4852,24 @@ Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_coun
 Scheme_Object *scheme_extract_struct_procedure(Scheme_Object *obj, int num_rands, Scheme_Object **rands, int *is_method)
 {
   Scheme_Struct_Type *stype;
-  Scheme_Object *a, *proc;
+  Scheme_Object *plain_obj, *a, *proc;
   int meth_wrap = 0;
 
-  stype = ((Scheme_Structure *)obj)->stype;
+  if (SCHEME_CHAPERONEP(obj))
+    plain_obj = SCHEME_CHAPERONE_VAL(obj);
+  else
+    plain_obj = obj;
+
+  stype = ((Scheme_Structure *)plain_obj)->stype;
   a = stype->proc_attr;
 
   if (SCHEME_INTP(a)) {
     *is_method = 0;
-    proc = ((Scheme_Structure *)obj)->slots[SCHEME_INT_VAL(a)];
+    if (!SAME_OBJ(plain_obj, obj)) {
+      proc = chaperone_struct_ref("struct-ref", obj, SCHEME_INT_VAL(a));
+    } else {
+      proc = ((Scheme_Structure *)obj)->slots[SCHEME_INT_VAL(a)];
+    }
   } else {
     *is_method = 1;
     proc = a;
@@ -4843,7 +4883,7 @@ Scheme_Object *scheme_extract_struct_procedure(Scheme_Object *obj, int num_rands
        * account for that.
        */
       if (scheme_reduced_procedure_struct
-	  && scheme_is_struct_instance(scheme_reduced_procedure_struct, obj))
+	  && scheme_is_struct_instance(scheme_reduced_procedure_struct, plain_obj))
 	meth_wrap = SCHEME_TRUEP(((Scheme_Structure *)obj)->slots[3]);
 
       scheme_wrong_count_m((char *)obj,