From b5e2d5f93e51ef6ea36bb619d7244ba9e793552f Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 20 Feb 2010 09:30:40 +0000 Subject: [PATCH] Okay, now override contracts are done, so only augments remain. svn: r18214 --- collects/scheme/private/class-internal.ss | 19 +++++-- collects/tests/mzscheme/contract-test.ss | 65 ++++++++++++++++++----- 2 files changed, 67 insertions(+), 17 deletions(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 4d5bf25152..4bc812fb1d 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -2723,13 +2723,22 @@ ;; Now the trickiest of them all, internal dynamic dispatch. (unless (null? (class/c-overrides ctc)) (vector-copy! dynamic-idxs 0 (class-dynamic-idxs cls)) - (let ([int-methods (class-int-methods cls)]) - (for ([m (in-list (class/c-overrides ctc))]) + (let ([dynamic-projs (class-dynamic-projs cls)]) + (for ([m (in-list (class/c-overrides ctc))] + [c (in-list (class/c-override-contracts ctc))]) (let* ([i (hash-ref method-ht m)] + [p ((contract-projection c) (blame-swap blame))] [old-idx (vector-ref dynamic-idxs i)] - [int-vec (vector-ref int-methods i)]) - (unless (= old-idx (vector-length int-vec)) - (vector-set! dynamic-idxs i (add1 old-idx))))))) + [proj-vec (vector-ref dynamic-projs i)]) + (if (= old-idx (vector-length proj-vec)) + (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)))) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 651d8a7d81..8af64a4f29 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -4596,52 +4596,93 @@ (test/spec-passed '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) (define/public (m x) x) (define/public (f x) (m x))) 'pos 'neg)] - [d% (class c% (super-new) - (define/override (m x) (add1 (super m x))))]) + [d% (class c% (super-new) (define/override (m x) (add1 (super m x))))]) (send (new d%) f 3))) (test/neg-blame '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) (define/public (m x) x) (define/public (f x) (add1 (m x)))) 'pos 'neg)] - [d% (class c% (super-new) - (define/override (m x) (zero? (super m x))))]) + [d% (class c% (super-new) (define/override (m x) (zero? (super m x))))]) (send (new d%) f 3))) (test/neg-blame '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) (define/public (m x) (zero? x)) (define/public (f x) (add1 (m x)))) 'pos 'neg)] - [d% (class c% (super-new) - (define/override (m x) (super m x)))]) + [d% (class c% (super-new) (define/override (m x) (super m x)))]) (send (new d%) f 3))) (test/pos-blame '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) (define/public (m x) x) (define/public (f x) (add1 (m #f)))) 'pos 'neg)] - [d% (class c% (super-new) - (define/override (m x) (+ x (super m x))))]) + [d% (class c% (super-new) (define/override (m x) (+ x (super m x))))]) (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))) + ; ; ; ;; ;; ; ;;