Add chaperone contract-related properties.

* Flat contracts are chaperone contracts, and chaperone contracts
    are (proxy) contracts.
  * Check in chaperone contracts that a chaperone (or chaperone-friendly
    value) is indeed returned.

collects/racket/contract/private/guts.rkt

@@ -15,8 +15,12 @@
          coerce-contracts
          coerce-flat-contract
          coerce-flat-contracts
+         coerce-chaperone-contract
+         coerce-chaperone-contracts
          coerce-contract/f
          
+         chaperone-contract?
+         
          flat-contract?
          flat-contract
          flat-contract-predicate
@@ -104,6 +108,28 @@
                x))
       ctc)))
 
+;; coerce-chaperone-contract : symbol any/c -> contract
+(define (coerce-chaperone-contract name x)
+  (let ([ctc (coerce-contract/f x)])
+    (unless (chaperone-contract-struct? ctc)
+      (error name
+             "expected a chaperone contract or a value that can be coerced into one, got ~e"
+             x))
+    ctc))
+
+;; coerce-chaperone-contacts : symbol (listof any/c) -> (listof flat-contract)
+;; like coerce-contracts, but insists on chaperone-contracts
+(define (coerce-chaperone-contracts name xs)
+  (for/list ([x (in-list xs)]
+             [i (in-naturals)])
+    (let ([ctc (coerce-contract/f x)])
+      (unless (chaperone-contract-struct? ctc)
+        (error name
+               "expected all of the arguments to be chaperone contracts, but argument ~a was not, got ~e"
+               i
+               x))
+      ctc)))
+
 ;; coerce-contract : symbol any/c -> contract
 (define (coerce-contract name x)
   (or (coerce-contract/f x)
@@ -231,6 +257,11 @@
     (and c
          (flat-contract-struct? c))))
 
+(define (chaperone-contract? x)
+  (let ([c (coerce-contract/f x)])
+    (and c
+         (chaperone-contract-struct? c))))
+
 (define (contract-name ctc)
   (contract-struct-name
    (coerce-contract 'contract-name ctc)))

collects/racket/contract/private/prop.rkt

@@ -12,13 +12,20 @@
          prop:flat-contract
          flat-contract-struct?
          
+         prop:chaperone-contract
+         chaperone-contract-struct?
+
          contract-property?
          build-contract-property
          
+         chaperone-contract-property?
+         build-chaperone-contract-property
+
          flat-contract-property?
          build-flat-contract-property
 
          make-contract
+         make-chaperone-contract
          make-flat-contract)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -66,6 +73,39 @@
          [stronger (contract-property-stronger prop)])
     (stronger a b)))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Chaperone Contract Property
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-struct chaperone-contract-property [implementation]
+  #:omit-define-syntaxes)
+
+(define (chaperone-contract-property-guard prop info)
+  (unless (chaperone-contract-property? prop)
+    (raise
+     (make-exn:fail:contract
+      (format "~a: expected a chaperone contract property; got: ~e"
+              'prop:chaperone-contract
+              prop)
+      (current-continuation-marks))))
+  prop)
+
+;; We check to make sure the contract projection actually resulted in
+;; a chaperone (or chaperone-friendly) version of the value.
+(define (chaperone-contract-property->contract-property fc)
+  (let ([impl (chaperone-contract-property-implementation fc)])
+    impl))
+
+(define-values [ prop:chaperone-contract
+                 chaperone-contract-struct?
+                 chaperone-contract-struct-property ]
+  (make-struct-type-property
+   'prop:chaperone-contract
+   chaperone-contract-property-guard
+   (list (cons prop:contract chaperone-contract-property->contract-property))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;;  Flat Contract Property
@@ -85,8 +125,9 @@
       (current-continuation-marks))))
   prop)
 
