Source

qtility / metaclass.lisp

Full commit
;;;; metaclass.lisp
;;;; Copyright (c) 2012 Robert Smith

(in-package #:qtl)

;;; Abstract Classes
;;; A metaclass for classes which cannot be instantiated.

(defclass abstract-class (standard-class) ())

(defmethod make-instance ((class abstract-class) &rest ignored)
  (declare (ignore ignored))
  (error "Attempting to instantiate an abstract class ~A"
	 (class-name class)))

(defmethod validate-superclass ((class abstract-class)
                                (superclass standard-class))
  t)

(defmethod validate-superclass ((class standard-class)
				(superclass abstract-class))
  t)


;;; Final Classes
;;; A metaclass for classes which cannot be subclassed.

(defclass final-class (standard-class) ())

(defmethod validate-superclass ((class final-class) 
				(superclass standard-class))
  t)

(defmethod validate-superclass ((class standard-class)
				(superclass final-class))
  (error "Attempting to subclass the final class ~A" (class-name superclass)))


;;;; Singleton Classes
;;;; A metaclass for classes which only can have a single instance.

(defclass singleton-class (standard-class)
  ((singleton :initform nil)))

;;; We can have standard -> singleton
(defmethod validate-superclass ((class singleton-class)
                                (superclass standard-class))
  t)

;;; We can have singleton -> singleton
(defmethod validate-superclass ((class singleton-class)
                                (superclass singleton-class))
  t)

;;; We CANNOT have singleton -> standard
(defmethod validate-superclass ((class standard-class)
                                (superclass singleton-class))
  nil)

(defmethod make-instance ((class singleton-class) &rest initargs)
  (declare (ignore initargs))
  (with-slots (singleton) class
    (or
     ;; If we already have an instance of CLASS, return it.
     singleton
     ;; Otherwise make a new one and save it.
     (setf singleton (call-next-method)))))

;;; Sometimes, for testing, we will want to reset the inherently saved
;;; state of singleton classes. That is, we will want to clear the
;;; "singleton caches". We can do this by recording every
;;; instantiation.

(defvar *singleton-class-registry* nil
  "A list of all of the singleton classes that get created.")

;;; Save singleton class objects when they're made.
(defmethod initialize-instance :after ((class singleton-class) &rest initargs)
  (declare (ignore initargs))
  (pushnew class *singleton-class-registry*))

(defun clear-singleton-class-instances ()
  "Clear out all of the saved instances of singleton classes."
  (dolist (class *singleton-class-registry*)
    (setf (slot-value class 'singleton) nil)))