API CHANGE: Removed the OBJECT arg from attribute-value

[clinton/lisp-on-lines.git] / src / description-class.lisp

diff --git a/src/description-class.lisp b/src/description-class.lisp
index f43beca..7e364e3 100644 (file)
--- a/src/description-class.lisp
+++ b/src/description-class.lisp
@@ -33,7 +33,7 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defparameter *defined-descriptions* nil))
 
-(defclass description-access-class (standard-layer-class contextl::special-layered-access-class )
+(define-layered-class description-access-class (standard-layer-class contextl::special-layered-access-class )
   ((defined-in-descriptions :initarg :in-description)
    (mixin-class-p :initarg :mixinp)))
 
@@ -50,12 +50,19 @@
   (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))
     attribute))
+
+(defmethod slot-value-using-class ((class description-access-class) object slotd)
+  (if (or 
+       (eq (slot-definition-name slotd) 'described-object)
+       (not (slot-boundp slotd 'attribute-object)))
+      (call-next-method)
+      (slot-definition-attribute-object slotd)))
     
 
 (defclass standard-description-class (description-access-class layered-class)
@@ -67,46 +74,65 @@
             (superclass standard-class))
   t)
 
-(defclass standard-description-object (standard-layer-object) ())
+(define-layered-class standard-description-object (standard-layer-object) 
+  ((described-object :accessor described-object 
+                    :special t)))
 
 (defun description-class-name  (description-class)
     (read-from-string (symbol-name (class-name description-class))))
-
+  
 (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 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.
+
+;;; ENDHACK.
 
   (let* ((description (find-layer class)) 
-        (attribute-objects (mapcar #'attribute-object (class-slots (class-of description))))
+        (attribute-objects 
+         (mapcar 
+          (lambda (slot)
+            (let* ((*init-time-description* description)
+                         (attribute                 (apply #'make-instance 
+                           'standard-attribute
+                           :description description
+                           (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-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)))
+                      (let ((initargs 
+                             (prepare-initargs attribute (direct-attribute-properties direct-slot))))
+                        
+                        (apply #'reinitialize-instance attribute 
+                               initargs )
+                        (when (not (eq (find-class (attribute-class attribute))
+                                       (class-of attribute)))
+                          
+                          (apply #'change-class attribute  (attribute-class attribute) 
+                                 initargs)))
+                      
+
+                      )))))))
 
 ;;;; HACK: run this at startup till we figure things out.
 (defun initialize-descriptions ()