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

fix class/c first-order check for interface contracts

Browse Source
This commit is contained in:
Robby Findler 2013-12-13 16:20:59 -06:00
parent 52c74701ec
commit 14645b8cc5
3 changed files with 21 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
pkgs/racket-pkgs/racket-test/tests/racket/contract/first-order.rkt
View File

@ -194,4 +194,17 @@
(ctest #f contract-first-order-passes? (ctest #f contract-first-order-passes?
(class/c [m (->m integer? integer?)]) (class/c [m (->m integer? integer?)])
(class object% (class object%
(define/public (m x y) x)))) (define/public (m x y) x)))
(ctest #f contract-first-order-passes?
(class/c [m (->m integer? integer?)])
(class* object% ((interface () [m (-> any/c integer? integer? any/c)]))
(define/public (m x y) x)))
(ctest #t contract-first-order-passes?
(class/c [m (-> any/c integer? integer?)])
(class* object% ((interface () [m (-> any/c integer? integer?)]))
(define/public (m x) x)))
)

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

@ -2817,9 +2817,12 @@ An example
[c (in-list (class/c-method-contracts ctc))]) [c (in-list (class/c-method-contracts ctc))])
(define mth (hash-ref method-ht m #f)) (define mth (hash-ref method-ht m #f))
(unless mth (fail "no public method ~a" m)) (unless mth (fail "no public method ~a" m))
(unless (contract-first-order-passes? (define meth-proc
c (let loop ([m/l (vector-ref methods mth)])
(vector-ref methods mth)) (cond
[(pair? m/l) (loop (car m/l))]
[else m/l])))
(unless (contract-first-order-passes? c meth-proc)
(fail "public method ~a doesn't match contract" m))) (fail "public method ~a doesn't match contract" m)))
(unless (class/c-opaque? ctc) (unless (class/c-opaque? ctc)
(for ([m (class/c-absents ctc)]) (for ([m (class/c-absents ctc)])