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 #:abstract-class-mixin #:instantiate-abstract-class
37 #:mdw-class #:abstract-class
38 #:print-object-with-slots))
40 (in-package #:mdw.mop)
42 ;;;--------------------------------------------------------------------------
45 (defclass compatible-class (standard-class)
48 "A class which can be be freely used in class heirarchies with
49 standard-class and other subclasses of compatible-class. This saves a
50 bunch of annoying messing about with `validate-superclass'."))
52 (defmethod validate-superclass
53 ((sub compatible-class) (super compatible-class))
56 (defmethod validate-superclass
57 ((sub compatible-class) (super standard-class))
58 (eq (class-of super) (find-class 'standard-class)))
60 (defmethod validate-superclass
61 ((sub standard-class) (super compatible-class))
62 (eq (class-of sub) (find-class 'standard-class)))
64 ;;;--------------------------------------------------------------------------
65 ;;; Utilities for messing with slot options.
67 (defgeneric initargs-for-effective-slot (class direct-slots)
69 "Missing functionality from the MOP: given a class and its direct slots
70 definitions, construct and return the proposed initializer list for
71 constructing the effective-slot."))
73 (defmethod initargs-for-effective-slot
74 ((class standard-class) direct-slots)
75 "Extract the effective slot options as required."
77 ;; This is taken from the Closette implementation, but it seems to work!
78 (let ((init-slot (find-if-not #'null direct-slots
79 :key #'slot-definition-initfunction)))
80 (list :name (slot-definition-name (car direct-slots))
81 :initform (and init-slot
82 (slot-definition-initform init-slot))
83 :initfunction (and init-slot
84 (slot-definition-initfunction init-slot))
85 :initargs (remove-duplicates
87 (mapcar #'slot-definition-initargs
89 :allocation (slot-definition-allocation (car direct-slots)))))
91 (defun make-effective-slot (class initargs)
92 "Construct an effectie slot definition for a slot on the class, given the
94 (apply #'make-instance
95 (apply #'effective-slot-definition-class class initargs)
98 (let ((stdslot (find-class 'standard-direct-slot-definition)))
99 (defmethod compute-effective-slot-definition
100 ((class compatible-class) slot-name direct-slots)
101 "Construct an effective slot definition for the given slot."
103 ;; Ideally we don't want to mess with a slot if it's entirely handled by
104 ;; the implementation. This check seems to work OK.
105 (if (every (lambda (slot)
106 (member (class-of slot)
107 (class-precedence-list stdslot)))
110 (make-effective-slot class
111 (initargs-for-effective-slot class
114 ;;;--------------------------------------------------------------------------
115 ;;; Filterered slots.
117 (defclass filtered-slot-class-mixin (compatible-class)
120 "A filtered slot interposes a filter on any attempt to write to the slot.
121 The filter is given the proposed new value, and should return the actual
122 new value. Specify the filter with a `:filter SYMBOL' slot option.
123 (Yes, I know that using functions would be nicer, but the MOP makes
124 that surprisingly difficult.)"))
126 (defclass filtered-direct-slot-definition
127 (standard-direct-slot-definition)
128 ((filter :initarg :filter :reader slot-definition-filter)))
130 (defgeneric slot-definition-filter (slot)
131 (:method ((slot slot-definition)) nil))
133 (defclass filtered-effective-slot-definition
134 (standard-effective-slot-definition)
135 ((filter :initarg :filter :accessor slot-definition-filter)))
137 (defmethod direct-slot-definition-class
138 ((class filtered-slot-class-mixin)
139 &key (filter nil filterp) &allow-other-keys)
140 (declare (ignore filter))
142 (find-class 'filtered-direct-slot-definition)
145 (defmethod effective-slot-definition-class
146 ((class filtered-slot-class-mixin)
147 &key (filter nil filterp) &allow-other-keys)
148 (declare (ignore filter))
150 (find-class 'filtered-effective-slot-definition)
153 (defmethod initialize-instance :after
154 ((slot filtered-direct-slot-definition) &key &allow-other-keys)
155 (with-slots (filter) slot
156 (when (and (consp filter)
157 (or (eq (car filter) 'function)
158 (eq (car filter) 'quote))
159 (symbolp (cadr filter))
160 (null (cddr filter)))
161 (setf filter (cadr filter)))))
163 (defmethod initargs-for-effective-slot
164 ((class filtered-slot-class-mixin) direct-slots)
165 (let ((filter-slot (find-if #'slot-definition-filter direct-slots)))
166 (append (and filter-slot
167 (list :filter (slot-definition-filter filter-slot)))
168 (call-next-method))))
170 (defmethod (setf slot-value-using-class)
172 (class filtered-slot-class-mixin)
173 (object standard-object)
174 (slot filtered-effective-slot-definition))
175 (call-next-method (funcall (slot-definition-filter slot) object value)
178 ;;;--------------------------------------------------------------------------
179 ;;; Abstract classes.
181 (defclass abstract-class-mixin (compatible-class)
184 "Confusingly enough, a concrete metaclass for abstract classes. This
185 class has a `make-instance' implementation which signals an error."))
187 (define-condition instantiate-abstract-class (error)
188 ((class :reader instantiate-abstract-class-class :initarg :class
189 :documentation "The class someone attempted to instantiate."))
190 (:report (lambda (cond stream)
191 (format stream "Cannot instantiate abstract class ~A."
192 (class-name (instantiate-abstract-class-class cond)))))
194 "Reports an attempt to instantiate an abstract class."))
196 (defmethod make-instance ((class abstract-class-mixin) &rest whatever)
197 "Signals an error. The caller is a naughty boy."
198 (declare (ignore whatever))
199 (error 'instantiate-abstract-class :class class))
201 ;;;--------------------------------------------------------------------------
204 (defclass mdw-class (filtered-slot-class-mixin
208 (defclass abstract-class (mdw-class abstract-class-mixin) ())
210 ;;;--------------------------------------------------------------------------
213 (defun print-object-with-slots (obj stream)
214 "Prints objects in a pleasant way. Not too clever about circularity."
215 (let ((class (pcl:class-of obj))
216 (magic (cons 'magic nil)))
217 (print-unreadable-object (obj stream)
218 (pprint-logical-block
220 (mapcan (lambda (slot)
221 (list (or (car (slot-definition-initargs slot))
222 (slot-definition-name slot))
223 (if (slot-boundp-using-class class obj slot)
224 (slot-value-using-class class obj slot)
226 (pcl:class-slots class)))
227 (format stream "~S" (pcl:class-name class))
230 (pprint-exit-if-list-exhausted)
232 (format stream " ~_")
233 (progn (format stream " ~@_~:I") (setf sep t)))
234 (let ((name (pprint-pop))
235 (value (pprint-pop)))
236 (format stream "~S ~@_~:[~S~;<unbound>~*~]"
237 name (eq value magic) value))))))))
239 ;;;----- That's all, folks --------------------------------------------------