;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; Useful bits of MOP hacking
;;;
;;; (c) 2006 Straylight/Edgeware
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
-;;;
+;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
-;;;
+;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;; Packages.
(defpackage #:mdw.mop
- (:use #:common-lisp #+cmu #:pcl)
- (:export #:compatible-class
- #:initargs-for-effective-slot #:make-effective-slot
- #:filtered-slot-class-mixin
- #:filtered-direct-slot-definition
- #:filtered-effective-slot-definition
- #:abstract-class-mixin #:instantiate-abstract-class
- #:mdw-class #:abstract-class
- #:print-object-with-slots))
+ (:use #:common-lisp #:mdw.base
+ #+(or cmu clisp) #:mop
+ #+sbcl #:sb-mop
+ #+ecl #:clos))
(in-package #:mdw.mop)
;;;--------------------------------------------------------------------------
+;;; Copying instances.
+
+(export 'copy-instance-using-class)
+(defgeneric copy-instance-using-class (class object &rest initargs)
+ (:documentation
+ "Does the donkey-work behind copy-instance."))
+
+(defmethod copy-instance-using-class
+ ((class standard-class) object &rest initargs)
+ (let ((new (apply #'allocate-instance class initargs)))
+ (dolist (slot (class-slots class))
+ (setf (slot-value-using-class class new slot)
+ (slot-value-using-class class object slot)))
+ (apply #'shared-initialize new nil initargs)
+ new))
+
+(export 'copy-instance)
+(defun copy-instance (object &rest initargs)
+ "Make a copy of OBJECT, modifying it by setting slots as requested by
+ INITARGS."
+ (apply #'copy-instance-using-class (class-of object) object initargs))
+
+;;;--------------------------------------------------------------------------
+;;; Handy macros.
+
+(export 'with-slot-variables)
+(defmacro with-slot-variables (slots instance &body body)
+ "A copy-out-and-write-back variant of with-slots.
+
+ The SLOTS argument is a list of slot specifications, each of which has the
+ form (NAME &key :update :variable). VARIABLE defaults to NAME, and
+ :update defaults to nil.
+
+ The INSTANCE argument has the form (INSTANCE &key :class), but an atom may
+ be used in place of a singleton list. If the CLASS is specified, then two
+ good things happen: firstly the INSTANCE is declared to be a member of the
+ CLASS, and secondly all the slot variables are declared to have the
+ appropriate types, as dredged up from the class's effective slot
+ definitions.
+
+ The effect of all this is to return the result of evaluating BODY in an
+ environment where the VARIABLEs are bound to the values of the NAMEd slots
+ of the given INSTANCE. If BODY completes successfully (rather than
+ throwing out, restarting, or anything like that) then the final values of
+ VARIABLEs for which UPDATE was set non-nil are written back to their
+ corresponding slots.
+
+ This stands a good chance of being rather faster than with-slots. It
+ does, however, run the risk of leaving things in an inconsistent state if
+ BODY escapes half-way through. Also, this requires recompilation if a
+ class's slots change type."
+ (multiple-value-bind (instance class)
+ (destructuring-bind
+ (instance &key class)
+ (listify instance)
+ (values instance (and class (find-class class))))
+ (let ((slots (mapcar (lambda (slot)
+ (destructuring-bind
+ (name &key update (variable name))
+ (listify slot)
+ (list name variable update)))
+ (if slots
+ (listify slots)
+ (mapcar #'slot-definition-name
+ (class-slots class))))))
+ (with-parsed-body (body decls) body
+ (with-gensyms (instvar)
+ `(let ((,instvar ,instance))
+ ,@(and class `((declare (type ,(class-name class) ,instvar))))
+ (let ,(loop for (name var update) in slots
+ collect `(,var (slot-value ,instvar ',name)))
+ ,@(and class
+ `((declare
+ ,@(loop
+ for (name var update) in slots
+ for slot = (or (find name
+ (class-slots class)
+ :key #'slot-definition-name)
+ (error
+ "Slot ~S not found in class ~S."
+ name (class-name class)))
+ collect `(type
+ ,(slot-definition-type slot)
+ ,name)))))
+ ,@decls
+ (multiple-value-prog1
+ (progn ,@body)
+ ,@(loop for (name var update) in slots
+ when update
+ collect `(setf (slot-value ,instvar ',name)
+ ,var))))))))))
+
+;;;--------------------------------------------------------------------------
;;; Basic stuff.
+(export 'compatible-class)
(defclass compatible-class (standard-class)
()
(:documentation
;;;--------------------------------------------------------------------------
;;; Utilities for messing with slot options.
+(export 'initargs-for-effective-slot)
(defgeneric initargs-for-effective-slot (class direct-slots)
(:documentation
"Missing functionality from the MOP: given a class and its direct slots
direct-slots)))
:allocation (slot-definition-allocation (car direct-slots)))))
+(export 'make-effective-slot)
(defun make-effective-slot (class initargs)
- "Construct an effectie slot definition for a slot on the class, given the
+ "Construct an effective slot definition for a slot on the class, given the
required arguments."
(apply #'make-instance
(apply #'effective-slot-definition-class class initargs)
(defmethod compute-effective-slot-definition
((class compatible-class) slot-name direct-slots)
"Construct an effective slot definition for the given slot."
+ (declare (ignore slot-name))
;;
;; Ideally we don't want to mess with a slot if it's entirely handled by
;; the implementation. This check seems to work OK.
;;;--------------------------------------------------------------------------
;;; Filterered slots.
+(export 'filtered-slot-class-mixin)
(defclass filtered-slot-class-mixin (compatible-class)
()
(:documentation
(Yes, I know that using functions would be nicer, but the MOP makes
that surprisingly difficult.)"))
+(defgeneric slot-definition-filter (slot)
+ (:method ((slot slot-definition)) nil))
+
+(export 'filtered-direct-slot-definition)
(defclass filtered-direct-slot-definition
(standard-direct-slot-definition)
((filter :initarg :filter :reader slot-definition-filter)))
-(defgeneric slot-definition-filter (slot)
- (:method ((slot slot-definition)) nil))
-
+(export 'filtered-effective-slot-definition)
(defclass filtered-effective-slot-definition
(standard-effective-slot-definition)
((filter :initarg :filter :accessor slot-definition-filter)))
(call-next-method)))
(defmethod initialize-instance :after
- ((slot filtered-direct-slot-definition) &key &allow-other-keys)
+ ((slot filtered-direct-slot-definition) &key)
(with-slots (filter) slot
(when (and (consp filter)
(or (eq (car filter) 'function)
class object slot))
;;;--------------------------------------------------------------------------
+;;; Predicates.
+
+(export 'predicate-class-mixin)
+(defclass predicate-class-mixin (compatible-class)
+ ((predicates :type list :initarg :predicate :initform nil
+ :documentation "Predicate generic function to create."))
+ (:documentation
+ "Class which can automatically generate a predicate generic function.
+ Adds the `:predicate' class option, which takes a single symbol argument
+ FUNC. If specified, and non-nil, a generic function FUNC with one
+ argument will be defined (if it doesn't already exist) with a default
+ method returning nil, and a method added specialized on this class
+ returning a non-nil value."))
+
+(defmethod shared-initialize :after
+ ((class predicate-class-mixin) slot-names &key)
+ (declare (ignore slot-names))
+ (with-slots (predicates) class
+ (dolist (predicate predicates)
+ (let ((lambda-list '(thing)))
+ (let ((gf (if (fboundp predicate)
+ (fdefinition predicate)
+ (let ((gf (ensure-generic-function
+ predicate :lambda-list lambda-list)))
+ (add-method gf (make-instance
+ 'standard-method
+ :specializers (list (find-class 't))
+ :lambda-list lambda-list
+ :function (constantly nil)))))))
+ (add-method gf (make-instance 'standard-method
+ :specializers (list class)
+ :lambda-list lambda-list
+ :function (constantly t))))))))
+
+;;;--------------------------------------------------------------------------
;;; Abstract classes.
+(export 'abstract-class-mixin)
(defclass abstract-class-mixin (compatible-class)
()
(:documentation
"Confusingly enough, a concrete metaclass for abstract classes. This
class has a `make-instance' implementation which signals an error."))
+(export '(instantiate-abstract-class instantiate-abstract-class-class))
(define-condition instantiate-abstract-class (error)
((class :reader instantiate-abstract-class-class :initarg :class
:documentation "The class someone attempted to instantiate."))
(error 'instantiate-abstract-class :class class))
;;;--------------------------------------------------------------------------
+;;; Singleton classes.
+
+(export 'singleton-class-mixin)
+(defclass singleton-class-mixin (compatible-class)
+ ((instance :initform nil :type (or null standard-object)))
+ (:documentation
+ "A class which has only one instance. All calls to `make-instance' return
+ the same object."))
+
+(defmethod allocate-instance ((class singleton-class-mixin) &key)
+ "If the class already has an instance, return it; otherwise allocate one,
+ store it away, and return that."
+ (with-slots (instance) class
+ (or instance
+ (setf instance (call-next-method)))))
+
+;;;--------------------------------------------------------------------------
;;; Useful classes.
+(export 'mdw-class)
(defclass mdw-class (filtered-slot-class-mixin
+ predicate-class-mixin
compatible-class)
- ())
+ ()
+ (:documentation
+ "A generally useful metaclass with handy features. If I've done the
+ hacking right, there shouldn't be a significant cost to using this
+ metaclass for all your classes if you don't use any of its fancy
+ features."))
+(export 'abstract-class)
(defclass abstract-class (mdw-class abstract-class-mixin) ())
+(export 'singleton-class)
+(defclass singleton-class (mdw-class singleton-class-mixin) ())
+
;;;--------------------------------------------------------------------------
;;; Printing things.
+(export 'print-object-with-slots)
(defun print-object-with-slots (obj stream)
"Prints objects in a pleasant way. Not too clever about circularity."
- (let ((class (pcl:class-of obj))
- (magic (cons 'magic nil)))
+ (let ((class (class-of obj))
+ (magic (cons 'magic nil)))
(print-unreadable-object (obj stream)
(pprint-logical-block
- (stream
- (mapcan (lambda (slot)
- (list (or (car (slot-definition-initargs slot))
- (slot-definition-name slot))
- (if (slot-boundp-using-class class obj slot)
- (slot-value-using-class class obj slot)
- magic)))
- (pcl:class-slots class)))
- (format stream "~S" (pcl:class-name class))
- (let ((sep nil))
- (loop
- (pprint-exit-if-list-exhausted)
- (if sep
- (format stream " ~_")
- (progn (format stream " ~@_~:I") (setf sep t)))
- (let ((name (pprint-pop))
- (value (pprint-pop)))
- (format stream "~S ~@_~:[~S~;<unbound>~*~]"
- name (eq value magic) value))))))))
+ (stream
+ (mapcan (lambda (slot)
+ (list (or (car (slot-definition-initargs slot))
+ (slot-definition-name slot))
+ (if (slot-boundp-using-class class obj slot)
+ (slot-value-using-class class obj slot)
+ magic)))
+ (class-slots class)))
+ (format stream "~S" (class-name class))
+ (let ((sep nil))
+ (loop
+ (pprint-exit-if-list-exhausted)
+ (if sep
+ (format stream " ~_")
+ (progn (format stream " ~@_~:I") (setf sep t)))
+ (let ((name (pprint-pop))
+ (value (pprint-pop)))
+ (format stream "~S ~@_~:[~W~;#<unbound>~*~]"
+ name (eq value magic) value))))))))
;;;----- That's all, folks --------------------------------------------------
~mdw / lisp / blobdiff