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

Fix a bug with class/c & interface ctc interaction

Browse Source 
Method concretization did not occur properly when particular
class contracts were applied along with interface contracts.
This commit is contained in:
Asumu Takikawa 2012-05-17 22:10:50 -04:00
parent d430656a03
commit 9d5aa5eec5
2 changed files with 66 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2761,6 +2761,8 @@ An example
(class-pos cls))] (class-pos cls))]
[method-width (class-method-width cls)] [method-width (class-method-width cls)]
[method-ht (class-method-ht cls)] [method-ht (class-method-ht cls)]
[method-ictcs (class-method-ictcs cls)]
[ctc-methods (class/c-methods ctc)]
[dynamic-features [dynamic-features
(append (class/c-overrides ctc) (append (class/c-overrides ctc)
(class/c-augments ctc) (class/c-augments ctc)
@ -2771,7 +2773,7 @@ An example
(class/c-augment-contracts ctc) (class/c-augment-contracts ctc)
(class/c-augride-contracts ctc) (class/c-augride-contracts ctc)
(class/c-inherit-contracts ctc))] (class/c-inherit-contracts ctc))]
[methods (if (null? (class/c-methods ctc)) [methods (if (null? ctc-methods)
(class-methods cls) (class-methods cls)
(make-vector method-width))] (make-vector method-width))]
[super-methods (if (null? (class/c-supers ctc)) [super-methods (if (null? (class/c-supers ctc))
@ -2810,7 +2812,7 @@ An example
method-width method-width
method-ht method-ht
(class-method-ids cls) (class-method-ids cls)
null (remq* ctc-methods method-ictcs)
(make-weak-hasheq) (make-weak-hasheq)
@ -2870,21 +2872,23 @@ An example
(set-class-field-set!! c object-field-set!)) (set-class-field-set!! c object-field-set!))
;; Handle public method contracts ;; Handle public method contracts
(unless (null? (class/c-methods ctc)) (unless (null? ctc-methods)
;; First, fill in from old methods ;; First, fill in from old methods
(vector-copy! methods 0 (class-methods cls)) (vector-copy! methods 0 (class-methods cls))
;; Concretize any interface contracts first ;; Concretize any interface contracts handled by this ctc
(unless (null? (class-method-ictcs cls)) (unless (null? (class-method-ictcs cls))
(for ([m (in-list (class-method-ictcs cls))]) (for ([m (in-list (class-method-ictcs cls))])
(define i (hash-ref method-ht m)) ;; only concretize if class/c takes responsibility for it
(define entry (vector-ref methods i)) (when (memq m ctc-methods)
;; we're passing through a contract boundary, so the positive blame (aka (define i (hash-ref method-ht m))
;; value server) is taking responsibility for any interface-contracted (define entry (vector-ref methods i))
;; methods) ;; we're passing through a contract boundary, so the positive blame (aka
(define info (replace-ictc-blame (cadr entry) #f (blame-positive blame))) ;; value server) is taking responsibility for any interface-contracted
(vector-set! methods i (concretize-ictc-method (car entry) info)))) ;; methods)
(define info (replace-ictc-blame (cadr entry) #f (blame-positive blame)))
(vector-set! methods i (concretize-ictc-method (car entry) info)))))
;; Now apply projections ;; Now apply projections
(for ([m (in-list (class/c-methods ctc))] (for ([m (in-list ctc-methods)]
[c (in-list (class/c-method-contracts ctc))]) [c (in-list (class/c-method-contracts ctc))])
(when c (when c
(define i (hash-ref method-ht m)) (define i (hash-ref method-ht m))

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

@ -8523,6 +8523,56 @@
(send (new c%) m 3)) (send (new c%) m 3))
"(class c%)") "(class c%)")
(test/spec-passed
'interface-higher-order-8
'(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)))
(test/spec-passed
'interface-higher-order-10
'(let* ([i1<%> (interface () [m (->m integer? integer?)])]
[i2<%> (interface (i1<%>) [m (->m integer? integer?)])]
[c% (contract (class/c)
(class* object% (i2<%>) (super-new) (define/public (m x) x))
'pos
'neg)])
(send (new c%) m 3)))
(test/neg-blame
'interface-higher-order-11
'(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) (define/public (m x) x))
'pos
'neg)])
(send (new c%) m 5.14)))
(test/spec-failed
'interface-higher-order-11
'(let* ([i1<%> (interface () [m (->m integer? integer?)])]
[i2<%> (interface (i1<%>) [m (->m integer? integer?)])]
[c% (contract (class/c m)
(class* object% (i2<%>) (super-new) (define/public (m x) x))
'pos
'neg)])
(send (new c%) m 5.14))
"pos")
(test/spec-failed
'interface-higher-order-12
'(let* ([i1<%> (interface () [m (->m integer? integer?)])]
[i2<%> (interface (i1<%>) [m (->m integer? integer?)])]
[c% (contract (class/c)
(class* object% (i2<%>) (super-new) (define/public (m x) x))
'pos
'neg)])
(send (new c%) m 5.14))
"top-level")
; ;
; ;
; ;