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 <ludo@gnu.org>

diff --git a/module/rnrs/lists.scm b/module/rnrs/lists.scm
index 812ce5f..0671e77 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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)))))