From b072098495f5c77f60d89fe0783b709300298c49 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sun, 14 Jul 2019 17:57:21 +0200 Subject: [PATCH] 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 --- NEWS | 3 +++ library.scm | 53 +++++++++++++++++++---------------------- manual/Module scheme | 11 +++++++-- tests/library-tests.scm | 11 +++++++++ 4 files changed, 47 insertions(+), 31 deletions(-) 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..4fa7cbc1 100644 --- a/library.scm +++ b/library.scm @@ -3005,46 +3005,41 @@ 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 loop ((all (cons lst1 lsts))) + (let* ((first (##sys#slot all 0)) + (safe-args (mapsafe (lambda (x) (car x)) + all 'for-each))) + (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. (map proc list[1] list[2] ...)
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. + (force promise)
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 -- 2.20.1