Add missing file and fix initialzation

darcs-hash:20070907034738-39164-cdd0d789c69492293c481653d39521721636d8e2.gz

diff --git a/src/attribute.lisp b/src/attribute.lisp
index 32279fe..5c8b03a 100644 (file)
--- a/src/attribute.lisp
+++ b/src/attribute.lisp
@@ -53,8 +53,6 @@
 (define-layered-method attribute-value (object attribute)
  (funcall (attribute-function attribute) object))
 
 (define-layered-method attribute-value (object attribute)
  (funcall (attribute-function attribute) object))
 

-
-

 (defmethod shared-initialize :around ((attribute standard-attribute) slots &rest initargs)
   (declare (ignore initargs))
     (setf (attribute-function attribute) 
 (defmethod shared-initialize :around ((attribute standard-attribute) slots &rest initargs)
   (declare (ignore initargs))
     (setf (attribute-function attribute) 

diff --git a/src/description-class.lisp b/src/description-class.lisp
new file mode 100644 (file)
index 0000000..9bf31e0
--- /dev/null
+++ b/src/description-class.lisp
@@ -0,0 +1,122 @@
+(in-package :lisp-on-lines)
+
+;;; * The Description Meta-Meta-Super class.
+
+(defclass description-special-layered-access-class 
+    (contextl::special-layered-access-class)
+ ((original-name :initarg original-name)
+  (description-layer :initarg description-layer)
+  (instance)))
+          
+(defmethod closer-mop:direct-slot-definition-class 
+    ((class description-special-layered-access-class) 
+     &key &allow-other-keys)
+  (find-class 'attribute-special-layered-direct-slot-definition))
+
+(defmethod closer-mop:effective-slot-definition-class 
+    ((class description-special-layered-access-class) 
+     &key name &allow-other-keys)
+    (declare (ignore name))
+  (find-class 'standard-attribute))
+
+(defmethod closer-mop:compute-effective-slot-definition :around
+    ((class description-special-layered-access-class) name direct-slot-definitions)
+  (declare (ignore name))
+  (let ((slotd (call-next-method)))
+    (setf (slot-value slotd 'direct-slots) direct-slot-definitions)
+    
+    (apply #'shared-initialize slotd nil (slot-value 
+                                         (find t direct-slot-definitions 
+                                               :test #'eq 
+                                               :key #'slot-definition-layer )
+                                         'initargs))
+
+    slotd))
+                                                  
+;;; * The Description Meta-Meta class.
+(defclass description-class (description-special-layered-access-class layered-class) 
+  ()
+  (:default-initargs :defining-metaclass 'description-special-layered-access-class))
+
+(defun initialize-description-class (class)
+  (let ((description (make-instance class)))
+    (setf (slot-value class 'instance) description)
+    (dolist (slotd (closer-mop:class-slots class))
+      (setf (slot-value slotd 'description) description)
+      (dolist (slot (slot-value slotd 'direct-slots))
+       (setf (slot-value slot 'initargs) 
+             (loop 
+                :for (initarg value) 
+                :on (slot-value slot 'initargs)
+                :by #'cddr
+                :nconc (list initarg
+                             (if (eval-attribute-initarg slotd initarg)
+                                 (eval value)
+                                 value))))
+       (ensure-layered-method  
+        'special-slot-values
+        `(lambda (description attribute)
+           (list ,@(loop 
+                :for (initarg value) 
+                :on (slot-value slot 'initargs)
+                :by #'cddr
+                :nconc (list (list 'quote (or (find-slot-name-from-initarg 
+                                  (class-of slotd) initarg) initarg))
+                             
+                                 value))))
+        :in-layer (slot-definition-layer slot) 
+        :qualifiers '(append)
+        :specializers (list class (closer-mop:intern-eql-specializer (closer-mop:slot-definition-name slotd))))))))
+
+(defmethod closer-mop:finalize-inheritance :after ((class description-class))
+  (initialize-description-class class))
+
+(define-layered-class description ()
+  ((identity :function #'identity))
+  (:metaclass description-class)
+  (description-layer t))
+
+(eval-when (:load-toplevel :execute)
+ (closer-mop:finalize-inheritance (find-class 'description)))
+
+;;; The layer itself. 
+#+nil(deflayer description ()
+  ()
+  (:metaclass description))
+
+#+nil (defmethod print-object ((object description) stream)
+  (call-next-method))
+
+(defgeneric find-description-class (name &optional errorp)        
+  ;; !-- Sometimes it gets inited, sometimes it don't.
+  (:method :around (name &optional errorp)
+          (let ((class (call-next-method)))
+            (unless (slot-boundp class 'instance)
+              (initialize-description-class class)) 
+            class))
+  (:method ((name (eql t)) &optional errorp)
+    (declare (ignore errorp))
+    (find-class 'description t))
+  (:method ((name symbol) &optional errorp)
+    (or (find-class (defining-description name) errorp)
+       (find-description-class t)))
+  (:method ((description description) &optional errorp)
+    (declare (ignore errorp))
+    (class-of description)))
+
+;;; A handy macro.
+(defmacro define-description (name &optional superdescriptions &body options)
+  (let ((description-name (defining-description name)))
+     
+    (destructuring-bind (&optional slots &rest options) options
+      `(prog1
+          (defclass ,description-name ,(append (mapcar #'defining-description superdescriptions) '(description))
+            ,(if slots slots '())
+            ,@options
+            ,@(unless (assoc :metaclass options)
+                      '((:metaclass description-class)))
+            (original-name . ,name))
+        (initialize-description-class (find-description-class ',description-name))))))
+
+
+

diff --git a/src/description.lisp b/src/description.lisp
index 20362f8..4195bb2 100644 (file)
--- a/src/description.lisp
+++ b/src/description.lisp
@@ -2,17 +2,6 @@
 
 (define-description description ())
 
 
 (define-description description ())
 

-(defgeneric find-description-class (name &optional errorp)        
-  (:method ((name (eql t)) &optional errorp)
-    (declare (ignore errorp))
-    (find-class 'description t))
-  (:method ((name symbol) &optional errorp)
-    (or (find-class (defining-description name) errorp)
-       (find-description-class t)))
-  (:method ((description description) &optional errorp)
-    (declare (ignore errorp))
-    (class-of description)))
-

 (defun find-description (name)
    (slot-value (find-description-class name) 'instance))
 
 (defun find-description (name)
    (slot-value (find-description-class name) 'instance))
 


@@ -36,6 +25,7 @@
               (display-attribute attribute)))
           (attributes description))))
 
               (display-attribute attribute)))
           (attributes description))))
 

+

 (define-layered-method description-of (object)
   (find-description 't))                             
 
 (define-layered-method description-of (object)
   (find-description 't))