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

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

[OKUMURA Yuki]

Hi,

Actually it's my own bug but let me report here: (scheme base) lacks
implementation for string-for-each thus following code does not work;

(import (scheme base))

(string-for-each
  (lambda (e f) 'ok)
  "01234"
  "slas")

Please note that we already have incompatible string-for-each for
SRFI-13 and R6RS.
(It seems current (scheme base) uses SRFI-13 one)
R7RS for-each (and map) procedures allow different length of
collection as arguments.

Checked on 2b4e45ca1b89a942200b7b9f46060dddc44d2876

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

[Mark H Weaver]

OKUMURA Yuki <mjt@cltn.org> wrote:
> Actually it's my own bug but let me report here: (scheme base) lacks
> implementation for string-for-each thus following code does not work;
> 
> (import (scheme base))
> 
> (string-for-each
>   (lambda (e f) 'ok)
>   "01234"
>   "slas")
> 
> Please note that we already have incompatible string-for-each for
> SRFI-13 and R6RS.
> (It seems current (scheme base) uses SRFI-13 one)
> R7RS for-each (and map) procedures allow different length of
> collection as arguments.
> 
> Checked on 2b4e45ca1b89a942200b7b9f46060dddc44d2876

For the record, the version of R7RS 'string-for-each' that I implemented
for Guile many years ago, in the 'r7rs-wip' branch of Guile's git
repository (not to be confused with 'wip-r7rs'), does not have this bug:

  https://git.savannah.gnu.org/cgit/guile.git/tree/module/scheme/base.scm?h=r7rs-wip&id=2d76447bda2f3d61c94d80b3b78732648a0a511d#n221

I'm not sure why Andy chose not to use my work.

      Mark

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

[Taylan Kammer]

[-- Attachment #1: Type: text/plain, Size: 107 bytes --]

Attached is a simple patch to use Mark's implementation
within the current (scheme base) module.

- Taylan

[-- Attachment #2: 0001-Fix-scheme-base-string-for-each.patch --]
[-- Type: text/plain, Size: 2480 bytes --]

From dda2aaaf0e9064f11d89a83f55340ba0c0115bca Mon Sep 17 00:00:00 2001
From: Taylan Kammer <taylan.kammer@gmail.com>
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

bug#40584: ...

[lloda]

Patch applied in 3243d96bb5b9658f08847a7073fe6c0b2ccab6be.

Thanks,

  Daniel