From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 20 Jan 2018 05:36:13 +0000 (-0800)
Subject: Tweak bundle index lookup; fix bundle tests.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~331
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6c741a60c9c6fe2389e924509fbc62dff6f6bff0;p=mit-scheme.git

Tweak bundle index lookup; fix bundle tests.
---

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index 5cd06e346..0fc2cdb33 100644
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -109,14 +109,7 @@ USA.
 		     (element-index tag name #t)))))
 
 (define (element-index tag name required?)
-  (let ((index
-	 (let* ((v (tag-element-names tag))
-		(end (vector-length v)))
-	   (let loop ((i 0))
-	     (and (fix:< i end)
-		  (if (eq? name (vector-ref v i))
-		      i
-		      (loop (fix:+ i 1))))))))
+  (let ((index (vector-find-next-element (tag-element-names tag) name)))
     (if (not (or index (not required?)))
 	(error "Unknown element name:" name (dispatch-tag->predicate tag)))
     index))
diff --git a/tests/runtime/test-bundle.scm b/tests/runtime/test-bundle.scm
index a13e81872..ae265d560 100644
--- a/tests/runtime/test-bundle.scm
+++ b/tests/runtime/test-bundle.scm
@@ -30,35 +30,48 @@ USA.
 
 (define-test 'simple
   (lambda ()
-    (define-bundle-interface <foo> capture-foo foo? a b c)
+    (define-bundle-interface foo? make-foo capture-foo a b c)
 
-    (assert-true (bundle-interface? <foo>))
-    (assert-equal (bundle-interface-element-names <foo>)
+    (assert-true (bundle-interface? foo?))
+    (assert-equal (bundle-interface-element-names foo?)
 		  '(a b c))
     (for-each (lambda (name)
-		(assert-equal (bundle-interface-element-properties <foo> name)
+		(assert-equal (bundle-interface-element-properties foo? name)
 			      '()))
-	      (bundle-interface-element-names <foo>))
-
-    (define foo
-      (let ((a 0)
-	    (b 1)
-	    (c 3))
-	(capture-foo)))
-
-    (assert-true (foo? foo))
-    (assert-eqv (bundle-ref foo 'a) 0)
-    (assert-eqv (bundle-ref foo 'b) 1)
-    (assert-eqv (bundle-ref foo 'c) 3)
-    (assert-eqv (bundle-ref foo 'd #f) #f)
-    (assert-error (lambda () (bundle-ref foo 'd)))))
+	      (bundle-interface-element-names foo?))
+
+    (define bundle-a (bundle-accessor foo? 'a))
+    (define bundle-b (bundle-accessor foo? 'b))
+    (define bundle-c (bundle-accessor foo? 'c))
+    (assert-error (lambda () (bundle-accessor foo 'd)))
+
+    (define (test-bundle bundle av bv cv)
+      (assert-true (foo? bundle))
+      (assert-eqv (bundle-ref bundle 'a) av)
+      (assert-eqv (bundle-ref bundle 'b) bv)
+      (assert-eqv (bundle-ref bundle 'c) cv)
+      (assert-eqv (bundle-ref bundle 'd #f) #f)
+      (assert-error (lambda () (bundle-ref foo 'd)))
+      (assert-eqv (bundle-a bundle) av)
+      (assert-eqv (bundle-b bundle) bv)
+      (assert-eqv (bundle-c bundle) cv))
+
+    (let ((a 10)
+	  (b 20)
+	  (c 40))
+      (test-bundle (make-foo a b c) a b c))
+
+    (let ((a 0)
+	  (b 1)
+	  (c 3))
+      (test-bundle (capture-foo) a b c))))
 
 (define-test 'metadata-table
   (lambda ()
 
-    (define-bundle-interface <metadata-table>
+    (define-bundle-interface metadata-table?
+      make-metadata-table
       capture-metadata-table
-      metadata-table?
       has?
       get
       put!