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

Instrumentation for object-contract.

Browse Source
This commit is contained in:
Vincent St-Amour 2016-01-11 16:22:11 -06:00
parent e5738b8ee6
commit 1277f0347a
2 changed files with 32 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -335,25 +335,39 @@
(mark-value '(chocolate-bar))))) (mark-value '(chocolate-bar)))))
'(chocolate-bar truffle fudge ganache)) '(chocolate-bar truffle fudge ganache))
(test/spec-passed/result (test/spec-passed
'contract-marks37 'contract-marks37
'(let () '(let ()
(define/contract my-evt (define/contract my-evt
(evt/c (λ _ (named-blame? 'top-level))) (evt/c (λ _ (named-blame? 'top-level)))
always-evt) always-evt)
(sync my-evt) (sync my-evt)))
3)
3)
(test/spec-passed/result (test/spec-passed
'contract-marks38 'contract-marks38
'(let () '(let ()
(define/contract chan (define/contract chan
(channel/c (λ _ (named-blame? 'top-level))) (channel/c (λ _ (named-blame? 'top-level)))
(make-channel)) (make-channel))
(thread (λ () (channel-get chan))) (thread (λ () (channel-get chan)))
(channel-put chan 'not-a-string) (channel-put chan 'not-a-string)))
3)
3) (test/spec-passed
'contract-marks39
'(let ()
(eval '(require racket/class))
(eval '((contract (->m neg-blame? any/c) (λ (_ x) x) 'pos 'neg) 'a 1))))
(test/spec-passed
'contract-marks40
'(let ()
(define o
(contract
(object-contract (field x pos-blame?) (f (->m neg-blame?)))
(new (class object% (init-field x) (define/public (f) x) (super-new)) [x 3])
'pos 'neg))
(get-field x o)
(set-field! x o 2)
(send o f)))
) )

11
racket/collects/racket/private/class-c-old.rkt
View File

@ -1649,6 +1649,15 @@
(define prj (contract-late-neg-projection c)) (define prj (contract-late-neg-projection c))
(define p-pos (prj (blame-add-field-context blame f #:swap? #f))) (define p-pos (prj (blame-add-field-context blame f #:swap? #f)))
(define p-neg (prj (blame-add-field-context blame f #:swap? #t))) (define p-neg (prj (blame-add-field-context blame f #:swap? #t)))
(hash-set! field-ht f (field-info-extend-external fi p-pos p-neg neg-party))))) (hash-set! field-ht f (field-info-extend-external fi
(lambda args
(with-contract-continuation-mark
(cons blame neg-party)
(apply p-pos args)))
(lambda args
(with-contract-continuation-mark
(cons blame neg-party)
(apply p-neg args)))
neg-party)))))
(copy-seals cls c))) (copy-seals cls c)))