mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 17:50:29 +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)