From bf3b24846ce01de46eb4ed2a454cd27b70d9f4ee Mon Sep 17 00:00:00 2001
From: Thomas White <taw@physics.org>
Date: Sun, 10 Jul 2022 16:46:55 +0200
Subject: Add "remove-fixture[s]-from-state!"

---
 guile/starlet/state.scm | 24 +++++++++++++++++++++++-
 1 file changed, 23 insertions(+), 1 deletion(-)

(limited to 'guile')

diff --git a/guile/starlet/state.scm b/guile/starlet/state.scm
index 560df82..15b5d4e 100644
--- a/guile/starlet/state.scm
+++ b/guile/starlet/state.scm
@@ -58,7 +58,9 @@
             atomically-overlay-state!
             update-state!
             add-update-hook!
-            state-empty?))
+            state-empty?
+            remove-fixtures-from-state!
+            remove-fixture-from-state!))
 
 
 ;; A "state" is an atomically-updating container for an immutable
@@ -453,3 +455,23 @@ pre-existing contents."
   (hash-table-empty?
     (atomic-box-ref
       (get-ht-box st))))
+
+
+(define (remove-fixtures-from-state! st fixture-list)
+  (let ((new-ht (make-hash-table))
+        (old-ht (atomic-box-ref (get-ht-box st))))
+    (state-for-each
+      (lambda (fix attr val)
+        (unless (memq fix fixture-list)
+          (hash-set! new-ht (cons fix attr) val)))
+      st)
+    (if (eq? old-ht (atomic-box-compare-and-swap!
+                      (get-ht-box st)
+                      old-ht
+                      new-ht))
+      (run-hook (get-update-hook st) #f)
+      (remove-fixtures-from-state! st fixture-list))))
+
+
+(define (remove-fixture-from-state! st fix)
+  (remove-fixtures-from-state! st (list fix)))
-- 
cgit v1.2.3