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

Add instrumentation for box contracts.

Browse Source
This commit is contained in:
Vincent St-Amour 2016-01-05 14:52:18 -06:00
parent 379a3dd110
commit 9b7724167a
2 changed files with 20 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
pkgs/racket-test/tests/racket/contract/prof.rkt
View File

@ -210,4 +210,14 @@
'(let () '(let ()
((contract (case-> (-> neg-blame? any/c)) ((contract (case-> (-> neg-blame? any/c))
(λ (x) x) 'pos 'neg) (λ (x) x) 'pos 'neg)
1)))) 1)))
(test/spec-passed
'provide/contract23
'(unbox (contract (box/c neg-blame?) (box 1) 'pos 'neg)))
(test/spec-passed
'provide/contract24
'(set-box! (contract (box/c neg-blame?) (box 1) 'pos 'neg) 2))
)

11
racket/collects/racket/contract/private/box.rkt
View File

@ -141,6 +141,7 @@
(define pos-elem-r-proj (r-vfp box-blame)) (define pos-elem-r-proj (r-vfp box-blame))
(define neg-elem-w-proj (w-vfp (blame-swap box-blame))) (define neg-elem-w-proj (w-vfp (blame-swap box-blame)))
(λ (val neg-party) (λ (val neg-party)
(define blame+neg-party (cons blame neg-party))
(cond (cond
[(check-box/c-np ctc val blame) [(check-box/c-np ctc val blame)
=> =>
@ -150,8 +151,14 @@
(box-immutable (pos-elem-r-proj (unbox val) neg-party)) (box-immutable (pos-elem-r-proj (unbox val) neg-party))
(chaperone/impersonate-box (chaperone/impersonate-box
val val
(λ (b v) (pos-elem-r-proj v neg-party)) (λ (b v)
(λ (b v) (neg-elem-w-proj v neg-party)) (with-contract-continuation-mark
blame+neg-party
(pos-elem-r-proj v neg-party)))
(λ (b v)
(with-contract-continuation-mark
blame+neg-party
(neg-elem-w-proj v neg-party)))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party blame neg-party)))]))))) impersonator-prop:blame (blame-add-missing-party blame neg-party)))])))))