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

Fix blame for behavioral subtyping.

Browse Source 
- negative parties of interface contracts should be
    the interface itself
This commit is contained in:
Asumu Takikawa 2012-05-03 14:19:55 -04:00 committed by Stevie Strickland
parent 14da5dacc5
commit 61784877a0
2 changed files with 40 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2547,14 +2547,14 @@ An example
(get-interface-contract-info i8 'x)
'((#<procedure:c8> i8 #f i6) (#<procedure:c6> i6 i8 i2)
(#<procedure:c2> i2 i6 i1) (#<procedure:c1> i1 i2 #f)
'((#<procedure:c8> i8 #f i8) (#<procedure:c6> i6 i8 i6)
(#<procedure:c2> i2 i6 i2) (#<procedure:c1> i1 i2 #f)
(#<procedure:c7> i7 i8 i4) (#<procedure:c4> i4 i7 i2)
(#<procedure:c7> i7 i8 i7) (#<procedure:c4> i4 i7 i4)
(#<procedure:c3> i3 i4 i1)
(#<procedure:c3> i3 i4 i3)
(#<procedure:c5> i5 i7 i3))
(#<procedure:c5> i5 i7 i5))
|#
;; interface symbol -> (listof (list contract name (or blame #f) (or blame #f)))
;; traverse hierarchy to find ctc/blame info for a given method
@ -2579,8 +2579,8 @@ An example
[(not our-ctc) dedup-infos]
;; if the parent's don't contract it, then it's just our ctc
[(null? dedup-infos) (list (list our-ctc our-name #f #f))]
;; our ctc should have a negative party of the first parent
[else (cons (list our-ctc our-name #f (cadr (car dedup-infos)))
;; our ctc should have a negative party of ourself (for behav. subtyping)
[else (cons (list our-ctc our-name #f our-name)
;; replace occurrences of #f positive blame with this interface
(map (λ (info)
(if (not (caddr info))

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

@ -8517,7 +8517,7 @@
[i2<%> (interface (i1<%>) [m (->m integer? integer?)])]
[c% (class* object% (i2<%>) (super-new) (define/public (m x) x))])
(send (new c%) m 3.14))
"(interface i1<%>)")
"(interface i2<%>)")
(test/spec-failed
'interface-higher-order-5
@ -8526,7 +8526,38 @@
[c% (class* object% (i2<%>) (super-new) (define/public (m x) 3.14))])
(send (new c%) m 3))
"(class c%)")
(test/spec-failed
'interface-higher-order-6
'(let* ([i1<%> (interface () [m (->m integer? integer?)])]
[i2<%> (interface (i1<%>) [m (->m number? number?)])]
[c% (class* object% (i2<%>) (super-new) (define/public (m x) 3.14))])
(send (new c%) m 3))
"(interface i2<%>)")
(test/spec-passed
'interface-higher-order-7
'(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))])
(send (new c%) m 3)))
(test/spec-failed
'interface-higher-order-7
'(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))])
(send (new c%) m 3.14))
"top-level")
(test/spec-failed
'interface-higher-order-7
'(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))])
(send (new c%) m 3))
"(class c%)")
;
;
;