;;; Packages.
(defpackage #:mdw.mop
- (:use #:common-lisp #+cmu #:pcl)
- (:export #:compatible-class
+ (:use #:common-lisp #:mdw.base #+cmu #:mop)
+ (:export #:copy-instance #:copy-instance-using-class
+ #:compatible-class
#:initargs-for-effective-slot #:make-effective-slot
#:filtered-slot-class-mixin
#:filtered-direct-slot-definition
#:filtered-effective-slot-definition
+ #:predicate-class-mixin
#:abstract-class-mixin #:instantiate-abstract-class
- #:mdw-class #:abstract-class
+ #:singleton-class-mixin
+ #:mdw-class #:abstract-class #:singleton-class
#:print-object-with-slots))
(in-package #:mdw.mop)
+;;;--------------------------------------------------------------------------
+;;; Copying instances.
+
+(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))
+
+(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))
+
;;;--------------------------------------------------------------------------
;;; Basic stuff.
(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 filtered-slot-class-mixin)
(object standard-object)
(slot filtered-effective-slot-definition))
- (call-next-method (funcall (slot-definition-filter slot) object value)
+ (call-next-method (funcall (slot-definition-filter slot) value)
class object slot))
+;;;--------------------------------------------------------------------------
+;;; Predicates.
+
+(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.
(declare (ignore whatever))
(error 'instantiate-abstract-class :class class))
+;;;--------------------------------------------------------------------------
+;;; Singleton classes.
+
+(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.
(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."))
(defclass abstract-class (mdw-class abstract-class-mixin) ())
+(defclass singleton-class (mdw-class singleton-class-mixin) ())
;;;--------------------------------------------------------------------------
;;; Printing things.
(progn (format stream " ~@_~:I") (setf sep t)))
(let ((name (pprint-pop))
(value (pprint-pop)))
- (format stream "~S ~@_~:[~S~;<unbound>~*~]"
+ (format stream "~S ~@_~:[~W~;#<unbound>~*~]"
name (eq value magic) value))))))))
;;;----- That's all, folks --------------------------------------------------
~mdw / lisp / blobdiff