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

Add instrumentation to set/c.

Browse Source
This commit is contained in:
Vincent St-Amour 2016-01-12 16:47:21 -06:00
parent a48b559324
commit 74c423bb24
2 changed files with 64 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -521,4 +521,39 @@
(eval '(async-channel-put c 3))
(eval '(async-channel-get c))))
(test/spec-passed
'contract-marks57
'(let ()
(eval '(require racket/generic))
(eval '(define-generics fooable (foo fooable)))
(eval '(struct s () #:methods gen:fooable [(define (foo x) x)]))
(eval '(foo (contract (generic-instance/c gen:fooable [foo (-> pos-blame? neg-blame?)])
(s) 'pos 'neg)))))
(test/spec-passed
'contract-marks58
'(let ()
(eval '(require racket/set))
(eval '(define s (contract (set/c pos-blame?) (set 1 2 3) 'pos 'neg)))
(eval '(set-add s 3))
(eval '(set-member? s 3))))
(test/spec-passed
'contract-marks59
'(let ()
(eval '(require racket/set))
(eval '(define s (contract (set/c pos-blame? #:lazy? #t #:kind 'mutable)
(mutable-set 1 2 3) 'pos 'neg)))
(eval '(set-add! s 3))
(eval '(set-member? s 3))))
(test/spec-passed
'contract-marks60
'(let ()
(eval '(require racket/set))
(eval '(define s (contract (set/c pos-blame? #:kind 'dont-care)
(list 1 2 3) 'pos 'neg)))
(eval '(set-add s 3))
(eval '(set-member? s 3))))
)

38
racket/collects/racket/set.rkt
View File

@ -198,6 +198,7 @@
(λ (val neg-party)
(set-contract-check cmp kind blame neg-party val)
(define (pos-interpose val ele) (late-neg-pos-proj ele neg-party))
(define blame+neg-party (cons blame neg-party))
(cond
[(set? val)
(chaperone-hash-set
@ -205,31 +206,44 @@
(λ (val ele) ele)
(λ (val ele) ele)
(λ (val ele) ele)
(λ (val ele) (late-neg-pos-proj ele neg-party))
(λ (val ele) (with-contract-continuation-mark
blame+neg-party
(late-neg-pos-proj ele neg-party)))
(λ (val) (void))
(λ (val ele) (late-neg-equal-key-pos-proj ele neg-party))
(λ (val ele) (with-contract-continuation-mark
blame+neg-party
(late-neg-equal-key-pos-proj ele neg-party)))
impersonator-prop:contracted ctc
impersonator-prop:blame (cons blame neg-party))]
[else
(chaperone-hash-set
val
(λ (val ele) ele)
(λ (val ele) (late-neg-neg-proj ele neg-party))
(λ (val ele) (with-contract-continuation-mark
blame+neg-party
(late-neg-neg-proj ele neg-party)))
(λ (val ele) ele)
(λ (val ele) (late-neg-pos-proj ele neg-party))
(λ (val ele) (with-contract-continuation-mark
blame+neg-party
(late-neg-pos-proj ele neg-party)))
(λ (val) (void))
(λ (val ele) (late-neg-equal-key-pos-proj ele neg-party))
(λ (val ele) (with-contract-continuation-mark
blame+neg-party
(late-neg-equal-key-pos-proj ele neg-party)))
impersonator-prop:contracted ctc
impersonator-prop:blame (cons blame neg-party))]))]
[else
(λ (val neg-party)
(define blame+neg-party (cons blame neg-party))
(set-contract-check cmp kind blame neg-party val)
(cond
[(set? val)
(chaperone-hash-set
(for/fold ([s (set-clear val)])
([e (in-set val)])
(set-add s (late-neg-pos-proj e neg-party)))
(set-add s (with-contract-continuation-mark
blame+neg-party
(late-neg-pos-proj e neg-party))))
#f #f #f
impersonator-prop:contracted ctc
impersonator-prop:blame (cons blame neg-party))]
@ -240,11 +254,17 @@
(chaperone-hash-set
val
(λ (val ele) ele)
(λ (val ele) (late-neg-neg-proj ele neg-party))
(λ (val ele) (with-contract-continuation-mark
blame+neg-party
(late-neg-neg-proj ele neg-party)))
(λ (val ele) ele)
(λ (val ele) (late-neg-pos-proj ele neg-party))
(λ (val ele) (with-contract-continuation-mark
blame+neg-party
(late-neg-pos-proj ele neg-party)))
(λ (val) (void))
(λ (val ele) (late-neg-equal-key-pos-proj ele neg-party))
(λ (val ele) (with-contract-continuation-mark
blame+neg-party
(late-neg-equal-key-pos-proj ele neg-party)))
impersonator-prop:contracted ctc
impersonator-prop:blame (cons blame neg-party))]))])))