Write a proper vector-map and vector-for-each for (rnrs base)

* module/rnrs/base.scm (vector-map vector-for-each): Rewrite to not be
slow.
* NEWS: Update.

2 files changed, 81 insertions, 9 deletions

diff --git a/NEWS b/NEWS
index 74a2641bd..3a8be50ce 100644
--- a/NEWS
+++ b/NEWS
@@ -138,10 +138,6 @@ The Gnulib compatibility library has been updated, for the first time
 since 2017 or so.  We expect no functional change but look forward to
 any bug reports.
 
-** Optimized "eof-object?"
-
-This predicate is now understood by the compiler.
-
 * New interfaces and functionality
 
 ** `call-with-port'
@@ -180,6 +176,11 @@ See "Syntax Case" in the manual.
 
 See "Syntax Transformer Helpers" in the manual.
 
+* Optimizations
+
+** eof-object?
+** R6RS vector-map, vector-for-each
+
 * Bug fixes
 
 ** Fix reverse-list->string docstring
diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index 9205016bd..ca01cfe9e 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -1,6 +1,6 @@
 ;;; base.scm --- The R6RS base library
 
-;;      Copyright (C) 2010, 2011, 2019 Free Software Foundation, Inc.
+;;      Copyright (C) 2010, 2011, 2019, 2021 Free Software Foundation, Inc.
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -231,10 +231,81 @@
    (and (rational-valued? x)
         (= x (floor (real-part x)))))
 
- (define (vector-for-each proc . vecs)
-   (apply for-each (cons proc (map vector->list vecs))))
- (define (vector-map proc . vecs)
-   (list->vector (apply map (cons proc (map vector->list vecs)))))
+ ;; Auxiliary procedure for vector-map and vector-for-each
+ (define (vector-lengths who vs)
+   (let ((lengths (map vector-length vs)))
+     (unless (apply = lengths)
+       (error (string-append (symbol->string who)
+                             ": Vectors of uneven length.")
+              vs))
+     (car lengths)))
+
+ (define vector-map
+   (case-lambda
+     "(vector-map f vec2 vec2 ...) -> vector
+
+Return a new vector of the size of the vector arguments, which must be
+of equal length. Each element at index @var{i} of the new vector is
+mapped from the old vectors by @code{(f (vector-ref vec1 i)
+(vector-ref vec2 i) ...)}.  The dynamic order of application of
+@var{f} is unspecified."
+     ((f v)
+      (let* ((len (vector-length v))
+             (result (make-vector len)))
+        (let loop ((i 0))
+          (unless (= i len)
+            (vector-set! result i (f (vector-ref v i)))
+            (loop (+ i 1))))
+        result))
+     ((f v1 v2)
+      (let* ((len (vector-lengths 'vector-map (list v1 v2)))
+             (result (make-vector len)))
+        (let loop ((i 0))
+          (unless (= i len)
+            (vector-set! result
+                         i
+                         (f (vector-ref v1 i) (vector-ref v2 i)))
+            (loop (+ i 1)))
+          result)))
+     ((f v . vs)
+      (let* ((vs (cons v vs))
+             (len (vector-lengths 'vector-map vs))
+             (result (make-vector len)))
+        (let loop ((i 0))
+          (unless (= i len)
+            (vector-set! result
+                         i
+                         (apply f (map (lambda (v) (vector-ref v i)) vs)))
+            (loop (+ i 1))))
+        result))))
+
+(define vector-for-each
+  (case-lambda
+    "(vector-for-each f vec1 vec2 ...) -> unspecified
+
+Call @code{(f (vector-ref vec1 i) (vector-ref vec2 i) ...)} for each index
+ in the provided vectors, which have to be of equal length. The iteration
+is strictly left-to-right."
+    ((f v)
+     (let ((len (vector-length v)))
+       (let loop ((i 0))
+         (unless (= i len)
+           (f (vector-ref v i))
+           (loop (+ i 1))))))
+    ((f v1 v2)
+     (let ((len (vector-lengths 'vector-for-each (list v1 v2))))
+       (let loop ((i 0))
+         (unless (= i len)
+           (f (vector-ref v1 i) (vector-ref v2 i))
+           (loop (+ i 1))))))
+    ((f v . vs)
+     (let* ((vs (cons v vs))
+            (len (vector-lengths 'vector-for-each vs)))
+       (let loop ((i 0))
+         (unless (= i len)
+           (apply f (map (lambda (v) (vector-ref v i)) vs))
+           (loop (+ i 1))))))))
+
 
  (define-syntax define-proxy
    (syntax-rules (@)