From 1ff8ffb793a988de0bea7b3c7e663886801e9ce9 Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Sat, 1 Jun 2024 11:06:53 -0700
Subject: Add: types.lisp, singletonc lasses, debugging instr.lisp

---
 src/util.lisp | 20 ++++++++++++++++++++
 1 file changed, 20 insertions(+)

(limited to 'src/util.lisp')

diff --git a/src/util.lisp b/src/util.lisp
index 5899b36..e561778 100644
--- a/src/util.lisp
+++ b/src/util.lisp
@@ -82,3 +82,23 @@ CLASS-OPTIONS is a PLIST of class options."
       `(defclass ,name ,supers
          (,@slot-defs)
          ,@options))))
+
+;;; SINGLETON CLASSES
+
+(defclass singleton (closer-mop:standard-class)
+  ((instance :reader singleton-instance
+             :initarg :instance
+             :documentation "The instance of a singleton class."))
+  (:documentation "Metaclass for singleton classes."))
+
+
+(defmethod closer-mop:validate-superclass
+    ((sub singleton) (sup closer-mop:standard-class))
+  t)
+
+(defmethod make-instance ((class singleton) &rest kwargs)
+  (declare (ignorable kwargs))
+  (if (slot-boundp class 'instance)
+      (slot-value class 'instance)
+      (setf (slot-value class 'instance) (call-next-method))))
+
-- 
cgit v1.2.3