Eliminate bundle types; original design using predicates is better.

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index d2bf7ec1e15d13963a4d4c28707791b02a4cc9a2..2dc34a890c57a0837e997e7e28e0a2f8f269f50c 100644 (file)
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -36,45 +36,45 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (make-bundle-type name #!optional parent-type)
+(define (make-bundle-predicate name #!optional parent-predicate)
   (let ((type
         (new-make-record-type name
                               '()
-                              (if (default-object? parent-type)
+                              (if (default-object? parent-predicate)
                                   <bundle>
-                                  (guarantee bundle-type? parent-type
-                                             'make-bundle-type)))))
+                                  (%predicate->record-type
+                                   (guarantee bundle-predicate?
+                                              parent-predicate
+                                              'make-bundle-predicate))))))
     (set-record-type-applicator! type %bundle-applicator)
-    type))
+    (record-predicate type)))
 
 (define (%bundle-applicator bundle operator . args)
   (apply (bundle-ref bundle operator) args))
 
-(define (bundle-type? object)
-  (and (record-type? object)
-       (predicate<= (record-predicate object) bundle?)))
-(register-predicate! bundle-type? 'bundle-type '<= record-type?)
+(define-integrable (%predicate->record-type predicate)
+  (predicate->dispatch-tag predicate))
 
-(define-unparser-method bundle-type?
-  (simple-unparser-method 'bundle-type
-    (lambda (type)
-      (list (dispatch-tag-name type)))))
+(define (bundle-predicate? object)
+  (and (predicate? object)
+       (predicate<= object bundle?)))
 
-(define (bundle-predicate type)
-  (guarantee bundle-type? type 'bundle-predicate)
-  (record-predicate type))
+(defer-boot-action 'predicate-relations
+  (lambda ()
+    (register-predicate! bundle-predicate? 'bundle-predicate '<= predicate?)))
 
-(define (alist->bundle type alist)
+(define (alist->bundle predicate alist)
   (guarantee %bundle-alist? alist 'alist->bundle)
-  ((record-constructor type) (alist-copy alist)))
+  ((record-constructor (%predicate->record-type predicate)) (alist-copy alist)))
 
 (defer-boot-action 'predicate-relations
   (lambda ()
     (set! alist->bundle
-         (named-lambda (alist->bundle type alist)
-           (guarantee bundle-type? type 'alist->bundle)
+         (named-lambda (alist->bundle predicate alist)
+           (guarantee bundle-predicate? predicate 'alist->bundle)
            (guarantee %bundle-alist? alist 'alist->bundle)
-           ((record-constructor type) (alist-copy alist))))
+           ((record-constructor (%predicate->record-type predicate))
+            (alist-copy alist))))
     unspecific))
 
 (define (%bundle-alist? object)
@@ -91,7 +91,7 @@ USA.
 (define-unparser-method bundle?
   (standard-unparser-method
    (lambda (bundle)
-     (dispatch-tag-name (bundle-type bundle)))
+     (record-type-name (record-type-descriptor bundle)))
    (lambda (bundle port)
      (let ((handler (bundle-ref bundle 'write-self #f)))
        (if handler
@@ -105,9 +105,9 @@ USA.
          (map (lambda (p) `(,(car p) ,(cdr p)))
               (bundle-alist bundle))))))
 
-(define (bundle-type bundle)
+(define (bundle-predicate bundle)
   (guarantee bundle? bundle 'bundle-type)
-  (record-type-descriptor bundle))
+  (record-predicate (record-type-descriptor bundle)))
 
 (define (bundle->alist bundle)
   (alist-copy (bundle-alist bundle)))

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index 2026710674c1d370a5c88f5bd69762e4ab3288c3..4dda86f43102c77fe019f00c67496064f4abe512 100644 (file)
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -494,8 +494,8 @@ USA.
 \f
 ;;;; Metadata tables
 
-(define <metadata-table>
-  (make-bundle-type 'metadata-table))
+(define metadata-table?
+  (make-bundle-predicate 'metadata-table))
 
 (define (make-alist-metadata-table)
   (let ((alist '()))
@@ -543,7 +543,7 @@ USA.
                  (put! (car p) (cdr p)))
                alist*))
 
-    (bundle <metadata-table>
+    (bundle metadata-table?
            has? get put! intern! delete! get-alist put-alist!)))
 \f
 (define (make-hashed-metadata-table)
@@ -574,7 +574,7 @@ USA.
                  (put! (car p) (cdr p)))
                alist*))
 
-    (bundle <metadata-table>
+    (bundle metadata-table?
            has? get put! intern! delete! get-alist put-alist!)))
 \f
 ;;;; Builder for vector-like sequences

diff --git a/src/runtime/hash.scm b/src/runtime/hash.scm
index 6b5655ecae4867a18f44e4a615f3b1c306d9ba38..8f7115cd0478488e9478f7f02c141f21f0d230eb 100644 (file)
--- a/src/runtime/hash.scm
+++ b/src/runtime/hash.scm
@@ -56,10 +56,9 @@ USA.
 (define (->hasher hasher caller)
   (if (default-object? hasher)
       default-object-hasher
-      (guarantee hasher? hasher caller)))
+      (guarantee object-hasher? hasher caller)))
 
-(define-deferred <object-hasher> (make-bundle-type 'object-hasher))
-(define-deferred object-hasher? (bundle-predicate <object-hasher>))
+(define-deferred object-hasher? (make-bundle-predicate 'object-hasher))
 (define-deferred default-object-hasher (make-object-hasher 313))
 
 (define (make-object-hasher #!optional initial-size)
@@ -101,5 +100,5 @@ USA.
            (lambda ()
              (hash-table-exists? unhash-table hash)))))
 
-    (bundle <object-hasher>
+    (bundle object-hasher?
            hash-object object-hashed? unhash-object valid-object-hash?)))
\ No newline at end of file

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index f1eb126229ecb365fce96a18f60d28f0f4c520a9..d60ba44a50f503b474d065e570741cb58bcfb3f5 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1929,11 +1929,10 @@ USA.
          bundle->alist
          bundle-names
          bundle-predicate
-         bundle-type
-         bundle-type?
+         bundle-predicate?
          bundle-ref
          bundle?
-         make-bundle-type))
+         make-bundle-predicate))
 
 (define-package (runtime environment)
   (files "environment")

diff --git a/tests/runtime/test-bundle.scm b/tests/runtime/test-bundle.scm
index c61e6b6a89f4926179cebda8d1ea91b9b952dac7..3eb0ce12ca2edf6e322c01b40b2cad598cbb3dc4 100644 (file)
--- a/tests/runtime/test-bundle.scm
+++ b/tests/runtime/test-bundle.scm
@@ -30,14 +30,13 @@ USA.
 \f
 (define-test 'simple
   (lambda ()
-    (define <foo> (make-bundle-type 'foo))
-    (assert-true (bundle-type? <foo>))
-    (define foo? (bundle-predicate <foo>))
+    (define foo? (make-bundle-predicate 'foo))
+    (assert-true (bundle-predicate? foo?))
 
     (let ((x 10)
          (y 20)
          (z 40))
-      (let ((b (bundle <foo> x y z)))
+      (let ((b (bundle foo? x y z)))
        (assert-true (foo? b))
        (assert-eqv (bundle-ref b 'x) x)
        (assert-eqv (bundle-ref b 'y) y)
@@ -48,11 +47,8 @@ USA.
 (define-test 'metadata-table
   (lambda ()
 
-    (define <metadata-table>
-      (make-bundle-type 'metadata-table))
-
     (define metadata-table?
-      (bundle-predicate <metadata-table>))
+      (make-bundle-predicate 'metadata-table))
 
     (define foo
       (let ((alist '()))
@@ -100,7 +96,7 @@ USA.
                      (put! (car p) (cdr p)))
                    alist*))
 
-       (bundle <metadata-table>
+       (bundle metadata-table?
                has?
                get
                put!