src/standard-descriptions/clos.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (defstruct unbound-slot-value (s))
   4
   5 (defvar +unbound-slot+ (make-unbound-slot-value))
   6
   7 (defmethod print-object ((object unbound-slot-value) stream)
   8   (print-unreadable-object (object stream)
   9     (format stream "UNBOUND")))
  10
  11 (define-description standard-object ()
  12   ((editp :value t)
  13    (class-slots :label "Slots"
  14                 :function (compose 'class-slots 'class-of))))
  15
  16 (define-layered-class slot-definition-attribute (standard-attribute)
  17  ((slot-name :initarg :slot-name :accessor attribute-slot-name)))
  18
  19 (defmethod shared-initialize :around ((object slot-definition-attribute)
  20                                       slots &rest args)
  21   (prog1 (call-next-method)
  22     (unless (attribute-setter object)
  23       (setf (attribute-setter object)
  24             (lambda (v o)
  25               (setf (slot-value o (attribute-slot-name object)) v))))))
  26
  27
  28 (define-layered-method attribute-value (object (attribute slot-definition-attribute))
  29   (if (slot-boundp object (attribute-slot-name attribute))
  30
  31       (slot-value object (attribute-slot-name attribute))
  32       (gensym "UNBOUND-SLOT-")))
  33
  34 (defun ensure-description-for-class (class &optional (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class)))))
  35   (let ((desc-class
  36          (ensure-class (defining-description name)
  37                 :direct-superclasses (list (class-of (find-description 'standard-object)))
  38                 :direct-slots (loop :for slot in (class-slots class)
  39                                  :collect `(:name ,(slot-definition-name slot)
  40                                             :attribute-class slot-definition-attribute
  41                                             :slot-name ,(slot-definition-name slot)
  42                                             :label ,(slot-definition-name slot))
  43                                  :into slots
  44                                  :collect (slot-definition-name slot) :into names
  45                                  :finally (return (cons `(:name active-attributes
  46                                                           :value ,names)
  47                                                         slots)))
  48                 :metaclass 'standard-description-class)))
  49
  50     (unless (ignore-errors (find-description (class-name class)))
  51       (ensure-class (defining-description (class-name class))
  52                     :direct-superclasses (list desc-class)
  53                         :metaclass 'standard-description-class))
  54   (find-description name)))
  55
  56 (defclass described-class ()
  57   ())
  58
  59 (defmethod validate-superclass
  60            ((class described-class)
  61             (superclass standard-class))
  62   t)
  63
  64 (defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()))
  65   (declare (dynamic-extent initargs))
  66   (finalize-inheritance class)
  67   (ensure-description-for-class class))
  68
  69
  70 (defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
  71   (declare (dynamic-extent initargs))
  72   (finalize-inheritance class)
  73   (ensure-description-for-class class))
  74
  75
  76
  77
  78 (define-layered-method description-of ((object standard-object))
  79   (or (ignore-errors (find-description (class-name (class-of object))))
  80       (find-description 'standard-object)))
  81
  82
  83
  84