Fix missing `without-special-symbol-access' in `funcall-with-attribute-context'

[clinton/lisp-on-lines.git] / src / standard-descriptions / clos.lisp

diff --git a/src/standard-descriptions/clos.lisp b/src/standard-descriptions/clos.lisp
index 1518392..f1465a1 100644 (file)
--- 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 ()