From 35afebaea3c9a74f347d2c97b2035ce09d1492e8 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 16 Feb 2010 19:58:07 +0000
Subject: [PATCH] Change object-contract to use find-method/who (already
 exported for Typed Scheme) to look for the appropriate method to wrap, which
 makes Robby's object-contracts appropriately translucent during contract
 wrapping.

svn: r18102
---
 collects/scheme/contract/private/object.ss | 26 ++++++++++------------
 collects/scheme/private/class-internal.ss  | 24 +++++++++-----------
 collects/tests/mzscheme/contract-test.ss   | 26 ++++++++++++++++++++++
 3 files changed, 48 insertions(+), 28 deletions(-)

diff --git a/collects/scheme/contract/private/object.ss b/collects/scheme/contract/private/object.ss
index 005a726288..380128a08a 100644
--- a/collects/scheme/contract/private/object.ss
+++ b/collects/scheme/contract/private/object.ss
@@ -72,20 +72,18 @@
                 (unless (object? val)
                   (raise-blame-error blame val "expected an object, got ~e" val))
                 
-                (let ([objs-mtds (interface->method-names (object-interface val))]
-                      [vtable (extract-vtable val)]
-                      [method-ht (extract-method-ht val)])
-                  (for-each (λ (m proj)
-                               (let ([index (hash-ref method-ht m #f)])
-                                 (unless index
-                                   (raise-blame-error blame val "expected an object with method ~s" m))
-                                 ;; verify the first-order properties by apply the projection and 
-                                 ;; throwing the result away. Without this, the contract wrappers
-                                 ;; just check the first-order properties of the wrappers, which is
-                                 ;; the wrong thing.
-                                 (proj (vector-ref vtable index))))
-                            meth-names
-                            meth-projs))
+               (for-each (λ (m proj)
+                           (let-values ([(method unwrapper) 
+                                         (find-method/who 'object-contract val m #:error? #f)])
+                             (unless method
+                               (raise-blame-error blame val "expected an object with method ~s" m))
+                             ;; verify the first-order properties by apply the projection and 
+                             ;; throwing the result away. Without this, the contract wrappers
+                             ;; just check the first-order properties of the wrappers, which is
+                             ;; the wrong thing.
+                             (proj method)))
+                         meth-names
+                         meth-projs)
                 
                 (let ([fields (field-names val)])
                   (for-each (λ (f)
diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index 375ba373e5..b81f5b5c49 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -2944,10 +2944,12 @@
 ;;               -> (values method-proc object)
 ;; returns the method's procedure and a function to unwrap `this' in the case
 ;; that this is a wrapper object that is just "falling thru".
-(define (find-method/who who in-object name)
+(define (find-method/who who in-object name #:error? [error? #t])
   (unless (object? in-object)
-    (obj-error who "target is not an object: ~e for method: ~a"
-               in-object name))
+    (if error?
+        (obj-error who "target is not an object: ~e for method: ~a"
+                   in-object name)
+        (values #f values)))
   
   (let-syntax ([loop-body
                 (lambda (stx)
@@ -2961,9 +2963,11 @@
                           [pos (values (vector-ref (class-methods c) pos) abs-object)]
                           [(wrapper-object? abs-object) wrapper-case]
                           [else
-                           (obj-error who "no such method: ~a~a"
-                                      name
-                                      (for-class (class-name c)))])))]))])
+                           (if error?
+                               (obj-error who "no such method: ~a~a"
+                                          name
+                                          (for-class (class-name c)))
+                               (values #f values))])))]))])
     (loop-body
      in-object
      (let loop ([loop-object in-object])
@@ -3677,12 +3681,6 @@
       
       cls)))
 
-; extract-vtable : object -> (vectorof method-proc[this args ... -> res])
-(define (extract-vtable o) (class-methods (object-ref o)))
-
-; extract-method-ht : object -> hash-table[sym -> number]
-(define (extract-method-ht o) (class-method-ht (object-ref o)))
-
 ;;--------------------------------------------------------------------
 ;;  misc utils
 ;;--------------------------------------------------------------------
@@ -3871,8 +3869,6 @@
 ;; Providing normal functionality:
 (provide (protect-out make-wrapper-class
                       wrapper-object-wrapped
-                      extract-vtable
-                      extract-method-ht
                       get-field/proc)
          
          (rename-out [_class class]) class* class/derived
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index 485b377237..e5e0269ee2 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -3959,6 +3959,32 @@
           (λ (x) x))
    1)
   
+  (test/spec-passed/result
+   'object-contract-layered1
+   '(send (contract (object-contract (m (-> number? number?)))
+                    (contract (object-contract)
+                              (new (class object% (super-new) (define/public (m x) x)))
+                              'pos
+                              'neg)
+                    'pos
+                    'neg)
+          m
+          5)
+   5)
+  
+  ;; Make sure we're not dropping projections on the floor.
+  (test/neg-blame
+   'object-contract-layered2
+   '(send (contract (object-contract (m (-> number? number?)))
+                    (contract (object-contract (m (-> string? string?)))
+                              (new (class object% (super-new) (define/public (m x) x)))
+                              'pos
+                              'neg)
+                    'pos
+                    'neg)
+          m
+          5))
+  
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;
   ;; test error message has right format