From e3aa7128fba4316d355245eca3cdf08ade4f987c Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 1 Nov 2003 22:23:00 +0000
Subject: [PATCH] ..

original commit: 506ac9967e119993bae271d05f7cb36c770b5e38
---
 collects/mzlib/contract.ss               | 21 +--------
 collects/tests/mzscheme/contract-test.ss | 55 ++++++++++++++++++------
 2 files changed, 44 insertions(+), 32 deletions(-)

diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss
index 9773687..0ef8eaa 100644
--- a/collects/mzlib/contract.ss
+++ b/collects/mzlib/contract.ss
@@ -1004,7 +1004,6 @@ improve method arity mismatch contract violation error messages?
            (raise-syntax-error 'object-contract "malformed ->d* method contract" stx mtd-stx)]
           [else (raise-syntax-error 'object-contract "unknown method contract syntax" stx mtd-stx)]))
       
-      
       ;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc]
       (define (build-methods-stx arg-spec-stxss)
         (let loop ([arg-spec-stxss arg-spec-stxss]
@@ -1093,7 +1092,6 @@ improve method arity mismatch contract violation error messages?
                                                       (list methods ...)
                                                       '(field-name ...)
                                                       )]
-                             [method-names-list '(method-name ...)]
                              [field-names-list '(field-name ...)])
                          (lambda (val)
                            (unless (object? val)
@@ -1107,15 +1105,7 @@ improve method arity mismatch contract violation error messages?
                                   (interface->method-names
                                    (object-interface
                                     val))])
-                             (for-each (lambda (val-mtd-name)
-                                         (unless (memq val-mtd-name method-names-list)
-                                           (raise-contract-error src-info
-                                                                 pos-blame
-                                                                 neg-blame
-                                                                 orig-str
-                                                                 "object has an extra method ~s" 
-                                                                 val-mtd-name)))
-                                       val-mtd-names)
+                             (void)
                              (unless (memq 'method-name val-mtd-names)
                                (raise-contract-error src-info
                                                      pos-blame
@@ -1125,15 +1115,6 @@ improve method arity mismatch contract violation error messages?
                                                      'method-name))
                              ...)
                            
-                           (for-each (lambda (val-field-name)
-                                       (unless (memq val-field-name field-names-list)
-                                         (raise-contract-error src-info
-                                                               pos-blame
-                                                               neg-blame
-                                                               orig-str
-                                                               "object has an extra field ~s"
-                                                               val-field-name)))
-                                     (field-names val))
                            (unless (field-bound? field-name val)
                              (raise-contract-error src-info
                                                    pos-blame
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index f128849..b2f989e 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -1439,19 +1439,50 @@
                     'neg)
           m 1 #t 'x 'y))
   
-  (test/pos-blame
-   'object-contract-drop-method
-   '(contract (object-contract (m (-> integer? integer?)))
-              (new (class object% (define/public (m x) x) (define/public (n x) x) (super-new)))
-              'pos
-              'neg))
+  (test/spec-passed/result
+   'object-contract-drop-method1
+   '(send (contract (object-contract (m (-> integer? integer?)))
+                    (new (class object% (define/public (m x) x) (define/public (n x) x) (super-new)))
+                    'pos
+                    'neg)
+          n 1)
+   1)
   
-  (test/pos-blame
-   'object-contract-drop-field
-   '(contract (object-contract (field f integer?))
-              (new (class object% (field [f 1] [g 2]) (super-new)))
-              'pos
-              'neg))
+  (test/spec-passed/result
+   'object-contract-drop-method2
+   '(let ([o (contract (object-contract (m (-> integer? integer?)))
+                       (new (class object% (define/public (m x) x) (define/public (n x) x) (super-new)))
+                       'pos
+                       'neg)])
+      (with-method ([m (o m)]
+                    [n (o n)])
+        (list (m 1) (n 2))))
+   '(1 2))
+  
+  (test/spec-passed/result
+   'object-contract-drop-field1
+   '(get-field g (contract (object-contract (field f integer?))
+                           (new (class object% (field [f 1] [g 2]) (super-new)))
+                           'pos
+                           'neg))
+   2)
+  
+  (test/spec-passed/result
+   'object-contract-drop-field2
+   '(field-bound? g (contract (object-contract (field f integer?))
+                              (new (class object% (field [f 1] [g 2]) (super-new)))
+                              'pos
+                              'neg))
+   #t)
+  
+  (test/spec-passed/result
+   'object-contract-drop-field3
+   '(field-names
+     (contract (object-contract)
+               (new (class object% (field [g 2]) (super-new)))
+               'pos
+               'neg))
+   '(g))
   
   
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;