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

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

@ -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

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

@ -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?)]))