X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/2548f0540da69973512f1827b2bfd2360470bb27..ddf67d6be45e1ea2d58aef8cceeba26f73ed1a0c:/src/standard-descriptions/clos.lisp?ds=inline

diff --git a/src/standard-descriptions/clos.lisp b/src/standard-descriptions/clos.lisp
index 1518392..f1465a1 100644
--- a/src/standard-descriptions/clos.lisp
+++ b/src/standard-descriptions/clos.lisp
@@ -13,18 +13,45 @@
    (class-slots :label "Slots" 
 		:function (compose 'class-slots 'class-of))))
 
-(define-layered-class slot-definition-attribute (standard-attribute)
+(define-description standard-object ()
+  ((editp :value t)
+   (class-slots :label "Slots" 
+		:function (compose 'class-slots 'class-of)))
+  (:in-description editable))
+
+(define-layered-class slot-definition-attribute (define-description-attribute)
  ((slot-name :initarg :slot-name 
 	     :accessor attribute-slot-name
 	     :layered t)))
 
+
+(define-layered-method attribute-active-p :around ((attribute slot-definition-attribute))		       
+ (let ((active? (slot-value attribute 'activep)))
+   (if (and (eq :when active?)
+	    (unbound-slot-value-p (attribute-value attribute)))
+       NIL
+       
+       (call-next-method))))
+
+(define-layered-method attribute-active-p 
+ :in-layer #.(defining-description 'editable) 
+ :around ((attribute slot-definition-attribute))		       
+ (let ((active? (slot-value attribute 'activep)))
+   (if (and (eq :when active?)
+	    (unbound-slot-value-p (attribute-value attribute)))
+       t      
+       (call-next-method))))
+
 (defmethod shared-initialize :around ((object slot-definition-attribute) 
 				      slots &rest args)
-  (prog1 (call-next-method)
-    (unless (attribute-setter object)
-      (setf (attribute-setter object) 
-	    (lambda (v o)
-	      (setf (slot-value o (attribute-slot-name object)) v))))))
+  (with-active-descriptions (editable) 
+    (prog1 (call-next-method)
+      (unless (attribute-setter object)
+	(setf (attribute-setter object) 
+	      (lambda (v o)
+		(if (unbound-slot-value-p v)
+		    (slot-makunbound o (attribute-slot-name object))
+		    (setf (slot-value o (attribute-slot-name object)) v))))))))
 		  
 
 (define-layered-method attribute-value-using-object (object (attribute slot-definition-attribute))
@@ -44,7 +71,7 @@
 			      (delete nil (mapcar (rcurry #'find-description nil) 
 						  (mapcar #'class-name direct-superclasses)))))
 	 (desc-class 
-	  (ensure-class (defining-description name) 
+	  (ensure-layer (defining-description name) 
 		:direct-superclasses (or super-descriptions (list (class-of (find-description 'standard-object))))
 		:direct-slots 
 		(loop 
@@ -79,12 +106,11 @@
 				 :finally (return (cons `(:name active-attributes
 							  :value ',(or attributes names))
 							slots)))	
-		:metaclass 'standard-description-class)))    
+		:metaclass 'define-description-class)))    
     (unless (ignore-errors (find-description (class-name class)))
-      (ensure-class (defining-description (class-name class))
-		    :direct-superclasses (list desc-class)
-		    :metaclass 'standard-description-class))
-    (find-description name)))
+      (find-layer  (ensure-layer (defining-description (class-name class))
+				 :direct-superclasses (list desc-class)
+				 :metaclass 'define-description-class)))))
 
 
 (defclass described-class ()