~ chicken-core (chicken-5) c968d65ce59dedecbded49f695812089e0be4321
commit c968d65ce59dedecbded49f695812089e0be4321
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sun Jul 14 17:57:21 2019 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Wed Jul 24 19:54:40 2019 +1200
Make map and for-each behave consistently between compiled and interpreted mode
In compiled mode, it would stop on the shortest list. In interpreted
mode, it would either do that or give an error, depending on which
list was the shortest.
Fixes #1422
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/NEWS b/NEWS
index 6b927474..653f5f0d 100644
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,9 @@
- Fix `memory-statistics` by returning semi-space bytes and used
semi-space bytes like the documentation says. Old implementation
returned full-heap size and (full-heap - used-semi-space).
+ - for-each and map now behave consistently in compiled and interpreted
+ mode, like in SRFI-1. They now stop when the shortest list is
+ exhausted instead of raising an exception (fixes #1422).
- Runtime system
- Quoted empty keywords like ||: and :|| are now read like prescribed
diff --git a/library.scm b/library.scm
index 7e69e598..f0781366 100644
--- a/library.scm
+++ b/library.scm
@@ -3005,46 +3005,40 @@ EOF
(else (##sys#error-not-a-proper-list lst0 'map)) ) ))
(letrec ((mapsafe
- (lambda (p lsts start loc)
- (if (eq? lsts '())
- lsts
- (let ((item (##sys#slot lsts 0)))
- (cond ((eq? item '())
- (check lsts start loc))
- ((pair? item)
- (cons (p item) (mapsafe p (##sys#slot lsts 1) #f loc)) )
- (else (##sys#error-not-a-proper-list item loc)) ) ) ) ) )
- (check
- (lambda (lsts start loc)
- (if (or (not start)
- (let loop ((lsts lsts))
- (and (not (eq? lsts '()))
- (not (eq? (##sys#slot lsts 0) '()))
- (loop (##sys#slot lsts 1)) ) ) )
- (##sys#error loc "lists are not of same length" lsts) ) ) ) )
+ (lambda (p lsts loc)
+ (call-with-current-continuation
+ (lambda (empty)
+ (let lp ((lsts lsts))
+ (if (eq? lsts '())
+ lsts
+ (let ((item (##sys#slot lsts 0)))
+ (cond ((eq? item '()) (empty '()))
+ ((pair? item)
+ (cons (p item) (lp (##sys#slot lsts 1))))
+ (else (##sys#error-not-a-proper-list item loc)))))))))))
(set! scheme#for-each
(lambda (fn lst1 . lsts)
(if (null? lsts)
(##sys#for-each fn lst1)
(let loop ((all (cons lst1 lsts)))
- (let ((first (##sys#slot all 0)))
- (cond ((pair? first)
- (apply fn (mapsafe (lambda (x) (car x)) all #t 'for-each)) ; ensure inlining
- (loop (mapsafe (lambda (x) (cdr x)) all #t 'for-each)) )
- (else (check all #t 'for-each)) ) ) ) ) ) )
+ (let* ((first (##sys#slot all 0))
+ (safe-args (mapsafe (lambda (x) (car x)) all 'for-each))) ; ensure inlining
+ (when (pair? safe-args)
+ (apply fn safe-args)
+ (loop (mapsafe (lambda (x) (cdr x)) all 'for-each))))))))
(set! scheme#map
(lambda (fn lst1 . lsts)
(if (null? lsts)
(##sys#map fn lst1)
(let loop ((all (cons lst1 lsts)))
- (let ((first (##sys#slot all 0)))
- (cond ((pair? first)
- (cons (apply fn (mapsafe (lambda (x) (car x)) all #t 'map))
- (loop (mapsafe (lambda (x) (cdr x)) all #t 'map)) ) )
- (else (check (##core#inline "C_i_cdr" all) #t 'map)
- '() ) ) ) ) ) ) ) )
+ (let* ((first (##sys#slot all 0))
+ (safe-args (mapsafe (lambda (x) (car x)) all 'map)))
+ (if (pair? safe-args)
+ (cons (apply fn safe-args)
+ (loop (mapsafe (lambda (x) (cdr x)) all 'map)))
+ '())))))))
;;; dynamic-wind:
diff --git a/manual/Module scheme b/manual/Module scheme
index 712c21ee..debafa82 100644
--- a/manual/Module scheme
+++ b/manual/Module scheme
@@ -2849,12 +2849,15 @@ arguments.
<procedure>(map proc list[1] list[2] ...)</procedure><br>
The lists must be lists, and proc must be a procedure taking as many
-arguments as there are lists and returning a single value. If more than
-one list is given, then they must all be the same length. Map applies
+arguments as there are lists and returning a single value. Map applies
proc element-wise to the elements of the lists and returns a list of
the results, in order. The dynamic order in which proc is applied to
the elements of the lists is unspecified.
+Like in SRFI-1, this procedure allows the arguments to be of unequal
+length; it terminates when the shortest list runs out. This is a
+CHICKEN extension to R5RS.
+
(map cadr '((a b) (d e) (g h)))
===> (b e h)
@@ -2884,6 +2887,10 @@ for-each is unspecified.
'(0 1 2 3 4))
v) ===> #(0 1 4 9 16)
+Like in SRFI-1, this procedure allows the arguments to be of unequal
+length; it terminates when the shortest list runs out. This is a
+CHICKEN extension to R5RS.
+
<procedure>(force promise)</procedure><br>
Forces the value of promise (see "[[#delayed-evaluation|delayed
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index 8d9e3b24..2379ed0f 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -243,6 +243,17 @@
(map (lambda (n) (number->string 32 n)) (list-tabulate 15 (cut + 2 <>)))
'("100000" "1012" "200" "112" "52" "44" "40" "35" "32" "2a" "28" "26" "24" "22" "20")))
+;; #1422
+(assert (equal? (map + '(1 2 3) '(1 2)) '(2 4)))
+(assert (equal? (map + '(1 2) '(1 2 3)) '(2 4)))
+(let ((result '()))
+ (for-each (lambda (x y) (set! result (cons (+ x y) result)))
+ '(1 2) '(1 2 3))
+ (assert (equal? result '(4 2))))
+(let ((result '()))
+ (for-each (lambda (x y) (set! result (cons (+ x y) result)))
+ '(1 2 3) '(1 2))
+ (assert (equal? result '(4 2))))
;; string->number conversion
Trap