1 (in-package :lisp-on-lines
)
4 (define-layered-class attribute
()
7 (defgeneric eval-attribute-initarg
(attribute initarg
)
11 (defmethod eval-attribute-initarg (attribute (initarg (eql :function
)))
14 (define-layered-function attribute-value
(object attribute
))
16 (define-layered-method attribute-value
(object attribute
)
17 (funcall (attribute-function attribute
) object
))
19 (deflayer LISP-ON-LINES
)
20 (ensure-active-layer 'lisp-on-lines
)
22 (defvar *standard-direct-slot-initarg-symbols
*
23 '(:layered
:class
:in-layer
:name
:readers
:writers
:initargs
:allow-other-keys
:special
))
25 (define-layered-function special-slot-values
(description slot-name
)
26 (:method-combination append
))
28 (define-layered-class attribute-special-layered-direct-slot-definition
29 (attribute contextl
::special-layered-direct-slot-definition
)
32 (defmethod shared-initialize :around
((instance attribute-special-layered-direct-slot-definition
) slots
&rest initargs
)
33 (setf (slot-value instance
'initargs
) (apply #'arnesi
:remove-keywords initargs
*standard-direct-slot-initarg-symbols
*))
36 (define-layered-class standard-attribute
37 (attribute contextl
::layered-effective-slot-definition-in-layers
)
40 :layered-accessor description-of
)
43 :layered-accessor attribute-label
48 :layered-accessor attribute-function
54 (defmethod shared-initialize :around
((attribute standard-attribute
) slots
&rest initargs
)
55 (declare (ignore initargs
))
56 (setf (attribute-function attribute
)
58 (slot-value attribute
'value
)))
61 (defun attribute-name (attribute)
62 (closer-mop:slot-definition-name attribute
))
64 (define-layered-method slot-value-using-layer
65 ; :in-layer lisp-on-lines
66 :around
(class (attribute standard-attribute
) slot reader
)
67 (loop for
(key var
) on
(special-slot-values (slot-value attribute
'description
)
68 (attribute-name attribute
))
69 :if
(eq (closer-mop:slot-definition-name slot
) key
)
70 :do
(return-from slot-value-using-layer var
))
73 (define-layered-method display-using-description
74 ((attribute standard-attribute
) display object
&rest args
)
75 (declare (ignore args
))
76 (format display
"~@[~A ~]~A" (attribute-label attribute
)
77 (display display
(attribute-value object attribute
))))