From 6cead90c1f44c72cac60d04391cbdde5c0cf1e02 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Fri, 18 May 2012 00:03:47 -0400 Subject: [PATCH] Fix bug in method concretization for interface ctcs There was a bug (unrelated to the last) caused by a bad mutation of a method table when creating copies of classes for interface contracts. --- collects/racket/private/class-internal.rkt | 27 ++++++---- collects/tests/racket/contract-test.rktl | 59 +++++++++++++++++++--- 2 files changed, 68 insertions(+), 18 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 517a86d26e..e84e04c989 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -3790,10 +3790,12 @@ An example [else ;; if there are contracted methods to concretize, do so (let* ([name (class-name cls)] + [ictc-meths (class-method-ictcs cls)] [method-width (class-method-width cls)] [method-ht (class-method-ht cls)] - [meths (class-methods cls)] - [ictc-meths (class-method-ictcs cls)] + [meths (if (null? ictc-meths) + (class-methods cls) + (make-vector method-width))] [field-pub-width (class-field-pub-width cls)] [field-ht (class-field-ht cls)] [class-make (if name @@ -3860,15 +3862,18 @@ An example (set-class-field-ref! c object-field-ref) (set-class-field-set!! c object-field-set!)) - ;; then apply the projections to get the concrete method - (vector-copy! meths 0 (class-methods cls)) - (for ([m (in-list ictc-meths)]) - (define index (hash-ref method-ht m)) - (define entry (vector-ref meths index)) - (define meth (car entry)) - (define ictc-infos (replace-ictc-blame (cadr entry) #f blame)) - (define wrapped-meth (concretize-ictc-method meth ictc-infos)) - (vector-set! meths index wrapped-meth)) + ;; Don't concretize if all concrete + (unless (null? ictc-meths) + ;; First, fill up since we're empty + (vector-copy! meths 0 (class-methods cls)) + ;; Then apply the projections to get the concrete methods + (for ([m (in-list ictc-meths)]) + (define index (hash-ref method-ht m)) + (define entry (vector-ref meths index)) + (define meth (car entry)) + (define ictc-infos (replace-ictc-blame (cadr entry) #f blame)) + (define wrapped-meth (concretize-ictc-method meth ictc-infos)) + (vector-set! meths index wrapped-meth))) (hash-set! (class-ictc-classes cls) blame c) c)])) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index f0cd00468e..ba7cd637ff 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -8508,7 +8508,7 @@ (send (new c%) m 3))) (test/spec-failed - 'interface-higher-order-7 + 'interface-higher-order-8 '(let* ([i1<%> (interface () [m (->m integer? number?)])] [i2<%> (interface (i1<%>) [m (->m number? integer?)])] [c% (class* object% (i2<%>) (super-new) (define/public (m x) x))]) @@ -8516,7 +8516,7 @@ "top-level") (test/spec-failed - 'interface-higher-order-7 + 'interface-higher-order-9 '(let* ([i1<%> (interface () [m (->m integer? number?)])] [i2<%> (interface (i1<%>) [m (->m number? integer?)])] [c% (class* object% (i2<%>) (super-new) (define/public (m x) 3.14))]) @@ -8524,7 +8524,7 @@ "(class c%)") (test/spec-passed - 'interface-higher-order-8 + 'interface-higher-order-10 '(let* ([i1<%> (interface () [m (->m integer? integer?)])] [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] [c% (class* object% (i2<%>) (super-new) (define/public (m x) x))] @@ -8532,7 +8532,7 @@ (send (new c2%) m 3))) (test/spec-passed - 'interface-higher-order-10 + 'interface-higher-order-11 '(let* ([i1<%> (interface () [m (->m integer? integer?)])] [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] [c% (contract (class/c) @@ -8542,7 +8542,7 @@ (send (new c%) m 3))) (test/neg-blame - 'interface-higher-order-11 + 'interface-higher-order-12 '(let* ([i1<%> (interface () [m (->m integer? integer?)])] [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] [c% (contract (class/c [m (->m integer? integer?)]) @@ -8552,7 +8552,7 @@ (send (new c%) m 5.14))) (test/spec-failed - 'interface-higher-order-11 + 'interface-higher-order-13 '(let* ([i1<%> (interface () [m (->m integer? integer?)])] [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] [c% (contract (class/c m) @@ -8563,7 +8563,7 @@ "pos") (test/spec-failed - 'interface-higher-order-12 + 'interface-higher-order-14 '(let* ([i1<%> (interface () [m (->m integer? integer?)])] [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] [c% (contract (class/c) @@ -8573,6 +8573,51 @@ (send (new c%) m 5.14)) "top-level") + (test/spec-passed + 'interface-internal-name-1 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (class* object% (i2<%>) + (super-new) + (public [n m]) + (define n (λ (x) x)))]) + (send (new c%) m 3))) + + (test/spec-passed + 'interface-internal-name-2 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (contract + (class/c [m (->m integer? integer?)]) + (class* object% (i2<%>) + (super-new) + (public [n m]) + (define n (λ (x) x))) + 'pos + 'neg)]) + (send (new c%) m 3))) + + (test/spec-passed + 'interface-mixin-1 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [mixin (λ (cls) + (class* cls (i2<%>) + (super-new) + (define/public (m x) x)))]) + (send (new (mixin object%)) m 3))) + + (test/spec-passed + 'interface-bad-concretization-1 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (class* object% (i2<%>) (super-new) (define/public (m x) x))] + [c2% (class c% (super-new))]) + (send (new c2%) m 3) + (with-contract region + #:result integer? + (send (new c2%) m 3)))) + ; ; ;