summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2014-03-30 22:28:07 +0200
committerAndy Wingo <wingo@pobox.com>2014-03-31 18:21:04 +0200
commit4926024cfbd9d0a428880a919b6e5a394b4a304d (patch)
tree46cc428574e55a9ac6c6333d0652485015acac1e
parentde3cbadcc08f7f46bab0d91d4dcc5bac2f64613f (diff)
downloadguile-4926024cfbd9d0a428880a919b6e5a394b4a304d.tar.gz
Simplify boot-9 and srfi-1 map
* module/ice-9/boot-9.scm (map): * module/srfi/srfi-1.scm (map): Simplify the implementations to check for list? beforehand. It's faster, and it will be needed if we decide to go recursive.
-rw-r--r--module/ice-9/boot-9.scm65
-rw-r--r--module/srfi/srfi-1.scm19
2 files changed, 20 insertions, 64 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 4d5d603ae..8bc8e5319 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -837,58 +837,23 @@ for key @var{k}, then invoke @var{thunk}."
(define map
(case-lambda
((f l)
- (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
- (if (pair? hare)
- (if move?
- (if (eq? tortoise hare)
- (scm-error 'wrong-type-arg "map" "Circular list: ~S"
- (list l) #f)
- (map1 (cdr hare) (cdr tortoise) #f
- (cons (f (car hare)) out)))
- (map1 (cdr hare) tortoise #t
- (cons (f (car hare)) out)))
- (if (null? hare)
- (reverse! out)
- (scm-error 'wrong-type-arg "map" "Not a list: ~S"
- (list l) #f)))))
+ (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)
- (let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '()))
- (cond
- ((pair? h1)
- (cond
- ((not (pair? h2))
- (scm-error 'wrong-type-arg "map"
- (if (list? h2)
- "List of wrong length: ~S"
- "Not a list: ~S")
- (list l2) #f))
- ((not move?)
- (map2 (cdr h1) (cdr h2) t1 t2 #t
- (cons (f (car h1) (car h2)) out)))
- ((eq? t1 h1)
- (scm-error 'wrong-type-arg "map" "Circular list: ~S"
- (list l1) #f))
- ((eq? t2 h2)
- (scm-error 'wrong-type-arg "map" "Circular list: ~S"
- (list l2) #f))
- (else
- (map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f
- (cons (f (car h1) (car h2)) out)))))
-
- ((and (null? h1) (null? h2))
- (reverse! out))
-
- ((null? h1)
- (scm-error 'wrong-type-arg "map"
- (if (list? h2)
- "List of wrong length: ~S"
- "Not a list: ~S")
- (list l2) #f))
- (else
- (scm-error 'wrong-type-arg "map"
- "Not a list: ~S"
- (list l1) #f)))))
+ (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)))
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index c7c1f8dee..919d51274 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -566,20 +566,11 @@ has just one element then that's the return value."
(case-lambda
((f l)
(check-arg procedure? f map)
- (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
- (if (pair? hare)
- (if move?
- (if (eq? tortoise hare)
- (scm-error 'wrong-type-arg "map" "Circular list: ~S"
- (list l) #f)
- (map1 (cdr hare) (cdr tortoise) #f
- (cons (f (car hare)) out)))
- (map1 (cdr hare) tortoise #t
- (cons (f (car hare)) out)))
- (if (null? hare)
- (reverse! out)
- (scm-error 'wrong-type-arg "map" "Not a list: ~S"
- (list l) #f)))))
+ (check-arg list? l map)
+ (let map1 ((in l) (out '()))
+ (if (pair? in)
+ (map1 (cdr in) (cons (f (car in)) out))
+ (reverse! out))))
((f l1 . rest)
(check-arg procedure? f map)