chiark - git - mdw - 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 #+(or cmu clisp) #:mop #+ecl #:clos)
  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       (with-parsed-body (body decls) body
 110         (with-gensyms (instvar)
 111           `(let ((,instvar ,instance))
 112              ,@(and class `((declare (type ,(class-name class) ,instvar))))
 113              (let ,(loop for (name var update) in slots
 114                          collect `(,var (slot-value ,instvar ',name)))
 115                ,@(and class
 116                       `((declare
 117                          ,@(loop
 118                             for (name var update) in slots
 119                             for slot = (or (find name
 120                                                  (class-slots class)
 121                                                  :key #'slot-definition-name)
 122                                            (error
 123                                             "Slot ~S not found in class ~S."
 124                                             name (class-name class)))
 125                             collect `(type
 126                                       ,(slot-definition-type slot)
 127                                       ,name)))))
 128                ,@decls
 129                (multiple-value-prog1
 130                    (progn ,@body)
 131                  ,@(loop for (name var update) in slots
 132                          when update
 133                          collect `(setf (slot-value ,instvar ',name)
 134                                    ,var))))))))))
 135
 136 ;;;--------------------------------------------------------------------------
 137 ;;; Basic stuff.
 138
 139 (defclass compatible-class (standard-class)
 140   ()
 141   (:documentation
 142    "A class which can be be freely used in class heirarchies with
 143     standard-class and other subclasses of compatible-class.  This saves a
 144     bunch of annoying messing about with `validate-superclass'."))
 145
 146 (defmethod validate-superclass
 147     ((sub compatible-class) (super compatible-class))
 148   t)
 149
 150 (defmethod validate-superclass
 151     ((sub compatible-class) (super standard-class))
 152   (eq (class-of super) (find-class 'standard-class)))
 153
 154 (defmethod validate-superclass
 155     ((sub standard-class) (super compatible-class))
 156   (eq (class-of sub) (find-class 'standard-class)))
 157
 158 ;;;--------------------------------------------------------------------------
 159 ;;; Utilities for messing with slot options.
 160
 161 (defgeneric initargs-for-effective-slot (class direct-slots)
 162   (:documentation
 163    "Missing functionality from the MOP: given a class and its direct slots
 164     definitions, construct and return the proposed initializer list for
 165     constructing the effective-slot."))
 166
 167 (defmethod initargs-for-effective-slot
 168     ((class standard-class) direct-slots)
 169   "Extract the effective slot options as required."
 170   ;;
 171   ;; This is taken from the Closette implementation, but it seems to work!
 172   (let ((init-slot (find-if-not #'null direct-slots
 173                                 :key #'slot-definition-initfunction)))
 174     (list :name (slot-definition-name (car direct-slots))
 175           :initform (and init-slot
 176                          (slot-definition-initform init-slot))
 177           :initfunction (and init-slot
 178                              (slot-definition-initfunction init-slot))
 179           :initargs (remove-duplicates
 180                      (apply #'append
 181                             (mapcar #'slot-definition-initargs
 182                                     direct-slots)))
 183           :allocation (slot-definition-allocation (car direct-slots)))))
 184
 185 (defun make-effective-slot (class initargs)
 186   "Construct an effectie slot definition for a slot on the class, given the
 187    required arguments."
 188   (apply #'make-instance
 189          (apply #'effective-slot-definition-class class initargs)
 190          initargs))
 191
 192 (let ((stdslot (find-class 'standard-direct-slot-definition)))
 193   (defmethod compute-effective-slot-definition
 194       ((class compatible-class) slot-name direct-slots)
 195     "Construct an effective slot definition for the given slot."
 196     (declare (ignore slot-name))
 197     ;;
 198     ;; Ideally we don't want to mess with a slot if it's entirely handled by
 199     ;; the implementation.  This check seems to work OK.
 200     (if (every (lambda (slot)
 201                  (member (class-of slot)
 202                          (class-precedence-list stdslot)))
 203                direct-slots)
 204         (call-next-method)
 205         (make-effective-slot class
 206                              (initargs-for-effective-slot class
 207                                                           direct-slots)))))
 208
 209 ;;;--------------------------------------------------------------------------
 210 ;;; Filterered slots.
 211
 212 (defclass filtered-slot-class-mixin (compatible-class)
 213   ()
 214   (:documentation
 215    "A filtered slot interposes a filter on any attempt to write to the slot.
 216     The filter is given the proposed new value, and should return the actual
 217     new value.  Specify the filter with a  `:filter SYMBOL' slot option.
 218     (Yes, I know that using functions would be nicer, but the MOP makes
 219     that surprisingly difficult.)"))
 220
 221 (defclass filtered-direct-slot-definition
 222     (standard-direct-slot-definition)
 223   ((filter :initarg :filter :reader slot-definition-filter)))
 224
 225 (defgeneric slot-definition-filter (slot)
 226   (:method ((slot slot-definition)) nil))
 227
 228 (defclass filtered-effective-slot-definition
 229     (standard-effective-slot-definition)
 230   ((filter :initarg :filter :accessor slot-definition-filter)))
 231
 232 (defmethod direct-slot-definition-class
 233     ((class filtered-slot-class-mixin)
 234      &key (filter nil filterp) &allow-other-keys)
 235   (declare (ignore filter))
 236   (if filterp
 237       (find-class 'filtered-direct-slot-definition)
 238       (call-next-method)))
 239
 240 (defmethod effective-slot-definition-class
 241     ((class filtered-slot-class-mixin)
 242      &key (filter nil filterp) &allow-other-keys)
 243   (declare (ignore filter))
 244   (if filterp
 245       (find-class 'filtered-effective-slot-definition)
 246       (call-next-method)))
 247
 248 (defmethod initialize-instance :after
 249     ((slot filtered-direct-slot-definition) &key)
 250   (with-slots (filter) slot
 251     (when (and (consp filter)
 252                (or (eq (car filter) 'function)
 253                    (eq (car filter) 'quote))
 254                (symbolp (cadr filter))
 255                (null (cddr filter)))
 256       (setf filter (cadr filter)))))
 257
 258 (defmethod initargs-for-effective-slot
 259     ((class filtered-slot-class-mixin) direct-slots)
 260   (let ((filter-slot (find-if #'slot-definition-filter direct-slots)))
 261     (append (and filter-slot
 262                  (list :filter (slot-definition-filter filter-slot)))
 263             (call-next-method))))
 264
 265 (defmethod (setf slot-value-using-class)
 266     (value
 267      (class filtered-slot-class-mixin)
 268      (object standard-object)
 269      (slot filtered-effective-slot-definition))
 270   (call-next-method (funcall (slot-definition-filter slot) value)
 271                     class object slot))
 272
 273 ;;;--------------------------------------------------------------------------
 274 ;;; Predicates.
 275
 276 (defclass predicate-class-mixin (compatible-class)
 277   ((predicates :type list :initarg :predicate :initform nil
 278                :documentation "Predicate generic function to create."))
 279   (:documentation
 280    "Class which can automatically generate a predicate generic function.
 281     Adds the `:predicate' class option, which takes a single symbol argument
 282     FUNC.  If specified, and non-nil, a generic function FUNC with one
 283     argument will be defined (if it doesn't already exist) with a default
 284     method returning nil, and a method added specialized on this class
 285     returning a non-nil value."))
 286
 287 (defmethod shared-initialize :after
 288     ((class predicate-class-mixin) slot-names &key)
 289   (declare (ignore slot-names))
 290   (with-slots (predicates) class
 291     (dolist (predicate predicates)
 292       (let ((lambda-list '(thing)))
 293         (let ((gf (if (fboundp predicate)
 294                       (fdefinition predicate)
 295                       (let ((gf (ensure-generic-function
 296                                  predicate :lambda-list lambda-list)))
 297                         (add-method gf (make-instance
 298                                         'standard-method
 299                                         :specializers (list (find-class 't))
 300                                         :lambda-list lambda-list
 301                                         :function (constantly nil)))))))
 302           (add-method gf (make-instance 'standard-method
 303                                         :specializers (list class)
 304                                         :lambda-list lambda-list
 305                                         :function (constantly t))))))))
 306
 307 ;;;--------------------------------------------------------------------------
 308 ;;; Abstract classes.
 309
 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 (define-condition instantiate-abstract-class (error)
 317   ((class :reader instantiate-abstract-class-class :initarg :class
 318           :documentation "The class someone attempted to instantiate."))
 319   (:report (lambda (cond stream)
 320              (format stream "Cannot instantiate abstract class ~A."
 321                      (class-name (instantiate-abstract-class-class cond)))))
 322   (:documentation
 323    "Reports an attempt to instantiate an abstract class."))
 324
 325 (defmethod make-instance ((class abstract-class-mixin) &rest whatever)
 326   "Signals an error.  The caller is a naughty boy."
 327   (declare (ignore whatever))
 328   (error 'instantiate-abstract-class :class class))
 329
 330 ;;;--------------------------------------------------------------------------
 331 ;;; Singleton classes.
 332
 333 (defclass singleton-class-mixin (compatible-class)
 334   ((instance :initform nil :type (or null standard-object)))
 335   (:documentation
 336    "A class which has only one instance.  All calls to `make-instance' return
 337     the same object."))
 338
 339 (defmethod allocate-instance ((class singleton-class-mixin) &key)
 340   "If the class already has an instance, return it; otherwise allocate one,
 341    store it away, and return that."
 342   (with-slots (instance) class
 343     (or instance
 344         (setf instance (call-next-method)))))
 345
 346 ;;;--------------------------------------------------------------------------
 347 ;;; Useful classes.
 348
 349 (defclass mdw-class (filtered-slot-class-mixin
 350                      predicate-class-mixin
 351                      compatible-class)
 352   ()
 353   (:documentation
 354    "A generally useful metaclass with handy features.  If I've done the
 355     hacking right, there shouldn't be a significant cost to using this
 356     metaclass for all your classes if you don't use any of its fancy
 357     features."))
 358
 359 (defclass abstract-class (mdw-class abstract-class-mixin) ())
 360 (defclass singleton-class (mdw-class singleton-class-mixin) ())
 361
 362 ;;;--------------------------------------------------------------------------
 363 ;;; Printing things.
 364
 365 (defun print-object-with-slots (obj stream)
 366   "Prints objects in a pleasant way.  Not too clever about circularity."
 367   (let ((class (class-of obj))
 368         (magic (cons 'magic nil)))
 369     (print-unreadable-object (obj stream)
 370       (pprint-logical-block
 371           (stream
 372            (mapcan (lambda (slot)
 373                      (list (or (car (slot-definition-initargs slot))
 374                                (slot-definition-name slot))
 375                            (if (slot-boundp-using-class class obj slot)
 376                                (slot-value-using-class class obj slot)
 377                                magic)))
 378                    (class-slots class)))
 379         (format stream "~S" (class-name class))
 380         (let ((sep nil))
 381           (loop
 382             (pprint-exit-if-list-exhausted)
 383             (if sep
 384                 (format stream " ~_")
 385                 (progn (format stream " ~@_~:I") (setf sep t)))
 386             (let ((name (pprint-pop))
 387                   (value (pprint-pop)))
 388               (format stream "~S ~@_~:[~W~;#<unbound>~*~]"
 389                       name (eq value magic) value))))))))
 390
 391 ;;;----- That's all, folks --------------------------------------------------