X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/920d2b95c4445a3bc1335634d0004b63148a028c..8a2e8de1d736200d9aa751b85d5f97af33b91150:/mdw-mop.lisp

diff --git a/mdw-mop.lisp b/mdw-mop.lisp
index 92c164f..f274dcb 100644
--- a/mdw-mop.lisp
+++ b/mdw-mop.lisp
@@ -27,15 +27,17 @@
 ;;; Packages.
 
 (defpackage #:mdw.mop
-  (:use #:common-lisp #+cmu #:pcl)
+  (:use #:common-lisp #:mdw.base #+(or cmu clisp) #: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)
@@ -63,6 +65,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)
@@ -100,6 +123,7 @@
   (defmethod compute-effective-slot-definition
       ((class compatible-class) slot-name direct-slots)
     "Construct an effective slot definition for the given slot."
+    (declare (ignore slot-name))
     ;;
     ;; Ideally we don't want to mess with a slot if it's entirely handled by
     ;; the implementation.  This check seems to work OK.
@@ -234,6 +258,22 @@
   (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.
 
 (defclass mdw-class (filtered-slot-class-mixin
@@ -247,13 +287,14 @@
     features."))
 
 (defclass abstract-class (mdw-class abstract-class-mixin) ())
+(defclass singleton-class (mdw-class singleton-class-mixin) ())
 
 ;;;--------------------------------------------------------------------------
 ;;; Printing things.
 
 (defun print-object-with-slots (obj stream)
   "Prints objects in a pleasant way.  Not too clever about circularity."
-  (let ((class (pcl:class-of obj))
+  (let ((class (class-of obj))
         (magic (cons 'magic nil)))
     (print-unreadable-object (obj stream)
       (pprint-logical-block
@@ -264,8 +305,8 @@
                            (if (slot-boundp-using-class class obj slot)
                                (slot-value-using-class class obj slot)
                                magic)))
-                   (pcl:class-slots class)))
-        (format stream "~S" (pcl:class-name class))
+                   (class-slots class)))
+        (format stream "~S" (class-name class))
         (let ((sep nil))
           (loop
             (pprint-exit-if-list-exhausted)
@@ -274,7 +315,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 --------------------------------------------------