mdw@git.distorted.org.uk Git - lisp/blob - mdw-mop.lisp

   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 --------------------------------------------------