From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 5 Dec 2019 00:19:41 +0000 (-0800)
Subject: Eliminate use of map*, append-map*, append-map*!.
X-Git-Tag: mit-scheme-pucked-10.1.20~10^2~8
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6cdb944ed11d7be7b89c67ed43fb43ccd8077a61;p=mit-scheme.git
Eliminate use of map*, append-map*, append-map*!.
---
diff --git a/src/compiler/back/regmap.scm b/src/compiler/back/regmap.scm
index 1d2083a09..89ee29046 100644
--- a/src/compiler/back/regmap.scm
+++ b/src/compiler/back/regmap.scm
@@ -311,9 +311,11 @@ registers into some interesting sorting order.
(if (null? entries)
regmap
(make-register-map
- (map* (map-entries:delete* regmap entries)
- pseudo-register-entry->temporary-entry
- entries)
+ (fold-right (lambda (reg entries)
+ (cons (pseudo-register-entry->temporary-entry reg)
+ entries))
+ (map-entries:delete* regmap entries)
+ entries)
(map-registers regmap))))
(define (register-map:keep-live-entries map live-registers)
diff --git a/src/compiler/base/pmerly.scm b/src/compiler/base/pmerly.scm
index 58ff5b196..95d9dde6e 100644
--- a/src/compiler/base/pmerly.scm
+++ b/src/compiler/base/pmerly.scm
@@ -665,11 +665,12 @@ USA.
(make-unassigned-reference-trap))
'()
(scode/make-sequence
- (map* body
- (lambda (binding)
- (scode/make-assignment (scode/binding-variable binding)
- (scode/binding-value binding)))
- bindings))))
+ (fold-right (lambda (binding exprs)
+ (cons (scode/make-assignment (scode/binding-variable binding)
+ (scode/binding-value binding))
+ exprs))
+ body
+ bindings))))
(define (scode/make-case-expression expression default clauses)
(define (kernel case-selector)
diff --git a/src/compiler/base/utils.scm b/src/compiler/base/utils.scm
index 7406976ca..99dc8d6e4 100644
--- a/src/compiler/base/utils.scm
+++ b/src/compiler/base/utils.scm
@@ -509,11 +509,19 @@ USA.
(let ((names (global-valued function-additional-names)))
(let ((procedures (map global-value names)))
(set! function-variables
- (map* boolean-valued-function-variables cons names procedures))))
+ (fold-right (lambda (name proc vars)
+ (cons (cons name proc) vars))
+ boolean-valued-function-variables
+ names
+ procedures))))
(let ((names (global-valued side-effect-free-additional-names)))
(let ((procedures (map global-value names)))
(set! side-effect-free-variables
- (map* function-variables cons names procedures))))
+ (fold-right (lambda (name proc vars)
+ (cons (cons name proc) vars))
+ function-variables
+ names
+ procedures))))
unspecific)
(define function-primitives
diff --git a/src/compiler/fggen/fggen.scm b/src/compiler/fggen/fggen.scm
index bf8e2df40..4629bcb13 100644
--- a/src/compiler/fggen/fggen.scm
+++ b/src/compiler/fggen/fggen.scm
@@ -455,7 +455,12 @@ USA.
(scode/make-lambda
scode-lambda-name:let auxiliary '() #f names '()
(scode/make-sequence
- (map* actions scode/make-assignment names values)))
+ (fold-right (lambda (name value exprs)
+ (cons (scode/make-assignment name value)
+ exprs))
+ actions
+ names
+ values)))
(map (lambda (name)
name ;; ignored
(make-unassigned-reference-trap))
diff --git a/src/compiler/machines/svm/assembler-compiler.scm b/src/compiler/machines/svm/assembler-compiler.scm
index 7fef59ea7..6c49e4a91 100644
--- a/src/compiler/machines/svm/assembler-compiler.scm
+++ b/src/compiler/machines/svm/assembler-compiler.scm
@@ -249,12 +249,14 @@ USA.
(define (expand-abbrevs inputs abbrevs)
(receive (abbrev-defs inputs) (split-list inputs abbrev-def?)
(let ((abbrevs
- (map* abbrevs
- (lambda (abbrev-def)
- (cons `(',(caadr abbrev-def) ,@(cdadr abbrev-def))
- (eval (caddr abbrev-def)
- (make-top-level-environment))))
- abbrev-defs))
+ (fold-right (lambda (abbrev-def abbrevs)
+ (cons (cons `(',(caadr abbrev-def)
+ ,@(cdadr abbrev-def))
+ (eval (caddr abbrev-def)
+ (make-top-level-environment)))
+ abbrevs))
+ abbrevs
+ abbrev-defs))
(any-expansions? #f))
(let ((outputs
(append-map (lambda (input)
diff --git a/src/ffi/generator.scm b/src/ffi/generator.scm
index f848e27df..0dc8f4f81 100644
--- a/src/ffi/generator.scm
+++ b/src/ffi/generator.scm
@@ -587,36 +587,38 @@ grovel_enums (FILE * out)
(define (gen-struct-grovel-funcs includes)
;; Returns the names of the generated functions.
- (append-map*!
+ (fold-right
+ (lambda (name.info result)
+ ;; Typedefs giving names to struct types.
+ (let* ((name (car name.info))
+ (ctype (definite-ctype name includes)))
+ (if (ctype/struct? ctype)
+ (cons (gen-struct-union-grovel-func name includes)
+ result)
+ result)))
(map (lambda (name.info)
;; The named structs, top-level OR internal.
(let ((name (list 'struct (car name.info))))
(gen-struct-union-grovel-func name includes)))
(c-includes/structs includes))
- (lambda (name.info)
- ;; Typedefs giving names to struct types.
- (let* ((name (car name.info))
- (ctype (definite-ctype name includes)))
- (if (ctype/struct? ctype)
- (list (gen-struct-union-grovel-func name includes))
- '())))
(c-includes/type-names includes)))
(define (gen-union-grovel-funcs includes)
;; Returns the names of the generated functions.
- (append-map*!
+ (fold-right
+ (lambda (name.info result)
+ ;; Typedefs giving names to union types.
+ (let* ((name (car name.info))
+ (ctype (definite-ctype name includes)))
+ (if (ctype/union? ctype)
+ (cons (gen-struct-union-grovel-func name includes)
+ result)
+ result)))
(map (lambda (name.info)
;; The named unions, top-level OR internal.
(let ((name (list 'union (car name.info))))
(gen-struct-union-grovel-func name includes)))
(c-includes/unions includes))
- (lambda (name.info)
- ;; Typedefs giving names to union types.
- (let* ((name (car name.info))
- (ctype (definite-ctype name includes)))
- (if (ctype/union? ctype)
- (list (gen-struct-union-grovel-func name includes))
- '())))
(c-includes/type-names includes)))
(define (gen-struct-union-grovel-func name includes)
diff --git a/src/imail/imail-top.scm b/src/imail/imail-top.scm
index f14814a95..08b6747b4 100644
--- a/src/imail/imail-top.scm
+++ b/src/imail/imail-top.scm
@@ -2307,14 +2307,16 @@ WARNING: With a prefix argument, this command may take a very long
(cond ((ref-variable imail-kept-headers context)
=> (lambda (regexps)
(remove-duplicates!
- (append-map*!
+ (fold-right
+ (lambda (regexp result)
+ (append! (filter (lambda (header)
+ (re-string-match
+ regexp
+ (header-field-name header)
+ #t))
+ headers)
+ result))
(mime-headers)
- (lambda (regexp)
- (filter (lambda (header)
- (re-string-match regexp
- (header-field-name header)
- #t))
- headers))
regexps)
(lambda (a b) (eq? a b)))))
((ref-variable imail-ignored-headers context)
diff --git a/src/runtime/dynamic.scm b/src/runtime/dynamic.scm
index fc9a13c82..81c3a0f1c 100644
--- a/src/runtime/dynamic.scm
+++ b/src/runtime/dynamic.scm
@@ -102,9 +102,11 @@ USA.
(define (parameterize* new-bindings thunk)
(guarantee alist? new-bindings 'parameterize*)
(let ((temp
- (map* bindings
- (lambda (p) (create-binding (car p) (cdr p)))
- new-bindings)))
+ (fold-right (lambda (p bindings)
+ (cons (create-binding (car p) (cdr p))
+ bindings))
+ bindings
+ new-bindings)))
(let ((swap!
(lambda ()
(set! bindings (set! temp (set! bindings)))
diff --git a/src/runtime/environment.scm b/src/runtime/environment.scm
index 5d892ae8a..5969c36d1 100644
--- a/src/runtime/environment.scm
+++ b/src/runtime/environment.scm
@@ -629,12 +629,14 @@ USA.
(stack-ccenv/safe-lookup
environment
(dbg-variable/name variable)))))))
- (map* (map* (let ((rest (dbg-procedure/rest procedure)))
- (if rest (lookup rest) '()))
- lookup
- (dbg-procedure/optional procedure))
- lookup
- (dbg-procedure/required procedure)))
+ (fold-right (lambda (variable values)
+ (cons (lookup variable) values))
+ (fold-right (lambda (variable values)
+ (cons (lookup variable) values))
+ (let ((rest (dbg-procedure/rest procedure)))
+ (if rest (lookup rest) '()))
+ (dbg-procedure/optional procedure))
+ (dbg-procedure/required procedure)))
'unknown)))
(define (stack-ccenv/bound-names environment)
diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index da5dd480d..3082ae9cf 100644
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -535,11 +535,12 @@ USA.
(scons-lambda '() expr)
(apply scons-lambda
temp-bvl
- (map* (list (unspecific-expression))
- (lambda (name temp)
- (scons-set! name temp))
- names
- temps))))))))))))
+ (fold-right (lambda (name temp exprs)
+ (cons (scons-set! name temp)
+ exprs))
+ (list (unspecific-expression))
+ names
+ temps))))))))))))
;;; This optimizes some simple cases, but it could be better. Among other
;;; things it could take advantage of arity-dispatched procedures in the right
diff --git a/src/sf/copy.scm b/src/sf/copy.scm
index 834154485..36ec67492 100644
--- a/src/sf/copy.scm
+++ b/src/sf/copy.scm
@@ -67,7 +67,11 @@ USA.
'())
(define (environment/bind environment variables values)
- (map* environment cons variables values))
+ (fold-right (lambda (var val env)
+ (cons (cons var val) env))
+ environment
+ variables
+ values))
(define (environment/lookup environment variable if-found if-not)
(guarantee-variable variable 'environment/lookup)
diff --git a/src/sf/pardec.scm b/src/sf/pardec.scm
index 63997b31f..40492ea22 100644
--- a/src/sf/pardec.scm
+++ b/src/sf/pardec.scm
@@ -233,19 +233,21 @@ USA.
(for-each (constructor 'integrate)
constant-names
constant-values)))
- (map* declarations
- (let ((top-level-block
- (let loop ((block block))
- (if (block/parent block)
- (loop (block/parent block))
- block))))
- (lambda (remaining)
- (make-declaration
- (vector-ref remaining 0)
- (variable/make&bind! top-level-block (vector-ref remaining 1))
- (vector-ref remaining 2)
- 'global)))
- remaining))))
+ (fold-right (let ((top-level-block
+ (let loop ((block block))
+ (if (block/parent block)
+ (loop (block/parent block))
+ block))))
+ (lambda (remaining decls)
+ (cons (make-declaration
+ (vector-ref remaining 0)
+ (variable/make&bind! top-level-block
+ (vector-ref remaining 1))
+ (vector-ref remaining 2)
+ 'global)
+ decls)))
+ declarations
+ remaining))))
;;; The corresponding case for R7RS is much simpler since the imports are
;;; explicit.
diff --git a/src/sf/tables.scm b/src/sf/tables.scm
index 8933fca79..dc0a520f6 100644
--- a/src/sf/tables.scm
+++ b/src/sf/tables.scm
@@ -44,7 +44,11 @@ USA.
(alist-cons variable value environment))
(define-integrable (environment/bind-multiple environment variables values)
- (map* environment cons variables values))
+ (fold-right (lambda (var val env)
+ (cons (cons var val) env))
+ environment
+ variables
+ values))
(define (environment/lookup environment variable if-found if-unknown if-not)
(let ((association (assq variable environment)))
@@ -217,11 +221,11 @@ USA.
(if-not))))
(define (operations/shadow operations variables)
- (vector (map* (vector-ref operations 0)
- (lambda (variable)
- (guarantee-variable variable 'operations/shadow)
- (cons variable false))
- variables)
+ (vector (fold-right (lambda (variable operations)
+ (guarantee-variable variable 'operations/shadow)
+ (cons (cons variable false) operations))
+ (vector-ref operations 0)
+ variables)
(vector-ref operations 1)
(vector-ref operations 2)))
diff --git a/src/sf/xform.scm b/src/sf/xform.scm
index 22209149a..a5075eecf 100644
--- a/src/sf/xform.scm
+++ b/src/sf/xform.scm
@@ -114,10 +114,11 @@ USA.
(variable/make&bind! top-level-block name)))))
(define (environment/bind environment variables)
- (map* environment
- (lambda (variable)
- (cons (variable/name variable) variable))
- variables))
+ (fold-right (lambda (variable env)
+ (cons (cons (variable/name variable) variable)
+ env))
+ environment
+ variables))
(define (transform/open-block block environment expression)
(transform/open-block* expression
diff --git a/src/xdoc/xdoc.scm b/src/xdoc/xdoc.scm
index 39ae99b48..350da57ee 100644
--- a/src/xdoc/xdoc.scm
+++ b/src/xdoc/xdoc.scm
@@ -1275,17 +1275,19 @@ USA.
(filter preserved-attribute? (xml-element-attributes elt)))
(define (merge-attributes attrs defaults)
- (map* (remove (lambda (attr)
- (%find-attribute (xml-attribute-name attr) attrs))
- defaults)
- (lambda (attr)
- (let ((attr*
- (and (merged-attribute? attr)
- (%find-attribute (xml-attribute-name attr) defaults))))
- (if attr*
- (merge-attribute attr attr*)
- attr)))
- attrs))
+ (fold-right (lambda (attr attrs)
+ (cons (let ((attr*
+ (and (merged-attribute? attr)
+ (%find-attribute (xml-attribute-name attr)
+ defaults))))
+ (if attr*
+ (merge-attribute attr attr*)
+ attr))
+ attrs))
+ (remove (lambda (attr)
+ (%find-attribute (xml-attribute-name attr) attrs))
+ defaults)
+ attrs))
(define (preserved-attribute? attr)
(let ((name (xml-attribute-name attr)))