diff options
author | Ian Price <ianprice90@googlemail.com> | 2012-11-22 09:45:12 +0000 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2012-11-22 22:26:16 +0100 |
commit | 06906f370f77cbab520ff0d3c47449526934a9c8 (patch) | |
tree | 756fa6471d541b7c115227028e2674d9fe209322 /module/rnrs | |
parent | 2c7b7e0f214be5ec5184949a94209668775f60bc (diff) | |
download | guile-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.scm | 39 |
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) |