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 ;; 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))])
(let ([i (hash-ref method-ht m)] (when c
[p ((contract-projection c) blame)]) (let ([i (hash-ref method-ht m)]
(vector-set! methods i (p (vector-ref methods i)))))) [p ((contract-projection c) blame)])
(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))])
(let ([i (hash-ref method-ht m)] (when c
[p ((contract-projection c) blame)]) (let ([i (hash-ref method-ht m)]
(vector-set! super-methods i (p (vector-ref super-methods i)))))) [p ((contract-projection c) blame)])
(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))])
(let ([i (hash-ref method-ht m)] (when c
[p ((contract-projection c) b)]) (let ([i (hash-ref method-ht m)]
(vector-set! inner-projs i [p ((contract-projection c) b)])
(compose (vector-ref inner-projs i) p)))))) (vector-set! inner-projs i
(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,16 +2706,17 @@
(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))])
(let* ([i (hash-ref field-ht f)] (when c
[pre-p (contract-projection c)] (let* ([i (hash-ref field-ht f)]
[old-ref (vector-ref ext-field-refs i)] [pre-p (contract-projection c)]
[old-set (vector-ref ext-field-sets i)]) [old-ref (vector-ref ext-field-refs i)]
(vector-set! ext-field-refs i [old-set (vector-ref ext-field-sets i)])
(λ (o) (vector-set! ext-field-refs i
((pre-p blame) (old-ref o)))) (λ (o)
(vector-set! ext-field-sets i ((pre-p blame) (old-ref o))))
(λ (o v) (vector-set! ext-field-sets i
(old-set o ((pre-p bset) v)))))))) (λ (o 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,16 +2725,17 @@
(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))])
(let* ([i (hash-ref field-ht f)] (when c
[pre-p (contract-projection c)] (let* ([i (hash-ref field-ht f)]
[old-ref (vector-ref int-field-refs i)] [pre-p (contract-projection c)]
[old-set (vector-ref int-field-sets i)]) [old-ref (vector-ref int-field-refs i)]
(vector-set! int-field-refs i [old-set (vector-ref int-field-sets i)])
(λ (o) (vector-set! int-field-refs i
((pre-p blame) (old-ref o)))) (λ (o)
(vector-set! int-field-sets i ((pre-p blame) (old-ref o))))
(λ (o v) (vector-set! int-field-sets i
(old-set o ((pre-p bset) v)))))))) (λ (o 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,24 +2745,25 @@
(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)])
(let* ([i (hash-ref method-ht m)] (when c
[p ((contract-projection c) (let* ([i (hash-ref method-ht m)]
(if swap-blame? (blame-swap blame) blame))] [p ((contract-projection c)
[old-idx (vector-ref dynamic-idxs i)] (if swap-blame? (blame-swap blame) blame))]
[proj-vec (vector-ref dynamic-projs i)]) [old-idx (vector-ref dynamic-idxs i)]
(if (= old-idx (vector-length proj-vec)) [proj-vec (vector-ref dynamic-projs i)])
(let* ([last-idx (sub1 old-idx)] (if (= old-idx (vector-length proj-vec))
[old-proj (vector-ref proj-vec last-idx)]) (let* ([last-idx (sub1 old-idx)]
(vector-set! proj-vec last-idx [old-proj (vector-ref proj-vec last-idx)])
(if swap-blame? (vector-set! proj-vec last-idx
(compose old-proj p) (if swap-blame?
(compose p old-proj)))) (compose old-proj p)
(let ([old-proj (vector-ref proj-vec old-idx)]) (compose p old-proj))))
(vector-set! dynamic-idxs i (add1 old-idx)) (let ([old-proj (vector-ref proj-vec old-idx)])
(vector-set! proj-vec old-idx (vector-set! dynamic-idxs i (add1 old-idx))
(if swap-blame? (vector-set! proj-vec old-idx
(compose old-proj p) (if swap-blame?
(compose p old-proj))))))))) (compose old-proj p)
(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)])
i (if (not ctc)
(build-compound-type-name i ctc))) i
is ctcs))] (build-compound-type-name i ctc))))]
[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))]
(cond [ctc (in-list (class/c-method-contracts ctc))])
[ctc (build-compound-type-name i ctc)] (cond
[else i])) [ctc (build-compound-type-name i ctc)]
(class/c-methods ctc) (class/c-method-contracts ctc))]) [else i]))])
(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?]))
@ -4115,6 +4136,20 @@
(class object% (super-new) (field [n 3])) (class object% (super-new) (field [n 3]))
'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
@ -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?)]))
@ -4265,6 +4343,21 @@
(class d% (super-new) (define/augride (m x) x))) (class d% (super-new) (define/augride (m x) x)))
'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
@ -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?)])
@ -4545,6 +4653,14 @@
'neg)] 'neg)]
[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
@ -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?)]))