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 #+cmu #:pcl)
31 (:export #:compatible-class
32 #:copy-instance #:copy-instance-using-class
33 #:initargs-for-effective-slot #:make-effective-slot
34 #:filtered-slot-class-mixin
35 #:filtered-direct-slot-definition
36 #:filtered-effective-slot-definition
37 #:predicate-class-mixin
38 #:abstract-class-mixin #:instantiate-abstract-class
39 #:mdw-class #:abstract-class
40 #:print-object-with-slots))
42 (in-package #:mdw.mop)
44 ;;;--------------------------------------------------------------------------
47 (defclass compatible-class (standard-class)
50 "A class which can be be freely used in class heirarchies with
51 standard-class and other subclasses of compatible-class. This saves a
52 bunch of annoying messing about with `validate-superclass'."))
54 (defmethod validate-superclass
55 ((sub compatible-class) (super compatible-class))
58 (defmethod validate-superclass
59 ((sub compatible-class) (super standard-class))
60 (eq (class-of super) (find-class 'standard-class)))
62 (defmethod validate-superclass
63 ((sub standard-class) (super compatible-class))
64 (eq (class-of sub) (find-class 'standard-class)))
66 ;;;--------------------------------------------------------------------------
67 ;;; Copying instances.
69 (defgeneric copy-instance-using-class (class object &rest initargs)
71 "Does the donkey-work behind copy-instance."))
73 (defmethod copy-instance-using-class
74 ((class standard-class) object &rest initargs)
75 (let ((new (apply #'allocate-instance class initargs)))
76 (dolist (slot (class-slots class))
77 (setf (slot-value-using-class class new slot)
78 (slot-value-using-class class object slot)))
79 (apply #'shared-initialize new nil initargs)
82 (defun copy-instance (object &rest initargs)
83 "Make a copy of OBJECT, modifying it by setting slots as requested by
85 (apply #'copy-instance-using-class (class-of object) object initargs))
87 ;;;--------------------------------------------------------------------------
88 ;;; Utilities for messing with slot options.
90 (defgeneric initargs-for-effective-slot (class direct-slots)
92 "Missing functionality from the MOP: given a class and its direct slots
93 definitions, construct and return the proposed initializer list for
94 constructing the effective-slot."))
96 (defmethod initargs-for-effective-slot
97 ((class standard-class) direct-slots)
98 "Extract the effective slot options as required."
100 ;; This is taken from the Closette implementation, but it seems to work!
101 (let ((init-slot (find-if-not #'null direct-slots
102 :key #'slot-definition-initfunction)))
103 (list :name (slot-definition-name (car direct-slots))
104 :initform (and init-slot
105 (slot-definition-initform init-slot))
106 :initfunction (and init-slot
107 (slot-definition-initfunction init-slot))
108 :initargs (remove-duplicates
110 (mapcar #'slot-definition-initargs
112 :allocation (slot-definition-allocation (car direct-slots)))))
114 (defun make-effective-slot (class initargs)
115 "Construct an effectie slot definition for a slot on the class, given the
117 (apply #'make-instance
118 (apply #'effective-slot-definition-class class initargs)
121 (let ((stdslot (find-class 'standard-direct-slot-definition)))
122 (defmethod compute-effective-slot-definition
123 ((class compatible-class) slot-name direct-slots)
124 "Construct an effective slot definition for the given slot."
126 ;; Ideally we don't want to mess with a slot if it's entirely handled by
127 ;; the implementation. This check seems to work OK.
128 (if (every (lambda (slot)
129 (member (class-of slot)
130 (class-precedence-list stdslot)))
133 (make-effective-slot class
134 (initargs-for-effective-slot class
137 ;;;--------------------------------------------------------------------------
138 ;;; Filterered slots.
140 (defclass filtered-slot-class-mixin (compatible-class)
143 "A filtered slot interposes a filter on any attempt to write to the slot.
144 The filter is given the proposed new value, and should return the actual
145 new value. Specify the filter with a `:filter SYMBOL' slot option.
146 (Yes, I know that using functions would be nicer, but the MOP makes
147 that surprisingly difficult.)"))
149 (defclass filtered-direct-slot-definition
150 (standard-direct-slot-definition)
151 ((filter :initarg :filter :reader slot-definition-filter)))
153 (defgeneric slot-definition-filter (slot)
154 (:method ((slot slot-definition)) nil))
156 (defclass filtered-effective-slot-definition
157 (standard-effective-slot-definition)
158 ((filter :initarg :filter :accessor slot-definition-filter)))
160 (defmethod direct-slot-definition-class
161 ((class filtered-slot-class-mixin)
162 &key (filter nil filterp) &allow-other-keys)
163 (declare (ignore filter))
165 (find-class 'filtered-direct-slot-definition)
168 (defmethod effective-slot-definition-class
169 ((class filtered-slot-class-mixin)
170 &key (filter nil filterp) &allow-other-keys)
171 (declare (ignore filter))
173 (find-class 'filtered-effective-slot-definition)
176 (defmethod initialize-instance :after
177 ((slot filtered-direct-slot-definition) &key)
178 (with-slots (filter) slot
179 (when (and (consp filter)
180 (or (eq (car filter) 'function)
181 (eq (car filter) 'quote))
182 (symbolp (cadr filter))
183 (null (cddr filter)))
184 (setf filter (cadr filter)))))
186 (defmethod initargs-for-effective-slot
187 ((class filtered-slot-class-mixin) direct-slots)
188 (let ((filter-slot (find-if #'slot-definition-filter direct-slots)))
189 (append (and filter-slot
190 (list :filter (slot-definition-filter filter-slot)))
191 (call-next-method))))
193 (defmethod (setf slot-value-using-class)
195 (class filtered-slot-class-mixin)
196 (object standard-object)
197 (slot filtered-effective-slot-definition))
198 (call-next-method (funcall (slot-definition-filter slot) value)
201 ;;;--------------------------------------------------------------------------
204 (defclass predicate-class-mixin (compatible-class)
205 ((predicates :type list :initarg :predicate :initform nil
206 :documentation "Predicate generic function to create."))
208 "Class which can automatically generate a predicate generic function.
209 Adds the `:predicate' class option, which takes a single symbol argument
210 FUNC. If specified, and non-nil, a generic function FUNC with one
211 argument will be defined (if it doesn't already exist) with a default
212 method returning nil, and a method added specialized on this class
213 returning a non-nil value."))
215 (defmethod shared-initialize :after
216 ((class predicate-class-mixin) slot-names &key)
217 (declare (ignore slot-names))
218 (with-slots (predicates) class
219 (dolist (predicate predicates)
220 (let ((lambda-list '(thing)))
221 (let ((gf (if (fboundp predicate)
222 (fdefinition predicate)
223 (let ((gf (ensure-generic-function
224 predicate :lambda-list lambda-list)))
225 (add-method gf (make-instance
227 :specializers (list (find-class 't))
228 :lambda-list lambda-list
229 :function (constantly nil)))))))
230 (add-method gf (make-instance 'standard-method
231 :specializers (list class)
232 :lambda-list lambda-list
233 :function (constantly t))))))))
235 ;;;--------------------------------------------------------------------------
236 ;;; Abstract classes.
238 (defclass abstract-class-mixin (compatible-class)
241 "Confusingly enough, a concrete metaclass for abstract classes. This
242 class has a `make-instance' implementation which signals an error."))
244 (define-condition instantiate-abstract-class (error)
245 ((class :reader instantiate-abstract-class-class :initarg :class
246 :documentation "The class someone attempted to instantiate."))
247 (:report (lambda (cond stream)
248 (format stream "Cannot instantiate abstract class ~A."
249 (class-name (instantiate-abstract-class-class cond)))))
251 "Reports an attempt to instantiate an abstract class."))
253 (defmethod make-instance ((class abstract-class-mixin) &rest whatever)
254 "Signals an error. The caller is a naughty boy."
255 (declare (ignore whatever))
256 (error 'instantiate-abstract-class :class class))
258 ;;;--------------------------------------------------------------------------
261 (defclass mdw-class (filtered-slot-class-mixin
262 predicate-class-mixin
266 "A generally useful metaclass with handy features. If I've done the
267 hacking right, there shouldn't be a significant cost to using this
268 metaclass for all your classes if you don't use any of its fancy
271 (defclass abstract-class (mdw-class abstract-class-mixin) ())
273 ;;;--------------------------------------------------------------------------
276 (defun print-object-with-slots (obj stream)
277 "Prints objects in a pleasant way. Not too clever about circularity."
278 (let ((class (pcl:class-of obj))
279 (magic (cons 'magic nil)))
280 (print-unreadable-object (obj stream)
281 (pprint-logical-block
283 (mapcan (lambda (slot)
284 (list (or (car (slot-definition-initargs slot))
285 (slot-definition-name slot))
286 (if (slot-boundp-using-class class obj slot)
287 (slot-value-using-class class obj slot)
289 (pcl:class-slots class)))
290 (format stream "~S" (pcl:class-name class))
293 (pprint-exit-if-list-exhausted)
295 (format stream " ~_")
296 (progn (format stream " ~@_~:I") (setf sep t)))
297 (let ((name (pprint-pop))
298 (value (pprint-pop)))
299 (format stream "~S ~@_~:[~W~;#<unbound>~*~]"
300 name (eq value magic) value))))))))
302 ;;;----- That's all, folks --------------------------------------------------