From: Mark Wooding <mdw@distorted.org.uk>
Date: Thu, 11 May 2006 13:04:59 +0000 (+0100)
Subject: mop: New metaclass for singleton classes: ensures only one instance.
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/lisp/commitdiff_plain/46cd5c4bce3089c64e40a23db9136b2ddcce3885

mop: New metaclass for singleton classes: ensures only one instance.
---

diff --git a/mdw-mop.lisp b/mdw-mop.lisp
index a669490..dc5eb87 100644
--- a/mdw-mop.lisp
+++ b/mdw-mop.lisp
@@ -36,7 +36,8 @@ (defpackage #:mdw.mop
 	     #: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)
@@ -255,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.
 
@@ -269,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.