diff --git a/pkgs/racket-test/tests/racket/contract/object.rkt b/pkgs/racket-test/tests/racket/contract/object.rkt index 7fada3dde7..65707cc979 100644 --- a/pkgs/racket-test/tests/racket/contract/object.rkt +++ b/pkgs/racket-test/tests/racket/contract/object.rkt @@ -217,4 +217,71 @@ (define/public (baz n) (list foo bar)))) 'pos 'neg) baz 1) - '(0 1))) + '(0 1)) + +(test/pos-blame + 'object/c-multiple-wrapping-1 + '(let () + (define c% + (class object% + (define/public (m) (void)) + (define/public (n) (void)) + (define/public (p) (void)) + (super-new))) + + (define a/c (object/c [m (-> any/c symbol?)])) + (define b/c (object/c [n (-> any/c string?)])) + (define c/c (object/c [p (-> any/c vector?)])) + + (define a-c (new c%)) + + (define x1 (contract a/c a-c 'pos 'neg)) + (define x2 (contract b/c x1 'pos 'neg)) + (define x3 (contract c/c x2 'pos 'neg)) + + (send x3 m))) +(test/pos-blame + 'object/c-multiple-wrapping-2 + '(let () + (define c% + (class object% + (define/public (m) (void)) + (define/public (n) (void)) + (define/public (p) (void)) + (super-new))) + + (define a/c (object/c [m (-> any/c symbol?)])) + (define b/c (object/c [n (-> any/c string?)])) + (define c/c (object/c [p (-> any/c vector?)])) + + (define a-c (new c%)) + + (define x1 (contract a/c a-c 'pos 'neg)) + (define x2 (contract b/c x1 'pos 'neg)) + (define x3 (contract c/c x2 'pos 'neg)) + + (send x3 n))) +(test/pos-blame + 'object/c-multiple-wrapping-3 + '(let () + (define c% + (class object% + (define/public (m) (void)) + (define/public (n) (void)) + (define/public (p) (void)) + (super-new))) + + (define a/c (object/c [m (-> any/c symbol?)])) + (define b/c (object/c [n (-> any/c string?)])) + (define c/c (object/c [p (-> any/c vector?)])) + + (define a-c (new c%)) + + (define x1 (contract a/c a-c 'pos 'neg)) + (define x2 (contract b/c x1 'pos 'neg)) + (define x3 (contract c/c x2 'pos 'neg)) + + (send x3 p))) + + +) diff --git a/racket/collects/racket/private/class-c-old.rkt b/racket/collects/racket/private/class-c-old.rkt index a340551950..c4cfddb0ab 100644 --- a/racket/collects/racket/private/class-c-old.rkt +++ b/racket/collects/racket/private/class-c-old.rkt @@ -1341,17 +1341,7 @@ [old-classes (reverse old-classes)]) (cond [(null? projs) (list class)] - [else - (cons class - (cond - [(and (pair? old-ctcs) (eq? (car old-ctcs) (car ctcs))) - (loop (car old-classes) - (cdr ctcs) - (cdr projs) - (cdr old-ctcs) - (cdr old-classes))] - [else - (loop ((car projs) class) (cdr ctcs) (cdr projs) '() '())]))])))) + [else (loop ((car projs) class) (cdr ctcs) (cdr projs) '() '())])))) (impersonate-struct interposed-val object-ref