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

Forgot about the no-contract forms, so needed to add tests for those, also.

Browse Source 
svn: r18218
This commit is contained in:
Stevie Strickland 2010-02-20 10:40:50 +00:00
parent 7830d55b42
commit cd4aa4c6f6
2 changed files with 191 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2670,9 +2670,10 @@
;; Now apply projections ;; Now apply projections
(for ([m (in-list (class/c-methods ctc))] (for ([m (in-list (class/c-methods ctc))]
[c (in-list (class/c-method-contracts ctc))]) [c (in-list (class/c-method-contracts ctc))])
(when c
(let ([i (hash-ref method-ht m)] (let ([i (hash-ref method-ht m)]
[p ((contract-projection c) blame)]) [p ((contract-projection c) blame)])
(vector-set! methods i (p (vector-ref methods i)))))) (vector-set! methods i (p (vector-ref methods i)))))))
;; Handle super contracts ;; Handle super contracts
(unless (null? (class/c-supers ctc)) (unless (null? (class/c-supers ctc))
@ -2681,9 +2682,10 @@
;; Now apply projections. ;; Now apply projections.
(for ([m (in-list (class/c-supers ctc))] (for ([m (in-list (class/c-supers ctc))]
[c (in-list (class/c-super-contracts ctc))]) [c (in-list (class/c-super-contracts ctc))])
(when c
(let ([i (hash-ref method-ht m)] (let ([i (hash-ref method-ht m)]
[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 ;; Add inner projections
(unless (null? (class/c-inners ctc)) (unless (null? (class/c-inners ctc))
@ -2691,10 +2693,11 @@
(let ([b (blame-swap blame)]) (let ([b (blame-swap blame)])
(for ([m (in-list (class/c-inners ctc))] (for ([m (in-list (class/c-inners ctc))]
[c (in-list (class/c-inner-contracts ctc))]) [c (in-list (class/c-inner-contracts ctc))])
(when c
(let ([i (hash-ref method-ht m)] (let ([i (hash-ref method-ht m)]
[p ((contract-projection c) b)]) [p ((contract-projection c) b)])
(vector-set! inner-projs i (vector-set! inner-projs i
(compose (vector-ref inner-projs i) p)))))) (compose (vector-ref inner-projs i) p)))))))
;; Handle external field contracts ;; Handle external field contracts
(unless (null? (class/c-fields ctc)) (unless (null? (class/c-fields ctc))
@ -2703,6 +2706,7 @@
(let ([bset (blame-swap blame)]) (let ([bset (blame-swap blame)])
(for ([f (in-list (class/c-fields ctc))] (for ([f (in-list (class/c-fields ctc))]
[c (in-list (class/c-field-contracts ctc))]) [c (in-list (class/c-field-contracts ctc))])
(when c
(let* ([i (hash-ref field-ht f)] (let* ([i (hash-ref field-ht f)]
[pre-p (contract-projection c)] [pre-p (contract-projection c)]
[old-ref (vector-ref ext-field-refs i)] [old-ref (vector-ref ext-field-refs i)]
@ -2712,7 +2716,7 @@
((pre-p blame) (old-ref o)))) ((pre-p blame) (old-ref o))))
(vector-set! ext-field-sets i (vector-set! ext-field-sets i
(λ (o v) (λ (o v)
(old-set o ((pre-p bset) v)))))))) (old-set o ((pre-p bset) v)))))))))
;; Handle internal field contracts ;; Handle internal field contracts
(unless (null? (class/c-inherits ctc)) (unless (null? (class/c-inherits ctc))
@ -2721,6 +2725,7 @@
(let ([bset (blame-swap blame)]) (let ([bset (blame-swap blame)])
(for ([f (in-list (class/c-inherits ctc))] (for ([f (in-list (class/c-inherits ctc))]
[c (in-list (class/c-inherit-contracts ctc))]) [c (in-list (class/c-inherit-contracts ctc))])
(when c
(let* ([i (hash-ref field-ht f)] (let* ([i (hash-ref field-ht f)]
[pre-p (contract-projection c)] [pre-p (contract-projection c)]
[old-ref (vector-ref int-field-refs i)] [old-ref (vector-ref int-field-refs i)]
@ -2730,7 +2735,7 @@
((pre-p blame) (old-ref o)))) ((pre-p blame) (old-ref o))))
(vector-set! int-field-sets i (vector-set! int-field-sets i
(λ (o v) (λ (o v)
(old-set o ((pre-p bset) v)))))))) (old-set o ((pre-p bset) v)))))))))
;; Now the trickiest of them all, internal dynamic dispatch. ;; Now the trickiest of them all, internal dynamic dispatch.
(unless (and (null? (class/c-overrides ctc)) (unless (and (null? (class/c-overrides ctc))
@ -2740,6 +2745,7 @@
(let ([dynamic-projs (class-dynamic-projs cls)]) (let ([dynamic-projs (class-dynamic-projs cls)])
(for ([m (in-list methods)] (for ([m (in-list methods)]
[c (in-list ctcs)]) [c (in-list ctcs)])
(when c
(let* ([i (hash-ref method-ht m)] (let* ([i (hash-ref method-ht m)]
[p ((contract-projection c) [p ((contract-projection c)
(if swap-blame? (blame-swap blame) blame))] (if swap-blame? (blame-swap blame) blame))]
@ -2757,7 +2763,7 @@
(vector-set! proj-vec old-idx (vector-set! proj-vec old-idx
(if swap-blame? (if swap-blame?
(compose old-proj p) (compose old-proj p)
(compose p old-proj))))))))) (compose p old-proj))))))))))
(vector-copy! dynamic-idxs 0 (class-dynamic-idxs cls)) (vector-copy! dynamic-idxs 0 (class-dynamic-idxs cls))
(add-projections (class/c-overrides ctc) (add-projections (class/c-overrides ctc)
(class/c-override-contracts ctc) (class/c-override-contracts ctc)
@ -2781,22 +2787,22 @@
(λ (ctc) (λ (ctc)
(let* ([pair-ids-ctcs (let* ([pair-ids-ctcs
(λ (is ctcs) (λ (is ctcs)
(map (λ (i ctc) (for/list ([i (in-list is)]
(if (null? ctc) [ctc (in-list ctcs)])
(if (not ctc)
i i
(build-compound-type-name i ctc))) (build-compound-type-name i ctc))))]
is ctcs))]
[handle-optional [handle-optional
(λ (name is ctcs) (λ (name is ctcs)
(if (null? is) (if (null? is)
null null
(list (cons name (pair-ids-ctcs is ctcs)))))] (list (cons name (pair-ids-ctcs is ctcs)))))]
[handled-methods [handled-methods
(map (λ (i ctc) (for/list ([i (in-list (class/c-methods ctc))]
[ctc (in-list (class/c-method-contracts ctc))])
(cond (cond
[ctc (build-compound-type-name i ctc)] [ctc (build-compound-type-name i ctc)]
[else i])) [else i]))])
(class/c-methods ctc) (class/c-method-contracts ctc))])
(apply build-compound-type-name (apply build-compound-type-name
'class/c 'class/c
(append (append

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

@ -4102,6 +4102,27 @@
'pos 'pos
'neg)) '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 (test/pos-blame
'class/c-first-order-field-1 'class/c-first-order-field-1
'(contract (class/c (field [n number?])) '(contract (class/c (field [n number?]))
@ -4116,6 +4137,20 @@
'pos 'pos
'neg)) '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 (test/pos-blame
'class/c-first-order-inherit-field-1 'class/c-first-order-inherit-field-1
'(contract (class/c (inherit-field [n number?])) '(contract (class/c (inherit-field [n number?]))
@ -4130,6 +4165,20 @@
'pos 'pos
'neg)) '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 (test/pos-blame
'class/c-first-order-super-1 'class/c-first-order-super-1
'(contract (class/c (super [m (-> any/c number? number?)])) '(contract (class/c (super [m (-> any/c number? number?)]))
@ -4174,6 +4223,20 @@
'pos 'pos
'neg)) '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 (test/pos-blame
'class/c-first-order-inner-1 'class/c-first-order-inner-1
'(contract (class/c (inner [m (-> any/c number? number?)])) '(contract (class/c (inner [m (-> any/c number? number?)]))
@ -4220,6 +4283,21 @@
'pos 'pos
'neg)) '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 (test/pos-blame
'class/c-first-order-override-1 'class/c-first-order-override-1
'(contract (class/c (override [m (-> any/c number? number?)])) '(contract (class/c (override [m (-> any/c number? number?)]))
@ -4266,6 +4344,21 @@
'pos 'pos
'neg)) '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 (test/pos-blame
'class/c-first-order-augment-1 'class/c-first-order-augment-1
'(contract (class/c (augment [m (-> any/c number? number?)])) '(contract (class/c (augment [m (-> any/c number? number?)]))
@ -4312,6 +4405,21 @@
'pos 'pos
'neg)) '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 (test/spec-passed
'class/c-higher-order-method-1 'class/c-higher-order-method-1
'(let ([c% (contract (class/c [m (-> any/c number? number?)]) '(let ([c% (contract (class/c [m (-> any/c number? number?)])
@ -4546,6 +4654,14 @@
[o (new c%)]) [o (new c%)])
(set-field! f o #f))) (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 (test/spec-passed/result
'class/c-higher-order-inherit-1 'class/c-higher-order-inherit-1
'(let* ([c% (contract (class/c (inherit-field [f number?])) '(let* ([c% (contract (class/c (inherit-field [f number?]))
@ -4594,6 +4710,17 @@
(define/public (m) (set! f #f)))]) (define/public (m) (set! f #f)))])
(send (new d%) m))) (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 (test/spec-passed
'class/c-higher-order-override-1 'class/c-higher-order-override-1
'(let* ([c% (contract (class/c (override [m (-> any/c integer? integer?)])) '(let* ([c% (contract (class/c (override [m (-> any/c integer? integer?)]))