summaryrefslogtreecommitdiff
path: root/module/rnrs
diff options
context:
space:
mode:
authorIan Price <ianprice90@googlemail.com>2012-11-22 09:45:12 +0000
committerLudovic Courtès <ludo@gnu.org>2012-11-22 22:26:16 +0100
commit06906f370f77cbab520ff0d3c47449526934a9c8 (patch)
tree756fa6471d541b7c115227028e2674d9fe209322 /module/rnrs
parent2c7b7e0f214be5ec5184949a94209668775f60bc (diff)
downloadguile-06906f370f77cbab520ff0d3c47449526934a9c8.tar.gz
R6RS `string-for-each' should accept multiple string arguments
* module/rnrs/base.scm (string-for-each): Rewrite. * test-suite/tests/r6rs-base.test ("string-for-each"): Add tests.
Diffstat (limited to 'module/rnrs')
-rw-r--r--module/rnrs/base.scm39
1 files changed, 38 insertions, 1 deletions
diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index 499a22444..9fedac01d 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -73,7 +73,7 @@
let-syntax letrec-syntax
syntax-rules identifier-syntax)
- (import (rename (except (guile) error raise map)
+ (import (rename (except (guile) error raise map string-for-each)
(log log-internal)
(euclidean-quotient div)
(euclidean-remainder mod)
@@ -86,6 +86,43 @@
(inexact->exact exact))
(srfi srfi-11))
+ (define string-for-each
+ (case-lambda
+ ((proc string)
+ (let ((end (string-length string)))
+ (let loop ((i 0))
+ (unless (= i end)
+ (proc (string-ref string i))
+ (loop (+ i 1))))))
+ ((proc string1 string2)
+ (let ((end1 (string-length string1))
+ (end2 (string-length string2)))
+ (unless (= end1 end2)
+ (assertion-violation 'string-for-each
+ "string arguments must all have the same length"
+ string1 string2))
+ (let loop ((i 0))
+ (unless (= i end1)
+ (proc (string-ref string1 i)
+ (string-ref string2 i))
+ (loop (+ i 1))))))
+ ((proc string . strings)
+ (let ((end (string-length string))
+ (ends (map string-length strings)))
+ (for-each (lambda (x)
+ (unless (= end x)
+ (apply assertion-violation
+ 'string-for-each
+ "string arguments must all have the same length"
+ string strings)))
+ ends)
+ (let loop ((i 0))
+ (unless (= i end)
+ (apply proc
+ (string-ref string i)
+ (map (lambda (s) (string-ref s i)) strings))
+ (loop (+ i 1))))))))
+
(define map
(case-lambda
((f l)