From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 16 Jan 2018 04:02:20 +0000 (-0800)
Subject: Implement simple weak sets.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~361
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=70d7fc059534f74c4eda16ba961904606c3cc5a0;p=mit-scheme.git

Implement simple weak sets.
---

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index 783d9e3ba..88cffd2d9 100644
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -104,6 +104,82 @@ USA.
 	   (object-new-type (ucode-type constant) 10)))))
     (ugh)))
 
+;;;; Simple weak-set implementation
+
+;;; Does not support #f as an item of the set.
+
+(define (%make-weak-set)
+  (%weak-cons 'weak-set '()))
+
+(define (%weak-set->list weak-set)
+  (weak-list->list (weak-cdr weak-set)))
+
+(define (%add-to-weak-set item weak-set)
+  (let loop
+      ((this (weak-cdr weak-set))
+       (prev weak-set))
+    (if (weak-pair? this)
+	(let ((item* (%weak-car this))
+	      (next (weak-cdr this)))
+	  (cond ((not item*)
+		 (weak-set-cdr! prev next)
+		 (loop next prev))
+		((eq? item item*)
+		 #f)
+		(else
+		 (loop next this))))
+	(begin
+	  (weak-set-cdr! prev (%weak-cons item '()))
+	  #t))))
+
+(define (%remove-from-weak-set item weak-set)
+  (let loop
+      ((this (weak-cdr weak-set))
+       (prev weak-set))
+    (if (weak-pair? this)
+	(let ((item* (%weak-car this))
+	      (next (weak-cdr this)))
+	  (cond ((not item*)
+		 (weak-set-cdr! prev next)
+		 (loop next prev))
+		((eq? item item*)
+		 (weak-set-cdr! prev next)
+		 #t)
+		(else
+		 (loop next this))))
+	#f)))
+
+(define (%weak-set-any predicate weak-set)
+  (let loop
+      ((this (weak-cdr weak-set))
+       (prev weak-set))
+    (if (weak-pair? this)
+	(let ((item (%weak-car this))
+	      (next (weak-cdr this)))
+	  (cond ((not item)
+		 (weak-set-cdr! prev next)
+		 (loop next prev))
+		((predicate item)
+		 #t)
+		(else
+		 (loop next this))))
+	#f)))
+
+(define (%weak-set-for-each procedure weak-set)
+  (let loop
+      ((this (weak-cdr weak-set))
+       (prev weak-set))
+    (if (weak-pair? this)
+	(let ((item (%weak-car this))
+	      (next (weak-cdr this)))
+	  (if item
+	      (begin
+		(procedure item)
+		(loop next this))
+	      (begin
+		(weak-set-cdr! prev next)
+		(loop next prev)))))))
+
 ;;;; Interrupt control
 
 (define interrupt-bit/stack     #x0001)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 80f2290a6..a1a646d53 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -191,6 +191,12 @@ USA.
 	  with-limited-interrupts
 	  without-interrupts)
   (export (runtime)
+	  %add-to-weak-set
+	  %make-weak-set
+	  %remove-from-weak-set
+	  %weak-set->list
+	  %weak-set-any
+	  %weak-set-for-each
 	  add-boot-init!
 	  defer-boot-action
 	  run-deferred-boot-actions)