diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index f970efd1d9..8e3b781649 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -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) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 4afa8fee5a..86fc1ec0bb 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -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