Commit | Line | Data |
---|---|---|
e96e008d MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
e96e008d MW |
3 | ;;; Useful bits of MOP hacking |
4 | ;;; | |
5 | ;;; (c) 2006 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This program is free software; you can redistribute it and/or modify | |
11 | ;;; it under the terms of the GNU General Public License as published by | |
12 | ;;; the Free Software Foundation; either version 2 of the License, or | |
13 | ;;; (at your option) any later version. | |
b2c12b4e | 14 | ;;; |
e96e008d MW |
15 | ;;; This program is distributed in the hope that it will be useful, |
16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
b2c12b4e | 19 | ;;; |
e96e008d MW |
20 | ;;; You should have received a copy of the GNU General Public License |
21 | ;;; along with this program; if not, write to the Free Software Foundation, | |
22 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
23 | ||
24 | ;;;-------------------------------------------------------------------------- | |
25 | ;;; Packages. | |
26 | ||
27 | (defpackage #:mdw.mop | |
d7d81997 MW |
28 | (:use #:common-lisp #:mdw.base |
29 | #+(or cmu clisp) #:mop | |
30 | #+sbcl #:sb-mop | |
77f935da | 31 | #+ecl #:clos)) |
e96e008d MW |
32 | |
33 | (in-package #:mdw.mop) | |
34 | ||
35 | ;;;-------------------------------------------------------------------------- | |
20be6570 MW |
36 | ;;; Copying instances. |
37 | ||
77f935da | 38 | (export 'copy-instance-using-class) |
20be6570 MW |
39 | (defgeneric copy-instance-using-class (class object &rest initargs) |
40 | (:documentation | |
41 | "Does the donkey-work behind copy-instance.")) | |
42 | ||
43 | (defmethod copy-instance-using-class | |
44 | ((class standard-class) object &rest initargs) | |
45 | (let ((new (apply #'allocate-instance class initargs))) | |
46 | (dolist (slot (class-slots class)) | |
47 | (setf (slot-value-using-class class new slot) | |
48 | (slot-value-using-class class object slot))) | |
49 | (apply #'shared-initialize new nil initargs) | |
50 | new)) | |
51 | ||
77f935da | 52 | (export 'copy-instance) |
20be6570 MW |
53 | (defun copy-instance (object &rest initargs) |
54 | "Make a copy of OBJECT, modifying it by setting slots as requested by | |
55 | INITARGS." | |
56 | (apply #'copy-instance-using-class (class-of object) object initargs)) | |
57 | ||
58 | ;;;-------------------------------------------------------------------------- | |
5cf4440b MW |
59 | ;;; Handy macros. |
60 | ||
77f935da | 61 | (export 'with-slot-variables) |
5cf4440b MW |
62 | (defmacro with-slot-variables (slots instance &body body) |
63 | "A copy-out-and-write-back variant of with-slots. | |
64 | ||
65 | The SLOTS argument is a list of slot specifications, each of which has the | |
66 | form (NAME &key :update :variable). VARIABLE defaults to NAME, and | |
67 | :update defaults to nil. | |
68 | ||
69 | The INSTANCE argument has the form (INSTANCE &key :class), but an atom may | |
70 | be used in place of a singleton list. If the CLASS is specified, then two | |
71 | good things happen: firstly the INSTANCE is declared to be a member of the | |
72 | CLASS, and secondly all the slot variables are declared to have the | |
73 | appropriate types, as dredged up from the class's effective slot | |
74 | definitions. | |
75 | ||
76 | The effect of all this is to return the result of evaluating BODY in an | |
77 | environment where the VARIABLEs are bound to the values of the NAMEd slots | |
78 | of the given INSTANCE. If BODY completes successfully (rather than | |
79 | throwing out, restarting, or anything like that) then the final values of | |
80 | VARIABLEs for which UPDATE was set non-nil are written back to their | |
81 | corresponding slots. | |
82 | ||
83 | This stands a good chance of being rather faster than with-slots. It | |
84 | does, however, run the risk of leaving things in an inconsistent state if | |
85 | BODY escapes half-way through. Also, this requires recompilation if a | |
86 | class's slots change type." | |
87 | (multiple-value-bind (instance class) | |
88 | (destructuring-bind | |
89 | (instance &key class) | |
90 | (listify instance) | |
91 | (values instance (and class (find-class class)))) | |
92 | (let ((slots (mapcar (lambda (slot) | |
93 | (destructuring-bind | |
94 | (name &key update (variable name)) | |
95 | (listify slot) | |
96 | (list name variable update))) | |
97 | (if slots | |
98 | (listify slots) | |
99 | (mapcar #'slot-definition-name | |
100 | (class-slots class)))))) | |
8f801ae8 | 101 | (with-parsed-body (body decls) body |
5cf4440b MW |
102 | (with-gensyms (instvar) |
103 | `(let ((,instvar ,instance)) | |
104 | ,@(and class `((declare (type ,(class-name class) ,instvar)))) | |
105 | (let ,(loop for (name var update) in slots | |
106 | collect `(,var (slot-value ,instvar ',name))) | |
107 | ,@(and class | |
108 | `((declare | |
109 | ,@(loop | |
110 | for (name var update) in slots | |
111 | for slot = (or (find name | |
112 | (class-slots class) | |
113 | :key #'slot-definition-name) | |
114 | (error | |
115 | "Slot ~S not found in class ~S." | |
116 | name (class-name class))) | |
117 | collect `(type | |
118 | ,(slot-definition-type slot) | |
119 | ,name))))) | |
120 | ,@decls | |
121 | (multiple-value-prog1 | |
122 | (progn ,@body) | |
123 | ,@(loop for (name var update) in slots | |
124 | when update | |
125 | collect `(setf (slot-value ,instvar ',name) | |
126 | ,var)))))))))) | |
127 | ||
128 | ;;;-------------------------------------------------------------------------- | |
e96e008d MW |
129 | ;;; Basic stuff. |
130 | ||
77f935da | 131 | (export 'compatible-class) |
e96e008d MW |
132 | (defclass compatible-class (standard-class) |
133 | () | |
134 | (:documentation | |
135 | "A class which can be be freely used in class heirarchies with | |
136 | standard-class and other subclasses of compatible-class. This saves a | |
137 | bunch of annoying messing about with `validate-superclass'.")) | |
138 | ||
139 | (defmethod validate-superclass | |
140 | ((sub compatible-class) (super compatible-class)) | |
141 | t) | |
142 | ||
143 | (defmethod validate-superclass | |
144 | ((sub compatible-class) (super standard-class)) | |
145 | (eq (class-of super) (find-class 'standard-class))) | |
146 | ||
147 | (defmethod validate-superclass | |
148 | ((sub standard-class) (super compatible-class)) | |
149 | (eq (class-of sub) (find-class 'standard-class))) | |
150 | ||
151 | ;;;-------------------------------------------------------------------------- | |
152 | ;;; Utilities for messing with slot options. | |
153 | ||
77f935da | 154 | (export 'initargs-for-effective-slot) |
e96e008d MW |
155 | (defgeneric initargs-for-effective-slot (class direct-slots) |
156 | (:documentation | |
157 | "Missing functionality from the MOP: given a class and its direct slots | |
158 | definitions, construct and return the proposed initializer list for | |
159 | constructing the effective-slot.")) | |
160 | ||
161 | (defmethod initargs-for-effective-slot | |
162 | ((class standard-class) direct-slots) | |
163 | "Extract the effective slot options as required." | |
164 | ;; | |
165 | ;; This is taken from the Closette implementation, but it seems to work! | |
166 | (let ((init-slot (find-if-not #'null direct-slots | |
167 | :key #'slot-definition-initfunction))) | |
168 | (list :name (slot-definition-name (car direct-slots)) | |
169 | :initform (and init-slot | |
170 | (slot-definition-initform init-slot)) | |
171 | :initfunction (and init-slot | |
172 | (slot-definition-initfunction init-slot)) | |
173 | :initargs (remove-duplicates | |
174 | (apply #'append | |
175 | (mapcar #'slot-definition-initargs | |
176 | direct-slots))) | |
177 | :allocation (slot-definition-allocation (car direct-slots))))) | |
178 | ||
77f935da | 179 | (export 'make-effective-slot) |
e96e008d | 180 | (defun make-effective-slot (class initargs) |
77f935da | 181 | "Construct an effective slot definition for a slot on the class, given the |
e96e008d MW |
182 | required arguments." |
183 | (apply #'make-instance | |
184 | (apply #'effective-slot-definition-class class initargs) | |
185 | initargs)) | |
186 | ||
187 | (let ((stdslot (find-class 'standard-direct-slot-definition))) | |
188 | (defmethod compute-effective-slot-definition | |
189 | ((class compatible-class) slot-name direct-slots) | |
190 | "Construct an effective slot definition for the given slot." | |
8a2e8de1 | 191 | (declare (ignore slot-name)) |
e96e008d MW |
192 | ;; |
193 | ;; Ideally we don't want to mess with a slot if it's entirely handled by | |
194 | ;; the implementation. This check seems to work OK. | |
195 | (if (every (lambda (slot) | |
196 | (member (class-of slot) | |
197 | (class-precedence-list stdslot))) | |
198 | direct-slots) | |
199 | (call-next-method) | |
200 | (make-effective-slot class | |
201 | (initargs-for-effective-slot class | |
202 | direct-slots))))) | |
203 | ||
204 | ;;;-------------------------------------------------------------------------- | |
205 | ;;; Filterered slots. | |
206 | ||
77f935da | 207 | (export 'filtered-slot-class-mixin) |
e96e008d MW |
208 | (defclass filtered-slot-class-mixin (compatible-class) |
209 | () | |
210 | (:documentation | |
211 | "A filtered slot interposes a filter on any attempt to write to the slot. | |
212 | The filter is given the proposed new value, and should return the actual | |
213 | new value. Specify the filter with a `:filter SYMBOL' slot option. | |
214 | (Yes, I know that using functions would be nicer, but the MOP makes | |
215 | that surprisingly difficult.)")) | |
216 | ||
fee2e08f MW |
217 | (defgeneric slot-definition-filter (slot) |
218 | (:method ((slot slot-definition)) nil)) | |
219 | ||
77f935da | 220 | (export 'filtered-direct-slot-definition) |
e96e008d MW |
221 | (defclass filtered-direct-slot-definition |
222 | (standard-direct-slot-definition) | |
223 | ((filter :initarg :filter :reader slot-definition-filter))) | |
224 | ||
77f935da | 225 | (export 'filtered-effective-slot-definition) |
e96e008d MW |
226 | (defclass filtered-effective-slot-definition |
227 | (standard-effective-slot-definition) | |
228 | ((filter :initarg :filter :accessor slot-definition-filter))) | |
229 | ||
230 | (defmethod direct-slot-definition-class | |
231 | ((class filtered-slot-class-mixin) | |
232 | &key (filter nil filterp) &allow-other-keys) | |
233 | (declare (ignore filter)) | |
234 | (if filterp | |
235 | (find-class 'filtered-direct-slot-definition) | |
236 | (call-next-method))) | |
237 | ||
238 | (defmethod effective-slot-definition-class | |
239 | ((class filtered-slot-class-mixin) | |
240 | &key (filter nil filterp) &allow-other-keys) | |
241 | (declare (ignore filter)) | |
242 | (if filterp | |
243 | (find-class 'filtered-effective-slot-definition) | |
244 | (call-next-method))) | |
245 | ||
246 | (defmethod initialize-instance :after | |
920d2b95 | 247 | ((slot filtered-direct-slot-definition) &key) |
e96e008d MW |
248 | (with-slots (filter) slot |
249 | (when (and (consp filter) | |
250 | (or (eq (car filter) 'function) | |
251 | (eq (car filter) 'quote)) | |
252 | (symbolp (cadr filter)) | |
253 | (null (cddr filter))) | |
254 | (setf filter (cadr filter))))) | |
255 | ||
256 | (defmethod initargs-for-effective-slot | |
257 | ((class filtered-slot-class-mixin) direct-slots) | |
258 | (let ((filter-slot (find-if #'slot-definition-filter direct-slots))) | |
259 | (append (and filter-slot | |
260 | (list :filter (slot-definition-filter filter-slot))) | |
261 | (call-next-method)))) | |
262 | ||
263 | (defmethod (setf slot-value-using-class) | |
264 | (value | |
265 | (class filtered-slot-class-mixin) | |
266 | (object standard-object) | |
267 | (slot filtered-effective-slot-definition)) | |
25760fe1 | 268 | (call-next-method (funcall (slot-definition-filter slot) value) |
e96e008d MW |
269 | class object slot)) |
270 | ||
271 | ;;;-------------------------------------------------------------------------- | |
9b2e67a5 MW |
272 | ;;; Predicates. |
273 | ||
77f935da | 274 | (export 'predicate-class-mixin) |
9b2e67a5 MW |
275 | (defclass predicate-class-mixin (compatible-class) |
276 | ((predicates :type list :initarg :predicate :initform nil | |
277 | :documentation "Predicate generic function to create.")) | |
278 | (:documentation | |
279 | "Class which can automatically generate a predicate generic function. | |
280 | Adds the `:predicate' class option, which takes a single symbol argument | |
281 | FUNC. If specified, and non-nil, a generic function FUNC with one | |
282 | argument will be defined (if it doesn't already exist) with a default | |
283 | method returning nil, and a method added specialized on this class | |
284 | returning a non-nil value.")) | |
285 | ||
286 | (defmethod shared-initialize :after | |
920d2b95 | 287 | ((class predicate-class-mixin) slot-names &key) |
9b2e67a5 MW |
288 | (declare (ignore slot-names)) |
289 | (with-slots (predicates) class | |
290 | (dolist (predicate predicates) | |
291 | (let ((lambda-list '(thing))) | |
292 | (let ((gf (if (fboundp predicate) | |
293 | (fdefinition predicate) | |
294 | (let ((gf (ensure-generic-function | |
295 | predicate :lambda-list lambda-list))) | |
296 | (add-method gf (make-instance | |
297 | 'standard-method | |
298 | :specializers (list (find-class 't)) | |
299 | :lambda-list lambda-list | |
300 | :function (constantly nil))))))) | |
301 | (add-method gf (make-instance 'standard-method | |
302 | :specializers (list class) | |
303 | :lambda-list lambda-list | |
304 | :function (constantly t)))))))) | |
305 | ||
306 | ;;;-------------------------------------------------------------------------- | |
e96e008d MW |
307 | ;;; Abstract classes. |
308 | ||
77f935da | 309 | (export 'abstract-class-mixin) |
e96e008d MW |
310 | (defclass abstract-class-mixin (compatible-class) |
311 | () | |
312 | (:documentation | |
313 | "Confusingly enough, a concrete metaclass for abstract classes. This | |
314 | class has a `make-instance' implementation which signals an error.")) | |
315 | ||
77f935da | 316 | (export '(instantiate-abstract-class instantiate-abstract-class-class)) |
e96e008d MW |
317 | (define-condition instantiate-abstract-class (error) |
318 | ((class :reader instantiate-abstract-class-class :initarg :class | |
319 | :documentation "The class someone attempted to instantiate.")) | |
320 | (:report (lambda (cond stream) | |
321 | (format stream "Cannot instantiate abstract class ~A." | |
322 | (class-name (instantiate-abstract-class-class cond))))) | |
323 | (:documentation | |
324 | "Reports an attempt to instantiate an abstract class.")) | |
325 | ||
326 | (defmethod make-instance ((class abstract-class-mixin) &rest whatever) | |
327 | "Signals an error. The caller is a naughty boy." | |
328 | (declare (ignore whatever)) | |
329 | (error 'instantiate-abstract-class :class class)) | |
330 | ||
331 | ;;;-------------------------------------------------------------------------- | |
46cd5c4b MW |
332 | ;;; Singleton classes. |
333 | ||
77f935da | 334 | (export 'singleton-class-mixin) |
46cd5c4b MW |
335 | (defclass singleton-class-mixin (compatible-class) |
336 | ((instance :initform nil :type (or null standard-object))) | |
337 | (:documentation | |
338 | "A class which has only one instance. All calls to `make-instance' return | |
339 | the same object.")) | |
340 | ||
341 | (defmethod allocate-instance ((class singleton-class-mixin) &key) | |
342 | "If the class already has an instance, return it; otherwise allocate one, | |
343 | store it away, and return that." | |
344 | (with-slots (instance) class | |
345 | (or instance | |
346 | (setf instance (call-next-method))))) | |
347 | ||
348 | ;;;-------------------------------------------------------------------------- | |
e96e008d MW |
349 | ;;; Useful classes. |
350 | ||
77f935da | 351 | (export 'mdw-class) |
e96e008d | 352 | (defclass mdw-class (filtered-slot-class-mixin |
9b2e67a5 | 353 | predicate-class-mixin |
e96e008d | 354 | compatible-class) |
9b2e67a5 MW |
355 | () |
356 | (:documentation | |
357 | "A generally useful metaclass with handy features. If I've done the | |
358 | hacking right, there shouldn't be a significant cost to using this | |
359 | metaclass for all your classes if you don't use any of its fancy | |
360 | features.")) | |
e96e008d | 361 | |
77f935da | 362 | (export 'abstract-class) |
e96e008d | 363 | (defclass abstract-class (mdw-class abstract-class-mixin) ()) |
77f935da MW |
364 | |
365 | (export 'singleton-class) | |
46cd5c4b | 366 | (defclass singleton-class (mdw-class singleton-class-mixin) ()) |
e96e008d MW |
367 | |
368 | ;;;-------------------------------------------------------------------------- | |
369 | ;;; Printing things. | |
370 | ||
77f935da | 371 | (export 'print-object-with-slots) |
e96e008d MW |
372 | (defun print-object-with-slots (obj stream) |
373 | "Prints objects in a pleasant way. Not too clever about circularity." | |
8a2e8de1 | 374 | (let ((class (class-of obj)) |
4da88bb9 | 375 | (magic (cons 'magic nil))) |
e96e008d MW |
376 | (print-unreadable-object (obj stream) |
377 | (pprint-logical-block | |
4da88bb9 MW |
378 | (stream |
379 | (mapcan (lambda (slot) | |
380 | (list (or (car (slot-definition-initargs slot)) | |
381 | (slot-definition-name slot)) | |
382 | (if (slot-boundp-using-class class obj slot) | |
383 | (slot-value-using-class class obj slot) | |
384 | magic))) | |
385 | (class-slots class))) | |
386 | (format stream "~S" (class-name class)) | |
387 | (let ((sep nil)) | |
388 | (loop | |
389 | (pprint-exit-if-list-exhausted) | |
390 | (if sep | |
391 | (format stream " ~_") | |
392 | (progn (format stream " ~@_~:I") (setf sep t))) | |
393 | (let ((name (pprint-pop)) | |
394 | (value (pprint-pop))) | |
395 | (format stream "~S ~@_~:[~W~;#<unbound>~*~]" | |
396 | name (eq value magic) value)))))))) | |
e96e008d MW |
397 | |
398 | ;;;----- That's all, folks -------------------------------------------------- |