Move initialization of attribute object

... to initialize-description-class, after a description is ready.

testing: <test-run 11 tests, 20 assertions, 0 failures in 17.993 sec>

darcs-hash:20080114223642-39164-bfee0f3c972dbb80f738763b7ed8743d171024d6.gz

diff --git a/src/attribute.lisp b/src/attribute.lisp
index 10bcb70..ba012b7 100644 (file)
--- a/src/attribute.lisp
+++ b/src/attribute.lisp
@@ -11,7 +11,8 @@
 (define-layered-class effective-attribute-definition-class (special-layered-effective-slot-definition) 
   ((direct-attributes :accessor attribute-direct-attributes)
    (attribute-object :accessor attribute-object
-                    :documentation "")))
+                    :documentation "")
+   (attribute-object-initargs :accessor attribute-object-initargs)))
 
 
 (define-layered-function attribute-value (object attribute))
@@ -39,7 +40,9 @@
    (description-name)
    (description-class :initarg description-class)
    (initfunctions :initform nil)
-   (attribute-class :accessor attribute-class :initarg :attribute-class :initform 'standard-attribute)
+   (attribute-class :accessor attribute-class 
+                   :initarg :attribute-class 
+                   :initform 'standard-attribute)
    (name :layered-accessor attribute-name 
          :initarg :name)
    (label :layered-accessor attribute-label 

diff --git a/src/description-class.lisp b/src/description-class.lisp
index f43beca..ac05535 100644 (file)
--- a/src/description-class.lisp
+++ b/src/description-class.lisp
@@ -50,11 +50,12 @@
   (declare (ignore name))
   (let ((attribute (call-next-method)))
     (setf (attribute-direct-attributes attribute) direct-slot-definitions)
-    (setf (attribute-object attribute) 
-         (make-instance 'standard-attribute 
-                        :name name 
-                        'effective-attribute attribute
-                        'description-class class))
+    (setf (attribute-object-initargs attribute)  
+         ;; This plist will be used to init the attribute object
+          ;; Once the description itself is properly initiated.
+         (list :name name 
+               'effective-attribute attribute
+               'description-class class))
     attribute))
     
 
@@ -74,39 +75,44 @@
 
 (defun initialize-description-class (class)
 
-  ;;; HACK: initialization does not happen 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
+;;; HACK: initialization does not happen 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.
+;;; ENDHACK.
 
   (let* ((description (find-layer class)) 
-        (attribute-objects (mapcar #'attribute-object (class-slots (class-of description))))
+        (attribute-objects 
+         (mapcar 
+          (lambda (slot)
+            (setf (attribute-object slot)
+                  (apply #'make-instance 
+                         'standard-attribute
+                         (attribute-object-initargs slot))))
+          (class-slots (class-of description))))
         (defining-classes (partial-class-defining-classes (class-of description))))
-    
 
-        
     (loop 
        :for (layer class) 
        :on  defining-classes :by #'cddr 
        :do (funcall-with-layer-context 
            (adjoin-layer (find-layer layer) (current-layer-context))
-          (lambda ()
-            (loop :for direct-slot :in (class-direct-slots class) 
-               :do (let ((attribute 
-                          (find (slot-definition-name direct-slot) 
-                                attribute-objects 
-                                :key #'attribute-name)))
-                     (apply #'reinitialize-instance attribute 
-                            (direct-attribute-properties direct-slot))
-                     (apply #'change-class attribute (attribute-class attribute) (direct-attribute-properties direct-slot))
-
-                     (setf (slot-value description (attribute-name attribute))
-                           attribute))))))))
+           (lambda ()
+             (loop :for direct-slot :in (class-direct-slots class) 
+                :do (let ((attribute 
+                           (find (slot-definition-name direct-slot) 
+                                 attribute-objects 
+                                 :key #'attribute-name)))
+                      (apply #'reinitialize-instance attribute 
+                             (direct-attribute-properties direct-slot))
+                      (apply #'change-class attribute (attribute-class attribute) (direct-attribute-properties direct-slot))
+
+                      (setf (slot-value description (attribute-name attribute))
+                            attribute))))))))
 
 ;;;; HACK: run this at startup till we figure things out.
 (defun initialize-descriptions () 

diff --git a/src/description.lisp b/src/description.lisp
index 49dd5ed..36211c4 100644 (file)
--- a/src/description.lisp
+++ b/src/description.lisp
@@ -56,7 +56,7 @@
                 ,@options
                 ,@(unless (assoc :metaclass options)
                           '((:metaclass standard-description-class))))
-;             (initialize-description)
+              (initialize-descriptions)
               (find-description ',name)))))))