Put reduce-right back.

diff --git a/src/runtime/list.scm b/src/runtime/list.scm
index b870f7331e06f3c7e5ecce2dcfbc7e4cd3de6650..030d731cd06ba78735a133dad72988241a404b97 100644 (file)
--- a/src/runtime/list.scm
+++ b/src/runtime/list.scm
@@ -796,11 +796,10 @@ USA.
 
 (define (%fold-left caller procedure initial list)
   (declare (integrate caller procedure initial))
-  (let %fold-left-step ((state initial)
-                       (remaining list))
-
+  (let %fold-left-step ((state initial) (remaining list))
     (if (pair? remaining)
-       (%fold-left-step (procedure state (car remaining)) (cdr remaining))
+       (%fold-left-step (procedure state (car remaining))
+                        (cdr remaining))
        (begin
          (if (not (null? remaining))
              (error:not-list list caller))
@@ -810,11 +809,8 @@ USA.
 ;; Invokes (PROCEDURE state arg1 arg2 ...) on the all the lists in parallel.
 ;; State is returned as soon as any list is exhausted.
 (define (%fold-left-lists caller procedure initial arglists)
-  (let fold-left-step ((state initial)
-                      (lists arglists))
-    (let collect-arguments ((arglists (reverse lists))
-                           (cars '())
-                           (cdrs '()))
+  (let fold-left-step ((state initial) (lists arglists))
+    (let collect-arguments ((arglists (reverse lists)) (cars '()) (cdrs '()))
       (if (pair? arglists)
          (let ((first-list (car arglists)))
            (if (pair? first-list)
@@ -828,9 +824,8 @@ USA.
          (begin
            (if (not (null? arglists))
                (mapper-error arglists caller))
-           (fold-left-step
-            (apply procedure state cars)
-            cdrs))))))
+           (fold-left-step (apply procedure state cars)
+                           cdrs))))))
 
 (define (fold-left procedure initial first . rest)
   (if (pair? rest)
@@ -848,10 +843,12 @@ USA.
                          (apply procedure (append arguments (list state))))
                        initial
                        (cons first rest))
-      (%fold-left 'FOLD (lambda (state item)
-                         (declare (integrate state item))
-                         (procedure item state))
-                 initial first)))
+      (%fold-left 'FOLD
+                 (lambda (state item)
+                   (declare (integrate state item))
+                   (procedure item state))
+                 initial
+                 first)))
 
 ;; Like FOLD-LEFT, with four differences.
 ;;    1. Not n-ary
@@ -860,15 +857,20 @@ USA.
 ;;    4. PROCEDURE takes arguments in the wrong order.
 (define (reduce procedure default list)
   (if (pair? list)
-      (%fold-left 'REDUCE (lambda (state item)
-                           (declare (integrate state item))
-                           (procedure item state)) 
-                 (car list) (cdr list))
+      (%fold-left 'REDUCE
+                 (lambda (state item)
+                   (declare (integrate state item))
+                   (procedure item state))
+                 (car list)
+                 (cdr list))
       (begin
        (if (not (null? list))
            (error:not-list list 'REDUCE))
        default)))
-\f
+
+(define (reduce-left procedure initial list)
+  (reduce (lambda (a b) (procedure b a)) initial list))
+
 (define (reduce-right procedure initial list)
   (if (pair? list)
       (let loop ((first (car list)) (rest (cdr list)))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 8848df1c297d19d58be0a27ed5ee5b9a648822ca..acbbddbc40b80f203fa534b03306cd19ed2889c0 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2682,6 +2682,7 @@ USA.
          null?
          pair?
          reduce
+         reduce-left
          reduce-right
          restricted-keyword-list?
          reverse