X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/e7c5f95a989882cabc1f4b6ea4598565ea317952..c29b2d2dda5ab82f7458666c154094693bfe9f1b:/src/attribute-test.lisp

diff --git a/src/attribute-test.lisp b/src/attribute-test.lisp
index 554b1a7..74caa00 100644
--- a/src/attribute-test.lisp
+++ b/src/attribute-test.lisp
@@ -5,49 +5,83 @@
 (deftest test-attribute-value ()
   (eval 
    '(progn 
-     (define-description attribute-test-2 ()
+     (define-description attribute-test-description ()
        ((attribute-1 :value "VALUE")
 	(attribute-2 :function (constantly "VALUE"))))
 
      (deflayer attribute-test)
 
-     (define-description attribute-test-2 ()
+     (define-description attribute-test-description ()
        ((attribute-1 :value "VALUE2")
 	(attribute-2 :function (constantly "VALUE2")))
        (:in-layer . attribute-test))))
 
-  (let ((d (find-description 'attribute-test-2)))
-    
+  (let ((d (find-description 'attribute-test-description)))
+    (dletf (((described-object d) nil))
     (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
 		
-
     (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)
   (eval '(progn
 	  (deflayer attribute-property-test)
-	  (define-description attribute-test-2 ()
+	  (define-description attribute-test-description ()
 	    ((attribute-1 :label "attribute1")
 	     (attribute-2 :label "attribute2"))
 	    (:in-layer . attribute-property-test))))
-
   (with-active-layers (attribute-property-test)
-    (let ((d (find-description 'attribute-test-2)))
+    (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 :compile-before-run t) ()
+  (eval '(progn 
+	  (define-layered-class
+		test-attribute-class (lol::standard-attribute)
+		((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!")))))
+
+  (let* ((d (find-description 'test-attribute-with-different-class-description))
+
+	 (a (find-attribute d 'attribute-with-different-class)))
+    (is (eq (class-of 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)))))
+
+
+