X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/6de8d30004efc9337b8c40d2ff2d0a76651d23eb..b7657b86f85f575d5776dc6b626b1dc258d1fa47:/src/description-class.lisp

diff --git a/src/description-class.lisp b/src/description-class.lisp
index 0669167..fb6e7ff 100644
--- 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.
 
-;;; 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 
@@ -54,28 +33,108 @@
 	  ;; 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))
+		'effective-attribute attribute))
     attribute))
+
+(defmethod slot-value-using-class ((class description-access-class) object slotd)
+        (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)))
     
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defparameter *description-attributes* (make-hash-table)))
+
+
+
 (defclass standard-description-class (description-access-class layered-class)
-  ()
+  ((attributes :accessor description-class-attributes :initform (list)))
   (:default-initargs :defining-metaclass 'description-access-class))
 
+
+
 (defmethod validate-superclass
            ((class standard-description-class)
             (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))))
+
+(defgeneric standard-description-p (description-candidate)
+  (:method (not-description)
+    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))
+		       (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.
@@ -90,11 +149,17 @@
 	 (attribute-objects 
 	  (mapcar 
 	   (lambda (slot)
-	     (setf (attribute-object slot)
-		   (apply #'make-instance 
-			  'standard-attribute
-			  (attribute-object-initargs slot))))
-	   (class-slots (class-of description))))
+	     (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 
@@ -113,15 +178,13 @@
 			 
 			 (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)))
+			   (warn "~%CHANGING CLASS~%")
 			   
 			   (apply #'change-class attribute  (attribute-class attribute) 
-				  initargs)))
-		       
-
-		       (setf (slot-value description (attribute-name attribute))
-			     attribute))))))))
+				  initargs))))))))))
 
 ;;;; HACK: run this at startup till we figure things out.
 (defun initialize-descriptions ()