Made attribute class layered

darcs-hash:20080119105510-39164-d4770a42971da8caad06f1205a47e16dbda9edc9.gz

diff --git a/src/attribute.lisp b/src/attribute.lisp
index 6d47657..c536d40 100644 (file)
--- a/src/attribute.lisp
+++ b/src/attribute.lisp
@@ -42,7 +42,8 @@
    (initfunctions :initform nil)
    (attribute-class :accessor attribute-class 
                    :initarg :attribute-class 
-                   :initform 'standard-attribute)
+                   :initform 'standard-attribute
+                   :layered t)
    (name :layered-accessor attribute-name 
          :initarg :name)
    (label :layered-accessor attribute-label 
@@ -65,6 +66,21 @@
   (print-unreadable-object (object stream :type nil :identity t)
     (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+"))))
 
+(defgeneric eval-property-initarg (att initarg)
+  (:method ((attribute standard-attribute) initarg)
+  nil)
+  (:method ((attribute standard-attribute) (initarg (eql :function)))
+    t))
+
+(defun prepare-initargs (att args)
+  (loop 
+     :for (key arg) 
+     :on args :by #'cddr 
+     :nconc (list key 
+                 (if (eval-property-initarg att key)
+                     (eval arg)
+                     arg))))
+
 (defvar *bypass-property-layered-function* nil)
 
 (define-layered-function property-layered-function (description attribute-name property-name)
@@ -82,8 +98,7 @@
   :in-layer (context t)
   (new-value class (attribute standard-attribute) property writer)
 
-  (when (or *bypass-property-layered-function*
-           (not (slot-definition-layeredp property)))
+  (when (or *bypass-property-layered-function*)
     (return-from slot-value-using-layer (call-next-method)))
 
   
@@ -129,15 +144,15 @@
         (ensure-layered-method 
          fn
          `(lambda (description)
-            ,new-value)
+            (funcall ,(lambda()
+                       new-value)))
          :in-layer layer 
          :specializers (list (class-of (attribute-description attribute)
                                       ))))))
       
       (if (slot-boundp attribute 'description-class)
          (do-set-slot)
-         (push (lambda () (do-set-slot)) 
-               (slot-value attribute 'initfunctions))))))
+         (error "serrint wif no desc WTF!")))))
 
 
 (define-layered-method slot-value-using-layer 
@@ -153,13 +168,17 @@
   (unless (slot-boundp-using-class class attribute property)
     (slot-unbound class attribute (slot-definition-name property)))
 
+  (let ((val (call-next-method)))
+    
   (if (and 
+       ;; Not special access 
+       (not (symbolp val))
        (contextl::slot-definition-layeredp property)
        (not *bypass-property-layered-function*))
-      (let ((fn (call-next-method)))
+      (let ((fn val))
        ;(dprint "... using fn ~A to get value" fn)
       (funcall fn layer  (attribute-description attribute)))
-      (call-next-method)))
+      val)))
 
 (defmacro define-bypass-function (name function-name)
   `(defun ,name (&rest args)
@@ -171,7 +190,7 @@
 (define-bypass-function (setf real-slot-value-using-class) (setf slot-value-using-class))
   
 (defun slot-boundp-using-property-layered-function (class attribute property)
-  (dprint "plf boundp:")
+  ;(dprint "plf boundp:")
   (let* ((really-bound-p 
          (real-slot-boundp-using-class class attribute property))
         (fn (if really-bound-p 
@@ -181,11 +200,13 @@
                        (attribute-description attribute)
                        (attribute-name attribute)
                        (closer-mop:slot-definition-name property))))))
-    (dprint "Slot was bound? ~A" really-bound-p)
-    ;; If the slot is unbound, we search for its layered-function
-      (if (generic-function-methods fn)
-         T
-         NIL)))
+
+    (if (symbolp fn)
+       ;;special symbol access in process
+       T
+       (if (generic-function-methods fn)
+           T
+           NIL))))
     
 (define-layered-method slot-boundp-using-layer  
   :in-layer (layer t)

diff --git a/src/description-class.lisp b/src/description-class.lisp
index 5297dfd..895c7ed 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)))
 
@@ -107,14 +107,16 @@
                            (find (slot-definition-name direct-slot) 
                                  attribute-objects 
                                  :key #'attribute-name)))
-                      (dprint "Re-initing")
-                      (apply #'reinitialize-instance attribute 
-                             (print (direct-attribute-properties direct-slot)))
-                      (when (not (eq (find-class (attribute-class attribute))
-                                 (class-of attribute)))
+                      (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) 
-                                 (direct-attribute-properties direct-slot)))
+                                 initargs)))
                       
 
                       (setf (slot-value description (attribute-name attribute))

diff --git a/src/description.lisp b/src/description.lisp
index 36211c4..c06a6f4 100644 (file)
--- a/src/description.lisp
+++ b/src/description.lisp
@@ -10,18 +10,24 @@
 (defun find-attribute (description attribute-name)
   (slot-value description attribute-name))
 
-#+nil(mapcar (lambda (slotd)  
-           (slot-value-using-class (class-of description) description slotd))
-           (class-slots (class-of description)))
+
 (defun description-attributes (description)
-  (mapcar #'attribute-object (class-slots (class-of description))))
+  (mapcar (curry
+          #'slot-value-using-class 
+          (class-of 'description)
+          description) 
+         (class-slots (class-of description))))
+
+(defvar *display-attributes* nil)
+(defun attribute-active-p (attribute)
+  (or (null *display-attributes*)
+      (find (attribute-name attribute) *display-attributes*)))
 
 (define-layered-function attributes (description)
   (:method (description)
     (remove-if-not 
      (lambda (attribute)
-       (and (eq (class-of description)
-               (print (slot-value attribute 'description-class)))
+       (and (attribute-active-p attribute)
            (some #'layer-active-p 
             (mapcar #'find-layer 
                     (slot-definition-layers 
@@ -35,7 +41,7 @@
     (destructuring-bind (&optional slots &rest options) options
       (let ((description-layers (cdr (assoc :in-description options))))
        (if description-layers
-           `(eval-when (:compile-toplevel :load-toplevel :execute)
+           `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
               ,@(loop 
                    :for layer 
                    :in description-layers
@@ -44,7 +50,7 @@
                                  ,@(acons 
                                    :in-layer (defining-description layer)
                                    (remove :in-description options :key #'car)))))
-           `(eval-when (:compile-toplevel :load-toplevel :execute)
+           `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
                                        ;  `(progn
               (defclass ,description-name 
                   ,(append (mapcar #'defining-description 

diff --git a/src/display.lisp b/src/display.lisp
index 862cf98..5888f0b 100644 (file)
--- a/src/display.lisp
+++ b/src/display.lisp
@@ -10,8 +10,9 @@
   (:documentation
    "Displays OBJECT via description using/in/with/on display"))
 
-(defun display (display object &rest args)
-  (display-using-description (description-of object) display object args))
+(defun display (display object &rest args &key attributes )
+  (let ((*display-attributes* attributes))
+    (display-using-description (description-of object) display object args)))
 
 (define-layered-method display-using-description 
   :around (description display object &rest args)
@@ -19,9 +20,11 @@
   (let ((*description* description)
        (*display* display)
        (*object*  object))
-      
     (call-next-method)))
 
+(defun display/d (&rest args)
+  (apply #'display-using-description args))
+
 
 
 (define-layered-method display-using-description (description display object &rest args)

diff --git a/src/standard-descriptions/clos.lisp b/src/standard-descriptions/clos.lisp
index ec80d86..2824c2e 100644 (file)
--- a/src/standard-descriptions/clos.lisp
+++ b/src/standard-descriptions/clos.lisp
@@ -8,13 +8,29 @@
  ((slot-name :initarg :slot-name :accessor attribute-slot-name)))
 
 (define-layered-method attribute-value (object (attribute slot-definition-attribute))
-  (slot-value object (attribute-slot-name attribute)))
+  (if (slot-boundp object (attribute-slot-name attribute))
+                      
+      (slot-value object (attribute-slot-name attribute))
+      (gensym "UNBOUND-SLOT-")))
+
+(defmacro define-description-for-class (class-name &optional (name (intern (format nil "DESCRIPTION-FOR-~A" class-name))))
+  `(progn 
+     (define-description ,name (standard-object)
+       ,(loop :for slot in (class-slots (find-class class-name))
+         :collect `(,(slot-definition-name slot) 
+                   :attribute-class slot-definition-attribute
+                   :slot-name ,(slot-definition-name slot)
+                   :label ,(slot-definition-name slot)))
+       (:mixinp t))
+     (unless (ignore-errors (find-description ',class-name))
+       (define-description ,class-name (,name) ()))))
+    
                       
                      
 (define-layered-method description-of ((object standard-object))
- (find-description 'standard-object))
-
-
+  (or (ignore-errors (find-description (class-name (class-of object))))
+      (find-description 'standard-object)))
+