conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* Added vararg case for for-each.

This commit is contained in:
Abdulaziz Ghuloum 2007-09-09 23:50:55 -04:00
parent 2692897900
commit 375b738ccb
3 changed files with 23 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

22
src/ikarus.lists.ss
View File

@ -536,7 +536,27 @@
(void) (void)
(error who "length mismatch"))] (error who "length mismatch"))]
[else (error who "not a list")])] [else (error who "not a list")])]
[_ (error who "vararg not supported yet")]))) [(f ls . ls*)
(unless (procedure? f)
(error 'for-each "~s is not a procedure" f))
(unless (list? ls)
(error 'for-each "~s is not a list" ls))
(let ([n (length ls)])
(for-each
(lambda (x)
(unless (and (list? x) (= (length x) n))
(error 'for-each "~s is not a list" x)))
ls*)
(let loop ([n (length ls)] [ls ls] [ls* ls*])
(cond
[($fx= n 0)
(unless (and (null? ls) (andmap null? ls*))
(error 'for-each "list modified by ~s" f))]
[else
(unless (and (pair? ls) (andmap pair? ls*))
(error 'for-each "list modified by ~s" f))
(apply f (car ls) (map car ls*))
(loop (fx- n 1) (cdr ls) (map cdr ls*))])))])))
(module (andmap) (module (andmap)
(define who 'andmap) (define who 'andmap)

4
src/todo-r6rs.ss
View File

@ -151,7 +151,7 @@
[expt C ba se] [expt C ba se]
[finite? S ba] [finite? S ba]
[floor C ba se] [floor C ba se]
[for-each S ba se] [for-each C ba se]
[gcd C ba se] [gcd C ba se]
[imag-part D ba se] [imag-part D ba se]
[inexact C ba] [inexact C ba]
@ -503,7 +503,7 @@
[assp S ls] [assp S ls]
[assq C ls se] [assq C ls se]
[assv C ls se] [assv C ls se]
[cons* S ls] [cons* C ls]
[filter S ls] [filter S ls]
[find S ls] [find S ls]
[fold-left S ls] [fold-left S ls]