X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/4358148e6c67fcc2ae24050c54d8050b4dc03f9d..e8d4fa4537a1655714ad8bbbf9b7ba2d85ead959:/src/description.lisp

diff --git a/src/description.lisp b/src/description.lisp
index 49dd5ed..ae5850c 100644
--- a/src/description.lisp
+++ b/src/description.lisp
@@ -8,25 +8,46 @@
   (description-class-name (class-of description)))
 
 (defun find-attribute (description attribute-name)
-  (slot-value description attribute-name))
+  (when (slot-exists-p description attribute-name) 
+    (slot-value description attribute-name)))
+
 
-#+nil(mapcar (lambda (slotd)  
-	    (slot-value-using-class (class-of description) description slotd))
-	    (class-slots (class-of description)))
 (defun description-attributes (description)
-  (mapcar #'attribute-object (class-slots (class-of description))))
+  (let ((class (class-of description)))
+    (loop :for slot :in (class-slots class)
+       :if (and 
+		(not (eq 'described-object 
+			 (slot-definition-name slot))))
+       :collect (slot-definition-attribute-object slot))))
+
+
 
 (define-layered-function attributes (description)
   (:method (description)
-    (remove-if-not 
-     (lambda (attribute)
-       (and (eq (class-of description)
-		(print (slot-value attribute 'description-class)))
-	    (some #'layer-active-p 
-	     (mapcar #'find-layer 
-		     (slot-definition-layers 
-		      (attribute-effective-attribute-definition attribute))))))
-     (description-attributes description))))
+    (let* ((active-attributes 
+	    (find-attribute description 'active-attributes))
+	   (attributes (when active-attributes
+	     (attribute-value active-attributes))))
+      (if attributes
+	  (mapcar (lambda (spec)		    
+		    (find-attribute 
+		     description
+		     (if (listp spec)
+			 (car spec)
+			 spec)))
+		  attributes)
+	  (remove-if-not 
+	   (lambda (attribute)
+	     (and (attribute-active-p attribute)		     
+		  (some #'layer-active-p 
+			(mapcar #'find-layer 
+				(slot-definition-layers 
+				 (attribute-effective-attribute-definition attribute))))))
+	   (description-attributes description))))))
+	  
+
+
+  
 
   
 ;;; A handy macro.
@@ -35,7 +56,7 @@
     (destructuring-bind (&optional slots &rest options) options
       (let ((description-layers (cdr (assoc :in-description options))))
 	(if description-layers
-	    `(eval-when (:compile-toplevel :load-toplevel :execute)
+	    `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
 	       ,@(loop 
 		    :for layer 
 		    :in description-layers
@@ -44,7 +65,7 @@
 				  ,@(acons 
 				    :in-layer (defining-description layer)
 				    (remove :in-description options :key #'car)))))
-	    `(eval-when (:compile-toplevel :load-toplevel :execute)
+	    `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
 					;  `(progn
 	       (defclass ,description-name 
 		   ,(append (mapcar #'defining-description 
@@ -56,7 +77,7 @@
 		 ,@options
 		 ,@(unless (assoc :metaclass options)
 			   '((:metaclass standard-description-class))))
-;	       (initialize-description)
+	       (initialize-descriptions)
 	       (find-description ',name)))))))