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

Okay, now override contracts are done, so only augments remain.

Browse Source 
svn: r18214
This commit is contained in:
Stevie Strickland 2010-02-20 09:30:40 +00:00
parent 3c1004fd05
commit b5e2d5f93e
2 changed files with 67 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2723,13 +2723,22 @@
;; Now the trickiest of them all, internal dynamic dispatch. ;; Now the trickiest of them all, internal dynamic dispatch.
(unless (null? (class/c-overrides ctc)) (unless (null? (class/c-overrides ctc))
(vector-copy! dynamic-idxs 0 (class-dynamic-idxs cls)) (vector-copy! dynamic-idxs 0 (class-dynamic-idxs cls))
(let ([int-methods (class-int-methods cls)]) (let ([dynamic-projs (class-dynamic-projs cls)])
(for ([m (in-list (class/c-overrides ctc))]) (for ([m (in-list (class/c-overrides ctc))]
[c (in-list (class/c-override-contracts ctc))])
(let* ([i (hash-ref method-ht m)] (let* ([i (hash-ref method-ht m)]
[p ((contract-projection c) (blame-swap blame))]
[old-idx (vector-ref dynamic-idxs i)] [old-idx (vector-ref dynamic-idxs i)]
[int-vec (vector-ref int-methods i)]) [proj-vec (vector-ref dynamic-projs i)])
(unless (= old-idx (vector-length int-vec)) (if (= old-idx (vector-length proj-vec))
(vector-set! dynamic-idxs i (add1 old-idx))))))) (let* ([last-idx (sub1 old-idx)]
[old-proj (vector-ref proj-vec last-idx)])
(vector-set! proj-vec last-idx
(compose old-proj p)))
(let ([old-proj (vector-ref proj-vec old-idx)])
(vector-set! dynamic-idxs i (add1 old-idx))
(vector-set! proj-vec old-idx
(compose old-proj p))))))))
c)))) c))))

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

@ -4596,52 +4596,93 @@
(test/spec-passed (test/spec-passed
'class/c-higher-order-override-1 'class/c-higher-order-override-1
'(let* ([c% (contract (class/c (override [m (-> number? number?)])) '(let* ([c% (contract (class/c (override [m (-> any/c number? number?)]))
(class object% (super-new) (class object% (super-new)
(define/public (m x) x) (define/public (m x) x)
(define/public (f x) (m x))) (define/public (f x) (m x)))
'pos 'pos
'neg)] 'neg)]
[d% (class c% (super-new) [d% (class c% (super-new) (define/override (m x) (add1 (super m x))))])
(define/override (m x) (add1 (super m x))))])
(send (new d%) f 3))) (send (new d%) f 3)))
(test/neg-blame (test/neg-blame
'class/c-higher-order-override-2 'class/c-higher-order-override-2
'(let* ([c% (contract (class/c (override [m (-> number? number?)])) '(let* ([c% (contract (class/c (override [m (-> any/c number? number?)]))
(class object% (super-new) (class object% (super-new)
(define/public (m x) x) (define/public (m x) x)
(define/public (f x) (add1 (m x)))) (define/public (f x) (add1 (m x))))
'pos 'pos
'neg)] 'neg)]
[d% (class c% (super-new) [d% (class c% (super-new) (define/override (m x) (zero? (super m x))))])
(define/override (m x) (zero? (super m x))))])
(send (new d%) f 3))) (send (new d%) f 3)))
(test/neg-blame (test/neg-blame
'class/c-higher-order-override-3 'class/c-higher-order-override-3
'(let* ([c% (contract (class/c (override [m (-> number? number?)])) '(let* ([c% (contract (class/c (override [m (-> any/c number? number?)]))
(class object% (super-new) (class object% (super-new)
(define/public (m x) (zero? x)) (define/public (m x) (zero? x))
(define/public (f x) (add1 (m x)))) (define/public (f x) (add1 (m x))))
'pos 'pos
'neg)] 'neg)]
[d% (class c% (super-new) [d% (class c% (super-new) (define/override (m x) (super m x)))])
(define/override (m x) (super m x)))])
(send (new d%) f 3))) (send (new d%) f 3)))
(test/pos-blame (test/pos-blame
'class/c-higher-order-override-4 'class/c-higher-order-override-4
'(let* ([c% (contract (class/c (override [m (-> number? number?)])) '(let* ([c% (contract (class/c (override [m (-> any/c number? number?)]))
(class object% (super-new) (class object% (super-new)
(define/public (m x) x) (define/public (m x) x)
(define/public (f x) (add1 (m #f)))) (define/public (f x) (add1 (m #f))))
'pos 'pos
'neg)] 'neg)]
[d% (class c% (super-new) [d% (class c% (super-new) (define/override (m x) (+ x (super m x))))])
(define/override (m x) (+ x (super m x))))])
(send (new d%) f 3))) (send (new d%) f 3)))
(test/pos-blame
'class/c-higher-order-override-5
'(let* ([c% (contract (class/c (override [m (-> any/c number? number?)]))
(class object% (super-new)
(define/public (m x) x)
(define/public (f x) (add1 (m #f))))
'pos
'neg1)]
[d% (contract (class/c (override [m (-> any/c string? string?)]))
c%
'pos1
'neg)]
[e% (class d% (super-new) (define/override (m x) (+ x (super m x))))])
(send (new e%) f 3)))
(test/spec-passed
'class/c-higher-order-override-6
'(let* ([c% (contract (class/c (override [m (-> any/c number? number?)]))
(class object% (super-new)
(define/public (m x) x)
(define/public (f x) (add1 (m 3.5))))
'pos
'neg1)]
[d% (contract (class/c (override [m (-> any/c integer? integer?)]))
(class c% (super-new) (define/public (g x) (add1 (m 3))))
'pos1
'neg)]
[e% (class d% (super-new) (define/override (m x) (+ x (super m x))))])
(send (new e%) g 3)))
(test/pos-blame
'class/c-higher-order-override-6
'(let* ([c% (contract (class/c (override [m (-> any/c number? number?)]))
(class object% (super-new)
(define/public (m x) x)
(define/public (f x) (add1 (m #f))))
'pos
'neg1)]
[d% (contract (class/c (override [m (-> any/c integer? integer?)]))
(class c% (super-new) (define/public (g x) (add1 (m 3))))
'pos1
'neg)]
[e% (class d% (super-new) (define/override (m x) (+ x (super m x))))])
(send (new e%) f 3)))
; ;
; ;
; ;; ;; ; ;; ; ;; ;; ; ;;