From d1fb3e2c17c9b4257b1c55b65f30fb40407a4992 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Mon, 20 May 2013 22:15:39 -0500
Subject: [PATCH] fix object/c's blame context manipulations

Specifically,
- add field and method contexts, and
- declare methods in object/c contracts to be #:important

closes PR 13765
---
 collects/racket/private/class-internal.rkt | 24 ++++++++++-------
 collects/tests/racket/contract-test.rktl   | 31 ++++++++++++++++++++++
 2 files changed, 45 insertions(+), 10 deletions(-)

diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt
index 94f472ac6c..710560bf7f 100644
--- a/collects/racket/private/class-internal.rkt
+++ b/collects/racket/private/class-internal.rkt
@@ -4984,19 +4984,21 @@ An example
             [c (in-list method-contracts)])
         (when c
           (let ([i (hash-ref method-ht m)]
-                [p ((contract-projection c) blame)])
+                [p ((contract-projection c) (blame-add-context blame (format "the ~a method in" m)
+                                                               #:important m))])
             (vector-set! meths i (make-method (p (vector-ref meths i)) m))))))
     
     ;; Handle external field contracts
     (unless (null? fields)
-      (let ([bset (blame-swap blame)])
-        (for ([f (in-list fields)]
-              [c (in-list field-contracts)])
-          (when c
-            (let ([fi (hash-ref field-ht f)]
-                  [p-pos ((contract-projection c) blame)]
-                  [p-neg ((contract-projection c) bset)])
-              (hash-set! field-ht f (field-info-extend-external fi p-pos p-neg)))))))
+      (for ([f (in-list fields)]
+            [c (in-list field-contracts)])
+        (when c
+          (define fld-context (format "the ~a field in" f))
+          (define bset (blame-add-context blame fld-context #:swap? #t))
+          (let ([fi (hash-ref field-ht f)]
+                [p-pos ((contract-projection c) (blame-add-context blame fld-context))]
+                [p-neg ((contract-projection c) bset)])
+            (hash-set! field-ht f (field-info-extend-external fi p-pos p-neg))))))
     
     c))
 
@@ -5007,7 +5009,9 @@ An example
 (define (make-wrapper-object ctc obj blame methods method-contracts fields field-contracts)
   (check-object-contract obj methods fields (λ args (apply raise-blame-error blame obj args)))
   (let ([original-obj (if (has-original-object? obj) (original-object obj) obj)]
-        [new-cls (make-wrapper-class (object-ref obj) blame methods method-contracts fields field-contracts)])
+        [new-cls (make-wrapper-class (object-ref obj) 
+                                     blame
+                                     methods method-contracts fields field-contracts)])
     (impersonate-struct obj object-ref (λ (o c) new-cls)
                         impersonator-prop:contracted ctc
                         impersonator-prop:original-object original-obj)))
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index c65918c29b..faeca8068f 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -13826,6 +13826,37 @@ so that propagation occurs.
                             'pos 'neg)
                   #f))
   
+  (context-test '("the 1st argument of" "the save-file method in")
+                '(send (contract (object/c
+                                  (save-file (->m string? string?)))
+                                 (new (class object%
+                                        (define/public (save-file s . args) #f)
+                                        (super-new)))
+                                 'pos
+                                 'neg)
+                       save-file 1))
+
+  (context-test '("the f field in")
+                '(get-field 
+                  f
+                  (contract (object/c (field [f string?]))
+                            (new (class object%
+                                   (field [f 1])
+                                   (super-new)))
+                            'pos
+                            'neg)))
+  
+  (context-test '("the 1st argument of" "the f field in")
+                '((get-field 
+                   f
+                   (contract (object/c (field [f (-> string? any)]))
+                             (new (class object%
+                                    (field [f (λ (x) 1)])
+                                    (super-new)))
+                             'pos
+                             'neg))
+                  #f))
+  
 
   (let* ([blame-pos (contract-eval '(make-blame (srcloc #f #f #f #f #f) #f (λ () 'integer?) 'positive 'negative #t))]
          [blame-neg (contract-eval `(blame-swap ,blame-pos))])