Data commit

Task/Singleton/TXR/singleton.txr

@@ -0,0 +1,33 @@
+;; Custom (:singleton) clause which adds behavior to a class
+;; asserting against multiple instantiation.
+(define-struct-clause :singleton ()
+  ^((:static inst-count 0)
+    (:postinit (me)
+      (assert (<= (inc me.inst-count) 1)))))
+
+(defstruct singleton-one ()
+  (:singleton)
+  (:method speak (me)
+    (put-line "I am singleton-one")))
+
+(defstruct singleton-two ()
+  (:singleton)
+  (:method speak (me)
+    (put-line "I am singleton-two")))
+
+;; Test
+
+;; Global singleton
+(defvarl s1 (new singleton-one))
+
+;; Local singleton in function (like static in C)
+;; load-time evaluates once.
+(defun fn ()
+  (let ((s2 (load-time (new singleton-two))))
+    s2.(speak)))
+
+s1.(speak)
+(fn) ;; multiple calls to fn don't re-instantiate singleton-two
+(fn)
+(put-line "so far, so good")
+(new singleton-two) ;; assertion gooes off