Implement simple weak sets.

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index 783d9e3bae79a7c3489602dc634f0aefe5fe91e3..88cffd2d9b809aa2d34a58b8c645757d6951a0d9 100644 (file)
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -104,6 +104,82 @@ USA.
           (object-new-type (ucode-type constant) 10)))))
     (ugh)))
 \f
+;;;; 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)))))))
+\f
 ;;;; Interrupt control
 
 (define interrupt-bit/stack     #x0001)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 80f2290a63a507a52b04d238d768bb4e7a93518d..a1a646d53c9641c7c9b5b0a348bd00f631cd4e68 100644 (file)
--- 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)