From d3b018b7cbcdb451aa67f7cefaeb276b6e0e4d1a Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@cs.indiana.edu>
Date: Wed, 11 Feb 2015 19:02:43 -0500
Subject: [PATCH] Re-do projections for struct fields in chaperone handlers.

If the selector is itself a chaperone, then doing the access once
will mean that the saved result is not `chaperone-of?` the result
of doing the access a second time, at least in some cases (such as
when the accessor uses vector contracts).

Thanks to Neil T for initial spotting, and to Robby for actually
finding the bug and suggesting the fix.
---
 .../tests/racket/contract/struct-dc.rkt       | 32 +++++++++++++++++
 .../racket/contract/private/struct-dc.rkt     | 34 ++++++++-----------
 2 files changed, 46 insertions(+), 20 deletions(-)

diff --git a/pkgs/racket-test/tests/racket/contract/struct-dc.rkt b/pkgs/racket-test/tests/racket/contract/struct-dc.rkt
index 9c62bae8ab..5da41f8604 100644
--- a/pkgs/racket-test/tests/racket/contract/struct-dc.rkt
+++ b/pkgs/racket-test/tests/racket/contract/struct-dc.rkt
@@ -178,6 +178,38 @@
      (and (exn:fail:contract:blame? x)
           (regexp-match #rx"promised: foo?" (exn-message x)))))
   
+  (test/spec-passed/result
+   'struct/c-contract-accessor
+   '(begin
+      (require (for-syntax racket/base))
+      (let ()
+        (struct d (vec))
+
+        (define dx-vec (contract (-> (struct/c d (vectorof any/c)) any) d-vec 'pos 'neg))
+        (define-syntax dx (list #'struct:d #'d #'d? (list #'dx-vec) (list #f) #f))
+
+        (struct gds dx ())
+        (define gd (contract (struct/c gds (vectorof any/c)) (gds (vector 1)) 'pos 'neg))
+        (vector-ref (d-vec gd) 0)))
+   1)
+  
+  (test/spec-passed
+   'struct/c-simple-contract-accessor 
+   '(let ()
+     (struct x (v))
+     
+     (define val1 (x (λ (e) e)))
+     (define val2
+       (chaperone-struct 
+        val1 x-v (λ (f v) (chaperone-procedure v (λ (a) a)))))
+     
+     (x-v (contract (struct/c x (any/c . -> . any/c)) val1 'y 'n))
+     (x-v (contract (struct/c x (any/c . -> . any/c)) val2 'y 'n))
+     (x-v (contract (struct/dc x [v (any/c . -> . any/c)]) val1 'y 'n))
+     (x-v (contract (struct/dc x [v (any/c . -> . any/c)]) val2 'y 'n))
+     (x-v (contract (struct/dc x [v () (any/c . -> . any/c)]) val1 'y 'n))
+     (x-v (contract (struct/dc x [v () (any/c . -> . any/c)]) val2 'y 'n))))
+  
   
   ;
   ;
diff --git a/racket/collects/racket/contract/private/struct-dc.rkt b/racket/collects/racket/contract/private/struct-dc.rkt
index 9c29bb2f8f..baa25818bb 100644
--- a/racket/collects/racket/contract/private/struct-dc.rkt
+++ b/racket/collects/racket/contract/private/struct-dc.rkt
@@ -349,15 +349,13 @@
                                                     (reverse (invariant-fields subcontract))))
                    (values chaperone-args impersonate-args)]
                   [(immutable? subcontract)
-                   (define projd
-                     (with-continuation-mark
-                      contract-continuation-mark-key blame
-                      (proj (sel v))))
+                   (define (chk fld v) (with-continuation-mark
+                                           contract-continuation-mark-key blame
+                                         (proj v)))
+                   (chk #f (sel v)) ;; check the field contract immediately
                    (values (if (flat-contract? (indep-ctc subcontract))
                                chaperone-args
-                               (list* sel
-                                      (λ (fld v) projd)
-                                      chaperone-args))
+                               (list* sel chk chaperone-args))
                            impersonate-args)]
                   [(lazy-immutable? subcontract)
                    (values (list* sel
@@ -397,15 +395,13 @@
                    (define proj (dep-ctc-blame-proj blame))
                    (cond
                      [(dep-immutable? subcontract)
-                      (define projd (proj (sel v)))
+                      (define (chk fld v) (with-continuation-mark
+                                              contract-continuation-mark-key blame
+                                            (proj v)))
+                      (chk #f (sel v)) ;; check the field contract immediately
                       (values (if (flat-contract? dep-ctc)
                                   chaperone-args
-                                  (list* sel
-                                         (λ (fld v)
-                                           (with-continuation-mark
-                                            contract-continuation-mark-key blame
-                                            projd))
-                                         chaperone-args))
+                                  (list* sel chk chaperone-args))
                               impersonate-args)]
                      [(dep-lazy-immutable? subcontract)
                       (values (list* sel
@@ -1350,12 +1346,10 @@
                                     (cache-λ (strct #,sub-val)
                                              #,this-body-code)])
                                proc-name)
-                           #`(let ([answer (let ([#,sub-val 
-                                                  (#,sel-id
-                                                   #,(opt/info-val opt/info))])
-                                             #,this-body-code)])
-                               (let ([proc-name (λ (strct fld) answer)])
-                                 proc-name))))))
+                           #`(let ([proc-name (λ (strct #,sub-val) #,this-body-code)])
+                               ;; check the field contract immediately
+                               (proc-name #f (#,sel-id #,(opt/info-val opt/info)))
+                               proc-name)))))
 
               (define this-fo-code 
                 (and (and (optres-flat this-optres)