From cd4aa4c6f6b88491701042fb14f7c99edef8b4f0 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 20 Feb 2010 10:40:50 +0000 Subject: [PATCH] Forgot about the no-contract forms, so needed to add tests for those, also. svn: r18218 --- collects/scheme/private/class-internal.ss | 122 +++++++++++---------- collects/tests/mzscheme/contract-test.ss | 127 ++++++++++++++++++++++ 2 files changed, 191 insertions(+), 58 deletions(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 8429af6eb6..6d0a2ed1df 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -2670,9 +2670,10 @@ ;; Now apply projections (for ([m (in-list (class/c-methods ctc))] [c (in-list (class/c-method-contracts ctc))]) - (let ([i (hash-ref method-ht m)] - [p ((contract-projection c) blame)]) - (vector-set! methods i (p (vector-ref methods i)))))) + (when c + (let ([i (hash-ref method-ht m)] + [p ((contract-projection c) blame)]) + (vector-set! methods i (p (vector-ref methods i))))))) ;; Handle super contracts (unless (null? (class/c-supers ctc)) @@ -2681,9 +2682,10 @@ ;; Now apply projections. (for ([m (in-list (class/c-supers ctc))] [c (in-list (class/c-super-contracts ctc))]) - (let ([i (hash-ref method-ht m)] - [p ((contract-projection c) blame)]) - (vector-set! super-methods i (p (vector-ref super-methods i)))))) + (when c + (let ([i (hash-ref method-ht m)] + [p ((contract-projection c) blame)]) + (vector-set! super-methods i (p (vector-ref super-methods i))))))) ;; Add inner projections (unless (null? (class/c-inners ctc)) @@ -2691,10 +2693,11 @@ (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)))))) + (when c + (let ([i (hash-ref method-ht m)] + [p ((contract-projection c) b)]) + (vector-set! inner-projs i + (compose (vector-ref inner-projs i) p))))))) ;; Handle external field contracts (unless (null? (class/c-fields ctc)) @@ -2703,16 +2706,17 @@ (let ([bset (blame-swap blame)]) (for ([f (in-list (class/c-fields ctc))] [c (in-list (class/c-field-contracts ctc))]) - (let* ([i (hash-ref field-ht f)] - [pre-p (contract-projection c)] - [old-ref (vector-ref ext-field-refs i)] - [old-set (vector-ref ext-field-sets i)]) - (vector-set! ext-field-refs i - (λ (o) - ((pre-p blame) (old-ref o)))) - (vector-set! ext-field-sets i - (λ (o v) - (old-set o ((pre-p bset) v)))))))) + (when c + (let* ([i (hash-ref field-ht f)] + [pre-p (contract-projection c)] + [old-ref (vector-ref ext-field-refs i)] + [old-set (vector-ref ext-field-sets i)]) + (vector-set! ext-field-refs i + (λ (o) + ((pre-p blame) (old-ref o)))) + (vector-set! ext-field-sets i + (λ (o v) + (old-set o ((pre-p bset) v))))))))) ;; Handle internal field contracts (unless (null? (class/c-inherits ctc)) @@ -2721,16 +2725,17 @@ (let ([bset (blame-swap blame)]) (for ([f (in-list (class/c-inherits ctc))] [c (in-list (class/c-inherit-contracts ctc))]) - (let* ([i (hash-ref field-ht f)] - [pre-p (contract-projection c)] - [old-ref (vector-ref int-field-refs i)] - [old-set (vector-ref int-field-sets i)]) - (vector-set! int-field-refs i - (λ (o) - ((pre-p blame) (old-ref o)))) - (vector-set! int-field-sets i - (λ (o v) - (old-set o ((pre-p bset) v)))))))) + (when c + (let* ([i (hash-ref field-ht f)] + [pre-p (contract-projection c)] + [old-ref (vector-ref int-field-refs i)] + [old-set (vector-ref int-field-sets i)]) + (vector-set! int-field-refs i + (λ (o) + ((pre-p blame) (old-ref o)))) + (vector-set! int-field-sets i + (λ (o v) + (old-set o ((pre-p bset) v))))))))) ;; Now the trickiest of them all, internal dynamic dispatch. (unless (and (null? (class/c-overrides ctc)) @@ -2740,24 +2745,25 @@ (let ([dynamic-projs (class-dynamic-projs cls)]) (for ([m (in-list methods)] [c (in-list ctcs)]) - (let* ([i (hash-ref method-ht m)] - [p ((contract-projection c) - (if swap-blame? (blame-swap blame) blame))] - [old-idx (vector-ref dynamic-idxs i)] - [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 - (if swap-blame? - (compose old-proj p) - (compose p old-proj)))) - (let ([old-proj (vector-ref proj-vec old-idx)]) - (vector-set! dynamic-idxs i (add1 old-idx)) - (vector-set! proj-vec old-idx - (if swap-blame? - (compose old-proj p) - (compose p old-proj))))))))) + (when c + (let* ([i (hash-ref method-ht m)] + [p ((contract-projection c) + (if swap-blame? (blame-swap blame) blame))] + [old-idx (vector-ref dynamic-idxs i)] + [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 + (if swap-blame? + (compose old-proj p) + (compose p old-proj)))) + (let ([old-proj (vector-ref proj-vec old-idx)]) + (vector-set! dynamic-idxs i (add1 old-idx)) + (vector-set! proj-vec old-idx + (if swap-blame? + (compose old-proj p) + (compose p old-proj)))))))))) (vector-copy! dynamic-idxs 0 (class-dynamic-idxs cls)) (add-projections (class/c-overrides ctc) (class/c-override-contracts ctc) @@ -2781,22 +2787,22 @@ (λ (ctc) (let* ([pair-ids-ctcs (λ (is ctcs) - (map (λ (i ctc) - (if (null? ctc) - i - (build-compound-type-name i ctc))) - is ctcs))] + (for/list ([i (in-list is)] + [ctc (in-list ctcs)]) + (if (not ctc) + i + (build-compound-type-name i ctc))))] [handle-optional (λ (name is ctcs) (if (null? is) null (list (cons name (pair-ids-ctcs is ctcs)))))] [handled-methods - (map (λ (i ctc) - (cond - [ctc (build-compound-type-name i ctc)] - [else i])) - (class/c-methods ctc) (class/c-method-contracts ctc))]) + (for/list ([i (in-list (class/c-methods ctc))] + [ctc (in-list (class/c-method-contracts ctc))]) + (cond + [ctc (build-compound-type-name i ctc)] + [else i]))]) (apply build-compound-type-name 'class/c (append diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index c895f6ba18..035cc09d96 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -4102,6 +4102,27 @@ 'pos 'neg)) + (test/pos-blame + 'class/c-first-order-method-3 + '(contract (class/c [m (-> any/c number? number?)]) + (class object% (super-new) (define/public (m) 3)) + 'pos + 'neg)) + + (test/pos-blame + 'class/c-first-order-method-4 + '(contract (class/c m) + object% + 'pos + 'neg)) + + (test/spec-passed + 'class/c-first-order-method-4 + '(contract (class/c m) + (class object% (super-new) (define/public (m) 3)) + 'pos + 'neg)) + (test/pos-blame 'class/c-first-order-field-1 '(contract (class/c (field [n number?])) @@ -4115,6 +4136,20 @@ (class object% (super-new) (field [n 3])) 'pos 'neg)) + + (test/pos-blame + 'class/c-first-order-field-3 + '(contract (class/c (field n)) + object% + 'pos + 'neg)) + + (test/spec-passed + 'class/c-first-order-field-4 + '(contract (class/c (field n)) + (class object% (super-new) (field [n 3])) + 'pos + 'neg)) (test/pos-blame 'class/c-first-order-inherit-field-1 @@ -4130,6 +4165,20 @@ 'pos 'neg)) + (test/pos-blame + 'class/c-first-order-inherit-field-3 + '(contract (class/c (inherit-field f)) + object% + 'pos + 'neg)) + + (test/spec-passed + 'class/c-first-order-inherit-field-4 + '(contract (class/c (inherit-field f)) + (class object% (super-new) (field [f 10])) + 'pos + 'neg)) + (test/pos-blame 'class/c-first-order-super-1 '(contract (class/c (super [m (-> any/c number? number?)])) @@ -4174,6 +4223,20 @@ 'pos 'neg)) + (test/pos-blame + 'class/c-first-order-super-7 + '(contract (class/c (super m)) + object% + 'pos + 'neg)) + + (test/spec-passed + 'class/c-first-order-super-8 + '(contract (class/c (super m)) + (class object% (super-new) (define/public (m) 3)) + 'pos + 'neg)) + (test/pos-blame 'class/c-first-order-inner-1 '(contract (class/c (inner [m (-> any/c number? number?)])) @@ -4220,6 +4283,21 @@ 'pos 'neg)) + (test/pos-blame + 'class/c-first-order-inner-7 + '(contract (class/c (inner m)) + object% + 'pos + 'neg)) + + (test/spec-passed + 'class/c-first-order-inner-8 + '(let* ([c% (contract (class/c (inner m)) + (class object% (super-new) (define/pubment (m) (inner 3 m))) + 'pos + 'neg)]) + (class c% (super-new) (define/augment (m) 5)))) + (test/pos-blame 'class/c-first-order-override-1 '(contract (class/c (override [m (-> any/c number? number?)])) @@ -4265,6 +4343,21 @@ (class d% (super-new) (define/augride (m x) x))) 'pos 'neg)) + + (test/pos-blame + 'class/c-first-order-override-7 + '(contract (class/c (override m)) + object% + 'pos + 'neg)) + + (test/spec-passed + 'class/c-first-order-override-8 + '(let ([c% (contract (class/c (override m)) + (class object% (super-new) (define/public (m) 3)) + 'pos + 'neg)]) + (class c% (super-new) (define/override (m) 5)))) (test/pos-blame 'class/c-first-order-augment-1 @@ -4312,6 +4405,21 @@ 'pos 'neg)) + (test/pos-blame + 'class/c-first-order-augment-7 + '(contract (class/c (augment m)) + object% + 'pos + 'neg)) + + (test/spec-passed + 'class/c-first-order-augment-8 + '(let ([c% (contract (class/c (augment m)) + (class object% (super-new) (define/pubment (m) 3)) + 'pos + 'neg)]) + (class c% (super-new) (inherit m)))) + (test/spec-passed 'class/c-higher-order-method-1 '(let ([c% (contract (class/c [m (-> any/c number? number?)]) @@ -4545,6 +4653,14 @@ 'neg)] [o (new c%)]) (set-field! f o #f))) + + (test/spec-passed + 'class/c-higher-order-field-5 + '(let ([c% (contract (class/c (field f)) + (class object% (super-new) (field [f 10])) + 'pos + 'neg)]) + (get-field f (new c%)))) (test/spec-passed/result 'class/c-higher-order-inherit-1 @@ -4594,6 +4710,17 @@ (define/public (m) (set! f #f)))]) (send (new d%) m))) + (test/spec-passed + 'class/c-higher-order-inherit-5 + '(let* ([c% (contract (class/c (inherit-field f)) + (class object% (super-new) (field [f 10])) + 'pos + 'neg)] + [d% (class c% (super-new) + (inherit-field f) + (define/public (m) f))]) + (send (new d%) m))) + (test/spec-passed 'class/c-higher-order-override-1 '(let* ([c% (contract (class/c (override [m (-> any/c integer? integer?)]))