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

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