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

Instrument higher-order hash/c.

Browse Source
This commit is contained in:
Vincent St-Amour 2016-01-08 14:58:03 -06:00
parent d34cd06b90
commit 72418fba03
2 changed files with 27 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -276,4 +276,14 @@
(eval '(f 2))) (eval '(f 2)))
3) 3)
(test/spec-passed/result
'contract-marks31
'((hash-ref (contract (hash/c (-> neg-blame? pos-blame?)
(-> neg-blame? pos-blame?))
(hash values values)
'pos 'neg)
values)
3)
3)
) )

23
racket/collects/racket/contract/private/hash.rkt
View File

@ -234,6 +234,7 @@
(define (handle-the-hash val neg-party (define (handle-the-hash val neg-party
pos-dom-proj neg-dom-proj mk-pos-rng-proj mk-neg-rng-proj pos-dom-proj neg-dom-proj mk-pos-rng-proj mk-neg-rng-proj
chaperone-or-impersonate-hash ctc blame) chaperone-or-impersonate-hash ctc blame)
(define blame+neg-party (cons blame neg-party))
(if (immutable? val) (if (immutable? val)
(for/fold ([h val]) ([(k v) (in-hash val)]) (for/fold ([h val]) ([(k v) (in-hash val)])
(hash-set h (hash-set h
@ -242,16 +243,26 @@
(chaperone-or-impersonate-hash (chaperone-or-impersonate-hash
val val
(λ (h k) (λ (h k)
(values (neg-dom-proj k neg-party) (values (with-contract-continuation-mark
blame+neg-party
(neg-dom-proj k neg-party))
(λ (h k v) (λ (h k v)
((mk-pos-rng-proj k) v neg-party)))) (with-contract-continuation-mark
blame+neg-party
((mk-pos-rng-proj k) v neg-party)))))
(λ (h k v) (λ (h k v)
(values (neg-dom-proj k neg-party) (with-contract-continuation-mark
((mk-neg-rng-proj k) v neg-party))) blame+neg-party
(values (neg-dom-proj k neg-party)
((mk-neg-rng-proj k) v neg-party))))
(λ (h k) (λ (h k)
(neg-dom-proj k neg-party)) (with-contract-continuation-mark
blame+neg-party
(neg-dom-proj k neg-party)))
(λ (h k) (λ (h k)
(pos-dom-proj k neg-party)) (with-contract-continuation-mark
blame+neg-party
(pos-dom-proj k neg-party)))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame blame))) impersonator-prop:blame blame)))