mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
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.
This commit is contained in:
Andy Wingo
parent
de0233af17
commit
9de674e6e6
3 changed files with 98 additions and 121 deletions
|
|
@ -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))))))))
|
||||
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue