From: Chris Hanson <cph@google.com>
Date: Tue, 23 Feb 2016 06:23:16 +0000 (-0800)
Subject: Put reduce-right back.
X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~135
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=de2cb85cfa59af7c645ea343f0b83c5bc3c60a8e;p=mit-scheme.git

Put reduce-right back.
---

diff --git a/src/runtime/list.scm b/src/runtime/list.scm
index b870f7331..030d731cd 100644
--- 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)))
-
+
+(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 8848df1c2..acbbddbc4 100644
--- 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