Eliminate use of fold-left.

diff --git a/src/compiler/machines/svm/assembler-compiler.scm b/src/compiler/machines/svm/assembler-compiler.scm
index a1c9ce95e861df45d0a508210ef530d9a44aa69e..7fef59ea72e4d1c26ea5264e69c2990d3ada096c 100644 (file)
--- a/src/compiler/machines/svm/assembler-compiler.scm
+++ b/src/compiler/machines/svm/assembler-compiler.scm
@@ -594,13 +594,13 @@ USA.
   (let ((names (map defn-name defns)))
     (let ((n
           (length
-           (fold-left (lambda (a b)
-                        (let join ((a a) (b b))
-                          (if (and (pair? a) (pair? b) (eqv? (car a) (car b)))
-                              (cons (car a) (join (cdr a) (cdr b)))
-                              '())))
-                      (car names)
-                      (cdr names)))))
+           (fold (lambda (a b)
+                   (let join ((a a) (b b))
+                     (if (and (pair? a) (pair? b) (eqv? (car a) (car b)))
+                         (cons (car a) (join (cdr a) (cdr b)))
+                         '())))
+                 (car names)
+                 (cdr names)))))
       (for-each (lambda (defn name)
                  (set-defn-name! defn (cons (car name) (list-tail name n))))
                defns

diff --git a/src/compiler/machines/svm/assembler-runtime.scm b/src/compiler/machines/svm/assembler-runtime.scm
index fd8c3935279ed11cec8eb3e695a5ad8c69ca1322..e805e110b0099401d8e553149c177600fc346349 100644 (file)
--- a/src/compiler/machines/svm/assembler-runtime.scm
+++ b/src/compiler/machines/svm/assembler-runtime.scm
@@ -214,14 +214,13 @@ USA.
 
 (define (fixed-instruction-width lap)
   (if (and (pair? lap) (pair? (car lap)) (null? (cdr lap)))
-      (fold-left + 0 (map bit-string-length
-                         (lap:syntax-instruction (car lap))))
+      (reduce + 0 (map bit-string-length (lap:syntax-instruction (car lap))))
       (error "FIXED-INSTRUCTION-WIDTH: Multiple instructions in LAP" lap)))
 
 (define (assemble-fixed-instruction width lap)
   (if (and (pair? lap) (pair? (car lap)) (null? (cdr lap)))
       (let* ((bits (lap:syntax-instruction (car lap)))
-            (len (fold-left + 0 (map bit-string-length bits))))
+            (len (reduce + 0 (map bit-string-length bits))))
        (if (not (= len width))
            (error "Mis-sized fixed instruction" lap))
        bits)
@@ -232,7 +231,7 @@ USA.
   ;; variable-width instructions (calculated by measuring a
   ;; representative assembled by MAKE-SAMPLE) and the range of offsets
   ;; encodable by each.
-  ;; 
+  ;;
   ;; The variable-width expression refers to *PC*, which is the PC at
   ;; the beginning of this instruction.  The instruction will actually
   ;; use the PC at the beginning of the next instruction.  Thus the

diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm
index 453e5e246d9a34d5af3b385dd3b4023737853de4..398f3666c4434ad585215215a0b17643fc8cc0e3 100644 (file)
--- a/src/runtime/arith.scm
+++ b/src/runtime/arith.scm
@@ -2226,10 +2226,10 @@ USA.
 (define-integrable integer-divide-remainder cdr)
 
 (define (gcd . integers)
-  (fold-left complex:gcd 0 integers))
+  (reduce complex:gcd 0 integers))
 
 (define (lcm . integers)
-  (fold-left complex:lcm 1 integers))
+  (reduce complex:lcm 1 integers))
 
 (define (atan z #!optional x)
   (if (default-object? x)

diff --git a/src/runtime/vector.scm b/src/runtime/vector.scm
index fcb464b60ca58b79b41025cc7fae46e3815382b8..29ec332ff30cdaf588e9739bdd8e51583facb4f2 100644 (file)
--- a/src/runtime/vector.scm
+++ b/src/runtime/vector.scm
@@ -204,10 +204,10 @@ USA.
   (let ((n (vector-length vector)))
     (if (pair? vectors)
        (let ((n
-              (fold-left (lambda (n v)
-                           (fix:min (vector-length v) n))
-                         n
-                         vectors)))
+              (fold (lambda (v n)
+                      (fix:min (vector-length v) n))
+                    n
+                    vectors)))
          (let loop ((i 0))
            (if (fix:< i n)
                (or (apply procedure
@@ -227,10 +227,10 @@ USA.
   (let ((n (vector-length vector)))
     (if (pair? vectors)
        (let ((n
-              (fold-left (lambda (n v)
-                           (fix:min (vector-length v) n))
-                         n
-                         vectors)))
+              (fold (lambda (v n)
+                      (fix:min (vector-length v) n))
+                    n
+                    vectors)))
          (let loop ((i 0))
            (if (fix:< i n)
                (and (apply procedure

diff --git a/src/sf/analyze.scm b/src/sf/analyze.scm
index 4ee93bb2a222ac170b575e982b5a34479eed7054..6fb0ef5fa61fdf0aa3af0d5f65771016f4897e79 100644 (file)
--- a/src/sf/analyze.scm
+++ b/src/sf/analyze.scm
@@ -248,10 +248,10 @@ USA.
   ((expression/method free-variables-dispatch-vector expression) expression))
 
 (define (expressions/free-variables expressions)
-  (fold-left (lambda (answer expression)
-               (lset-union eq? answer (expression/free-variables expression)))
-             (no-free-variables)
-             expressions))
+  (fold (lambda (expression answer)
+          (lset-union eq? answer (expression/free-variables expression)))
+        (no-free-variables)
+        expressions))
 
 (define free-variables-dispatch-vector
   (expression/make-dispatch-vector))
@@ -313,20 +313,20 @@ USA.
 (define-method/free-variables 'open-block
   (lambda (expression)
     (let ((omit (block/bound-variables (open-block/block expression))))
-     (fold-left (lambda (variables action)
-                  (if (eq? action open-block/value-marker)
-                      variables
-                      (lset-union eq?
-                                 variables
-                                 (lset-difference
-                                  eq?
-                                  (expression/free-variables action)
-                                  omit))))
-                (lset-difference eq?
-                                (expressions/free-variables
-                                 (open-block/values expression))
-                                omit)
-                (open-block/actions expression)))))
+     (fold (lambda (action variables)
+             (if (eq? action open-block/value-marker)
+                 variables
+                 (lset-union eq?
+                            variables
+                            (lset-difference
+                             eq?
+                             (expression/free-variables action)
+                             omit))))
+           (lset-difference eq?
+                           (expressions/free-variables
+                            (open-block/values expression))
+                           omit)
+           (open-block/actions expression)))))
 
 (define-method/free-variables 'procedure
   (lambda (expression)
@@ -368,11 +368,11 @@ USA.
   ((expression/method is-free-dispatch-vector expression) expression variable))
 
 (define (expressions/free-variable? expressions variable)
-  (fold-left (lambda (answer expression)
-               (or answer
-                   (expression/free-variable? expression variable)))
-             #f
-             expressions))
+  (fold (lambda (expression answer)
+          (or answer
+              (expression/free-variable? expression variable)))
+        #f
+        expressions))
 
 (define is-free-dispatch-vector
   (expression/make-dispatch-vector))
@@ -430,13 +430,13 @@ USA.
 
 (define-method/free-variable? 'open-block
   (lambda (expression variable)
-    (fold-left (lambda (answer action)
-                 (or answer
-                     (if (eq? action open-block/value-marker)
-                         #f
-                         (expression/free-variable? action variable))))
-               #f
-               (open-block/actions expression))))
+    (fold (lambda (action answer)
+            (or answer
+                (if (eq? action open-block/value-marker)
+                    #f
+                    (expression/free-variable? action variable))))
+          #f
+          (open-block/actions expression))))
 
 (define-method/free-variable? 'procedure
   (lambda (expression variable)
@@ -450,13 +450,13 @@ USA.
 
 (define-method/free-variable? 'sequence
   (lambda (expression variable)
-  (fold-left (lambda (answer action)
-               (or answer
-                   (if (eq? action open-block/value-marker)
-                       #f
-                       (expression/free-variable? action variable))))
-             #f
-             (sequence/actions expression))))
+  (fold (lambda (action answer)
+          (or answer
+              (if (eq? action open-block/value-marker)
+                  #f
+                  (expression/free-variable? action variable))))
+        #f
+        (sequence/actions expression))))
 
 (define-method/free-variable? 'the-environment false-procedure)
 \f
@@ -476,11 +476,11 @@ USA.
    expression variable info))
 
 (define (expressions/free-variable-info expressions variable info)
-  (fold-left (lambda (answer expression)
-               (expression/free-variable-info-dispatch expression variable
-                                                      answer))
-             info
-             expressions))
+  (fold (lambda (expression answer)
+          (expression/free-variable-info-dispatch expression variable
+                                                 answer))
+        info
+        expressions))
 
 (define free-info-dispatch-vector
   (expression/make-dispatch-vector))
@@ -546,13 +546,13 @@ USA.
 
 (define-method/free-variable-info 'open-block
   (lambda (expression variable info)
-    (fold-left (lambda (info action)
-                 (if (eq? action open-block/value-marker)
-                     info
-                     (expression/free-variable-info-dispatch action variable
-                                                            info)))
-               info
-               (open-block/actions expression))))
+    (fold (lambda (action info)
+            (if (eq? action open-block/value-marker)
+                info
+                (expression/free-variable-info-dispatch action variable
+                                                       info)))
+          info
+          (open-block/actions expression))))
 
 (define-method/free-variable-info 'procedure
   (lambda (expression variable info)
@@ -811,10 +811,10 @@ USA.
 
 (define-method/size 'combination
   (lambda (expression)
-    (fold-left (lambda (total operand)
-                 (fix:+ total (expression/size operand)))
-               (fix:1+ (expression/size (combination/operator expression)))
-               (combination/operands expression))))
+    (fold (lambda (operand total)
+            (fix:+ total (expression/size operand)))
+          (fix:1+ (expression/size (combination/operator expression)))
+          (combination/operands expression))))
 
 (define-method/size 'conditional
   (lambda (expression)
@@ -842,12 +842,12 @@ USA.
 
 (define-method/size 'open-block
   (lambda (expression)
-    (fold-left (lambda (total action)
-                (if (eq? action open-block/value-marker)
-                    total
-                    (fix:+ total (expression/size action))))
-              1
-              (open-block/actions expression))))
+    (fold (lambda (action total)
+            (if (eq? action open-block/value-marker)
+                total
+                (fix:+ total (expression/size action))))
+          1
+          (open-block/actions expression))))
 
 (define-method/size 'procedure
   (lambda (expression)
@@ -864,10 +864,10 @@ USA.
 
 (define-method/size 'sequence
   (lambda (expression)
-    (fold-left (lambda (total action)
-                 (fix:+ total (expression/size action)))
-               1
-               (sequence/actions expression))))
+    (fold (lambda (action total)
+            (fix:+ total (expression/size action)))
+          1
+          (sequence/actions expression))))
 \f
 ;;; EXPRESSION->list <expr>
 ;;

diff --git a/src/sf/object.scm b/src/sf/object.scm
index a120f7022c2af2015eba7a9ec09673cb95da5ca3..bbb7a0f6e2c360f51f3d0b20e92c19898a4b57b0 100644 (file)
--- a/src/sf/object.scm
+++ b/src/sf/object.scm
@@ -577,22 +577,22 @@ USA.
 ;;  Ensure that sequences are always flat.
 (define (sequence/make scode actions)
   (define (sequence/collect-actions collected actions)
-    (fold-left (lambda (reversed action)
-                 (if (sequence? action)
-                     (sequence/collect-actions reversed
-                                              (sequence/actions action))
-                     (cons action reversed)))
-               collected
-               actions))
+    (fold (lambda (action reversed)
+            (if (sequence? action)
+                (sequence/collect-actions reversed
+                                         (sequence/actions action))
+                (cons action reversed)))
+          collected
+          actions))
   (let ((filtered-actions
-         (fold-left (lambda (filtered action)
-                      (if (expression/effect-free? action)
-                          (if (null? filtered)
-                              (list action)
-                              filtered)
-                          (cons action filtered)))
-                    '()
-                    (sequence/collect-actions '() actions))))
+         (fold (lambda (action filtered)
+                 (if (expression/effect-free? action)
+                     (if (null? filtered)
+                         (list action)
+                         filtered)
+                     (cons action filtered)))
+               '()
+               (sequence/collect-actions '() actions))))
     (cond ((not (pair? filtered-actions))
           (constant/make unspecific unspecific))
          ((not (pair? (cdr filtered-actions)))