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