Add :attributes option to core description class

darcs-hash:20080831202257-39164-f18a33729dbabb54acc451e03ffde7d82720198b.gz

diff --git a/src/description-class.lisp b/src/description-class.lisp
index de1fc0c..d874d82 100644 (file)
--- a/src/description-class.lisp
+++ b/src/description-class.lisp
@@ -14,6 +14,7 @@
 
 (define-layered-class description-access-class (standard-layer-class contextl::special-layered-access-class )
   ((defined-in-descriptions :initarg :in-description)
 
 (define-layered-class description-access-class (standard-layer-class contextl::special-layered-access-class )
   ((defined-in-descriptions :initarg :in-description)

+   (class-active-attributes-definition :initarg :attributes)

    (mixin-class-p :initarg :mixinp)))
 
 (defmethod direct-slot-definition-class
    (mixin-class-p :initarg :mixinp)))
 
 (defmethod direct-slot-definition-class


@@ -73,47 +74,33 @@
     NIL)
   (:method ((description standard-description-object))
     T))
     NIL)
   (:method ((description standard-description-object))
     T))

-  
-(defun initialize-description-class (class)

 
 

-;;; HACK: initialization does not happ   en properly 
-;;; when compiling and loading or something like that.
-;;; Obviously i'm not sure why.
-;;; So we're going to explicitly initialize things.
-;;; For now. --drewc
-
-  (pushnew class *defined-descriptions*)
-
-;;; ENDHACK.
-  
-  (let* ((description (find-layer class)) 
-        (attribute-objects 
-         (setf (description-class-attributes (class-of description))
-               (mapcar 
-                (lambda (slot)
-                  (or (find-attribute description 
-                                      (slot-definition-name slot) nil)
-                      (let* ((*init-time-description* description)
-                             (attribute-class (or 
-                                               (ignore-errors 
-                                                 (slot-value-using-class 
-                                                  (class-of description) description slot))
-                                               'standard-attribute))
-                             (attribute                     
-                              (apply #'make-instance 
-                                     attribute-class
-                                     :description description
-                                     :attribute-class attribute-class
-                                     (attribute-object-initargs slot))))
-                        (setf (slot-definition-attribute-object slot) attribute))))
-                (remove 'described-object (class-slots (class-of description))
-                        :key #'slot-definition-name))))
-        (defining-classes 
-         (partial-class-defining-classes class)))
+(defun compute-effective-attribute-objects (description)
+  (mapcar 
+   (lambda (slot)
+     (or (find-attribute description 
+                        (slot-definition-name slot) nil)
+        (let* ((*init-time-description* description)
+               (attribute-class (or 
+                                 (ignore-errors 
+                                   (slot-value-using-class 
+                                    (class-of description) description slot))
+                                 'standard-attribute))
+               (attribute                   
+                (apply #'make-instance 
+                       attribute-class
+                       :description description
+                       :attribute-class attribute-class
+                       (attribute-object-initargs slot))))
+          (setf (slot-definition-attribute-object slot) attribute))))
+   (remove 'described-object (class-slots (class-of description))
+          :key #'slot-definition-name)))
+
+(defun initialize-effective-attribute-values-for-description-class (class description attribute-objects)

 
     (loop 
        :for (layer class) 
 
     (loop 
        :for (layer class) 

-       :on  defining-classes :by #'cddr 
+       :on    (partial-class-defining-classes class) :by #'cddr 

        :do (funcall-with-layer-context 
            (adjoin-layer (find-layer layer) (current-layer-context))
            (lambda ()
        :do (funcall-with-layer-context 
            (adjoin-layer (find-layer layer) (current-layer-context))
            (lambda ()


@@ -130,7 +117,31 @@
                         (setf (slot-value description (attribute-name attribute)) 
                               (attribute-class attribute))
                         (apply #'change-class attribute  (find-class (attribute-class attribute))
                         (setf (slot-value description (attribute-name attribute)) 
                               (attribute-class attribute))
                         (apply #'change-class attribute  (find-class (attribute-class attribute))

-                               initargs)))))))))
+                               initargs))))
+             (when (slot-boundp  class 'class-active-attributes-definition)
+             (with-described-object (nil description) 
+               (setf (slot-value (find-attribute description 'active-attributes) 'value) 
+                     (slot-value class 'class-active-attributes-definition))))))))
+    
+(defun initialize-description-class (class)
+
+;;; HACK: initialization does not happ   en properly 
+;;; when compiling and loading or something like that.
+;;; Obviously i'm not sure why.
+;;; So we're going to explicitly initialize things.
+;;; For now. --drewc
+
+  (pushnew class *defined-descriptions*)
+
+;;; ENDHACK.
+  
+  (let* ((description (find-layer class)) 
+        (attribute-objects 
+         (setf (description-class-attributes (class-of description))
+               (compute-effective-attribute-objects description))))
+
+    (initialize-effective-attribute-values-for-description-class class description attribute-objects)
+))

 
 
 #+old(defun initialize-description-class (class)
 
 
 #+old(defun initialize-description-class (class)