guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.3-1-gd825841


From: Ludovic Courtès
Subject: [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.3-1-gd825841
Date: Tue, 01 Nov 2011 00:12:04 +0000

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=d825841db0eb920150d6734b8928b6a3decbca0e

The branch, stable-2.0 has been updated
       via  d825841db0eb920150d6734b8928b6a3decbca0e (commit)
      from  2be3feb17e5456bba71749e0e97adf45c32c4e0e (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 d825841db0eb920150d6734b8928b6a3decbca0e
Author: Ian Price <address@hidden>
Date:   Wed Oct 26 20:24:05 2011 +0100

    Fix R6RS `fold-left' so the accumulator is the first argument.
    
    * module/rnrs/lists.scm (fold-left): New procedure.
    
    * module/rnrs/records/syntactic.scm (define-record-type): Fix to use
      corrected `fold-left'.
    
    * test-suite/tests/r6rs-lists.test: Add tests.
    
    Signed-off-by: Ludovic Courtès <address@hidden>

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

Summary of changes:
 module/rnrs/lists.scm             |   12 +++++++++---
 module/rnrs/records/syntactic.scm |    4 ++--
 test-suite/tests/r6rs-lists.test  |   26 ++++++++++++++++++++++++++
 3 files changed, 37 insertions(+), 5 deletions(-)

diff --git a/module/rnrs/lists.scm b/module/rnrs/lists.scm
index 812ce5f..0671e77 100644
--- a/module/rnrs/lists.scm
+++ b/module/rnrs/lists.scm
@@ -22,8 +22,7 @@
          remv remq memp member memv memq assp assoc assv assq cons*)
   (import (rnrs base (6))
           (only (guile) filter member memv memq assoc assv assq cons*)
-         (rename (only (srfi srfi-1) fold 
-                                     any 
+         (rename (only (srfi srfi-1) any 
                                      every 
                                      remove 
                                      member 
@@ -32,7 +31,6 @@
                                      partition
                                      fold-right 
                                      filter-map)
-                 (fold fold-left) 
                  (any exists) 
                  (every for-all)
                  (remove remp)
@@ -40,6 +38,14 @@
                  (member memp-internal)
                  (assoc assp-internal)))
 
+  (define (fold-left combine nil list . lists)
+    (define (fold nil lists)
+      (if (exists null? lists)
+          nil
+          (fold (apply combine nil (map car lists))
+                (map cdr lists))))
+    (fold nil (cons list lists)))
+
   (define (remove obj list) (remp (lambda (elt) (equal? obj elt)) list))
   (define (remv obj list) (remp (lambda (elt) (eqv? obj elt)) list))
   (define (remq obj list) (remp (lambda (elt) (eq? obj elt)) list))
diff --git a/module/rnrs/records/syntactic.scm 
b/module/rnrs/records/syntactic.scm
index a497b90..bde6f93 100644
--- a/module/rnrs/records/syntactic.scm
+++ b/module/rnrs/records/syntactic.scm
@@ -134,13 +134,13 @@
               (let* ((fields (if (unspecified? _fields) '() _fields))
                      (field-names (list->vector (map car fields)))
                      (field-accessors
-                      (fold-left (lambda (x c lst)
+                      (fold-left (lambda (lst x c)
                                    (cons #`(define #,(cadr x)
                                              (record-accessor record-name #,c))
                                          lst))
                                  '() fields (sequence (length fields))))
                      (field-mutators
-                      (fold-left (lambda (x c lst)
+                      (fold-left (lambda (lst x c)
                                    (if (caddr x)
                                        (cons #`(define #,(caddr x)
                                                  (record-mutator record-name
diff --git a/test-suite/tests/r6rs-lists.test b/test-suite/tests/r6rs-lists.test
index ba645ed..030091f 100644
--- a/test-suite/tests/r6rs-lists.test
+++ b/test-suite/tests/r6rs-lists.test
@@ -30,3 +30,29 @@
     (let ((d '((3 a) (1 b) (4 c))))
       (equal? (assp even? d) '(4 c)))))
 
+(with-test-prefix "fold-left"
+  (pass-if "fold-left sum"
+    (equal? (fold-left + 0 '(1 2 3 4 5))
+            15))
+  (pass-if "fold-left reverse"
+    (equal? (fold-left (lambda (a e) (cons e a)) '() '(1 2 3 4 5))
+            '(5 4 3 2 1)))
+  (pass-if "fold-left max-length"
+    (equal? (fold-left (lambda (max-len s)
+                         (max max-len (string-length s)))
+                       0
+                       '("longest" "long" "longer"))
+            7))
+  (pass-if "fold-left with-cons"
+    (equal? (fold-left cons '(q) '(a b c))
+            '((((q) . a) . b) . c)))
+  (pass-if "fold-left sum-multiple"
+    (equal? (fold-left + 0 '(1 2 3) '(4 5 6))
+            21))
+  (pass-if "fold-left pairlis"
+    (equal? (fold-left (lambda (accum e1 e2)
+                         (cons (cons e1 e2) accum))
+                       '((d . 4))
+                       '(a b c)
+                       '(1 2 3))
+            '((c . 3) (b . 2) (a . 1) (d  . 4)))))


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]