From: Chris Hanson Date: Wed, 4 Dec 2019 08:45:23 +0000 (-0800) Subject: Eliminate use of fold-left. X-Git-Tag: mit-scheme-pucked-10.1.20~10^2~11 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=31013ad058c3f967e59f332cd0d9f4d04ad42b04;p=mit-scheme.git Eliminate use of fold-left. --- diff --git a/src/compiler/machines/svm/assembler-compiler.scm b/src/compiler/machines/svm/assembler-compiler.scm index a1c9ce95e..7fef59ea7 100644 --- 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 fd8c39352..e805e110b 100644 --- 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 453e5e246..398f3666c 100644 --- 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 fcb464b60..29ec332ff 100644 --- 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 4ee93bb2a..6fb0ef5fa 100644 --- 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) @@ -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)))) ;;; EXPRESSION->list ;; diff --git a/src/sf/object.scm b/src/sf/object.scm index a120f7022..bbb7a0f6e 100644 --- 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)))