From b59955bc01a5849248f6bd3bdebd5922bf9bc29a Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Fri, 19 Feb 2010 00:34:27 +0000
Subject: [PATCH] Ah, that'd be the issue.  THE TESTS WERE WRONG.  All's well,
 and I've even added a couple more tests to make sure we apply the projections
 in the right order.

svn: r18176
---
 collects/scheme/private/class-internal.ss | 18 +++++++++++-
 collects/tests/mzscheme/contract-test.ss  | 34 +++++++++++++++++++++--
 2 files changed, 48 insertions(+), 4 deletions(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index 7f069ccc5a..f0d6666c2e 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -2471,6 +2471,9 @@
              [super-methods (if (null? (class/c-supers ctc))
                                 (class-super-methods cls)
                                 (make-vector method-width))]
+             [inner-projs (if (null? (class/c-inners ctc))
+                              (class-inner-projs cls)
+                              (make-vector method-width))]
              [class-make (if name
                              (make-naming-constructor 
                               struct:class
@@ -2492,7 +2495,7 @@
                             (class-beta-methods cls)
                             (class-meth-flags cls)
                             
-                            (class-inner-projs cls)
+                            inner-projs
                             
                             (class-field-width cls)
                             (class-field-ht cls)
@@ -2554,6 +2557,19 @@
                   [p ((contract-projection c) blame)])
               (vector-set! super-methods i (p (vector-ref super-methods i))))))
         
+        ;; Add inner projections
+        (unless (null? (class/c-inners ctc))
+          (let ([old-inner-projs (class-inner-projs cls)])
+            (for ([n (in-range method-width)])
+              (vector-set! inner-projs n (vector-ref old-inner-projs n))))
+          (let ([b (blame-swap blame)])
+            (for ([m (in-list (class/c-inners ctc))]
+                  [c (in-list (class/c-inner-contracts ctc))])
+              (let ([i (hash-ref method-ht m)]
+                    [p ((contract-projection c) b)])
+                (vector-set! inner-projs i
+                             (compose (vector-ref inner-projs i) p))))))
+        
         c))))
 
 (define-struct class/c 
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index 75321740f4..c3c7747d97 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -4364,7 +4364,7 @@
            [d% (class c% (super-new) (define/augride (m x) (add1 x)))])
       (send (new d%) m 3)))
 
-  (test/pos-blame
+  (test/neg-blame
    'class/c-higher-order-inner-2
    '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)]))
                          (class object% (super-new) (define/pubment (m x) (+ x (inner x m x))))
@@ -4373,7 +4373,7 @@
            [d% (class c% (super-new) (define/augride (m x) (zero? x)))])
       (send (new d%) m 3)))
 
-  (test/neg-blame
+  (test/pos-blame
    'class/c-higher-order-inner-3
    '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)]))
                          (class object% (super-new) (define/pubment (m x) (+ x (inner x m (zero? x)))))
@@ -4382,7 +4382,7 @@
            [d% (class c% (super-new) (define/augride (m x) (add1 x)))])
       (send (new d%) m 3)))
 
-  (test/pos-blame
+  (test/neg-blame
    'class/c-higher-order-inner-4
    '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)]))
                          (class object% (super-new) (define/pubment (m x) (+ x (inner x m x))))
@@ -4401,6 +4401,34 @@
            [d% (class c% (super-new) (define/augment (m x) (if (inner x m x) (add1 x) x)))]
            [e% (class d% (super-new) (define/augride (m x) (zero? x)))])
       (send (new e%) m 3)))
+
+  ;; Make sure the order of the wrapping is correct in the next two.
+  (test/neg-blame
+   'class/c-higher-order-inner-6
+   '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)]))
+                         (class object% (super-new) (define/pubment (m x) (+ x (inner x m x))))
+                         'pos
+                         'neg1)]
+           [d% (contract (class/c (inner [m (-> any/c number? number?)]))
+                         c%
+                         'pos1
+                         'neg)]
+           [e% (class d% (super-new) (define/augride (m x) (zero? x)))])
+      (send (new e%) m 3)))
+
+  (test/pos-blame
+   'class/c-higher-order-inner-7
+   '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)]))
+                         (class object% (super-new) (define/pubment (m x) (+ x (inner x m #f))))
+                         'pos
+                         'neg1)]
+           [d% (contract (class/c (inner [m (-> any/c number? number?)]))
+                         c%
+                         'pos1
+                         'neg)]
+           [e% (class d% (super-new) (define/augride (m x) (add1 x)))])
+      (send (new e%) m 3)))
+  
 ;                                                              
 ;                                                              
 ;             ;;        ;;                     ;    ;;