[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-92-g06906f3

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=06906f370f77cbab520ff0d3c47449526934a9c8

The branch, stable-2.0 has been updated
       via  06906f370f77cbab520ff0d3c47449526934a9c8 (commit)
      from  2c7b7e0f214be5ec5184949a94209668775f60bc (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 06906f370f77cbab520ff0d3c47449526934a9c8
Author: Ian Price <address@hidden>
Date:   Thu Nov 22 09:45:12 2012 +0000

    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.

-----------------------------------------------------------------------

Summary of changes:
 module/rnrs/base.scm            |   39 +++++++++++++++++++++++++++++++++++++-
 test-suite/tests/r6rs-base.test |   40 +++++++++++++++++++++++++++++++++++++++
 2 files changed, 78 insertions(+), 1 deletions(-)

diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index 499a224..9fedac0 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)
diff --git a/test-suite/tests/r6rs-base.test b/test-suite/tests/r6rs-base.test
index df11d67..fb49141 100644
--- a/test-suite/tests/r6rs-base.test
+++ b/test-suite/tests/r6rs-base.test
@@ -196,3 +196,43 @@
     (guard (condition ((assertion-violation? condition) #t))
       (assert #f)
       #f)))
+
+(with-test-prefix "string-for-each"
+  (pass-if "reverse string"
+    (let ((s "reverse me") (l '()))
+      (string-for-each (lambda (x) (set! l (cons x l))) s)
+      (equal? "em esrever" (list->string l))))
+  (pass-if "two strings good"
+    (let ((s1 "two legs good")
+          (s2 "four legs bad")
+          (c '()))
+      (string-for-each (lambda (c1 c2)
+                         (set! c (cons* c2 c1 c)))
+                       s1 s2)
+      (equal? (list->string c)
+              "ddaobo gs gsegle lr uoowft")))
+  (pass-if "two strings bad"
+    (let ((s1 "frotz")
+          (s2 "veeblefetzer"))
+      (guard (condition ((assertion-violation? condition) #t))
+        (string-for-each (lambda (s1 s2) #f) s1 s2)
+        #f)))
+  (pass-if "many strings good"
+    (let ((s1 "foo")
+          (s2 "bar")
+          (s3 "baz")
+          (s4 "zot")
+          (c '()))
+      (string-for-each (lambda (c1 c2 c3 c4)
+                         (set! c (cons* c4 c3 c2 c1 c)))
+                       s1 s2 s3 s4)
+      (equal? (list->string c)
+              "tzrooaaozbbf")))
+  (pass-if "many strings bad"
+    (let ((s1 "foo")
+          (s2 "bar")
+          (s3 "baz")
+          (s4 "quux"))
+      (guard (condition ((assertion-violation? condition) #t))
+        (string-for-each (lambda _ #f) s1 s2 s3 s4)
+        #f))))


hooks/post-receive
-- 
GNU Guile