| 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 #+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)) |
| 39 | |
| 40 | (in-package #:mdw.mop) |
| 41 | |
| 42 | ;;;-------------------------------------------------------------------------- |
| 43 | ;;; Basic stuff. |
| 44 | |
| 45 | (defclass compatible-class (standard-class) |
| 46 | () |
| 47 | (:documentation |
| 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'.")) |
| 51 | |
| 52 | (defmethod validate-superclass |
| 53 | ((sub compatible-class) (super compatible-class)) |
| 54 | t) |
| 55 | |
| 56 | (defmethod validate-superclass |
| 57 | ((sub compatible-class) (super standard-class)) |
| 58 | (eq (class-of super) (find-class 'standard-class))) |
| 59 | |
| 60 | (defmethod validate-superclass |
| 61 | ((sub standard-class) (super compatible-class)) |
| 62 | (eq (class-of sub) (find-class 'standard-class))) |
| 63 | |
| 64 | ;;;-------------------------------------------------------------------------- |
| 65 | ;;; Utilities for messing with slot options. |
| 66 | |
| 67 | (defgeneric initargs-for-effective-slot (class direct-slots) |
| 68 | (:documentation |
| 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.")) |
| 72 | |
| 73 | (defmethod initargs-for-effective-slot |
| 74 | ((class standard-class) direct-slots) |
| 75 | "Extract the effective slot options as required." |
| 76 | ;; |
| 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 |
| 86 | (apply #'append |
| 87 | (mapcar #'slot-definition-initargs |
| 88 | direct-slots))) |
| 89 | :allocation (slot-definition-allocation (car direct-slots))))) |
| 90 | |
| 91 | (defun make-effective-slot (class initargs) |
| 92 | "Construct an effectie slot definition for a slot on the class, given the |
| 93 | required arguments." |
| 94 | (apply #'make-instance |
| 95 | (apply #'effective-slot-definition-class class initargs) |
| 96 | initargs)) |
| 97 | |
| 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." |
| 102 | ;; |
| 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))) |
| 108 | direct-slots) |
| 109 | (call-next-method) |
| 110 | (make-effective-slot class |
| 111 | (initargs-for-effective-slot class |
| 112 | direct-slots))))) |
| 113 | |
| 114 | ;;;-------------------------------------------------------------------------- |
| 115 | ;;; Filterered slots. |
| 116 | |
| 117 | (defclass filtered-slot-class-mixin (compatible-class) |
| 118 | () |
| 119 | (:documentation |
| 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.)")) |
| 125 | |
| 126 | (defclass filtered-direct-slot-definition |
| 127 | (standard-direct-slot-definition) |
| 128 | ((filter :initarg :filter :reader slot-definition-filter))) |
| 129 | |
| 130 | (defgeneric slot-definition-filter (slot) |
| 131 | (:method ((slot slot-definition)) nil)) |
| 132 | |
| 133 | (defclass filtered-effective-slot-definition |
| 134 | (standard-effective-slot-definition) |
| 135 | ((filter :initarg :filter :accessor slot-definition-filter))) |
| 136 | |
| 137 | (defmethod direct-slot-definition-class |
| 138 | ((class filtered-slot-class-mixin) |
| 139 | &key (filter nil filterp) &allow-other-keys) |
| 140 | (declare (ignore filter)) |
| 141 | (if filterp |
| 142 | (find-class 'filtered-direct-slot-definition) |
| 143 | (call-next-method))) |
| 144 | |
| 145 | (defmethod effective-slot-definition-class |
| 146 | ((class filtered-slot-class-mixin) |
| 147 | &key (filter nil filterp) &allow-other-keys) |
| 148 | (declare (ignore filter)) |
| 149 | (if filterp |
| 150 | (find-class 'filtered-effective-slot-definition) |
| 151 | (call-next-method))) |
| 152 | |
| 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))))) |
| 162 | |
| 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)))) |
| 169 | |
| 170 | (defmethod (setf slot-value-using-class) |
| 171 | (value |
| 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) |
| 176 | class object slot)) |
| 177 | |
| 178 | ;;;-------------------------------------------------------------------------- |
| 179 | ;;; Abstract classes. |
| 180 | |
| 181 | (defclass abstract-class-mixin (compatible-class) |
| 182 | () |
| 183 | (:documentation |
| 184 | "Confusingly enough, a concrete metaclass for abstract classes. This |
| 185 | class has a `make-instance' implementation which signals an error.")) |
| 186 | |
| 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))))) |
| 193 | (:documentation |
| 194 | "Reports an attempt to instantiate an abstract class.")) |
| 195 | |
| 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)) |
| 200 | |
| 201 | ;;;-------------------------------------------------------------------------- |
| 202 | ;;; Useful classes. |
| 203 | |
| 204 | (defclass mdw-class (filtered-slot-class-mixin |
| 205 | compatible-class) |
| 206 | ()) |
| 207 | |
| 208 | (defclass abstract-class (mdw-class abstract-class-mixin) ()) |
| 209 | |
| 210 | ;;;-------------------------------------------------------------------------- |
| 211 | ;;; Printing things. |
| 212 | |
| 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 |
| 219 | (stream |
| 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) |
| 225 | magic))) |
| 226 | (pcl:class-slots class))) |
| 227 | (format stream "~S" (pcl:class-name class)) |
| 228 | (let ((sep nil)) |
| 229 | (loop |
| 230 | (pprint-exit-if-list-exhausted) |
| 231 | (if sep |
| 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)))))))) |
| 238 | |
| 239 | ;;;----- That's all, folks -------------------------------------------------- |