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

Add test for r7rs string-for-each

Browse source 
* test-suite/tests/r7rs.test: As stated.
* module/scheme/base.scm: Reindent and add minimal doc.
This commit is contained in:
Daniel Llorens 2023-09-29 16:49:57 +02:00
parent 3243d96bb5
commit 4daf4664cf
2 changed files with 27 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

37
module/scheme/base.scm
View file

@ -406,24 +406,25 @@
s*))))) s*)))))
(define r7:string-for-each (define r7:string-for-each
(case-lambda (case-lambda
((proc s) (string-for-each proc s)) "Like @code{for-each}, but takes strings instead of lists."
((proc s1 s2) ((proc s) (string-for-each proc s))
(let ((len (min (string-length s1) ((proc s1 s2)
(string-length s2)))) (let ((len (min (string-length s1)
(let loop ((i 0)) (string-length s2))))
(when (< i len) (let loop ((i 0))
(proc (string-ref s1 i) (when (< i len)
(string-ref s2 i)) (proc (string-ref s1 i)
(loop (+ i 1)))))) (string-ref s2 i))
((proc . strings) (loop (+ i 1))))))
(let ((len (apply min (map string-length strings)))) ((proc . strings)
(let loop ((i 0)) (let ((len (apply min (map string-length strings))))
(when (< i len) (let loop ((i 0))
(apply proc (map (lambda (s) (when (< i len)
(string-ref s i)) (apply proc (map (lambda (s)
strings)) (string-ref s i))
(loop (+ i 1)))))))) strings))
(loop (+ i 1))))))))
(define (bytevector . lis) (define (bytevector . lis)
(u8-list->bytevector lis)) (u8-list->bytevector lis))

8
test-suite/tests/r7rs.test
View file

@ -1773,6 +1773,14 @@
"abcde") "abcde")
v)) v))
(test '(4 3 2 1)
(let ((v '()))
(string-for-each
(lambda (b c) (set! v (cons (- (char->integer b) (char->integer c)) v)))
"bdfh"
"abcde")
v))
(test '(0 1 4 9 16) (let ((v (make-list 5))) (test '(0 1 4 9 16) (let ((v (make-list 5)))
(vector-for-each (vector-for-each
(lambda (i) (list-set! v i (* i i))) (lambda (i) (list-set! v i (* i i)))