Fix missing `without-special-symbol-access' in `funcall-with-attribute-context'
[clinton/lisp-on-lines.git] / src / standard-descriptions / clos.lisp
index 0fc53af..f1465a1 100644 (file)
    (class-slots :label "Slots" 
                :function (compose 'class-slots 'class-of))))
 
-(define-layered-class slot-definition-attribute (standard-attribute)
- ((slot-name :initarg :slot-name :accessor attribute-slot-name)))
+(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))
   (if (slot-boundp object (attribute-slot-name attribute))
                       
       (slot-value object (attribute-slot-name attribute))
-      (gensym "UNBOUND-SLOT-")))
-
-(defun ensure-description-for-class (class &optional (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class)))))
-  (let ((desc-class 
-        (ensure-class (defining-description name) 
-               :direct-superclasses (list (class-of (find-description 'standard-object)))
-               :direct-slots (loop :for slot in (class-slots class)
-                                :collect `(:name ,(slot-definition-name slot) 
-                                           :attribute-class slot-definition-attribute
-                                           :slot-name ,(slot-definition-name slot)
-                                           :label ,(slot-definition-name slot))
-                                :into slots
+      +unbound-slot+))
+
+(defun attribute-slot-makunbound (attribute)
+  (slot-makunbound (attribute-object attribute) (attribute-slot-name attribute)))
+
+(defun ensure-description-for-class (class &key attributes (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class)))) 
+                                    direct-superclasses direct-slot-specs)
+
+  (let* ((super-descriptions
+         (mapcar #'class-of 
+                             (delete nil (mapcar (rcurry #'find-description nil) 
+                                                 (mapcar #'class-name direct-superclasses)))))
+        (desc-class 
+         (ensure-layer (defining-description name) 
+               :direct-superclasses (or super-descriptions (list (class-of (find-description 'standard-object))))
+               :direct-slots 
+               (loop 
+                  :for slot in (class-slots class)
+                  :collect 
+                  (let ((direct-spec 
+                         (find (slot-definition-name slot) 
+                               direct-slot-specs
+                               :key (rcurry 'getf :name))))
+                    (if direct-spec 
+                        (append (alexandria:remove-from-plist direct-spec 
+                                                              :initfunction
+                                                              :initform
+                                                              :initargs
+                                                              :readers
+                                                              :writers)
+                                (unless 
+                                    (getf direct-spec :attribute-class)
+                                  (list :attribute-class 'slot-definition-attribute))
+                                (unless 
+                                    (getf direct-spec :label)
+                                  (list :label (format nil 
+                                                       "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot))))))
+                                (list :slot-name (slot-definition-name slot)))
+                        `(:name ,(slot-definition-name slot) 
+                                :attribute-class slot-definition-attribute
+                                :slot-name ,(slot-definition-name slot)
+                                :label ,(format nil 
+                                                "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot)))))))
+                  :into slots
                                 :collect (slot-definition-name slot) :into names
                                 :finally (return (cons `(:name active-attributes
-                                                         :value ,names)
+                                                         :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 ()
+  ((direct-slot-specs :accessor class-direct-slot-specs)
+   (attributes :initarg :attributes :initform nil)))
+
+(defmethod ensure-class-using-class :around ((class described-class) name &rest args)
+  
+  (call-next-method))
+
+(defmethod direct-slot-definition-class ((class described-class) &rest initargs)
+  (let ((slot-class (call-next-method))) 
+    (make-instance (class-of slot-class) :direct-superclasses (list slot-class (find-class 'described-class-direct-slot-definition)))))
+
+(defclass described-class-direct-slot-definition ()
   ())
 
+(defmethod shared-initialize :around ((class described-class-direct-slot-definition) slot-names &key &allow-other-keys)
+  (call-next-method))
+  
 (defmethod validate-superclass
            ((class described-class)
             (superclass standard-class))
   t)
 
-(defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()))
+(defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots)
   (declare (dynamic-extent initargs))
   (finalize-inheritance class)
-  (ensure-description-for-class class))
+  (ensure-description-for-class class :direct-slot-specs direct-slots 
+                                     :direct-superclasses  direct-superclasses
+                                     :attributes (slot-value class 'attributes)))
 
-
-(defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
+(defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots)
   (declare (dynamic-extent initargs))
   (finalize-inheritance class)
-  (ensure-description-for-class class))
+  (ensure-description-for-class class :direct-slot-specs direct-slots 
+                                     :direct-superclasses direct-superclasses
+                                     :attributes (slot-value class 'attributes)))
+
+(defclass described-standard-class (described-class standard-class ) ())
 
+(defmethod validate-superclass
+    ((class described-standard-class)
+     (superclass standard-class))
+  t)
 
 (define-layered-method description-of ((object standard-object))
   (or (ignore-errors (find-description (class-name (class-of object))))
       (find-description 'standard-object)))
-                     
-                      
-  
+
+