From 46cd5c4bce3089c64e40a23db9136b2ddcce3885 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Thu, 11 May 2006 14:04:59 +0100 Subject: [PATCH] mop: New metaclass for singleton classes: ensures only one instance. --- mdw-mop.lisp | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) 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 @@ #: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) @@ -256,6 +257,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 @@ -269,6 +286,7 @@ features.")) (defclass abstract-class (mdw-class abstract-class-mixin) ()) +(defclass singleton-class (mdw-class singleton-class-mixin) ()) ;;;-------------------------------------------------------------------------- ;;; Printing things. -- 2.11.0