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

Instrument id table contracts.

Browse Source
This commit is contained in:
Vincent St-Amour 2016-01-13 16:39:31 -06:00
parent d5ae7125e5
commit 4fd60fed11
2 changed files with 44 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -597,4 +597,23 @@
(in-dict '((1 . 2) (3 . 4))) 'pos 'neg) (in-dict '((1 . 2) (3 . 4))) 'pos 'neg)
0)))) 0))))
(test/spec-passed
'contract-marks65
'(let ()
(eval '(require syntax/id-table))
(eval '(define t (contract (free-id-table/c pos-blame? neg-blame?)
(make-free-id-table)
'pos 'neg)))
(eval '(free-id-table-set! t #'a 3))
(eval '(free-id-table-ref t #'a))))
(test/spec-passed
'contract-marks66
'(let ()
(eval '(require syntax/id-table))
(eval '(define t (contract (free-id-table/c pos-blame? neg-blame?)
(make-immutable-free-id-table)
'pos 'neg)))
(eval '(free-id-table-ref (free-id-table-set t #'a 3) #'a))))
) )

35
racket/collects/syntax/id-table.rkt
View File

@ -130,20 +130,35 @@
(define pos-rng-proj (id-table/c-rng-pos-proj ctc blame)) (define pos-rng-proj (id-table/c-rng-pos-proj ctc blame))
(define neg-rng-proj (id-table/c-rng-neg-proj ctc blame)) (define neg-rng-proj (id-table/c-rng-neg-proj ctc blame))
(lambda (tbl neg-party) (lambda (tbl neg-party)
(define blame+neg-party (cons blame neg-party))
(check-id-table/c ctc tbl blame neg-party) (check-id-table/c ctc tbl blame neg-party)
;;TODO for immutable hash tables optimize this chaperone to a flat ;;TODO for immutable hash tables optimize this chaperone to a flat
;;check if possible ;;check if possible
(if (immutable-idtbl? tbl) (if (immutable-idtbl? tbl)
(chaperone-immutable-id-table tbl (chaperone-immutable-id-table
(λ (val) (pos-dom-proj val neg-party)) tbl
(λ (val) (pos-rng-proj val neg-party)) (λ (val) (with-contract-continuation-mark
impersonator-prop:contracted ctc) blame+neg-party
(chaperone-mutable-id-table tbl (pos-dom-proj val neg-party)))
(λ (val) (neg-dom-proj val neg-party)) (λ (val) (with-contract-continuation-mark
(λ (val) (pos-dom-proj val neg-party)) blame+neg-party
(λ (val) (neg-rng-proj val neg-party)) (pos-rng-proj val neg-party)))
(λ (val) (pos-rng-proj val neg-party)) impersonator-prop:contracted ctc)
impersonator-prop:contracted ctc))))) (chaperone-mutable-id-table
tbl
(λ (val) (with-contract-continuation-mark
blame+neg-party
(neg-dom-proj val neg-party)))
(λ (val) (with-contract-continuation-mark
blame+neg-party
(pos-dom-proj val neg-party)))
(λ (val) (with-contract-continuation-mark
blame+neg-party
(neg-rng-proj val neg-party)))
(λ (val) (with-contract-continuation-mark
blame+neg-party
(pos-rng-proj val neg-party)))
impersonator-prop:contracted ctc)))))
(struct flat-id-table/c base-id-table/c () (struct flat-id-table/c base-id-table/c ()
#:omit-define-syntaxes #:omit-define-syntaxes