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. @@ -829,83 +863,6 @@ for key @var{k}, then invoke @var{thunk}." (define! 'throw throw)) - - -;;; 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)))))))) - - ;;; 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)