-(define flat-contract-property->contract-property
+(define (flat-contract-property->chaperone-contract-property fc)
-  flat-contract-property-implementation)
+  (let ([impl (flat-contract-property-implementation fc)])
+    (make-chaperone-contract-property impl)))
 
 (define (flat-contract-property->procedure-property prop)
   (let* ([impl (flat-contract-property-implementation prop)]
@@ -99,7 +140,7 @@
   (make-struct-type-property
    'prop:flat-contract
    flat-contract-property-guard
-   (list (cons prop:contract flat-contract-property->contract-property)
+   (list (cons prop:chaperone-contract flat-contract-property->chaperone-contract-property)
          (cons prop:procedure flat-contract-property->procedure-property))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -143,6 +184,22 @@
                   'anonymous-flat-contract
                   flat-projection-wrapper))
 
+(define (chaperone-projection-wrapper f)
+  (λ (c)
+    (let ([proj (f c)])
+      (λ (b)
+        (let ([p (proj b)])
+          (λ (v)
+            (let ([v* (p v)])
+              (unless (chaperone-of? v* v)
+                (error "expected a chaperone of ~v, got ~v" v v*))
+              v*)))))))
+
+(define build-chaperone-contract-property
+  (build-property (compose make-chaperone-contract-property make-contract-property)
+                  'anonymous-chaperone-contract
+                  chaperone-projection-wrapper))
+
 (define (get-any? c) any?)
 (define (any? x) #t)
 
@@ -172,6 +229,16 @@
    #:stronger (lambda (a b) ((make-contract-stronger a) a b))
    #:generator #f))
 
+(define-struct make-chaperone-contract [ name first-order projection stronger ]
+  #:omit-define-syntaxes
+  #:property prop:chaperone-contract
+  (build-chaperone-contract-property
+   #:name (lambda (c) (make-chaperone-contract-name c))
+   #:first-order (lambda (c) (make-chaperone-contract-first-order c))
+   #:projection (lambda (c) (make-chaperone-contract-projection c))
+   #:stronger (lambda (a b) ((make-chaperone-contract-stronger a) a b))
+   #:generator #f))
+
 (define-struct make-flat-contract [ name first-order projection stronger ]
   #:omit-define-syntaxes
   #:property prop:flat-contract
@@ -203,5 +270,8 @@
 (define make-contract
   (build-contract make-make-contract 'anonymous-contract))
 
+(define make-chaperone-contract
+  (build-contract make-make-chaperone-contract 'anonymous-chaperone-contract))
+
 (define make-flat-contract
   (build-contract make-make-flat-contract 'anonymous-flat-contract))

collects/tests/racket/contract-test.rktl

@@ -3672,6 +3672,90 @@
   
   (ctest #t contract? proj:add1->sub1)
   (ctest #f flat-contract? proj:add1->sub1)
+  (ctest #f chaperone-contract? proj:add1->sub1)
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;;  make-chaperone-contract
+  ;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  
+  (contract-eval
+   '(define proj:prime-box-list/c
+      (let* ([prime? (λ (n)
+                       (for/and ([m (in-range 2 (add1 (floor (sqrt n))))])
+                         (not (= (remainder n m) 0))))]
+             [wrap-box (λ (blame b)
+                         (chaperone-box
+                          b
+                          (λ (b v)
+                            (unless (prime? v)
+                              (raise-blame-error blame v
+                                                 "expected prime, got ~v" v))
+                            v)
+                          (λ (b v)
+                            (unless (prime? v)
+                              (raise-blame-error (blame-swap blame) v
+                                                 "expected prime, got ~v" v))
+                            v)))])
+        (make-chaperone-contract
+         #:name 'prime-box-list/c
+         #:first-order (λ (v) (and (list? v) (andmap box? v)))
+         #:projection (λ (blame)
+                        (λ (v)
+                          (unless (and (list? v) (andmap box? v))
+                            (raise-blame-error blame v
+                                               "expected list of boxes, got ~v" v))
+                          (map (λ (b) (wrap-box blame b)) v)))))))
+  
+  (test/spec-passed/result
+   'make-chaperone-contract-1
+   '(contract proj:prime-box-list/c
+              (list (box 2) (box 3) (box 5) (box 7))
+              'pos 'neg)
+   (list (box 2) (box 3) (box 5) (box 7)))
+  
+  (test/pos-blame
+   'make-chaperone-contract-2
+   '(let ([boxes (contract proj:prime-box-list/c
+                           (list (box 2) (box 3) (box 4) (box 5))
+                           'pos 'neg)])
+      (unbox (caddr boxes))))
+  
+  (test/neg-blame
+   'make-chaperone-contract-3
+   '(let ([boxes (contract proj:prime-box-list/c
+                           (list (box 2) (box 3) (box 4) (box 5))
+                           'pos 'neg)])
+      (set-box! (caddr boxes) 6)))
+  
+  (ctest #t contract? proj:prime-box-list/c)
+  (ctest #f flat-contract? proj:prime-box-list/c)
+  (ctest #t chaperone-contract? proj:prime-box-list/c)
+  
+  (contract-eval
+   '(define proj:bad-prime-box-list/c
+      (let* ([prime? (λ (n)
+                       (for/and ([m (in-range 2 (add1 (floor (sqrt n))))])
+                         (not (= (remainder n m) 0))))]
+             [wrap-box (λ (blame b) (box (unbox b)))])
+        (make-chaperone-contract
+         #:name 'bad-prime-box-list/c
+         #:first-order (λ (v) (and (list? v) (andmap box? v)))
+         #:projection (λ (blame)
+                        (λ (v)
+                          (unless (and (list? v) (andmap box? v))
+                            (raise-blame-error blame v
+                                               "expected list of boxes, got ~v" v))
+                          (map (λ (b) (wrap-box blame b)) v)))))))
+  
+  (ctest #t contract? proj:bad-prime-box-list/c)
+  (ctest #f flat-contract? proj:bad-prime-box-list/c)
+  (ctest #t chaperone-contract? proj:bad-prime-box-list/c)
+  
+  (contract-error-test
+   '(contract proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg)
+   exn:fail?)
   
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;
@@ -3700,6 +3784,11 @@
   (ctest #t contract? proj:prime/c)
   (ctest #t flat-contract? proj:prime/c)
   
+  (test/spec-passed/result
+   'make-flat-contract-5
+   '(chaperone-contract? proj:prime/c)
+   #t)
+  
   ;; Check to make sure that flat contracts always return the original value,
   ;; even if the projection is written badly.
   (contract-eval
@@ -3734,6 +3823,11 @@
   (ctest #t contract? proj:prime-list/c)
   (ctest #t flat-contract? proj:prime-list/c)
   
+  (test/spec-passed/result
+   'make-flat-contract-bad-6
+   '(chaperone-contract? proj:prime-list/c)
+   #t)
+  
   
 ;                                                                                           
 ;