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
  18              :accessor attribute-slot-name
  19              :layered t)))
  20
  21 (defmethod shared-initialize :around ((object slot-definition-attribute)
  22                                       slots &rest args)
  23   (prog1 (call-next-method)
  24     (unless (attribute-setter object)
  25       (setf (attribute-setter object)
  26             (lambda (v o)
  27               (setf (slot-value o (attribute-slot-name object)) v))))))
  28
  29
  30 (define-layered-method attribute-value-using-object (object (attribute slot-definition-attribute))
  31   (if (slot-boundp object (attribute-slot-name attribute))
  32
  33       (slot-value object (attribute-slot-name attribute))
  34       +unbound-slot+))
  35
  36 (defun ensure-description-for-class (class &optional (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class)))))
  37   (let ((desc-class
  38          (ensure-class (defining-description name)
  39                 :direct-superclasses (list (class-of (find-description 'standard-object)))
  40                 :direct-slots (loop :for slot in (class-slots class)
  41                                  :collect `(:name ,(slot-definition-name slot)
  42                                             :attribute-class slot-definition-attribute
  43                                             :slot-name ,(slot-definition-name slot)
  44                                             :label ,(format nil
  45                                                             "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot)))))
  46                                  :into slots
  47                                  :collect (slot-definition-name slot) :into names
  48                                  :finally (return (cons `(:name active-attributes
  49                                                           :value ',names)
  50                                                         slots)))
  51                 :metaclass 'standard-description-class)))
  52
  53     (unless (ignore-errors (find-description (class-name class)))
  54       (ensure-class (defining-description (class-name class))
  55                     :direct-superclasses (list desc-class)
  56                         :metaclass 'standard-description-class))
  57   (find-description name)))
  58
  59
  60 (defclass described-class ()
  61   ())
  62
  63 (defmethod validate-superclass
  64            ((class described-class)
  65             (superclass standard-class))
  66   t)
  67
  68 (defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()))
  69   (declare (dynamic-extent initargs))
  70   (finalize-inheritance class)
  71   (ensure-description-for-class class))
  72
  73
  74 (defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
  75   (declare (dynamic-extent initargs))
  76   (finalize-inheritance class)
  77   (ensure-description-for-class class))
  78
  79 (defclass described-standard-class (standard-class described-class) ())
  80
  81 (defmethod validate-superclass
  82     ((class described-standard-class)
  83      (superclass standard-class))
  84   t)
  85
  86 (define-layered-method description-of ((object standard-object))
  87   (or (ignore-errors (find-description (class-name (class-of object))))
  88       (find-description 'standard-object)))
  89
  90
  91
  92
  93
  94