From 2f6f403ce8e2bbfe223a9ceac039122ba6d8dd23 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Tue, 12 Jan 2016 12:24:44 -0600
Subject: [PATCH] Fix and improve ->i instrumentation.

---
 .../tests/racket/contract/prof.rkt            | 39 +++++++++++++++++++
 .../racket/contract/private/arr-i.rkt         |  9 +++--
 2 files changed, 45 insertions(+), 3 deletions(-)

diff --git a/pkgs/racket-test/tests/racket/contract/prof.rkt b/pkgs/racket-test/tests/racket/contract/prof.rkt
index 32c843dd86..38191641bb 100644
--- a/pkgs/racket-test/tests/racket/contract/prof.rkt
+++ b/pkgs/racket-test/tests/racket/contract/prof.rkt
@@ -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))
+
   )
diff --git a/racket/collects/racket/contract/private/arr-i.rkt b/racket/collects/racket/contract/private/arr-i.rkt
index 6393b98bbb..2368c356ef 100644
--- a/racket/collects/racket/contract/private/arr-i.rkt
+++ b/racket/collects/racket/contract/private/arr-i.rkt
@@ -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))))))