(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))))
\f
(define (register-map:keep-live-entries map live-registers)
(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))))
\f
(define (scode/make-case-expression expression default clauses)
(define (kernel case-selector)
(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
(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))
(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)
(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)
(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)
(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)))
(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)
(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))))))))))))
\f
;;; This optimizes some simple cases, but it could be better. Among other
;;; things it could take advantage of arity-dispatched procedures in the right
'())
(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)
(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))))
\f
;;; The corresponding case for R7RS is much simpler since the imports are
;;; explicit.
(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)))
(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)))
(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))
\f
(define (transform/open-block block environment expression)
(transform/open-block* expression
(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)))
projects / mit-scheme.git / commitdiff