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

Ah, that'd be the issue. THE TESTS WERE WRONG. All's well, and I've even

Browse Source 
added a couple more tests to make sure we apply the projections in the right
order.

svn: r18176
This commit is contained in:
Stevie Strickland 2010-02-19 00:34:27 +00:00
parent 7fe863e792
commit b59955bc01
2 changed files with 48 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/scheme/private/class-internal.ss
View File

@ -2471,6 +2471,9 @@
[super-methods (if (null? (class/c-supers ctc)) [super-methods (if (null? (class/c-supers ctc))
(class-super-methods cls) (class-super-methods cls)
(make-vector method-width))] (make-vector method-width))]
[inner-projs (if (null? (class/c-inners ctc))
(class-inner-projs cls)
(make-vector method-width))]
[class-make (if name [class-make (if name
(make-naming-constructor (make-naming-constructor
struct:class struct:class
@ -2492,7 +2495,7 @@
(class-beta-methods cls) (class-beta-methods cls)
(class-meth-flags cls) (class-meth-flags cls)
(class-inner-projs cls) inner-projs
(class-field-width cls) (class-field-width cls)
(class-field-ht cls) (class-field-ht cls)
@ -2554,6 +2557,19 @@
[p ((contract-projection c) blame)]) [p ((contract-projection c) blame)])
(vector-set! super-methods i (p (vector-ref super-methods i)))))) (vector-set! super-methods i (p (vector-ref super-methods i))))))
;; Add inner projections
(unless (null? (class/c-inners ctc))
(let ([old-inner-projs (class-inner-projs cls)])
(for ([n (in-range method-width)])
(vector-set! inner-projs n (vector-ref old-inner-projs n))))
(let ([b (blame-swap blame)])
(for ([m (in-list (class/c-inners ctc))]
[c (in-list (class/c-inner-contracts ctc))])
(let ([i (hash-ref method-ht m)]
[p ((contract-projection c) b)])
(vector-set! inner-projs i
(compose (vector-ref inner-projs i) p))))))
c)))) c))))
(define-struct class/c (define-struct class/c

34
collects/tests/mzscheme/contract-test.ss
View File

@ -4364,7 +4364,7 @@
[d% (class c% (super-new) (define/augride (m x) (add1 x)))]) [d% (class c% (super-new) (define/augride (m x) (add1 x)))])
(send (new d%) m 3))) (send (new d%) m 3)))
(test/pos-blame (test/neg-blame
'class/c-higher-order-inner-2 'class/c-higher-order-inner-2
'(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)])) '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)]))
(class object% (super-new) (define/pubment (m x) (+ x (inner x m x)))) (class object% (super-new) (define/pubment (m x) (+ x (inner x m x))))
@ -4373,7 +4373,7 @@
[d% (class c% (super-new) (define/augride (m x) (zero? x)))]) [d% (class c% (super-new) (define/augride (m x) (zero? x)))])
(send (new d%) m 3))) (send (new d%) m 3)))
(test/neg-blame (test/pos-blame
'class/c-higher-order-inner-3 'class/c-higher-order-inner-3
'(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)])) '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)]))
(class object% (super-new) (define/pubment (m x) (+ x (inner x m (zero? x))))) (class object% (super-new) (define/pubment (m x) (+ x (inner x m (zero? x)))))
@ -4382,7 +4382,7 @@
[d% (class c% (super-new) (define/augride (m x) (add1 x)))]) [d% (class c% (super-new) (define/augride (m x) (add1 x)))])
(send (new d%) m 3))) (send (new d%) m 3)))
(test/pos-blame (test/neg-blame
'class/c-higher-order-inner-4 'class/c-higher-order-inner-4
'(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)])) '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)]))
(class object% (super-new) (define/pubment (m x) (+ x (inner x m x)))) (class object% (super-new) (define/pubment (m x) (+ x (inner x m x))))
@ -4401,6 +4401,34 @@
[d% (class c% (super-new) (define/augment (m x) (if (inner x m x) (add1 x) x)))] [d% (class c% (super-new) (define/augment (m x) (if (inner x m x) (add1 x) x)))]
[e% (class d% (super-new) (define/augride (m x) (zero? x)))]) [e% (class d% (super-new) (define/augride (m x) (zero? x)))])
(send (new e%) m 3))) (send (new e%) m 3)))
;; Make sure the order of the wrapping is correct in the next two.
(test/neg-blame
'class/c-higher-order-inner-6
'(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)]))
(class object% (super-new) (define/pubment (m x) (+ x (inner x m x))))
'pos
'neg1)]
[d% (contract (class/c (inner [m (-> any/c number? number?)]))
c%
'pos1
'neg)]
[e% (class d% (super-new) (define/augride (m x) (zero? x)))])
(send (new e%) m 3)))
(test/pos-blame
'class/c-higher-order-inner-7
'(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)]))
(class object% (super-new) (define/pubment (m x) (+ x (inner x m #f))))
'pos
'neg1)]
[d% (contract (class/c (inner [m (-> any/c number? number?)]))
c%
'pos1
'neg)]
[e% (class d% (super-new) (define/augride (m x) (add1 x)))])
(send (new e%) m 3)))
; ;
; ;
; ;; ;; ; ;; ; ;; ;; ; ;;