(: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
(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)))
(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
(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)