suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add chaperone contract-related properties.

Browse Source 
* 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.
This commit is contained in:
Stevie Strickland 2010-09-07 18:15:09 -04:00
parent 56a5a2627e
commit ec0711bf49
3 changed files with 198 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/racket/contract/private/guts.rkt
View File

@ -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)))

76
collects/racket/contract/private/prop.rkt
View File

@ -11,14 +11,21 @@
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
flat-contract-property-implementation)
(define (flat-contract-property->chaperone-contract-property fc)
(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))

94
collects/tests/racket/contract-test.rktl
View File

@ -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)
;
;