Refactor handling of explicit tag supersets.

Was hash table, now is weak list.

diff --git a/src/runtime/predicate-lattice.scm b/src/runtime/predicate-lattice.scm
index c74c9f978de245abab5b3435f448646dda8bf60d..d85f9213913c2448bb120abb5424205e2b824e74 100644 (file)
--- a/src/runtime/predicate-lattice.scm
+++ b/src/runtime/predicate-lattice.scm
@@ -67,9 +67,9 @@ USA.
                        tag<=-overrides)))
             (if v
                 ((vector-ref v 2) tag1 tag2)
-                (any (lambda (tag)
-                       (cached-tag<= tag tag2))
-                     (get-tag-supersets tag1)))))))
+                (any-tag-superset (lambda (tag)
+                                    (cached-tag<= tag tag2))
+                                  tag1))))))
 
 (define (define-tag<= test1 test2 handler)
   (set! tag<=-overrides
@@ -111,8 +111,6 @@ USA.
   (if (and (eq? operator 'set-tag<=!)
            (pair? rest))
       (let ((superset (car rest)))
-        (if (tag<= tag superset)
-            (error "Tag already has this superset:" tag superset))
         (if (tag>= tag superset)
             (error "Not allowed to create a superset loop:" tag superset))))
   (hash-table-clear! tag<=-cache))
\ No newline at end of file

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index 804e0570bf0215d3a2d5cab58daed50ad57b7194..d572b7586b57c3c95dc3804c9056270c34754faa 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -104,8 +104,7 @@ USA.
                    (if (default-object? description)
                        (delay (object->description name))
                        (delay description))
-                   (make-key-weak-eq-hash-table)
-                   (make-key-weak-eq-hash-table))))
+                   (%make-weak-set))))
     (set-predicate-tag! predicate tag)
     tag))
 
@@ -125,14 +124,13 @@ USA.
       (write object port))))
 
 (define-record-type <tag>
-    (%make-tag name predicate extra description subsets supersets)
+    (%make-tag name predicate extra description supersets)
     tag?
   (name tag-name)
   (predicate tag->predicate)
   (extra tag-extra)
   (description %tag-description)
-  (subsets tag-subsets)
-  (supersets tag-supersets))
+  (supersets %tag-supersets))
 
 (define-unparser-method tag?
   (simple-unparser-method 'tag
@@ -142,19 +140,58 @@ USA.
 (define (tag-description tag)
   (force (%tag-description tag)))
 
-(define (get-tag-subsets tag)
-  (hash-table-keys (tag-subsets tag)))
+(define (tag-supersets tag)
+  (%weak-set->list (%tag-supersets tag)))
 
-(define (get-tag-supersets tag)
-  (hash-table-keys (tag-supersets tag)))
+(define (any-tag-superset predicate tag)
+  (%weak-set-any predicate (%tag-supersets tag)))
 
 (define (set-tag<=! tag superset)
-  (event-distributor/invoke! event:predicate-metadata 'set-tag<=! tag superset)
-  (%link! tag superset))
-
-(define (%link! subset superset)
-  (hash-table-set! (tag-subsets superset) subset subset)
-  (hash-table-set! (tag-supersets subset) superset superset))
+  (guarantee tag? superset 'set-tag<=!)
+  (if (%add-to-weak-set superset (%tag-supersets tag))
+      (event-distributor/invoke! event:predicate-metadata
+                                'set-tag<=! tag superset)
+      (error "Tag already has this superset:" tag superset)))
+\f
+(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 (%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 event:predicate-metadata (make-event-distributor))
 \f

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 181d77039367b04862e63ef2b5f47938d37ab427..80f2290a63a507a52b04d238d768bb4e7a93518d 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1840,9 +1840,8 @@ USA.
          predicate-name
          set-predicate<=!)
   (export (runtime)
+         any-tag-superset
          event:predicate-metadata
-         get-tag-subsets
-         get-tag-supersets
          make-tag
          predicate->tag
          set-tag<=!
@@ -1850,6 +1849,7 @@ USA.
          tag-description
          tag-extra
          tag-name
+         tag-supersets
          tag?))
 
 (define-package (runtime predicate-lattice)