added ROFL test cases + extra formatting hooks for attributes

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

diff --git a/src/description-class.lisp b/src/description-class.lisp
index 7e364e3..fb6e7ff 100644 (file)
--- a/src/description-class.lisp
+++ b/src/description-class.lisp
@@ -4,27 +4,6 @@
 ;;;; A description is an object which is used 
 ;;;; to describe another object.
 
 ;;;; A description is an object which is used 
 ;;;; to describe another object.
 

-;;; HACK:
-;;; Since i'm not using deflayer, ensure-layer etc, 
-;;; There are a few places where contextl gets confused 
-;;; trying to locate my description layers.
-
-;;; TODO: investigate switching to deflayer!
-
-(defun contextl::prepare-layer (layer)
-  (if (symbolp layer)
-      (if (eq (symbol-package layer)
-         (find-package :description-definers))
-         layer
-         (contextl::defining-layer layer))
-      
-      layer))
-
-(defmethod find-layer-class :around ((layer symbol) &optional errorp environment)
-  (if (eq (symbol-package layer)
-         (find-package :description-definers))
-      (find-class layer)
-      (call-next-method)))

 
 ;;; #+HACK
 ;;; I'm having some 'issues' with 
 
 ;;; #+HACK
 ;;; I'm having some 'issues' with 


@@ -58,17 +37,25 @@
     attribute))
 
 (defmethod slot-value-using-class ((class description-access-class) object slotd)
     attribute))
 
 (defmethod slot-value-using-class ((class description-access-class) object slotd)

-  (if (or 
+        (call-next-method)
+#+nil  (if (or 

        (eq (slot-definition-name slotd) 'described-object)
        (not (slot-boundp slotd 'attribute-object)))
       (call-next-method)
       (slot-definition-attribute-object slotd)))
     
 
        (eq (slot-definition-name slotd) 'described-object)
        (not (slot-boundp slotd 'attribute-object)))
       (call-next-method)
       (slot-definition-attribute-object slotd)))
     
 

+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defparameter *description-attributes* (make-hash-table)))
+
+
+

 (defclass standard-description-class (description-access-class layered-class)
 (defclass standard-description-class (description-access-class layered-class)

-  ()
+  ((attributes :accessor description-class-attributes :initform (list)))

   (:default-initargs :defining-metaclass 'description-access-class))
 
   (:default-initargs :defining-metaclass 'description-access-class))
 

+
+

 (defmethod validate-superclass
            ((class standard-description-class)
             (superclass standard-class))
 (defmethod validate-superclass
            ((class standard-description-class)
             (superclass standard-class))


@@ -80,9 +67,74 @@
 
 (defun description-class-name  (description-class)
     (read-from-string (symbol-name (class-name description-class))))
 
 (defun description-class-name  (description-class)
     (read-from-string (symbol-name (class-name description-class))))

+
+(defgeneric standard-description-p (description-candidate)
+  (:method (not-description)
+    NIL)
+  (:method ((description standard-description-object))
+    T))

   
 (defun initialize-description-class (class)
 
   
 (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))
+                      (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)))
+
+    (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)))
+                      (let ((initargs 
+                             (prepare-initargs attribute (direct-attribute-properties direct-slot))))
+                        
+                        (apply #'reinitialize-instance attribute 
+                               initargs )
+                        (setf (slot-value description (attribute-name attribute)) 
+                              (attribute-class attribute))
+                        (apply #'change-class attribute  (attribute-class attribute)
+                               initargs)))))))))
+
+
+#+old(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.
 ;;; HACK: initialization does not happ   en properly 
 ;;; when compiling and loading or something like that.
 ;;; Obviously i'm not sure why.


@@ -98,11 +150,12 @@
          (mapcar 
           (lambda (slot)
             (let* ((*init-time-description* description)
          (mapcar 
           (lambda (slot)
             (let* ((*init-time-description* description)

-                         (attribute                 (apply #'make-instance 
+                         (attribute                 
+                          (apply #'make-instance 

                            'standard-attribute
                            :description description
                            (attribute-object-initargs slot))))
                            'standard-attribute
                            :description description
                            (attribute-object-initargs slot))))

-                    
+              

                     
               (setf (slot-definition-attribute-object slot) attribute)))
           (remove 'described-object (class-slots (class-of description))
                     
               (setf (slot-definition-attribute-object slot) attribute)))
           (remove 'described-object (class-slots (class-of description))


@@ -125,14 +178,13 @@
                         
                         (apply #'reinitialize-instance attribute 
                                initargs )
                         
                         (apply #'reinitialize-instance attribute 
                                initargs )

+                        (warn "Attribute class for ~A is ~A" attribute (attribute-class attribute))

                         (when (not (eq (find-class (attribute-class attribute))
                                        (class-of attribute)))
                         (when (not (eq (find-class (attribute-class attribute))
                                        (class-of attribute)))

+                          (warn "~%CHANGING CLASS~%")

                           
                           (apply #'change-class attribute  (attribute-class attribute) 
                           
                           (apply #'change-class attribute  (attribute-class attribute) 

-                                 initargs)))
-                      
-
-                      )))))))
+                                 initargs))))))))))

 
 ;;;; HACK: run this at startup till we figure things out.
 (defun initialize-descriptions () 
 
 ;;;; HACK: run this at startup till we figure things out.
 (defun initialize-descriptions ()