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 #+cmu #:pcl)
31 (:export #:compatible-class
32 #:initargs-for-effective-slot #:make-effective-slot
33 #:filtered-slot-class-mixin
34 #:filtered-direct-slot-definition
35 #:filtered-effective-slot-definition
36 #:predicate-class-mixin
37 #:abstract-class-mixin #:instantiate-abstract-class
38 #:mdw-class #:abstract-class
39 #:print-object-with-slots))
41 (in-package #:mdw.mop)
43 ;;;--------------------------------------------------------------------------
46 (defclass compatible-class (standard-class)
49 "A class which can be be freely used in class heirarchies with
50 standard-class and other subclasses of compatible-class. This saves a
51 bunch of annoying messing about with `validate-superclass'."))
53 (defmethod validate-superclass
54 ((sub compatible-class) (super compatible-class))
57 (defmethod validate-superclass
58 ((sub compatible-class) (super standard-class))
59 (eq (class-of super) (find-class 'standard-class)))
61 (defmethod validate-superclass
62 ((sub standard-class) (super compatible-class))
63 (eq (class-of sub) (find-class 'standard-class)))
65 ;;;--------------------------------------------------------------------------
66 ;;; Utilities for messing with slot options.
68 (defgeneric initargs-for-effective-slot (class direct-slots)
70 "Missing functionality from the MOP: given a class and its direct slots
71 definitions, construct and return the proposed initializer list for
72 constructing the effective-slot."))
74 (defmethod initargs-for-effective-slot
75 ((class standard-class) direct-slots)
76 "Extract the effective slot options as required."
78 ;; This is taken from the Closette implementation, but it seems to work!
79 (let ((init-slot (find-if-not #'null direct-slots
80 :key #'slot-definition-initfunction)))
81 (list :name (slot-definition-name (car direct-slots))
82 :initform (and init-slot
83 (slot-definition-initform init-slot))
84 :initfunction (and init-slot
85 (slot-definition-initfunction init-slot))
86 :initargs (remove-duplicates
88 (mapcar #'slot-definition-initargs
90 :allocation (slot-definition-allocation (car direct-slots)))))
92 (defun make-effective-slot (class initargs)
93 "Construct an effectie slot definition for a slot on the class, given the
95 (apply #'make-instance
96 (apply #'effective-slot-definition-class class initargs)
99 (let ((stdslot (find-class 'standard-direct-slot-definition)))
100 (defmethod compute-effective-slot-definition
101 ((class compatible-class) slot-name direct-slots)
102 "Construct an effective slot definition for the given slot."
104 ;; Ideally we don't want to mess with a slot if it's entirely handled by
105 ;; the implementation. This check seems to work OK.
106 (if (every (lambda (slot)
107 (member (class-of slot)
108 (class-precedence-list stdslot)))
111 (make-effective-slot class
112 (initargs-for-effective-slot class
115 ;;;--------------------------------------------------------------------------
116 ;;; Filterered slots.
118 (defclass filtered-slot-class-mixin (compatible-class)
121 "A filtered slot interposes a filter on any attempt to write to the slot.
122 The filter is given the proposed new value, and should return the actual
123 new value. Specify the filter with a `:filter SYMBOL' slot option.
124 (Yes, I know that using functions would be nicer, but the MOP makes
125 that surprisingly difficult.)"))
127 (defclass filtered-direct-slot-definition
128 (standard-direct-slot-definition)
129 ((filter :initarg :filter :reader slot-definition-filter)))
131 (defgeneric slot-definition-filter (slot)
132 (:method ((slot slot-definition)) nil))
134 (defclass filtered-effective-slot-definition
135 (standard-effective-slot-definition)
136 ((filter :initarg :filter :accessor slot-definition-filter)))
138 (defmethod direct-slot-definition-class
139 ((class filtered-slot-class-mixin)
140 &key (filter nil filterp) &allow-other-keys)
141 (declare (ignore filter))
143 (find-class 'filtered-direct-slot-definition)
146 (defmethod effective-slot-definition-class
147 ((class filtered-slot-class-mixin)
148 &key (filter nil filterp) &allow-other-keys)
149 (declare (ignore filter))
151 (find-class 'filtered-effective-slot-definition)
154 (defmethod initialize-instance :after
155 ((slot filtered-direct-slot-definition) &key)
156 (with-slots (filter) slot
157 (when (and (consp filter)
158 (or (eq (car filter) 'function)
159 (eq (car filter) 'quote))
160 (symbolp (cadr filter))
161 (null (cddr filter)))
162 (setf filter (cadr filter)))))
164 (defmethod initargs-for-effective-slot
165 ((class filtered-slot-class-mixin) direct-slots)
166 (let ((filter-slot (find-if #'slot-definition-filter direct-slots)))
167 (append (and filter-slot
168 (list :filter (slot-definition-filter filter-slot)))
169 (call-next-method))))
171 (defmethod (setf slot-value-using-class)
173 (class filtered-slot-class-mixin)
174 (object standard-object)
175 (slot filtered-effective-slot-definition))
176 (call-next-method (funcall (slot-definition-filter slot) value)
179 ;;;--------------------------------------------------------------------------
182 (defclass predicate-class-mixin (compatible-class)
183 ((predicates :type list :initarg :predicate :initform nil
184 :documentation "Predicate generic function to create."))
186 "Class which can automatically generate a predicate generic function.
187 Adds the `:predicate' class option, which takes a single symbol argument
188 FUNC. If specified, and non-nil, a generic function FUNC with one
189 argument will be defined (if it doesn't already exist) with a default
190 method returning nil, and a method added specialized on this class
191 returning a non-nil value."))
193 (defmethod shared-initialize :after
194 ((class predicate-class-mixin) slot-names &key)
195 (declare (ignore slot-names))
196 (with-slots (predicates) class
197 (dolist (predicate predicates)
198 (let ((lambda-list '(thing)))
199 (let ((gf (if (fboundp predicate)
200 (fdefinition predicate)
201 (let ((gf (ensure-generic-function
202 predicate :lambda-list lambda-list)))
203 (add-method gf (make-instance
205 :specializers (list (find-class 't))
206 :lambda-list lambda-list
207 :function (constantly nil)))))))
208 (add-method gf (make-instance 'standard-method
209 :specializers (list class)
210 :lambda-list lambda-list
211 :function (constantly t))))))))
213 ;;;--------------------------------------------------------------------------
214 ;;; Abstract classes.
216 (defclass abstract-class-mixin (compatible-class)
219 "Confusingly enough, a concrete metaclass for abstract classes. This
220 class has a `make-instance' implementation which signals an error."))
222 (define-condition instantiate-abstract-class (error)
223 ((class :reader instantiate-abstract-class-class :initarg :class
224 :documentation "The class someone attempted to instantiate."))
225 (:report (lambda (cond stream)
226 (format stream "Cannot instantiate abstract class ~A."
227 (class-name (instantiate-abstract-class-class cond)))))
229 "Reports an attempt to instantiate an abstract class."))
231 (defmethod make-instance ((class abstract-class-mixin) &rest whatever)
232 "Signals an error. The caller is a naughty boy."
233 (declare (ignore whatever))
234 (error 'instantiate-abstract-class :class class))
236 ;;;--------------------------------------------------------------------------
239 (defclass mdw-class (filtered-slot-class-mixin
240 predicate-class-mixin
244 "A generally useful metaclass with handy features. If I've done the
245 hacking right, there shouldn't be a significant cost to using this
246 metaclass for all your classes if you don't use any of its fancy
249 (defclass abstract-class (mdw-class abstract-class-mixin) ())
251 ;;;--------------------------------------------------------------------------
254 (defun print-object-with-slots (obj stream)
255 "Prints objects in a pleasant way. Not too clever about circularity."
256 (let ((class (pcl:class-of obj))
257 (magic (cons 'magic nil)))
258 (print-unreadable-object (obj stream)
259 (pprint-logical-block
261 (mapcan (lambda (slot)
262 (list (or (car (slot-definition-initargs slot))
263 (slot-definition-name slot))
264 (if (slot-boundp-using-class class obj slot)
265 (slot-value-using-class class obj slot)
267 (pcl:class-slots class)))
268 (format stream "~S" (pcl:class-name class))
271 (pprint-exit-if-list-exhausted)
273 (format stream " ~_")
274 (progn (format stream " ~@_~:I") (setf sep t)))
275 (let ((name (pprint-pop))
276 (value (pprint-pop)))
277 (format stream "~S ~@_~:[~S~;<unbound>~*~]"
278 name (eq value magic) value))))))))
280 ;;;----- That's all, folks --------------------------------------------------