diff options
author | Andy Wingo <wingo@pobox.com> | 2014-05-01 21:14:42 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2014-05-01 21:17:28 +0200 |
commit | 9de674e6e63ed1576c5b0660ac709f430822dbcf (patch) | |
tree | 19d419ecf61173a0c5f55d2819cefe6c320fbfbf /module/srfi/srfi-1.scm | |
parent | de0233af177806ac96d535bb58f27875fb8c5375 (diff) | |
download | guile-9de674e6e63ed1576c5b0660ac709f430822dbcf.tar.gz |
Rewrite boot-9 map to be recursive and pure
* module/ice-9/boot-9.scm (map): Rewrite to be recursive and pure
instead of iterative and effectful. At best this is faster; at worst
it is slower. In any case it resolves continuation-related issues.
* module/srfi/srfi-1.scm (fold): Specialize the two-arg case.
(map): Rewrite to be recursive.
* test-suite/tests/r5rs_pitfall.test (8.3): Update for new expected map
behavior.
Diffstat (limited to 'module/srfi/srfi-1.scm')
-rw-r--r-- | module/srfi/srfi-1.scm | 72 |
1 files changed, 46 insertions, 26 deletions
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index 5e859d1c2..0806e7363 100644 --- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -454,21 +454,41 @@ a list of those after." ;;; Fold, unfold & map -(define (fold kons knil list1 . rest) - "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return +(define fold + (case-lambda + "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return that result. See the manual for details." - (check-arg procedure? kons fold) - (if (null? rest) - (let f ((knil knil) (list1 list1)) - (if (null? list1) - knil - (f (kons (car list1) knil) (cdr list1)))) - (let f ((knil knil) (lists (cons list1 rest))) - (if (any null? lists) - knil - (let ((cars (map car lists)) - (cdrs (map cdr lists))) - (f (apply kons (append! cars (list knil))) cdrs)))))) + ((kons knil list1) + (check-arg procedure? kons fold) + (check-arg list? list1 fold) + (let fold1 ((knil knil) (list1 list1)) + (if (pair? list1) + (fold1 (kons (car list1) knil) (cdr list1)) + knil))) + ((kons knil list1 list2) + (check-arg procedure? kons fold) + (let* ((len1 (length+ list1)) + (len2 (length+ list2)) + (len (if (and len1 len2) + (min len1 len2) + (or len1 len2)))) + (unless len + (scm-error 'wrong-type-arg "fold" + "Args do not contain a proper (finite) list: ~S" + (list (list list1 list2)) #f)) + (let fold2 ((knil knil) (list1 list1) (list2 list2) (len len)) + (if (zero? len) + knil + (fold2 (kons (car list1) (car list2) knil) + (cdr list1) (cdr list2) (1- len)))))) + ((kons knil list1 . rest) + (check-arg procedure? kons fold) + (let foldn ((knil knil) (lists (cons list1 rest))) + (if (any null? lists) + knil + (let ((cars (map car lists)) + (cdrs (map cdr lists))) + (foldn (apply kons (append! cars (list knil))) cdrs))))))) (define (fold-right kons knil clist1 . rest) (check-arg procedure? kons fold-right) @@ -567,10 +587,10 @@ has just one element then that's the return value." ((f l) (check-arg procedure? f map) (check-arg list? l map) - (let map1 ((in l) (out '())) - (if (pair? in) - (map1 (cdr in) (cons (f (car in)) out)) - (reverse! out)))) + (let map1 ((l l)) + (if (pair? l) + (cons (f (car l)) (map1 (cdr l))) + '()))) ((f l1 l2) (check-arg procedure? f map) @@ -583,11 +603,11 @@ has just one element then that's the return value." (scm-error 'wrong-type-arg "map" "Args do not contain a proper (finite) list: ~S" (list (list l1 l2)) #f)) - (let map2 ((l1 l1) (l2 l2) (out '()) (len len)) + (let map2 ((l1 l1) (l2 l2) (len len)) (if (zero? len) - (reverse! out) - (map2 (cdr l1) (cdr l2) - (cons (f (car l1) (car l2)) out) (1- len)))))) + '() + (cons (f (car l1) (car l2)) + (map2 (cdr l1) (cdr l2) (1- len))))))) ((f l1 . rest) (check-arg procedure? f map) @@ -602,11 +622,11 @@ has just one element then that's the return value." (scm-error 'wrong-type-arg "map" "Args do not contain a proper (finite) list: ~S" (list (cons l1 rest)) #f)) - (let mapn ((l1 l1) (rest rest) (len len) (out '())) + (let mapn ((l1 l1) (rest rest) (len len)) (if (zero? len) - (reverse! out) - (mapn (cdr l1) (map cdr rest) (1- len) - (cons (apply f (car l1) (map car rest)) out)))))))) + '() + (cons (apply f (car l1) (map car rest)) + (mapn (cdr l1) (map cdr rest) (1- len))))))))) (define map-in-order map) |