;;; Packages.
(defpackage #:mdw.mop
- (:use #:common-lisp #:mdw.base #+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-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)
(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.
(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
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
(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)