5 ;;; Useful bits of MOP hacking
7 ;;; (c) 2006 Straylight/Edgeware
10 ;;;----- Licensing notice ---------------------------------------------------
12 ;;; This program is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2 of the License, or
15 ;;; (at your option) any later version.
17 ;;; This program is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with this program; if not, write to the Free Software Foundation,
24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
26 ;;;--------------------------------------------------------------------------
30 (:use #:common-lisp #:mdw.base
31 #+(or cmu clisp) #:mop
34 (:export #:copy-instance #:copy-instance-using-class
37 #:initargs-for-effective-slot #:make-effective-slot
38 #:filtered-slot-class-mixin
39 #:filtered-direct-slot-definition
40 #:filtered-effective-slot-definition
41 #:predicate-class-mixin
42 #:abstract-class-mixin #:instantiate-abstract-class
43 #:singleton-class-mixin
44 #:mdw-class #:abstract-class #:singleton-class
45 #:print-object-with-slots))
47 (in-package #:mdw.mop)
49 ;;;--------------------------------------------------------------------------
50 ;;; Copying instances.
52 (defgeneric copy-instance-using-class (class object &rest initargs)
54 "Does the donkey-work behind copy-instance."))
56 (defmethod copy-instance-using-class
57 ((class standard-class) object &rest initargs)
58 (let ((new (apply #'allocate-instance class initargs)))
59 (dolist (slot (class-slots class))
60 (setf (slot-value-using-class class new slot)
61 (slot-value-using-class class object slot)))
62 (apply #'shared-initialize new nil initargs)
65 (defun copy-instance (object &rest initargs)
66 "Make a copy of OBJECT, modifying it by setting slots as requested by
68 (apply #'copy-instance-using-class (class-of object) object initargs))
70 ;;;--------------------------------------------------------------------------
73 (defmacro with-slot-variables (slots instance &body body)
74 "A copy-out-and-write-back variant of with-slots.
76 The SLOTS argument is a list of slot specifications, each of which has the
77 form (NAME &key :update :variable). VARIABLE defaults to NAME, and
78 :update defaults to nil.
80 The INSTANCE argument has the form (INSTANCE &key :class), but an atom may
81 be used in place of a singleton list. If the CLASS is specified, then two
82 good things happen: firstly the INSTANCE is declared to be a member of the
83 CLASS, and secondly all the slot variables are declared to have the
84 appropriate types, as dredged up from the class's effective slot
87 The effect of all this is to return the result of evaluating BODY in an
88 environment where the VARIABLEs are bound to the values of the NAMEd slots
89 of the given INSTANCE. If BODY completes successfully (rather than
90 throwing out, restarting, or anything like that) then the final values of
91 VARIABLEs for which UPDATE was set non-nil are written back to their
94 This stands a good chance of being rather faster than with-slots. It
95 does, however, run the risk of leaving things in an inconsistent state if
96 BODY escapes half-way through. Also, this requires recompilation if a
97 class's slots change type."
98 (multiple-value-bind (instance class)
100 (instance &key class)
102 (values instance (and class (find-class class))))
103 (let ((slots (mapcar (lambda (slot)
105 (name &key update (variable name))
107 (list name variable update)))
110 (mapcar #'slot-definition-name
111 (class-slots class))))))
112 (with-parsed-body (body decls) body
113 (with-gensyms (instvar)
114 `(let ((,instvar ,instance))
115 ,@(and class `((declare (type ,(class-name class) ,instvar))))
116 (let ,(loop for (name var update) in slots
117 collect `(,var (slot-value ,instvar ',name)))
121 for (name var update) in slots
122 for slot = (or (find name
124 :key #'slot-definition-name)
126 "Slot ~S not found in class ~S."
127 name (class-name class)))
129 ,(slot-definition-type slot)
132 (multiple-value-prog1
134 ,@(loop for (name var update) in slots
136 collect `(setf (slot-value ,instvar ',name)
139 ;;;--------------------------------------------------------------------------
142 (defclass compatible-class (standard-class)
145 "A class which can be be freely used in class heirarchies with
146 standard-class and other subclasses of compatible-class. This saves a
147 bunch of annoying messing about with `validate-superclass'."))
149 (defmethod validate-superclass
150 ((sub compatible-class) (super compatible-class))
153 (defmethod validate-superclass
154 ((sub compatible-class) (super standard-class))
155 (eq (class-of super) (find-class 'standard-class)))
157 (defmethod validate-superclass
158 ((sub standard-class) (super compatible-class))
159 (eq (class-of sub) (find-class 'standard-class)))
161 ;;;--------------------------------------------------------------------------
162 ;;; Utilities for messing with slot options.
164 (defgeneric initargs-for-effective-slot (class direct-slots)
166 "Missing functionality from the MOP: given a class and its direct slots
167 definitions, construct and return the proposed initializer list for
168 constructing the effective-slot."))
170 (defmethod initargs-for-effective-slot
171 ((class standard-class) direct-slots)
172 "Extract the effective slot options as required."
174 ;; This is taken from the Closette implementation, but it seems to work!
175 (let ((init-slot (find-if-not #'null direct-slots
176 :key #'slot-definition-initfunction)))
177 (list :name (slot-definition-name (car direct-slots))
178 :initform (and init-slot
179 (slot-definition-initform init-slot))
180 :initfunction (and init-slot
181 (slot-definition-initfunction init-slot))
182 :initargs (remove-duplicates
184 (mapcar #'slot-definition-initargs
186 :allocation (slot-definition-allocation (car direct-slots)))))
188 (defun make-effective-slot (class initargs)
189 "Construct an effectie slot definition for a slot on the class, given the
191 (apply #'make-instance
192 (apply #'effective-slot-definition-class class initargs)
195 (let ((stdslot (find-class 'standard-direct-slot-definition)))
196 (defmethod compute-effective-slot-definition
197 ((class compatible-class) slot-name direct-slots)
198 "Construct an effective slot definition for the given slot."
199 (declare (ignore slot-name))
201 ;; Ideally we don't want to mess with a slot if it's entirely handled by
202 ;; the implementation. This check seems to work OK.
203 (if (every (lambda (slot)
204 (member (class-of slot)
205 (class-precedence-list stdslot)))
208 (make-effective-slot class
209 (initargs-for-effective-slot class
212 ;;;--------------------------------------------------------------------------
213 ;;; Filterered slots.
215 (defclass filtered-slot-class-mixin (compatible-class)
218 "A filtered slot interposes a filter on any attempt to write to the slot.
219 The filter is given the proposed new value, and should return the actual
220 new value. Specify the filter with a `:filter SYMBOL' slot option.
221 (Yes, I know that using functions would be nicer, but the MOP makes
222 that surprisingly difficult.)"))
224 (defgeneric slot-definition-filter (slot)
225 (:method ((slot slot-definition)) nil))
227 (defclass filtered-direct-slot-definition
228 (standard-direct-slot-definition)
229 ((filter :initarg :filter :reader slot-definition-filter)))
231 (defclass filtered-effective-slot-definition
232 (standard-effective-slot-definition)
233 ((filter :initarg :filter :accessor slot-definition-filter)))
235 (defmethod direct-slot-definition-class
236 ((class filtered-slot-class-mixin)
237 &key (filter nil filterp) &allow-other-keys)
238 (declare (ignore filter))
240 (find-class 'filtered-direct-slot-definition)
243 (defmethod effective-slot-definition-class
244 ((class filtered-slot-class-mixin)
245 &key (filter nil filterp) &allow-other-keys)
246 (declare (ignore filter))
248 (find-class 'filtered-effective-slot-definition)
251 (defmethod initialize-instance :after
252 ((slot filtered-direct-slot-definition) &key)
253 (with-slots (filter) slot
254 (when (and (consp filter)
255 (or (eq (car filter) 'function)
256 (eq (car filter) 'quote))
257 (symbolp (cadr filter))
258 (null (cddr filter)))
259 (setf filter (cadr filter)))))
261 (defmethod initargs-for-effective-slot
262 ((class filtered-slot-class-mixin) direct-slots)
263 (let ((filter-slot (find-if #'slot-definition-filter direct-slots)))
264 (append (and filter-slot
265 (list :filter (slot-definition-filter filter-slot)))
266 (call-next-method))))
268 (defmethod (setf slot-value-using-class)
270 (class filtered-slot-class-mixin)
271 (object standard-object)
272 (slot filtered-effective-slot-definition))
273 (call-next-method (funcall (slot-definition-filter slot) value)
276 ;;;--------------------------------------------------------------------------
279 (defclass predicate-class-mixin (compatible-class)
280 ((predicates :type list :initarg :predicate :initform nil
281 :documentation "Predicate generic function to create."))
283 "Class which can automatically generate a predicate generic function.
284 Adds the `:predicate' class option, which takes a single symbol argument
285 FUNC. If specified, and non-nil, a generic function FUNC with one
286 argument will be defined (if it doesn't already exist) with a default
287 method returning nil, and a method added specialized on this class
288 returning a non-nil value."))
290 (defmethod shared-initialize :after
291 ((class predicate-class-mixin) slot-names &key)
292 (declare (ignore slot-names))
293 (with-slots (predicates) class
294 (dolist (predicate predicates)
295 (let ((lambda-list '(thing)))
296 (let ((gf (if (fboundp predicate)
297 (fdefinition predicate)
298 (let ((gf (ensure-generic-function
299 predicate :lambda-list lambda-list)))
300 (add-method gf (make-instance
302 :specializers (list (find-class 't))
303 :lambda-list lambda-list
304 :function (constantly nil)))))))
305 (add-method gf (make-instance 'standard-method
306 :specializers (list class)
307 :lambda-list lambda-list
308 :function (constantly t))))))))
310 ;;;--------------------------------------------------------------------------
311 ;;; Abstract classes.
313 (defclass abstract-class-mixin (compatible-class)
316 "Confusingly enough, a concrete metaclass for abstract classes. This
317 class has a `make-instance' implementation which signals an error."))
319 (define-condition instantiate-abstract-class (error)
320 ((class :reader instantiate-abstract-class-class :initarg :class
321 :documentation "The class someone attempted to instantiate."))
322 (:report (lambda (cond stream)
323 (format stream "Cannot instantiate abstract class ~A."
324 (class-name (instantiate-abstract-class-class cond)))))
326 "Reports an attempt to instantiate an abstract class."))
328 (defmethod make-instance ((class abstract-class-mixin) &rest whatever)
329 "Signals an error. The caller is a naughty boy."
330 (declare (ignore whatever))
331 (error 'instantiate-abstract-class :class class))
333 ;;;--------------------------------------------------------------------------
334 ;;; Singleton classes.
336 (defclass singleton-class-mixin (compatible-class)
337 ((instance :initform nil :type (or null standard-object)))
339 "A class which has only one instance. All calls to `make-instance' return
342 (defmethod allocate-instance ((class singleton-class-mixin) &key)
343 "If the class already has an instance, return it; otherwise allocate one,
344 store it away, and return that."
345 (with-slots (instance) class
347 (setf instance (call-next-method)))))
349 ;;;--------------------------------------------------------------------------
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 (defclass abstract-class (mdw-class abstract-class-mixin) ())
363 (defclass singleton-class (mdw-class singleton-class-mixin) ())
365 ;;;--------------------------------------------------------------------------
368 (defun print-object-with-slots (obj stream)
369 "Prints objects in a pleasant way. Not too clever about circularity."
370 (let ((class (class-of obj))
371 (magic (cons 'magic nil)))
372 (print-unreadable-object (obj stream)
373 (pprint-logical-block
375 (mapcan (lambda (slot)
376 (list (or (car (slot-definition-initargs slot))
377 (slot-definition-name slot))
378 (if (slot-boundp-using-class class obj slot)
379 (slot-value-using-class class obj slot)
381 (class-slots class)))
382 (format stream "~S" (class-name class))
385 (pprint-exit-if-list-exhausted)
387 (format stream " ~_")
388 (progn (format stream " ~@_~:I") (setf sep t)))
389 (let ((name (pprint-pop))
390 (value (pprint-pop)))
391 (format stream "~S ~@_~:[~W~;#<unbound>~*~]"
392 name (eq value magic) value))))))))
394 ;;;----- That's all, folks --------------------------------------------------