| 1 | |
| 2 | (in-package :lisp-on-lines) |
| 3 | |
| 4 | (define-layered-class attribute () |
| 5 | ()) |
| 6 | |
| 7 | (define-layered-class standard-attribute (simple-plist-attribute) |
| 8 | ((attribute-layers :accessor attribute-layers :initform nil) |
| 9 | (name |
| 10 | :layered-accessor attribute-name |
| 11 | :initarg :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) |
| 19 | (keyword |
| 20 | :layered-accessor attribute-keyword |
| 21 | :initarg :keyword |
| 22 | :initform nil |
| 23 | :layered t) |
| 24 | (activep |
| 25 | :layered-accessor attribute-active-p |
| 26 | :initarg :activep ;deprecated |
| 27 | :initarg :active |
| 28 | :initform t |
| 29 | :layered t |
| 30 | :special t |
| 31 | :documentation |
| 32 | "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.") |
| 33 | (value |
| 34 | :layered-accessor attribute-value |
| 35 | :initarg :value |
| 36 | :layered t |
| 37 | :special t) |
| 38 | (function |
| 39 | :initarg :function |
| 40 | :layered-accessor attribute-function |
| 41 | :layered t |
| 42 | :special t) |
| 43 | (active-attributes :layered-accessor attribute-active-attributes |
| 44 | :initarg :attributes |
| 45 | :layered t |
| 46 | :special t) |
| 47 | (active-descriptions :layered-accessor attribute-active-descriptions |
| 48 | :initarg :activate |
| 49 | :initform nil |
| 50 | :layered t |
| 51 | :special t) |
| 52 | (inactive-descriptions :layered-accessor attribute-inactive-descriptions |
| 53 | :initarg :deactivate |
| 54 | :initform nil |
| 55 | :layered t |
| 56 | :special t) |
| 57 | )) |
| 58 | |
| 59 | (defmethod attribute-description ((attribute standard-attribute)) |
| 60 | (find-layer (attribute-description-class attribute))) |
| 61 | |
| 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))) |
| 67 | active?))) |
| 68 | |
| 69 | |
| 70 | (define-layered-method attribute-object ((attribute standard-attribute)) |
| 71 | (described-object (dynamic description))) |
| 72 | |
| 73 | (define-layered-function attribute-value-using-object (object attribute)) |
| 74 | (define-layered-function (setf attribute-value-using-object) (value object attribute)) |
| 75 | |
| 76 | (define-layered-method attribute-value ((attribute standard-attribute)) |
| 77 | (attribute-value-using-object (attribute-object attribute) attribute)) |
| 78 | |
| 79 | (define-layered-method attribute-value-using-object (object attribute) |
| 80 | (let ((fn (handler-case (attribute-function attribute) |
| 81 | (unbound-slot () nil)))) |
| 82 | (if fn |
| 83 | (funcall fn object) |
| 84 | (slot-value attribute 'value)))) |
| 85 | |
| 86 | (define-layered-method (setf attribute-value) (value (attribute standard-attribute)) |
| 87 | (setf (attribute-value-using-object (attribute-object attribute) attribute) value)) |
| 88 | |
| 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" |
| 91 | object attribute)) |
| 92 | |
| 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+")))) |