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