| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; $Id$ |
| 4 | ;;; |
| 5 | ;;; Useful bits of MOP hacking |
| 6 | ;;; |
| 7 | ;;; (c) 2006 Straylight/Edgeware |
| 8 | ;;; |
| 9 | |
| 10 | ;;;----- Licensing notice --------------------------------------------------- |
| 11 | ;;; |
| 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. |
| 16 | ;;; |
| 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. |
| 21 | ;;; |
| 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. |
| 25 | |
| 26 | ;;;-------------------------------------------------------------------------- |
| 27 | ;;; Packages. |
| 28 | |
| 29 | (defpackage #:mdw.mop |
| 30 | (:use #:common-lisp #:mdw.base #+(or cmu clisp) #:mop) |
| 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 | #:singleton-class-mixin |
| 40 | #:mdw-class #:abstract-class #:singleton-class |
| 41 | #:print-object-with-slots)) |
| 42 | |
| 43 | (in-package #:mdw.mop) |
| 44 | |
| 45 | ;;;-------------------------------------------------------------------------- |
| 46 | ;;; Basic stuff. |
| 47 | |
| 48 | (defclass compatible-class (standard-class) |
| 49 | () |
| 50 | (:documentation |
| 51 | "A class which can be be freely used in class heirarchies with |
| 52 | standard-class and other subclasses of compatible-class. This saves a |
| 53 | bunch of annoying messing about with `validate-superclass'.")) |
| 54 | |
| 55 | (defmethod validate-superclass |
| 56 | ((sub compatible-class) (super compatible-class)) |
| 57 | t) |
| 58 | |
| 59 | (defmethod validate-superclass |
| 60 | ((sub compatible-class) (super standard-class)) |
| 61 | (eq (class-of super) (find-class 'standard-class))) |
| 62 | |
| 63 | (defmethod validate-superclass |
| 64 | ((sub standard-class) (super compatible-class)) |
| 65 | (eq (class-of sub) (find-class 'standard-class))) |
| 66 | |
| 67 | ;;;-------------------------------------------------------------------------- |
| 68 | ;;; Copying instances. |
| 69 | |
| 70 | (defgeneric copy-instance-using-class (class object &rest initargs) |
| 71 | (:documentation |
| 72 | "Does the donkey-work behind copy-instance.")) |
| 73 | |
| 74 | (defmethod copy-instance-using-class |
| 75 | ((class standard-class) object &rest initargs) |
| 76 | (let ((new (apply #'allocate-instance class initargs))) |
| 77 | (dolist (slot (class-slots class)) |
| 78 | (setf (slot-value-using-class class new slot) |
| 79 | (slot-value-using-class class object slot))) |
| 80 | (apply #'shared-initialize new nil initargs) |
| 81 | new)) |
| 82 | |
| 83 | (defun copy-instance (object &rest initargs) |
| 84 | "Make a copy of OBJECT, modifying it by setting slots as requested by |
| 85 | INITARGS." |
| 86 | (apply #'copy-instance-using-class (class-of object) object initargs)) |
| 87 | |
| 88 | ;;;-------------------------------------------------------------------------- |
| 89 | ;;; Utilities for messing with slot options. |
| 90 | |
| 91 | (defgeneric initargs-for-effective-slot (class direct-slots) |
| 92 | (:documentation |
| 93 | "Missing functionality from the MOP: given a class and its direct slots |
| 94 | definitions, construct and return the proposed initializer list for |
| 95 | constructing the effective-slot.")) |
| 96 | |
| 97 | (defmethod initargs-for-effective-slot |
| 98 | ((class standard-class) direct-slots) |
| 99 | "Extract the effective slot options as required." |
| 100 | ;; |
| 101 | ;; This is taken from the Closette implementation, but it seems to work! |
| 102 | (let ((init-slot (find-if-not #'null direct-slots |
| 103 | :key #'slot-definition-initfunction))) |
| 104 | (list :name (slot-definition-name (car direct-slots)) |
| 105 | :initform (and init-slot |
| 106 | (slot-definition-initform init-slot)) |
| 107 | :initfunction (and init-slot |
| 108 | (slot-definition-initfunction init-slot)) |
| 109 | :initargs (remove-duplicates |
| 110 | (apply #'append |
| 111 | (mapcar #'slot-definition-initargs |
| 112 | direct-slots))) |
| 113 | :allocation (slot-definition-allocation (car direct-slots))))) |
| 114 | |
| 115 | (defun make-effective-slot (class initargs) |
| 116 | "Construct an effectie slot definition for a slot on the class, given the |
| 117 | required arguments." |
| 118 | (apply #'make-instance |
| 119 | (apply #'effective-slot-definition-class class initargs) |
| 120 | initargs)) |
| 121 | |
| 122 | (let ((stdslot (find-class 'standard-direct-slot-definition))) |
| 123 | (defmethod compute-effective-slot-definition |
| 124 | ((class compatible-class) slot-name direct-slots) |
| 125 | "Construct an effective slot definition for the given slot." |
| 126 | (declare (ignore slot-name)) |
| 127 | ;; |
| 128 | ;; Ideally we don't want to mess with a slot if it's entirely handled by |
| 129 | ;; the implementation. This check seems to work OK. |
| 130 | (if (every (lambda (slot) |
| 131 | (member (class-of slot) |
| 132 | (class-precedence-list stdslot))) |
| 133 | direct-slots) |
| 134 | (call-next-method) |
| 135 | (make-effective-slot class |
| 136 | (initargs-for-effective-slot class |
| 137 | direct-slots))))) |
| 138 | |
| 139 | ;;;-------------------------------------------------------------------------- |
| 140 | ;;; Filterered slots. |
| 141 | |
| 142 | (defclass filtered-slot-class-mixin (compatible-class) |
| 143 | () |
| 144 | (:documentation |
| 145 | "A filtered slot interposes a filter on any attempt to write to the slot. |
| 146 | The filter is given the proposed new value, and should return the actual |
| 147 | new value. Specify the filter with a `:filter SYMBOL' slot option. |
| 148 | (Yes, I know that using functions would be nicer, but the MOP makes |
| 149 | that surprisingly difficult.)")) |
| 150 | |
| 151 | (defclass filtered-direct-slot-definition |
| 152 | (standard-direct-slot-definition) |
| 153 | ((filter :initarg :filter :reader slot-definition-filter))) |
| 154 | |
| 155 | (defgeneric slot-definition-filter (slot) |
| 156 | (:method ((slot slot-definition)) nil)) |
| 157 | |
| 158 | (defclass filtered-effective-slot-definition |
| 159 | (standard-effective-slot-definition) |
| 160 | ((filter :initarg :filter :accessor slot-definition-filter))) |
| 161 | |
| 162 | (defmethod direct-slot-definition-class |
| 163 | ((class filtered-slot-class-mixin) |
| 164 | &key (filter nil filterp) &allow-other-keys) |
| 165 | (declare (ignore filter)) |
| 166 | (if filterp |
| 167 | (find-class 'filtered-direct-slot-definition) |
| 168 | (call-next-method))) |
| 169 | |
| 170 | (defmethod effective-slot-definition-class |
| 171 | ((class filtered-slot-class-mixin) |
| 172 | &key (filter nil filterp) &allow-other-keys) |
| 173 | (declare (ignore filter)) |
| 174 | (if filterp |
| 175 | (find-class 'filtered-effective-slot-definition) |
| 176 | (call-next-method))) |
| 177 | |
| 178 | (defmethod initialize-instance :after |
| 179 | ((slot filtered-direct-slot-definition) &key) |
| 180 | (with-slots (filter) slot |
| 181 | (when (and (consp filter) |
| 182 | (or (eq (car filter) 'function) |
| 183 | (eq (car filter) 'quote)) |
| 184 | (symbolp (cadr filter)) |
| 185 | (null (cddr filter))) |
| 186 | (setf filter (cadr filter))))) |
| 187 | |
| 188 | (defmethod initargs-for-effective-slot |
| 189 | ((class filtered-slot-class-mixin) direct-slots) |
| 190 | (let ((filter-slot (find-if #'slot-definition-filter direct-slots))) |
| 191 | (append (and filter-slot |
| 192 | (list :filter (slot-definition-filter filter-slot))) |
| 193 | (call-next-method)))) |
| 194 | |
| 195 | (defmethod (setf slot-value-using-class) |
| 196 | (value |
| 197 | (class filtered-slot-class-mixin) |
| 198 | (object standard-object) |
| 199 | (slot filtered-effective-slot-definition)) |
| 200 | (call-next-method (funcall (slot-definition-filter slot) value) |
| 201 | class object slot)) |
| 202 | |
| 203 | ;;;-------------------------------------------------------------------------- |
| 204 | ;;; Predicates. |
| 205 | |
| 206 | (defclass predicate-class-mixin (compatible-class) |
| 207 | ((predicates :type list :initarg :predicate :initform nil |
| 208 | :documentation "Predicate generic function to create.")) |
| 209 | (:documentation |
| 210 | "Class which can automatically generate a predicate generic function. |
| 211 | Adds the `:predicate' class option, which takes a single symbol argument |
| 212 | FUNC. If specified, and non-nil, a generic function FUNC with one |
| 213 | argument will be defined (if it doesn't already exist) with a default |
| 214 | method returning nil, and a method added specialized on this class |
| 215 | returning a non-nil value.")) |
| 216 | |
| 217 | (defmethod shared-initialize :after |
| 218 | ((class predicate-class-mixin) slot-names &key) |
| 219 | (declare (ignore slot-names)) |
| 220 | (with-slots (predicates) class |
| 221 | (dolist (predicate predicates) |
| 222 | (let ((lambda-list '(thing))) |
| 223 | (let ((gf (if (fboundp predicate) |
| 224 | (fdefinition predicate) |
| 225 | (let ((gf (ensure-generic-function |
| 226 | predicate :lambda-list lambda-list))) |
| 227 | (add-method gf (make-instance |
| 228 | 'standard-method |
| 229 | :specializers (list (find-class 't)) |
| 230 | :lambda-list lambda-list |
| 231 | :function (constantly nil))))))) |
| 232 | (add-method gf (make-instance 'standard-method |
| 233 | :specializers (list class) |
| 234 | :lambda-list lambda-list |
| 235 | :function (constantly t)))))))) |
| 236 | |
| 237 | ;;;-------------------------------------------------------------------------- |
| 238 | ;;; Abstract classes. |
| 239 | |
| 240 | (defclass abstract-class-mixin (compatible-class) |
| 241 | () |
| 242 | (:documentation |
| 243 | "Confusingly enough, a concrete metaclass for abstract classes. This |
| 244 | class has a `make-instance' implementation which signals an error.")) |
| 245 | |
| 246 | (define-condition instantiate-abstract-class (error) |
| 247 | ((class :reader instantiate-abstract-class-class :initarg :class |
| 248 | :documentation "The class someone attempted to instantiate.")) |
| 249 | (:report (lambda (cond stream) |
| 250 | (format stream "Cannot instantiate abstract class ~A." |
| 251 | (class-name (instantiate-abstract-class-class cond))))) |
| 252 | (:documentation |
| 253 | "Reports an attempt to instantiate an abstract class.")) |
| 254 | |
| 255 | (defmethod make-instance ((class abstract-class-mixin) &rest whatever) |
| 256 | "Signals an error. The caller is a naughty boy." |
| 257 | (declare (ignore whatever)) |
| 258 | (error 'instantiate-abstract-class :class class)) |
| 259 | |
| 260 | ;;;-------------------------------------------------------------------------- |
| 261 | ;;; Singleton classes. |
| 262 | |
| 263 | (defclass singleton-class-mixin (compatible-class) |
| 264 | ((instance :initform nil :type (or null standard-object))) |
| 265 | (:documentation |
| 266 | "A class which has only one instance. All calls to `make-instance' return |
| 267 | the same object.")) |
| 268 | |
| 269 | (defmethod allocate-instance ((class singleton-class-mixin) &key) |
| 270 | "If the class already has an instance, return it; otherwise allocate one, |
| 271 | store it away, and return that." |
| 272 | (with-slots (instance) class |
| 273 | (or instance |
| 274 | (setf instance (call-next-method))))) |
| 275 | |
| 276 | ;;;-------------------------------------------------------------------------- |
| 277 | ;;; Useful classes. |
| 278 | |
| 279 | (defclass mdw-class (filtered-slot-class-mixin |
| 280 | predicate-class-mixin |
| 281 | compatible-class) |
| 282 | () |
| 283 | (:documentation |
| 284 | "A generally useful metaclass with handy features. If I've done the |
| 285 | hacking right, there shouldn't be a significant cost to using this |
| 286 | metaclass for all your classes if you don't use any of its fancy |
| 287 | features.")) |
| 288 | |
| 289 | (defclass abstract-class (mdw-class abstract-class-mixin) ()) |
| 290 | (defclass singleton-class (mdw-class singleton-class-mixin) ()) |
| 291 | |
| 292 | ;;;-------------------------------------------------------------------------- |
| 293 | ;;; Printing things. |
| 294 | |
| 295 | (defun print-object-with-slots (obj stream) |
| 296 | "Prints objects in a pleasant way. Not too clever about circularity." |
| 297 | (let ((class (class-of obj)) |
| 298 | (magic (cons 'magic nil))) |
| 299 | (print-unreadable-object (obj stream) |
| 300 | (pprint-logical-block |
| 301 | (stream |
| 302 | (mapcan (lambda (slot) |
| 303 | (list (or (car (slot-definition-initargs slot)) |
| 304 | (slot-definition-name slot)) |
| 305 | (if (slot-boundp-using-class class obj slot) |
| 306 | (slot-value-using-class class obj slot) |
| 307 | magic))) |
| 308 | (class-slots class))) |
| 309 | (format stream "~S" (class-name class)) |
| 310 | (let ((sep nil)) |
| 311 | (loop |
| 312 | (pprint-exit-if-list-exhausted) |
| 313 | (if sep |
| 314 | (format stream " ~_") |
| 315 | (progn (format stream " ~@_~:I") (setf sep t))) |
| 316 | (let ((name (pprint-pop)) |
| 317 | (value (pprint-pop))) |
| 318 | (format stream "~S ~@_~:[~W~;#<unbound>~*~]" |
| 319 | name (eq value magic) value)))))))) |
| 320 | |
| 321 | ;;;----- That's all, folks -------------------------------------------------- |