From 6dc71eeec1b0efad9be23c6f72323cdc58caf26b Mon Sep 17 00:00:00 2001
From: Linus <bjornstam.linus@fastmail.se>
Date: Wed, 17 Feb 2021 22:28:19 +0100
Subject: [PATCH] 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.
---
 module/rnrs/base.scm | 80 +++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 76 insertions(+), 4 deletions(-)

diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index 9205016bd..cd2327e49 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -231,10 +231,82 @@
    (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)
+      (apply 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 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 (apply 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 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 (apply 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 (@)
-- 
2.25.1