Implement vector-any and vector-every.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index cc1678e361ad7bcdb0f4c2123718c316de4518c8..3485888413ec651a2d1a374f53e6e104cdc48a32 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -851,12 +851,14 @@ USA.
          subvector-uniform?
          vector
          vector->list
+         vector-any
          vector-append
          vector-binary-search
          vector-builder
          vector-copy
          vector-copy!
          vector-eighth
+         vector-every
          vector-fifth
          vector-fill!
          vector-filled?

diff --git a/src/runtime/vector.scm b/src/runtime/vector.scm
index 15c6bdd85b94a35cbc49305af59456167014b78b..90d50df6372ea37ce6b5bd6f455c937ef6319d34 100644 (file)
--- a/src/runtime/vector.scm
+++ b/src/runtime/vector.scm
@@ -200,6 +200,52 @@ USA.
 (define (for-each-vector-element vector procedure)
   (vector-for-each procedure vector))
 \f
+(define (vector-any procedure vector . vectors)
+  (let ((n (vector-length vector)))
+    (if (pair? vectors)
+       (let ((n
+              (fold-left (lambda (n v)
+                           (fix:min (vector-length v) n))
+                         n
+                         vectors)))
+         (let loop ((i 0))
+           (if (fix:< i n)
+               (or (apply procedure
+                          (vector-ref vector i)
+                          (map (lambda (vector*)
+                                 (vector-ref vector* i))
+                               vectors))
+                   (loop (fix:+ i 1)))
+               #f)))
+       (let loop ((i 0))
+         (if (fix:< i n)
+             (or (procedure (vector-ref vector i))
+                 (loop (fix:+ i 1)))
+             #f)))))
+
+(define (vector-every procedure vector . vectors)
+  (let ((n (vector-length vector)))
+    (if (pair? vectors)
+       (let ((n
+              (fold-left (lambda (n v)
+                           (fix:min (vector-length v) n))
+                         n
+                         vectors)))
+         (let loop ((i 0))
+           (if (fix:< i n)
+               (and (apply procedure
+                           (vector-ref vector i)
+                           (map (lambda (vector*)
+                                  (vector-ref vector* i))
+                                vectors))
+                    (loop (fix:+ i 1)))
+               #t)))
+       (let loop ((i 0))
+         (if (fix:< i n)
+             (and (procedure (vector-ref vector i))
+                  (loop (fix:+ i 1)))
+             #t)))))
+\f
 (define (subvector-find-next-element vector start end item)
   (guarantee-subvector vector start end 'subvector-find-next-element)
   (let loop ((index start))