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

Add instrumentation to class/c.

Browse Source 
Method contracts are taken care of by the function combinators.

So only field contract instrumentation is necessary.
This commit is contained in:
Vincent St-Amour 2016-01-22 15:30:07 -06:00
parent 95c0dfce38
commit 9d990b65dc
2 changed files with 127 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -645,4 +645,99 @@
(eval '(let ([f f]) (f 1))))
(void))
(test/spec-passed
'contract-marks68
'(let ()
(define woody%
(class object%
(define/public (draw who)
(format "reach for the sky, ~a" who))
(super-new)))
(define woody+c%
(contract
(class/c [draw (->m neg-blame? pos-blame?)])
woody% 'pos 'neg))
(send (new woody+c%) draw #f)))
(test/spec-passed
'contract-marks69
'(let ()
(define woody%
(class object%
(define/public (draw who)
(format "reach for the sky, ~a" who))
(super-new)))
(define woody/hat%
(class woody%
(field [hat-location 'uninitialized])
(define/public (lose-hat) (set! hat-location 'lost))
(define/public (find-hat) (set! hat-location 'on-head))
(super-new)))
(define woody/hat+c%
(contract (class/c [draw (->m neg-blame? pos-blame?)]
[lose-hat (->m pos-blame?)]
[find-hat (->m pos-blame?)]
(field [hat-location pos-blame?]))
woody/hat% 'pos 'neg))
(get-field hat-location (new woody/hat+c%))
(let ([woody (new woody/hat+c%)])
(set-field! hat-location woody 'under-the-dresser))))
(test/spec-passed
'contract-marks70
'(let ()
(define woody%
(class object%
(define/public (draw who)
(format "reach for the sky, ~a" who))
(super-new)))
(define woody/hat%
(class woody%
(field [hat-location 'uninitialized])
(define/public (lose-hat) (set! hat-location 'lost))
(define/public (find-hat) (set! hat-location 'on-head))
(super-new)))
(define woody/hat+c%
(contract (class/c [draw (->m neg-blame? pos-blame?)]
[lose-hat (->m pos-blame?)]
[find-hat (->m pos-blame?)]
(field [hat-location pos-blame?]))
woody/hat% 'pos 'neg))
(define woody/hat2%
(class woody/hat+c%
(inherit-field hat-location)
(define/public (eat-hat) (set! hat-location 'stomach))
(super-new)))
(send (new woody/hat2%) eat-hat)))
(test/spec-passed
'contract-marks71
'(let ()
(define woody%
(class object%
(define/public (draw who)
(format "reach for the sky, ~a" who))
(super-new)))
(define woody/init-hat%
(class woody%
(init init-hat-location)
(field [hat-location init-hat-location])
(define/public (lose-hat) (set! hat-location 'lost))
(define/public (find-hat) (set! hat-location 'on-head))
(super-new)))
(define woody/init-hat+c%
(contract
(class/c [draw (->m neg-blame? pos-blame?)]
[lose-hat (->m pos-blame?)]
[find-hat (->m pos-blame?)]
(init [init-hat-location pos-blame?])
(field [hat-location pos-blame?]))
woody/init-hat% 'pos 'neg))
(get-field hat-location
(new woody/init-hat+c%
[init-hat-location 'lost]))
(get-field hat-location
(new woody/init-hat+c%
[init-hat-location 'slinkys-mouth]))))
)

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

@ -164,21 +164,36 @@
(define external-field-projections
(for/list ([f (in-list (class/c-fields ctc))]
[c (in-list (class/c-field-contracts ctc))])
(define pos-blame (blame-add-field-context blame f #:swap? #f))
(define neg-blame (blame-add-field-context blame f #:swap? #t))
(and c
(let ([p-pos ((contract-late-neg-projection c)
(blame-add-field-context blame f #:swap? #f))]
pos-blame)]
[p-neg ((contract-late-neg-projection c)
(blame-add-field-context blame f #:swap? #t))])
(cons p-pos p-neg)))))
neg-blame)])
(cons (lambda (x pos-party)
(define blame+pos-party (cons pos-blame pos-party))
(with-contract-continuation-mark
blame+pos-party
(p-pos x pos-party)))
(lambda (x neg-party)
(define blame+neg-party (cons neg-blame neg-party))
(with-contract-continuation-mark
blame+neg-party
(p-neg x neg-party))))))))
;; zip the inits and contracts together for ordered selection
(define inits+contracts
(for/list ([init (in-list (class/c-inits ctc))]
[ctc (in-list (class/c-init-contracts ctc))])
(if ctc
(list init ((contract-late-neg-projection ctc)
(blame-add-init-context blame init)))
(list init #f))))
(cond [ctc
(define blame* (blame-add-init-context blame init))
(define neg-acceptor ((contract-late-neg-projection ctc) blame*))
(list init (lambda (x neg-party)
(with-contract-continuation-mark
(cons blame* neg-party)
(neg-acceptor x neg-party))))]
[else (list init #f)])))
(λ (cls neg-party)
(class/c-check-first-order
@ -411,7 +426,16 @@
(let* ([blame-acceptor (contract-late-neg-projection c)]
[p-pos (blame-acceptor blame)]
[p-neg (blame-acceptor bswap)])
(cons p-pos p-neg)))))
(cons (lambda (x pos-party)
(define blame+pos-party (cons blame pos-party))
(with-contract-continuation-mark
blame+pos-party
(p-pos x pos-party)))
(lambda (x neg-party)
(define blame+neg-party (cons blame neg-party))
(with-contract-continuation-mark
blame+neg-party
(p-neg x neg-party))))))))
(define override-projections
(for/list ([m (in-list (internal-class/c-overrides internal-ctc))]