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

Add instrumentation to struct property contracts.

Browse Source
This commit is contained in:
Vincent St-Amour 2016-01-12 11:07:18 -06:00
parent 1661eeda18
commit d0c48de685
2 changed files with 24 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -407,4 +407,24 @@
(set-s-x! s* 3)
(s-x s*)))
(test/spec-passed
'contract-marks45
'(let ()
(eval '(module propmod racket/base
(require racket/contract 'prof-fun)
(define-values (prop prop? prop-ref)
(make-struct-type-property 'prop))
(define (app-prop x v)
(((prop-ref x) x) v))
(provide/contract
[prop (struct-type-property/c
(-> (lambda _ (named-blame? 'propmod))
(-> (lambda _ (named-blame? 'propmod))
(lambda _ (named-blame? 'propmod)))))])
(provide prop-ref app-prop)))
(eval '(require 'propmod))
(eval '(struct s (f) #:property prop (lambda (s) (s-f s))))
(eval '(define s1 (s even?)))
(eval '(app-prop s1 5))))
)

5
racket/collects/racket/contract/private/struct-prop.rkt
View File

@ -16,11 +16,14 @@
(raise-blame-error input-blame x #:neg-party
'(expected "struct-type-property" given: "~e")
x))
(define blame+neg-party (cons blame neg-party))
(define-values (nprop _pred _acc)
(make-struct-type-property
(wrap-name x)
(lambda (val _info)
(late-neg-proj val neg-party))
(with-contract-continuation-mark
blame+neg-party
(late-neg-proj val neg-party)))
(list (cons x values))))
nprop)))