summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/ice-9/boot-9.scm143
-rw-r--r--module/srfi/srfi-1.scm72
-rw-r--r--test-suite/tests/r5rs_pitfall.test4
3 files changed, 98 insertions, 121 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 8bc8e5319..7f38c4b19 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -239,49 +239,83 @@ file with the given name already exists, the effect is unspecified."
-;;; Boot versions of `map' and `for-each', enough to get the expander
-;;; running.
+;;; {map and for-each}
;;;
+
(define map
(case-lambda
((f l)
+ (if (not (list? l))
+ (scm-error 'wrong-type-arg "map" "Not a list: ~S"
+ (list l) #f))
(let map1 ((l l))
- (if (null? l)
- '()
- (cons (f (car l)) (map1 (cdr l))))))
+ (if (pair? l)
+ (cons (f (car l)) (map1 (cdr l)))
+ '())))
+
((f l1 l2)
+ (if (not (= (length l1) (length l2)))
+ (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
+ (list l2) #f))
+
(let map2 ((l1 l1) (l2 l2))
- (if (null? l1)
- '()
+ (if (pair? l1)
(cons (f (car l1) (car l2))
- (map2 (cdr l1) (cdr l2))))))
+ (map2 (cdr l1) (cdr l2)))
+ '())))
+
((f l1 . rest)
- (let lp ((l1 l1) (rest rest))
- (if (null? l1)
- '()
+ (let ((len (length l1)))
+ (let mapn ((rest rest))
+ (or (null? rest)
+ (if (= (length (car rest)) len)
+ (mapn (cdr rest))
+ (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
+ (list (car rest)) #f)))))
+ (let mapn ((l1 l1) (rest rest))
+ (if (pair? l1)
(cons (apply f (car l1) (map car rest))
- (lp (cdr l1) (map cdr rest))))))))
+ (mapn (cdr l1) (map cdr rest)))
+ '())))))
+
+(define map-in-order map)
(define for-each
(case-lambda
((f l)
+ (if (not (list? l))
+ (scm-error 'wrong-type-arg "for-each" "Not a list: ~S" (list l) #f))
(let for-each1 ((l l))
- (if (pair? l)
+ (if (not (null? l))
(begin
(f (car l))
(for-each1 (cdr l))))))
+
((f l1 l2)
+ (if (not (= (length l1) (length l2)))
+ (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
+ (list l2) #f))
(let for-each2 ((l1 l1) (l2 l2))
- (if (pair? l1)
+ (if (not (null? l1))
(begin
(f (car l1) (car l2))
(for-each2 (cdr l1) (cdr l2))))))
+
((f l1 . rest)
- (let lp ((l1 l1) (rest rest))
+ (let ((len (length l1)))
+ (let for-eachn ((rest rest))
+ (or (null? rest)
+ (if (= (length (car rest)) len)
+ (for-eachn (cdr rest))
+ (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
+ (list (car rest)) #f)))))
+
+ (let for-eachn ((l1 l1) (rest rest))
(if (pair? l1)
(begin
(apply f (car l1) (map car rest))
- (lp (cdr l1) (map cdr rest))))))))
+ (for-eachn (cdr l1) (map cdr rest))))))))
+
;; Temporary definition used in the include-from-path expansion;
;; replaced later.
@@ -831,83 +865,6 @@ for key @var{k}, then invoke @var{thunk}."
-;;; The real versions of `map' and `for-each', with cycle detection, and
-;;; that use reverse! instead of recursion in the case of `map'.
-;;;
-(define map
- (case-lambda
- ((f l)
- (unless (list? l)
- (scm-error 'wrong-type-arg "map" "Not a list: ~S"
- (list l) #f))
- (let map1 ((l l) (out '()))
- (if (pair? l)
- (map1 (cdr l) (cons (f (car l)) out))
- (reverse! out))))
-
- ((f l1 l2)
- (unless (= (length l1) (length l2))
- (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
- (list l2) #f))
-
- (let map2 ((l1 l1) (l2 l2) (out '()))
- (if (pair? l1)
- (map2 (cdr l1) (cdr l2) (cons (f (car l1) (car l2)) out))
- (reverse! out))))
-
- ((f l1 . rest)
- (let ((len (length l1)))
- (let mapn ((rest rest))
- (or (null? rest)
- (if (= (length (car rest)) len)
- (mapn (cdr rest))
- (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
- (list (car rest)) #f)))))
- (let mapn ((l1 l1) (rest rest) (out '()))
- (if (null? l1)
- (reverse! out)
- (mapn (cdr l1) (map cdr rest)
- (cons (apply f (car l1) (map car rest)) out)))))))
-
-(define map-in-order map)
-
-(define for-each
- (case-lambda
- ((f l)
- (unless (list? l)
- (scm-error 'wrong-type-arg "for-each" "Not a list: ~S" (list l) #f))
- (let for-each1 ((l l))
- (unless (null? l)
- (f (car l))
- (for-each1 (cdr l)))))
-
- ((f l1 l2)
- (unless (= (length l1) (length l2))
- (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
- (list l2) #f))
- (let for-each2 ((l1 l1) (l2 l2))
- (unless (null? l1)
- (f (car l1) (car l2))
- (for-each2 (cdr l1) (cdr l2)))))
-
- ((f l1 . rest)
- (let ((len (length l1)))
- (let for-eachn ((rest rest))
- (or (null? rest)
- (if (= (length (car rest)) len)
- (for-eachn (cdr rest))
- (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
- (list (car rest)) #f)))))
-
- (let for-eachn ((l1 l1) (rest rest))
- (if (pair? l1)
- (begin
- (apply f (car l1) (map car rest))
- (for-eachn (cdr l1) (map cdr rest))))))))
-
-
-
-
;;;
;;; Extensible exception printing.
;;;
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)
diff --git a/test-suite/tests/r5rs_pitfall.test b/test-suite/tests/r5rs_pitfall.test
index 0bab38cc4..1d9fcf7a0 100644
--- a/test-suite/tests/r5rs_pitfall.test
+++ b/test-suite/tests/r5rs_pitfall.test
@@ -1,5 +1,5 @@
;;;; r5rs_pitfall.test --- tests some pitfalls in R5RS -*- scheme -*-
-;;;; Copyright (C) 2003, 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2004, 2006, 2014 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -292,7 +292,7 @@
;;Not really an error to fail this (Matthias Radestock)
;;If this returns (0 1 0), your map isn't call/cc safe, but is probably
;;tail-recursive. If its (0 0 0), the opposite is true.
-(should-be 8.3 '(0 1 0)
+(should-be 8.3 '(0 0 0)
(let ()
(define executed-k #f)
(define cont #f)