e7c5f95a |
1 | (in-package :lisp-on-lines) |
2 | |
4358148e |
3 | (define-layered-class direct-attribute-definition-class |
4 | (special-layered-direct-slot-definition contextl::singleton-direct-slot-definition) |
5 | ((attribute-properties :accessor direct-attribute-properties |
6 | :documentation "This is an plist to hold the values of the attribute's properties as described by this direct attrbiute definition."))) |
e7c5f95a |
7 | |
4358148e |
8 | (defmethod initialize-instance :after ((attribute direct-attribute-definition-class) &rest initargs) |
9 | (setf (direct-attribute-properties attribute) initargs)) |
e7c5f95a |
10 | |
4358148e |
11 | (define-layered-class effective-attribute-definition-class (special-layered-effective-slot-definition) |
12 | ((direct-attributes :accessor attribute-direct-attributes) |
13 | (attribute-object :accessor attribute-object |
f2ff8a16 |
14 | :documentation "") |
15 | (attribute-object-initargs :accessor attribute-object-initargs))) |
e7c5f95a |
16 | |
e7c5f95a |
17 | |
4358148e |
18 | (define-layered-function attribute-value (object attribute)) |
e7c5f95a |
19 | |
4358148e |
20 | (define-layered-method attribute-value (object attribute) |
21 | |
22 | (let ((fn (handler-case (attribute-function attribute) |
23 | (unbound-slot () nil)))) |
24 | (if fn |
25 | (funcall fn object) |
26 | (%attribute-value attribute)))) |
27 | |
28 | (defmethod attribute-description (attribute) |
29 | ;(break "description for ~A is (slot-value attribute 'description-name)") |
30 | (find-layer (slot-value attribute 'description-class)) |
31 | #+nil (let ((name (slot-value attribute 'description-name))) |
32 | (when name |
33 | (find-description name)))) |
34 | |
35 | |
36 | (define-layered-class standard-attribute () |
37 | |
38 | ((effective-attribute-definition :initarg effective-attribute |
39 | :accessor attribute-effective-attribute-definition) |
40 | (description-name) |
41 | (description-class :initarg description-class) |
42 | (initfunctions :initform nil) |
f2ff8a16 |
43 | (attribute-class :accessor attribute-class |
44 | :initarg :attribute-class |
45 | :initform 'standard-attribute) |
4358148e |
46 | (name :layered-accessor attribute-name |
47 | :initarg :name) |
48 | (label :layered-accessor attribute-label |
49 | :initarg :label |
50 | :initform nil |
51 | :layered t |
52 | ;:special t |
53 | ) |
e7c5f95a |
54 | (function |
55 | :initarg :function |
56 | :layered-accessor attribute-function |
57 | :layered t) |
4358148e |
58 | (value :layered-accessor %attribute-value |
59 | :initarg :value |
60 | :layered t))) |
61 | |
62 | |
63 | |
64 | (defmethod print-object ((object standard-attribute) stream) |
65 | (print-unreadable-object (object stream :type nil :identity t) |
66 | (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+")))) |
67 | |
68 | (defvar *bypass-property-layered-function* nil) |
69 | |
70 | (define-layered-function property-layered-function (description attribute-name property-name) |
71 | (:method (description attribute-name property-name) |
72 | ;(dprint "First Time PLFunction for ~A ~A ~A" description attribute-name property-name) |
73 | (ensure-layered-function |
74 | (defining-description (intern (format nil "~A-~A-~A" |
75 | (description-print-name description) |
76 | attribute-name |
77 | property-name))) |
78 | |
79 | :lambda-list '(description)))) |
80 | |
81 | (define-layered-method (setf slot-value-using-layer) |
82 | :in-layer (context t) |
83 | (new-value class (attribute standard-attribute) property writer) |
84 | |
85 | (when (or *bypass-property-layered-function* |
86 | (not (slot-definition-layeredp property))) |
87 | (return-from slot-value-using-layer (call-next-method))) |
88 | |
89 | |
90 | ;;FIXME: this is wrong for so many reasons. |
91 | (let ((layer |
92 | (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context)) |
93 | :key #'class-name))))) |
94 | |
95 | |
96 | (flet ((do-set-slot() |
97 | |
98 | (let ((fn |
99 | (let ((*bypass-property-layered-function* t)) |
100 | (if (slot-boundp-using-class class attribute property) |
101 | (slot-value-using-class class attribute property) |
102 | (setf (slot-value-using-class class attribute property) |
103 | (property-layered-function |
104 | (attribute-description attribute) |
105 | (attribute-name attribute) |
106 | (closer-mop:slot-definition-name property))))))) |
107 | ;(dprint "We are setting the fn ~A " fn) |
108 | (when (not (generic-function-methods fn)) |
109 | ; (dprint "... there are no methods on it ever") |
110 | ;; * This slot has never been set before. |
111 | ;; create a method on property-layered-function |
112 | ;; so subclasses can see this new property. |
113 | (ensure-layered-method |
114 | (layered-function-definer 'property-layered-function) |
115 | `(lambda (description attribute property) |
116 | (declare (ignore description attribute property)) |
117 | ,fn) |
118 | :in-layer layer |
119 | :specializers |
120 | (list (class-of |
121 | (attribute-description attribute)) |
122 | (closer-mop:intern-eql-specializer |
123 | (attribute-name attribute)) |
124 | (closer-mop:intern-eql-specializer |
125 | (closer-mop:slot-definition-name property))))) |
126 | |
127 | |
128 | ;; finally, specialize this property to this description. |
129 | (ensure-layered-method |
130 | fn |
131 | `(lambda (description) |
132 | ,new-value) |
133 | :in-layer layer |
134 | :specializers (list (class-of (attribute-description attribute) |
135 | )))))) |
136 | |
137 | (if (slot-boundp attribute 'description-class) |
138 | (do-set-slot) |
139 | (push (lambda () (do-set-slot)) |
140 | (slot-value attribute 'initfunctions)))))) |
e7c5f95a |
141 | |
e7c5f95a |
142 | |
143 | (define-layered-method slot-value-using-layer |
4358148e |
144 | :in-layer (layer t) |
145 | :around (class (attribute standard-attribute) property reader) |
4358148e |
146 | |
81d70610 |
147 | ;; (dprint "Getting the slot value of ~A" property) |
4358148e |
148 | |
81d70610 |
149 | ;; We do some magic in here and i thought it |
150 | ;; would be called magically in call-next-method. |
151 | ;; This explicit call is good enough for now. |
152 | |
153 | (unless (slot-boundp-using-class class attribute property) |
154 | (slot-unbound class attribute (slot-definition-name property))) |
155 | |
156 | (if (and |
4358148e |
157 | (contextl::slot-definition-layeredp property) |
158 | (not *bypass-property-layered-function*)) |
159 | (let ((fn (call-next-method))) |
160 | ;(dprint "... using fn ~A to get value" fn) |
161 | (funcall fn layer (attribute-description attribute))) |
162 | (call-next-method))) |
163 | |
81d70610 |
164 | (defmacro define-bypass-function (name function-name) |
165 | `(defun ,name (&rest args) |
166 | (let ((*bypass-property-layered-function* t)) |
167 | (apply (function ,function-name) args)))) |
4358148e |
168 | |
81d70610 |
169 | (define-bypass-function real-slot-boundp-using-class slot-boundp-using-class) |
170 | (define-bypass-function real-slot-value-using-class slot-value-using-class) |
171 | (define-bypass-function (setf real-slot-value-using-class) (setf slot-value-using-class)) |
172 | |
4358148e |
173 | (defun slot-boundp-using-property-layered-function (class attribute property) |
81d70610 |
174 | (dprint "plf boundp:") |
175 | (let* ((really-bound-p |
176 | (real-slot-boundp-using-class class attribute property)) |
177 | (fn (if really-bound-p |
178 | (real-slot-value-using-class class attribute property) |
179 | (setf (real-slot-value-using-class class attribute property) |
180 | (property-layered-function |
181 | (attribute-description attribute) |
4358148e |
182 | (attribute-name attribute) |
81d70610 |
183 | (closer-mop:slot-definition-name property)))))) |
184 | (dprint "Slot was bound? ~A" really-bound-p) |
185 | ;; If the slot is unbound, we search for its layered-function |
4358148e |
186 | (if (generic-function-methods fn) |
81d70610 |
187 | T |
188 | NIL))) |
4358148e |
189 | |
81d70610 |
190 | (define-layered-method slot-boundp-using-layer |
4358148e |
191 | :in-layer (layer t) |
192 | :around (class (attribute standard-attribute) property reader) |
193 | (if *bypass-property-layered-function* |
194 | (call-next-method) |
195 | (slot-boundp-using-property-layered-function class attribute property))) |
196 | |
197 | (defun attribute-value* (attribute) |
198 | (attribute-value *object* attribute)) |
199 | |
200 | (defmacro with-attributes (names description &body body) |
201 | `(with-slots ,names ,description ,@body)) |
202 | |
203 | (defun display-attribute (attribute) |
204 | (display-using-description attribute *display* *object*)) |
205 | |
e7c5f95a |
206 | (define-layered-method display-using-description |
207 | ((attribute standard-attribute) display object &rest args) |
4358148e |
208 | (declare (ignore args)) |
209 | (when (attribute-label attribute) |
210 | (format display "~A " (attribute-label attribute))) |
211 | (format display "~A" (attribute-value object attribute))) |
212 | |
213 | |
e7c5f95a |
214 | |
215 | |
216 | |
217 | |
218 | |
219 | |
220 | |
221 | |
222 | |