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

Fix and improve ->i instrumentation.

Browse Source
This commit is contained in:
Vincent St-Amour 2016-01-12 12:24:44 -06:00
parent d0c48de685
commit 2f6f403ce8
2 changed files with 45 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -427,4 +427,43 @@
(eval '(define s1 (s even?))) (eval '(define s1 (s even?)))
(eval '(app-prop s1 5)))) (eval '(app-prop s1 5))))
(test/spec-passed
'contract-marks46
'((contract (->i ([x () pos-blame?] [y (x) pos-blame?])
#:rest [z (x y) pos-blame?]
#:pre (x y z) pos-blame?
[res (x y z) neg-blame?]
#:post (res x y z) neg-blame?)
(lambda (x y . z) 3)
'pos 'neg)
1 2 3))
(test/spec-passed
'contract-marks47
'((contract (->i ([x () pos-blame?] [y (x) pos-blame?])
([w (x y) pos-blame?])
#:rest [z (x y) pos-blame?]
#:pre (x y z) pos-blame?
[res (x y z) neg-blame?]
#:post (res x y z) neg-blame?)
(lambda (x y [w 3] . z) 3)
'pos 'neg)
1 2 3 4))
(test/spec-passed
'contract-marks48
'((contract (->i ([x () pos-blame?] [y (x) pos-blame?])
[res (x y) neg-blame?])
(lambda (x y) 3)
'pos 'neg)
1 2))
(test/spec-passed
'contract-marks49
'((contract (->i ([x () pos-blame?])
[res (x) neg-blame?])
(lambda (x) 3)
'pos 'neg)
1))
) )

9
racket/collects/racket/contract/private/arr-i.rkt
View File

@ -811,7 +811,7 @@ evaluted left-to-right.)
#`(case-lambda #`(case-lambda
[#,(vector->list wrapper-ress) [#,(vector->list wrapper-ress)
(with-contract-continuation-mark (with-contract-continuation-mark
blame blame+neg-party
#,(add-wrapper-let #,(add-wrapper-let
(add-post-cond an-istx indy-arg-vars ordered-args indy-res-vars ordered-ress (add-post-cond an-istx indy-arg-vars ordered-args indy-res-vars ordered-ress
#`(values #,@(vector->list wrapper-ress))) #`(values #,@(vector->list wrapper-ress)))
@ -906,6 +906,7 @@ evaluted left-to-right.)
(with-syntax ([arg-checker (or (syntax-local-infer-name stx) 'arg-checker)]) (with-syntax ([arg-checker (or (syntax-local-infer-name stx) 'arg-checker)])
#`(λ #,wrapper-proc-arglist #`(λ #,wrapper-proc-arglist
(λ (val neg-party) (λ (val neg-party)
(define blame+neg-party (cons blame neg-party))
(chk val #,(and (syntax-parameter-value #'making-a-method) #t)) (chk val #,(and (syntax-parameter-value #'making-a-method) #t))
(c-or-i-procedure (c-or-i-procedure
val val
@ -915,10 +916,12 @@ evaluted left-to-right.)
(make-keyword-procedure (make-keyword-procedure
(λ (kwds kwd-args . args) (λ (kwds kwd-args . args)
(with-contract-continuation-mark (with-contract-continuation-mark
blame (keyword-apply arg-checker kwds kwd-args args))) blame+neg-party
(keyword-apply arg-checker kwds kwd-args args)))
(λ args (λ args
(with-contract-continuation-mark (with-contract-continuation-mark
blame (apply arg-checker args))))) blame+neg-party
(apply arg-checker args)))))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame blame)))))) impersonator-prop:blame blame))))))