mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

R6RS `string-for-each' should accept multiple string arguments

Browse source 
* module/rnrs/base.scm (string-for-each): Rewrite.
* test-suite/tests/r6rs-base.test ("string-for-each"): Add tests.
This commit is contained in:
Ian Price 2012-11-22 09:45:12 +00:00 • committed by Ludovic Courtès
parent 2c7b7e0f21
commit 06906f370f
2 changed files with 78 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

39
module/rnrs/base.scm
View file

@ -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)

40
test-suite/tests/r6rs-base.test
View file

@ -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))))