Clean up bundle implementation.

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index f9151a90599528a7704ba962a19d53b8d2444b60..ec15d37afcec0c1d16b7ffa8592abdee69ad2b10 100644 (file)
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -31,60 +31,76 @@ USA.
 ;;; procedure to call, and the rest of the bundle's arguments are passed to the
 ;;; selected procedure.
 
-;;; Each bundle also carries a predicate that can be used to identify it.
-;;; Normally the predicate is shared between bundles with the same general
-;;; structure.
+;;; Each bundle also carries a type that can be used to identify it.  Normally
+;;; the type is shared between bundles with the same general structure.
 
 (declare (usual-integrations))
 \f
-(define (make-bundle-predicate name)
-  (letrec ((predicate
-            (lambda (object)
-              (and (bundle? object)
-                   (eq? predicate (bundle-predicate object))))))
-    (register-predicate! predicate name '<= bundle?)
-    predicate))
-
-(define (bundle-predicate? object)
-  (and (predicate? object)
-       (predicate<= object bundle?)))
-(register-predicate! bundle-predicate? 'bundle-predicate)
-
-;; Defer this because predicate? will change later in the cold load.
-(defer-boot-action 'predicate-relations
-  (lambda ()
-    (set-predicate<=! bundle-predicate? predicate?)))
-
-(define (alist->bundle predicate alist)
-  (guarantee bundle-predicate? predicate 'alist->bundle)
-  (guarantee bundle-alist? alist 'alist->bundle)
-  (%make-bundle predicate (alist-copy alist)))
-
-(define (bundle-alist? object)
+(define (make-bundle-type name #!optional parent-type)
+  (let ((type
+        (new-make-record-type name
+                              '()
+                              (if (default-object? parent-type)
+                                  <bundle>
+                                  (guarantee bundle-type? parent-type
+                                             'make-bundle-type)))))
+    (set-record-type-applicator! type %bundle-applicator)
+    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-unparser-method bundle-type?
+  (simple-unparser-method 'bundle-type
+    (lambda (type)
+      (list (dispatch-tag-name type)))))
+
+(define (bundle-predicate type)
+  (guarantee bundle-type? type 'bundle-predicate)
+  (record-predicate type))
+
+(define (alist->bundle type alist)
+  (guarantee bundle-type? type 'alist->bundle)
+  (guarantee %bundle-alist? alist 'alist->bundle)
+  ((record-constructor type) (alist-copy alist)))
+
+(define (%bundle-alist? object)
   (and (alist? object)
        (every (lambda (p)
                 (symbol? (car p)))
               object)))
 
 (define-record-type <bundle>
-    (%make-bundle predicate alist)
+    (%unused% alist) ;change to #f after 9.3 release
     bundle?
-  (predicate bundle-predicate)
   (alist bundle-alist))
 
-(set-record-type-applicator! <bundle>
-  (lambda (bundle operator . args)
-    (apply (bundle-ref bundle operator) args)))
-
 (define-unparser-method bundle?
   (standard-unparser-method
    (lambda (bundle)
-     (predicate-name (bundle-predicate bundle)))
+     (dispatch-tag-name (bundle-type bundle)))
    (lambda (bundle port)
      (let ((handler (bundle-ref bundle 'write-self #f)))
        (if handler
           (handler port))))))
 
+(define-pp-describer bundle?
+  (lambda (bundle)
+    (let ((handler (bundle-ref bundle 'describe-self #f)))
+      (if handler
+         (handler)
+         (map (lambda (p) `(,(car p) ,(cdr p)))
+              (bundle-alist bundle))))))
+
+(define (bundle-type bundle)
+  (guarantee bundle? bundle 'bundle-type)
+  (record-type-descriptor bundle))
+
 (define (bundle->alist bundle)
   (alist-copy (bundle-alist bundle)))
 

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

diff --git a/tests/runtime/test-bundle.scm b/tests/runtime/test-bundle.scm
index ea6546588cc03d8c56005f702711fca5b4c69888..c61e6b6a89f4926179cebda8d1ea91b9b952dac7 100644 (file)
--- a/tests/runtime/test-bundle.scm
+++ b/tests/runtime/test-bundle.scm
@@ -30,14 +30,14 @@ USA.
 \f
 (define-test 'simple
   (lambda ()
-    (define foo? (make-bundle-predicate 'foo))
-
-    (assert-true (bundle-predicate? foo?))
+    (define <foo> (make-bundle-type 'foo))
+    (assert-true (bundle-type? <foo>))
+    (define foo? (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,8 +48,11 @@ USA.
 (define-test 'metadata-table
   (lambda ()
 
+    (define <metadata-table>
+      (make-bundle-type 'metadata-table))
+
     (define metadata-table?
-      (make-bundle-predicate 'metadata-table))
+      (bundle-predicate <metadata-table>))
 
     (define foo
       (let ((alist '()))
@@ -97,7 +100,7 @@ USA.
                      (put! (car p) (cdr p)))
                    alist*))
 
-       (bundle metadata-table?
+       (bundle <metadata-table>
                has?
                get
                put!