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 67bc8095ebbd921f8bd9054d46b8ca3d70ea3f93..c7ebc7603a372dc9ab391d14ac3874333bcf4efc 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 9ba8cbf3d0439b85f6b9c719448b6e4034d88248..6a06ddaeb817d365a80d7c066fbe454cf5fb8f83 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 ()