bug#40584: R7RS string-for-each does not work two or more strings on its argument

From dda2aaaf0e9064f11d89a83f55340ba0c0115bca Mon Sep 17 00:00:00 2001
From: Taylan Kammer <[email protected]>
Date: Wed, 12 May 2021 22:36:26 +0200
Subject: [PATCH] Fix (scheme base) string-for-each.

* module/scheme/base.scm (r7:string-for-each): New procedure.

Fixes <https://bugs.gnu.org/40584>.
---
 module/scheme/base.scm | 26 ++++++++++++++++++++++++--
 1 file changed, 24 insertions(+), 2 deletions(-)

diff --git a/module/scheme/base.scm b/module/scheme/base.scm
index 20e280467..58d5acc74 100644
--- a/module/scheme/base.scm
+++ b/module/scheme/base.scm
@@ -51,6 +51,7 @@
             open-output-bytevector get-output-bytevector
             peek-u8 read-u8 read-bytevector read-bytevector!
             read-string read-line
+            (r7:string-for-each . string-for-each)
             write-u8 write-bytevector write-string flush-output-port
             (r7:string-map . string-map)
             bytevector bytevector-append
@@ -108,7 +109,7 @@
    real? remainder reverse round set!
    set-car! set-cdr! string string->list string->number
    string->symbol string-append
-   string-copy string-copy! string-fill! string-for-each
+   string-copy string-copy! string-fill!
    string-length string-ref string-set! string<=? string<?
    string=? string>=? string>? string? substring symbol->string
    symbol? syntax-error syntax-rules truncate
@@ -403,7 +404,28 @@
 (define (r7:string-map proc s . s*)
   (if (null? s*)
       (string-map proc s)
-      (list->string (apply map proc (string->list s) (map string->list s*)))))
+      (list->string (apply map proc (string->list s) (map string->list
+                                                          s*)))))
+
+(define r7:string-for-each
+      (case-lambda
+        ((proc s) (string-for-each proc s))
+        ((proc s1 s2)
+         (let ((len (min (string-length s1)
+                         (string-length s2))))
+           (let loop ((i 0))
+             (when (< i len)
+               (proc (string-ref s1 i)
+                     (string-ref s2 i))
+               (loop (+ i 1))))))
+        ((proc . strings)
+         (let ((len (apply min (map string-length strings))))
+           (let loop ((i 0))
+             (when (< i len)
+               (apply proc (map (lambda (s)
+                                  (string-ref s i))
+                                strings))
+               (loop (+ i 1))))))))
 
 (define (bytevector . lis)
   (u8-list->bytevector lis))
-- 
2.30.2