Allow alist->bundle to accept #F as predicate.

Also beef up bundle tests a bit.

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index fa2956cce22013540c883cd88c68ac4cbb25ccf1..d6a436237fd17907f7a7c4c6def641db6ad1edc1 100644 (file)
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -57,16 +57,21 @@ USA.
 
 (define (alist->bundle predicate alist)
   (guarantee %bundle-alist? alist 'alist->bundle)
-  ((record-constructor (%predicate->record-type predicate)) (alist-copy alist)))
+  ((record-constructor
+    (if predicate
+       (%bundle-predicate->record-type predicate)
+       <bundle>))
+   (alist-copy alist)))
+
+(define %bundle-predicate->record-type
+  %predicate->record-type)
 
 (defer-boot-action 'predicate-relations
   (lambda ()
-    (set! alist->bundle
-         (named-lambda (alist->bundle predicate alist)
+    (set! %bundle-predicate->record-type
+         (named-lambda (%bundle-predicate->record-type predicate)
            (guarantee bundle-predicate? predicate 'alist->bundle)
-           (guarantee %bundle-alist? alist 'alist->bundle)
-           ((record-constructor (%predicate->record-type predicate))
-            (alist-copy alist))))
+           (%predicate->record-type predicate)))
     unspecific))
 
 (define (%bundle-alist? object)

diff --git a/tests/runtime/test-bundle.scm b/tests/runtime/test-bundle.scm
index 0303442f6d415fb105ad014d79ea978e1e09b0de..684c314255e63488fdd8fe8252b8fd3c7d0dfde0 100644 (file)
--- a/tests/runtime/test-bundle.scm
+++ b/tests/runtime/test-bundle.scm
@@ -30,19 +30,32 @@ USA.
 \f
 (define-test 'simple
   (lambda ()
-    (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)))
-       (assert-true (foo? b))
-       (assert-eqv (bundle-ref b 'x) x)
-       (assert-eqv (bundle-ref b 'y) y)
-       (assert-eqv (bundle-ref b 'z) z)
-       (assert-eqv (bundle-ref b 'w #f) #f)
-       (assert-error (lambda () (bundle-ref foo 'w)))))))
+    (define (x) 10)
+    (define (y) 20)
+    (define (z) 40)
+
+    (define (simple-tests b)
+      (assert-true (bundle? b))
+      (assert-eqv (bundle-ref b 'x) x)
+      (assert-eqv (bundle-ref b 'y) y)
+      (assert-eqv (bundle-ref b 'z) z)
+      (assert-eqv (bundle-ref b 'w #f) #f)
+
+      (assert-eqv (b 'x) (x))
+      (assert-eqv (b 'y) (y))
+      (assert-eqv (b 'z) (z))
+      (assert-error (lambda () (b 'w))))
+
+    (simple-tests (bundle #f x y z))
+
+    (assert-true (bundle-predicate? bundle?))
+    (simple-tests (bundle bundle? x y z))
+
+    (let ((predicate (make-bundle-predicate 'foo)))
+      (assert-true (bundle-predicate? predicate))
+      (let ((b (bundle predicate x y z)))
+       (assert-true (predicate b))
+       (simple-tests b)))))
 
 (define-test 'metadata-table
   (lambda ()