2 (in-package :lisp-on-lines
)
4 (define-layered-class attribute
()
7 (define-layered-class standard-attribute
(simple-plist-attribute)
8 ((attribute-layers :accessor attribute-layers
:initform nil
)
10 :layered-accessor attribute-name
12 (effective-attribute-definition
13 :initarg effective-attribute
14 :accessor attribute-effective-attribute-definition
)
15 #+nil
(attribute-class
16 :accessor attribute-class
17 :initarg
:attribute-class
18 :initform
'standard-attribute
)
20 :layered-accessor attribute-keyword
25 :layered-accessor attribute-active-p
26 :initarg
:activep
;deprecated
32 "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.")
34 :layered-accessor attribute-value
40 :layered-accessor attribute-function
43 (active-attributes :layered-accessor attribute-active-attributes
47 (active-descriptions :layered-accessor attribute-active-descriptions
52 (inactive-descriptions :layered-accessor attribute-inactive-descriptions
59 (defmethod attribute-description ((attribute standard-attribute
))
60 (find-layer (attribute-description-class attribute
)))
62 (define-layered-function attribute-object
(attribute))
63 (define-layered-method attribute-active-p
:around
(attribute)
64 (let ((active?
(call-next-method)))
65 (if (eq :when active?
)
66 (not (null (attribute-value attribute
)))
70 (define-layered-method attribute-object
((attribute standard-attribute
))
71 (described-object (dynamic description
)))
73 (define-layered-function attribute-value-using-object
(object attribute
))
74 (define-layered-function (setf attribute-value-using-object
) (value object attribute
))
76 (define-layered-method attribute-value
((attribute standard-attribute
))
77 (attribute-value-using-object (attribute-object attribute
) attribute
))
79 (define-layered-method attribute-value-using-object
(object attribute
)
80 (let ((fn (handler-case (attribute-function attribute
)
81 (unbound-slot () nil
))))
84 (slot-value attribute
'value
))))
86 (define-layered-method (setf attribute-value
) (value (attribute standard-attribute
))
87 (setf (attribute-value-using-object (attribute-object attribute
) attribute
) value
))
89 (define-layered-method (setf attribute-value-using-object
) (value object attribute
)
90 (error "No (SETF ATTRIBUTE-VALUE-USING-OBJECT) for ~A ~A and we are not editable"
93 (defmethod print-object ((object standard-attribute
) stream
)
94 (print-unreadable-object (object stream
:type nil
:identity t
)
95 (format stream
"ATTRIBUTE ~A" (or (ignore-errors (attribute-name object
)) "+unnamed-attribute+"))))