;;; Packages.
(defpackage #:mdw.mop
- (:use #:common-lisp #:mdw.base #+cmu #:pcl)
- (:export #:compatible-class
- #:copy-instance #:copy-instance-using-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
(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.
((sub standard-class) (super compatible-class))
(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.