mop: Handy function for making modified copies of instances.

[lisp] / mdw-mop.lisp

diff --git a/mdw-mop.lisp b/mdw-mop.lisp
index 92c164f..a669490 100644 (file)
--- a/mdw-mop.lisp
+++ b/mdw-mop.lisp
@@ -27,8 +27,9 @@
 ;;; Packages.
 
 (defpackage #:mdw.mop
-  (:use #:common-lisp #+cmu #:pcl)
+  (:use #:common-lisp #:mdw.base #+cmu #:pcl)
   (:export #:compatible-class
+          #:copy-instance #:copy-instance-using-class
           #:initargs-for-effective-slot #:make-effective-slot
           #:filtered-slot-class-mixin
             #:filtered-direct-slot-definition
@@ -63,6 +64,27 @@
   (eq (class-of sub) (find-class 'standard-class)))
 
 ;;;--------------------------------------------------------------------------
+;;; 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))
+
+;;;--------------------------------------------------------------------------
 ;;; Utilities for messing with slot options.
 
 (defgeneric initargs-for-effective-slot (class direct-slots)
@@ -274,7 +296,7 @@
                 (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 --------------------------------------------------