From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 6 Jan 2019 02:28:40 +0000 (-0800)
Subject: Allow alist->bundle to accept #F as predicate.
X-Git-Tag: mit-scheme-pucked-10.1.9~3^2~20
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=30f505a6005de525ad2f4bb76578679f955a6271;p=mit-scheme.git

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 67bc8095e..c7ebc7603 100644
--- 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 9ba8cbf3d..6a06ddaeb 100644
--- a/tests/runtime/test-bundle.scm
+++ b/tests/runtime/test-bundle.scm
@@ -30,19 +30,32 @@ USA.
 
 (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 ()