src/attribute.lisp

   1 (in-package :lisp-on-lines)
   2
   3
   4 (define-layered-class attribute ()
   5   ())
   6
   7 (defgeneric eval-attribute-initarg (attribute initarg)
   8   (:method (a i)
   9     nil))
  10
  11 (defmethod eval-attribute-initarg (attribute (initarg (eql :function)))
  12   t)
  13 (define-layered-function attribute-value (object attribute))
  14
  15
  16
  17 (deflayer LISP-ON-LINES)
  18 (ensure-active-layer 'lisp-on-lines)
  19
  20 (defvar *standard-direct-slot-initarg-symbols*
  21     '(:layered :class :in-layer :name :readers :writers :initargs :allow-other-keys :special))
  22
  23 (define-layered-function special-slot-values (description slot-name)
  24   (:method-combination append))
  25
  26 (define-layered-class attribute-special-layered-direct-slot-definition
  27   (attribute contextl::special-layered-direct-slot-definition)
  28   (initargs))
  29
  30 (defmethod shared-initialize :around ((instance attribute-special-layered-direct-slot-definition) slots &rest initargs )
  31   (setf (slot-value instance 'initargs)
  32         (apply #'arnesi:remove-keywords initargs *standard-direct-slot-initarg-symbols*))
  33   (call-next-method))
  34
  35 (define-layered-class standard-attribute
  36   (attribute contextl::layered-effective-slot-definition-in-layers)
  37   ((direct-slots)
  38    (description
  39     :layered-accessor description-of)
  40    (label
  41     :initarg :label
  42     :layered-accessor attribute-label
  43     :layered t
  44     :initform nil)
  45    (function
  46     :initarg :function
  47     :layered-accessor attribute-function
  48     :layered t)
  49    (value
  50     :initarg :value
  51     :layered t)))
  52
  53 (define-layered-method attribute-value (object attribute)
  54  (funcall (attribute-function attribute) object))
  55
  56 (defmethod shared-initialize :around ((attribute standard-attribute) slots &rest initargs)
  57   (declare (ignore initargs))
  58     (setf (attribute-function attribute)
  59         (lambda (object)
  60           (slot-value attribute 'value)))
  61   (call-next-method))
  62
  63 (defun attribute-name (attribute)
  64   (closer-mop:slot-definition-name attribute))
  65
  66 (define-layered-method slot-value-using-layer
  67 ;  :in-layer lisp-on-lines
  68   :around (class (attribute standard-attribute) slot reader)
  69   (loop for (key var) on (special-slot-values (slot-value attribute 'description)
  70                                                      (attribute-name attribute))
  71               :if (eq (closer-mop:slot-definition-name slot) key)
  72               :do (return-from slot-value-using-layer var))
  73   (call-next-method))
  74
  75 (define-layered-method display-using-description
  76   ((attribute standard-attribute) display object &rest args)
  77  (declare (ignore args))
  78  (format display "~@[~A ~]~A" (attribute-label attribute)
  79          (attribute-value object attribute)))
  80
  81
  82
  83
  84
  85
  86
  87
  88