From d0c48de68594c59fe3b2c97b76e037ce23d00f3a Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 12 Jan 2016 11:07:18 -0600 Subject: [PATCH] Add instrumentation to struct property contracts. --- .../tests/racket/contract/prof.rkt | 20 +++++++++++++++++++ .../racket/contract/private/struct-prop.rkt | 5 ++++- 2 files changed, 24 insertions(+), 1 deletion(-) diff --git a/pkgs/racket-test/tests/racket/contract/prof.rkt b/pkgs/racket-test/tests/racket/contract/prof.rkt index ec5a827f06..32c843dd86 100644 --- a/pkgs/racket-test/tests/racket/contract/prof.rkt +++ b/pkgs/racket-test/tests/racket/contract/prof.rkt @@ -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)))) + ) diff --git a/racket/collects/racket/contract/private/struct-prop.rkt b/racket/collects/racket/contract/private/struct-prop.rkt index b468aa215f..6c3f2edc51 100644 --- a/racket/collects/racket/contract/private/struct-prop.rkt +++ b/racket/collects/racket/contract/private/struct-prop.rkt @@ -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)))