Merge branch 'master' of git+ssh://metalzone.distorted.org.uk/~mdw/public-git/lisp

[lisp] / mdw-mop.lisp

diff --git a/mdw-mop.lisp b/mdw-mop.lisp
index e88ff1227a007e10fd375b154f3288b11d6960f9..51db744226852a8bb1f784be784f46b6d1fb5ae9 100644 (file)
--- a/mdw-mop.lisp
+++ b/mdw-mop.lisp
@@ -27,15 +27,17 @@
 ;;; Packages.
 
 (defpackage #:mdw.mop
-  (:use #:common-lisp #:mdw.base #+cmu #:pcl)
+  (:use #:common-lisp #:mdw.base #+cmu #:mop)
   (:export #:compatible-class
+          #:copy-instance #:copy-instance-using-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)
@@ -62,6 +64,27 @@ (defmethod validate-superclass
     ((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.
 
@@ -233,6 +256,22 @@ (defmethod make-instance ((class abstract-class-mixin) &rest whatever)
   (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.
 
@@ -247,6 +286,7 @@ (defclass mdw-class (filtered-slot-class-mixin
     features."))
 
 (defclass abstract-class (mdw-class abstract-class-mixin) ())
+(defclass singleton-class (mdw-class singleton-class-mixin) ())
 
 ;;;--------------------------------------------------------------------------
 ;;; Printing things.