added ROFL test cases + extra formatting hooks for attributes

[clinton/lisp-on-lines.git] / src / attribute-test.lisp

diff --git a/src/attribute-test.lisp b/src/attribute-test.lisp
index 632cba7..74caa00 100644 (file)
--- a/src/attribute-test.lisp
+++ b/src/attribute-test.lisp
@@ -17,14 +17,13 @@
        (:in-layer . attribute-test))))
 
   (let ((d (find-description 'attribute-test-description)))
        (:in-layer . attribute-test))))
 
   (let ((d (find-description 'attribute-test-description)))

-    
+    (dletf (((described-object d) nil))

     (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
                
     (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
                

-

     (with-active-layers (attribute-test)
     (with-active-layers (attribute-test)

-      (is (equalp (attribute-value nil (find-attribute d 'attribute-1))
-                 (attribute-value nil (find-attribute d 'attribute-2))))
-      (is (equalp "VALUE2" (attribute-value nil (find-attribute d 'attribute-1)))))))
+      (is (equalp (attribute-value (find-attribute d 'attribute-1))
+                 (attribute-value (find-attribute d 'attribute-2))))
+      (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1))))))))

 
 (deftest test-attribute-property-inheriting ()
   (test-attribute-value)
 
 (deftest test-attribute-property-inheriting ()
   (test-attribute-value)


@@ -36,27 +35,27 @@
            (:in-layer . attribute-property-test))))
   (with-active-layers (attribute-property-test)
     (let ((d (find-description 'attribute-test-description)))
            (:in-layer . attribute-property-test))))
   (with-active-layers (attribute-property-test)
     (let ((d (find-description 'attribute-test-description)))

+      (dletf (((described-object d) nil))

     
     

-      (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
+       (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))

 
 

-      (is (equalp "attribute1" (attribute-label (find-attribute d 'attribute-1))))
-      (is (equalp "attribute2" (attribute-label (find-attribute d 'attribute-2))))
+       (is (equalp "attribute1" (attribute-label (find-attribute d 'attribute-1))))
+       (is (equalp "attribute2" (attribute-label (find-attribute d 'attribute-2))))

                
 
                
 

-      (with-active-layers (attribute-test)
-       (is (equalp (attribute-value nil (find-attribute d 'attribute-1))
-                   (attribute-value nil (find-attribute d 'attribute-2))))
-       (is (equalp "VALUE2" (attribute-value nil (find-attribute d 'attribute-1))))))))
+       (with-active-layers (attribute-test)
+         (is (equalp (attribute-value (find-attribute d 'attribute-1))
+                     (attribute-value (find-attribute d 'attribute-2))))
+         (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1)))))))))

 
 

-(deftest test-attribute-with-different-class ()
+(deftest (test-attribute-with-different-class :compile-before-run t) ()

   (eval '(progn 
   (eval '(progn 

-;;;; We cannot ever redefine this class ic think... 
-;;; as attributes are also slot meta-objects.
-         (unless (find-class 'test-attribute-class nil) 
-           (define-layered-class
+         (define-layered-class

                test-attribute-class (lol::standard-attribute)
                test-attribute-class (lol::standard-attribute)

-               ((some-slot :initarg :some-slot :layered-accessor some-slot))))
-
+               ((some-slot :initarg :some-slot 
+                           :layered t 
+                           :layered-accessor some-slot)))
+         

          (define-description test-attribute-with-different-class-description ()
            ((attribute-with-different-class :attribute-class test-attribute-class :some-slot "BRILLANT!")))))
 
          (define-description test-attribute-with-different-class-description ()
            ((attribute-with-different-class :attribute-class test-attribute-class :some-slot "BRILLANT!")))))
 


@@ -67,6 +66,20 @@
            (find-class 'test-attribute-class)))
     (is (equalp "BRILLANT!" (some-slot a)))))
 
            (find-class 'test-attribute-class)))
     (is (equalp "BRILLANT!" (some-slot a)))))
 

+(deftest (test-attribute-with-different-class-and-subclassed-description :compile-before-run t) ()
+  (test-attribute-with-different-class)
+  (eval '(progn          
+         (define-description test-attribute-with-different-class-description-sub 
+             (test-attribute-with-different-class-description)
+           ())))
+
+  (let* ((d (find-description 'test-attribute-with-different-class-description-sub))
+
+        (a (find-attribute d 'attribute-with-different-class)))
+    (is (eq (class-of a)
+           (find-class 'test-attribute-class)))
+    (is (equalp "BRILLANT!" (some-slot a)))))
+