From 4b6a6387f82f1bb2058d642dcbd7040ce2578cea Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Sun, 7 May 2006 18:34:47 +0100
Subject: [PATCH] mop: Handy function for making modified copies of instances.

---
 mdw-base.lisp |  8 +++++++-
 mdw-mop.lisp  | 22 ++++++++++++++++++++++
 2 files changed, 29 insertions(+), 1 deletion(-)

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 0b68b8d..59ea692 100644
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -30,7 +30,7 @@
   (:use #:common-lisp)
   (:export #:compile-time-defun
 	   #:show
-	   #:stringify #:listify #:fix-pair #:pairify #:parse-body
+	   #:stringify #:mappend #:listify #:fix-pair #:pairify #:parse-body
 	   #:whitespace-char-p
 	   #:slot-uninitialized
 	   #:nlet #:while #:case2 #:ecase2
@@ -69,6 +69,12 @@
     (t (with-output-to-string (s)
 	 (princ str s)))))
 
+(defun mappend (function list &rest more-lists)
+  "Apply FUNCTION to corresponding elements of LIST and MORE-LISTS, yielding
+   a list.  Return the concatenation of all the resulting lists.  Like
+   mapcan, but nondestructive."
+  (apply #'append (apply #'mapcar function list more-lists)))
+
 (compile-time-defun listify (x)
   "If X is a (possibly empty) list, return X; otherwise return (list X)."
   (if (listp x) x (list x)))
diff --git a/mdw-mop.lisp b/mdw-mop.lisp
index e88ff12..a669490 100644
--- a/mdw-mop.lisp
+++ b/mdw-mop.lisp
@@ -29,6 +29,7 @@
 (defpackage #:mdw.mop
   (: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)
-- 
2.11.0