From: Chris Hanson 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)))