[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-45-gb8f1919

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=b8f191964e519807bb6d05ea0f2296a46d2144bd

The branch, stable-2.0 has been updated
       via  b8f191964e519807bb6d05ea0f2296a46d2144bd (commit)
      from  6ffb5f9765866ea7037a4acdab8378c470f7931b (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit b8f191964e519807bb6d05ea0f2296a46d2144bd
Author: Andy Wingo <address@hidden>
Date:   Wed Aug 17 23:24:20 2011 +0200

    fix r6rs `map'
    
    * module/rnrs/base.scm (map): Define a version of map that is safe for
      multiple returns, though slower.

-----------------------------------------------------------------------

Summary of changes:
 module/rnrs/base.scm |   72 +++++++++++++++++++++++++++++++++++++++++++++++++-
 1 files changed, 71 insertions(+), 1 deletions(-)

diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index 4cfd1d1..499a224 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -73,7 +73,7 @@
          let-syntax letrec-syntax
 
          syntax-rules identifier-syntax)
-  (import (rename (except (guile) error raise)
+  (import (rename (except (guile) error raise map)
                   (log log-internal)
                   (euclidean-quotient div)
                   (euclidean-remainder mod)
@@ -86,6 +86,76 @@
                   (inexact->exact exact))
           (srfi srfi-11))
 
+ (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)))))
+    
+     ((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)))))
+
+     ((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 log
    (case-lambda
      ((n)


hooks/post-receive
-- 
GNU Guile