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

Rename tests to be more specific, start inner tests, fix introduced bug.

Browse Source 
svn: r18164
This commit is contained in:
Stevie Strickland 2010-02-18 22:27:34 +00:00
parent 690b82da14
commit ce04db35a0
2 changed files with 87 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2399,51 +2399,51 @@
(if blame
(apply raise-blame-error blame cls str args)
(return #f)))
(define method-ht (class-method-ht cls))
(define beta-methods (class-beta-methods cls))
(define meth-flags (class-meth-flags cls))
(unless (class? cls)
(failed "not a class"))
(for ([m (class/c-methods ctc)])
(unless (hash-ref method-ht m #f)
(failed "no public method ~a" m)))
(for ([m (class/c-overrides ctc)])
(let ([index (hash-ref method-ht m #f)])
(unless index
(failed "no public method ~a" m))
(let ([vec (vector-ref beta-methods index)])
(unless (zero? (vector-length vec))
(failed "method ~a was previously augmentable" m)))
(let ([flag (vector-ref meth-flags index)])
(when (eq? flag 'final)
(failed "method ~a is final, not overrideable" m)))))
(for ([m (class/c-augments ctc)])
(let ([index (hash-ref method-ht m #f)])
(unless index
(failed "no public method ~a" m))
(let ([vec (vector-ref beta-methods index)])
(when (zero? (vector-length vec))
(failed "method ~a has never been augmentable" m)))))
(for ([s (class/c-supers ctc)])
(let ([index (hash-ref method-ht s #f)])
(unless index
(failed "no public method ~a" s))
(let ([flag (vector-ref meth-flags index)])
(when (eq? flag 'final)
(failed "method ~a is final, not overrideable" s))
(when (eq? flag 'augmentable)
(failed "method ~a is augmentable, not overrideable" s)))))
(for ([i (class/c-inners ctc)])
(let ([index (hash-ref method-ht i #f)])
(unless index
(failed "no public method ~a" i))
(let* ([super (vector-ref (class-supers cls) (sub1 (class-pos cls)))])
(unless (eq? (vector-ref meth-flags index) 'augmentable)
(failed "method ~a is not augmentable" i)))))
(let ([field-ht (class-field-ht cls)])
(for ([m (class/c-fields ctc)])
(unless (hash-ref field-ht m #f)
(failed "no public field ~a" m))))
(let ([method-ht (class-method-ht cls)]
[beta-methods (class-beta-methods cls)]
[meth-flags (class-meth-flags cls)])
(for ([m (class/c-methods ctc)])
(unless (hash-ref method-ht m #f)
(failed "no public method ~a" m)))
(for ([m (class/c-overrides ctc)])
(let ([index (hash-ref method-ht m #f)])
(unless index
(failed "no public method ~a" m))
(let ([vec (vector-ref beta-methods index)])
(unless (zero? (vector-length vec))
(failed "method ~a was previously augmentable" m)))
(let ([flag (vector-ref meth-flags index)])
(when (eq? flag 'final)
(failed "method ~a is final, not overrideable" m)))))
(for ([m (class/c-augments ctc)])
(let ([index (hash-ref method-ht m #f)])
(unless index
(failed "no public method ~a" m))
(let ([vec (vector-ref beta-methods index)])
(when (zero? (vector-length vec))
(failed "method ~a has never been augmentable" m)))))
(for ([s (class/c-supers ctc)])
(let ([index (hash-ref method-ht s #f)])
(unless index
(failed "no public method ~a" s))
(let ([flag (vector-ref meth-flags index)])
(when (eq? flag 'final)
(failed "method ~a is final, not overrideable" s))
(when (eq? flag 'augmentable)
(failed "method ~a is augmentable, not overrideable" s)))))
(for ([i (class/c-inners ctc)])
(let ([index (hash-ref method-ht i #f)])
(unless index
(failed "no public method ~a" i))
(let* ([super (vector-ref (class-supers cls) (sub1 (class-pos cls)))])
(unless (eq? (vector-ref meth-flags index) 'augmentable)
(failed "method ~a is not augmentable" i)))))
(let ([field-ht (class-field-ht cls)])
(for ([m (class/c-fields ctc)])
(unless (hash-ref field-ht m #f)
(failed "no public field ~a" m)))))
#t))
(define (class/c-proj ctc)

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

@ -4074,64 +4074,71 @@
;
;
(test/pos-blame
'class/c-first-order-class-1
'(contract (class/c)
3
'pos
'neg))
(test/spec-passed
'class/c-first-order-1
'class/c-first-order-class-2
'(contract (class/c)
object%
'pos
'neg))
(test/pos-blame
'class/c-first-order-2
'class/c-first-order-method-1
'(contract (class/c [m (-> any/c number? number?)])
object%
'pos
'neg))
(test/spec-passed
'class/c-first-order-3
'class/c-first-order-method-2
'(contract (class/c [m (-> any/c number? number?)])
(class object% (super-new) (define/public (m x) (add1 x)))
'pos
'neg))
(test/pos-blame
'class/c-first-order-4
'class/c-first-order-field-1
'(contract (class/c (field [n number?]))
object%
'pos
'neg))
(test/spec-passed
'class/c-first-order-5
'class/c-first-order-field-2
'(contract (class/c (field [n number?]))
(class object% (super-new) (field [n 3]))
'pos
'neg))
(test/pos-blame
'class/c-first-order-6
'class/c-first-order-super-1
'(contract (class/c (super [m (-> any/c number? number?)]))
object%
'pos
'neg))
(test/pos-blame
'class/c-first-order-7
'class/c-first-order-super-2
'(contract (class/c (super [m (-> any/c number? number?)]))
(class object% (super-new) (define/pubment (m x) (add1 x)))
'pos
'neg))
(test/pos-blame
'class/c-first-order-8
'class/c-first-order-super-3
'(contract (class/c (super [m (-> any/c number? number?)]))
(class object% (super-new) (define/public-final (m x) (add1 x)))
'pos
'neg))
(test/pos-blame
'class/c-first-order-9
'class/c-first-order-super-4
'(contract (class/c (super [m (-> any/c number? number?)]))
(let ([c% (class object% (super-new) (define/public (m x) (add1 x)))])
(class c% (super-new) (define/overment (m x) (add1 x))))
@ -4139,20 +4146,34 @@
'neg))
(test/spec-passed
'class/c-first-order-10
'class/c-first-order-super-5
'(contract (class/c (super [m (-> any/c number? number?)]))
(class object% (super-new) (define/public (m x) (add1 x)))
'pos
'neg))
(test/spec-passed
'class/c-first-order-11
'class/c-first-order-super-6
'(contract (class/c (super [m (-> any/c number? number?)]))
(let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))])
(class c% (super-new) (define/augride (m x) (add1 x))))
'pos
'neg))
(test/pos-blame
'class/c-first-order-inner-1
'(contract (class/c (inner [m (-> any/c number? number?)]))
object%
'pos
'neg))
(test/spec-passed
'class/c-first-order-inner-2
'(contract (class/c (inner [m (-> any/c number? number?)]))
(class object% (super-new) (define/pubment (m x) (inner x m x)))
'pos
'neg))
;
;
; ;; ;; ; ;;
@ -4171,36 +4192,43 @@
; ;;;;
; ;;;
(test/pos-blame
'object/c-first-order-object-1
'(contract (object/c)
3
'pos
'neg))
(test/spec-passed
'object/c-first-order-1
'object/c-first-order-object-2
'(contract (object/c)
(new object%)
'pos
'neg))
(test/pos-blame
'object/c-first-order-2
'object/c-first-order-method-1
'(contract (object/c [m (-> any/c number? number?)])
(new object%)
'pos
'neg))
(test/spec-passed
'object/c-first-order-3
'object/c-first-order-method-2
'(contract (object/c [m (-> any/c number? number?)])
(new (class object% (super-new) (define/public (m x) (add1 x))))
'pos
'neg))
(test/pos-blame
'object/c-first-order-4
'object/c-first-order-field-1
'(contract (object/c (field [n number?]))
(new object%)
'pos
'neg))
(test/spec-passed
'object/c-first-order-5
'object/c-first-order-field-2
'(contract (object/c (field [n number?]))
(new (class object% (super-new) (field [n 3])))
'pos