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

svn: r18164

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)])
+    (let ([method-ht (class-method-ht cls)]
-      (unless (hash-ref method-ht m #f)
+          [beta-methods (class-beta-methods cls)]
-        (failed "no public method ~a" m)))
+          [meth-flags (class-meth-flags cls)]) 
-    (for ([m (class/c-overrides ctc)])
+      (for ([m (class/c-methods ctc)])
-      (let ([index (hash-ref method-ht m #f)])
+        (unless (hash-ref method-ht m #f)
-        (unless index
+          (failed "no public method ~a" m)))
-          (failed "no public method ~a" m))
+      (for ([m (class/c-overrides ctc)])
-        (let ([vec (vector-ref beta-methods index)])
+        (let ([index (hash-ref method-ht m #f)])
-          (unless (zero? (vector-length vec))
+          (unless index
-            (failed "method ~a was previously augmentable" m)))
+            (failed "no public method ~a" m))
-        (let ([flag (vector-ref meth-flags index)])
+          (let ([vec (vector-ref beta-methods index)])
-          (when (eq? flag 'final)
+            (unless (zero? (vector-length vec))
-            (failed "method ~a is final, not overrideable" m)))))
+              (failed "method ~a was previously augmentable" m)))
-    (for ([m (class/c-augments ctc)])
+          (let ([flag (vector-ref meth-flags index)])
-      (let ([index (hash-ref method-ht m #f)])
+            (when (eq? flag 'final)
-        (unless index
+              (failed "method ~a is final, not overrideable" m)))))
-          (failed "no public method ~a" m))
+      (for ([m (class/c-augments ctc)])
-        (let ([vec (vector-ref beta-methods index)])
+        (let ([index (hash-ref method-ht m #f)])
-          (when (zero? (vector-length vec))
+          (unless index
-            (failed "method ~a has never been augmentable" m)))))
+            (failed "no public method ~a" m))
-    (for ([s (class/c-supers ctc)])
+          (let ([vec (vector-ref beta-methods index)])
-      (let ([index (hash-ref method-ht s #f)])
+            (when (zero? (vector-length vec))
-        (unless index
+              (failed "method ~a has never been augmentable" m)))))
-          (failed "no public method ~a" s))
+      (for ([s (class/c-supers ctc)])
-        (let ([flag (vector-ref meth-flags index)])
+        (let ([index (hash-ref method-ht s #f)])
-          (when (eq? flag 'final)
+          (unless index
-            (failed "method ~a is final, not overrideable" s))
+            (failed "no public method ~a" s))
-          (when (eq? flag 'augmentable)
+          (let ([flag (vector-ref meth-flags index)])
-            (failed "method ~a is augmentable, not overrideable" s)))))
+            (when (eq? flag 'final)
-    (for ([i (class/c-inners ctc)])
+              (failed "method ~a is final, not overrideable" s))
-      (let ([index (hash-ref method-ht i #f)])
+            (when (eq? flag 'augmentable)
-        (unless index
+              (failed "method ~a is augmentable, not overrideable" s)))))
-          (failed "no public method ~a" i))
+      (for ([i (class/c-inners ctc)])
-        (let* ([super (vector-ref (class-supers cls) (sub1 (class-pos cls)))])
+        (let ([index (hash-ref method-ht i #f)])
-          (unless (eq? (vector-ref meth-flags index) 'augmentable)
+          (unless index
-            (failed "method ~a is not augmentable" i)))))
+            (failed "no public method ~a" i))
-    (let ([field-ht (class-field-ht cls)])
+          (let* ([super (vector-ref (class-supers cls) (sub1 (class-pos cls)))])
-      (for ([m (class/c-fields ctc)])
+            (unless (eq? (vector-ref meth-flags index) 'augmentable)
-        (unless (hash-ref field-ht m #f)
+              (failed "method ~a is not augmentable" i)))))
-          (failed "no public field ~a" m))))
+      (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)

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