3 ;;; Useful bits of MOP hacking
5 ;;; (c) 2006 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
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.
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.
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.
24 ;;;--------------------------------------------------------------------------
28 (:use #:common-lisp #:mdw.base
29 #+(or cmu clisp) #:mop
33 (in-package #:mdw.mop)
35 ;;;--------------------------------------------------------------------------
36 ;;; Copying instances.
38 (export 'copy-instance-using-class)
39 (defgeneric copy-instance-using-class (class object &rest initargs)
41 "Does the donkey-work behind copy-instance."))
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)
52 (export 'copy-instance)
53 (defun copy-instance (object &rest initargs)
54 "Make a copy of OBJECT, modifying it by setting slots as requested by
56 (apply #'copy-instance-using-class (class-of object) object initargs))
58 ;;;--------------------------------------------------------------------------
61 (export 'with-slot-variables)
62 (defmacro with-slot-variables (slots instance &body body)
63 "A copy-out-and-write-back variant of with-slots.
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.
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
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
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)
91 (values instance (and class (find-class class))))
92 (let ((slots (mapcar (lambda (slot)
94 (name &key update (variable name))
96 (list name variable update)))
99 (mapcar #'slot-definition-name
100 (class-slots class))))))
101 (with-parsed-body (body decls) body
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)))
110 for (name var update) in slots
111 for slot = (or (find name
113 :key #'slot-definition-name)
115 "Slot ~S not found in class ~S."
116 name (class-name class)))
118 ,(slot-definition-type slot)
121 (multiple-value-prog1
123 ,@(loop for (name var update) in slots
125 collect `(setf (slot-value ,instvar ',name)
128 ;;;--------------------------------------------------------------------------
131 (export 'compatible-class)
132 (defclass compatible-class (standard-class)
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'."))
139 (defmethod validate-superclass
140 ((sub compatible-class) (super compatible-class))
143 (defmethod validate-superclass
144 ((sub compatible-class) (super standard-class))
145 (eq (class-of super) (find-class 'standard-class)))
147 (defmethod validate-superclass
148 ((sub standard-class) (super compatible-class))
149 (eq (class-of sub) (find-class 'standard-class)))
151 ;;;--------------------------------------------------------------------------
152 ;;; Utilities for messing with slot options.
154 (export 'initargs-for-effective-slot)
155 (defgeneric initargs-for-effective-slot (class direct-slots)
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."))
161 (defmethod initargs-for-effective-slot
162 ((class standard-class) direct-slots)
163 "Extract the effective slot options as required."
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
175 (mapcar #'slot-definition-initargs
177 :allocation (slot-definition-allocation (car direct-slots)))))
179 (export 'make-effective-slot)
180 (defun make-effective-slot (class initargs)
181 "Construct an effective slot definition for a slot on the class, given the
183 (apply #'make-instance
184 (apply #'effective-slot-definition-class class initargs)
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."
191 (declare (ignore slot-name))
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)))
200 (make-effective-slot class
201 (initargs-for-effective-slot class
204 ;;;--------------------------------------------------------------------------
205 ;;; Filterered slots.
207 (export 'filtered-slot-class-mixin)
208 (defclass filtered-slot-class-mixin (compatible-class)
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.)"))
217 (defgeneric slot-definition-filter (slot)
218 (:method ((slot slot-definition)) nil))
220 (export 'filtered-direct-slot-definition)
221 (defclass filtered-direct-slot-definition
222 (standard-direct-slot-definition)
223 ((filter :initarg :filter :reader slot-definition-filter)))
225 (export 'filtered-effective-slot-definition)
226 (defclass filtered-effective-slot-definition
227 (standard-effective-slot-definition)
228 ((filter :initarg :filter :accessor slot-definition-filter)))
230 (defmethod direct-slot-definition-class
231 ((class filtered-slot-class-mixin)
232 &key (filter nil filterp) &allow-other-keys)
233 (declare (ignore filter))
235 (find-class 'filtered-direct-slot-definition)
238 (defmethod effective-slot-definition-class
239 ((class filtered-slot-class-mixin)
240 &key (filter nil filterp) &allow-other-keys)
241 (declare (ignore filter))
243 (find-class 'filtered-effective-slot-definition)
246 (defmethod initialize-instance :after
247 ((slot filtered-direct-slot-definition) &key)
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)))))
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))))
263 (defmethod (setf slot-value-using-class)
265 (class filtered-slot-class-mixin)
266 (object standard-object)
267 (slot filtered-effective-slot-definition))
268 (call-next-method (funcall (slot-definition-filter slot) value)
271 ;;;--------------------------------------------------------------------------
274 (export 'predicate-class-mixin)
275 (defclass predicate-class-mixin (compatible-class)
276 ((predicates :type list :initarg :predicate :initform nil
277 :documentation "Predicate generic function to create."))
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."))
286 (defmethod shared-initialize :after
287 ((class predicate-class-mixin) slot-names &key)
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
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))))))))
306 ;;;--------------------------------------------------------------------------
307 ;;; Abstract classes.
309 (export 'abstract-class-mixin)
310 (defclass abstract-class-mixin (compatible-class)
313 "Confusingly enough, a concrete metaclass for abstract classes. This
314 class has a `make-instance' implementation which signals an error."))
316 (export '(instantiate-abstract-class instantiate-abstract-class-class))
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)))))
324 "Reports an attempt to instantiate an abstract class."))
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))
331 ;;;--------------------------------------------------------------------------
332 ;;; Singleton classes.
334 (export 'singleton-class-mixin)
335 (defclass singleton-class-mixin (compatible-class)
336 ((instance :initform nil :type (or null standard-object)))
338 "A class which has only one instance. All calls to `make-instance' return
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
346 (setf instance (call-next-method)))))
348 ;;;--------------------------------------------------------------------------
352 (defclass mdw-class (filtered-slot-class-mixin
353 predicate-class-mixin
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
362 (export 'abstract-class)
363 (defclass abstract-class (mdw-class abstract-class-mixin) ())
365 (export 'singleton-class)
366 (defclass singleton-class (mdw-class singleton-class-mixin) ())
368 ;;;--------------------------------------------------------------------------
371 (export 'print-object-with-slots)
372 (defun print-object-with-slots (obj stream)
373 "Prints objects in a pleasant way. Not too clever about circularity."
374 (let ((class (class-of obj))
375 (magic (cons 'magic nil)))
376 (print-unreadable-object (obj stream)
377 (pprint-logical-block
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)
385 (class-slots class)))
386 (format stream "~S" (class-name class))
389 (pprint-exit-if-list-exhausted)
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))))))))
398 ;;;----- That's all, folks --------------------------------------------------