suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix bug in method concretization for interface ctcs

Browse Source 
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.
This commit is contained in:
Asumu Takikawa 2012-05-18 00:03:47 -04:00
parent 9d5aa5eec5
commit 6cead90c1f
2 changed files with 68 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
collects/racket/private/class-internal.rkt
View File

@ -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)]))

59
collects/tests/racket/contract-test.rktl
View File

@ -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))))
;
;
;