#| -*-Scheme-*-
-$Id: lamlift.scm,v 1.5 1995/03/11 16:01:01 adams Exp $
+$Id: lamlift.scm,v 1.6 1995/04/29 01:02:49 adams Exp $
-Copyright (c) 1994 Massachusetts Institute of Technology
+Copyright (c) 1994-1995 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(let ((bindings* (lamlift/bindings env* env bindings)))
(set-lamlift/env/split?! env* 'UNNECESSARY)
`(CALL ,rator*
- ,@(lmap cadr bindings*))))))))
+ ,@(map cadr bindings*))))))))
(else
`(CALL ,(lamlift/expr env rator)
,(lamlift/expr env cont)
(illegal expr))))
(define (lamlift/expr* env exprs)
- (lmap (lambda (expr)
- (lamlift/expr env expr))
- exprs))
+ (map (lambda (expr)
+ (lamlift/expr env expr))
+ exprs))
(define (lamlift/remember new old)
(code-rewrite/remember new old))
binding)))))
(define (lamlift/renames env names)
- (lmap (lambda (name)
- (cons name
- (if (not (lamlift/bound? env name))
- name
- (variable/rename name))))
- names))
+ (map (lambda (name)
+ (cons name
+ (if (not (lamlift/bound? env name))
+ name
+ (variable/rename name))))
+ names))
(define (lamlift/rename-lambda-list lambda-list pairs)
- (lmap (lambda (token)
- (let ((pair (assq token pairs)))
- (if (not pair)
- token
- (cdr pair))))
- lambda-list))
+ (map (lambda (token)
+ (let ((pair (assq token pairs)))
+ (if (not pair)
+ token
+ (cdr pair))))
+ lambda-list))
(define (lamlift/bound? env name)
(let loop ((env env))
(lamlift/env/context outer-env)
bindings)
outer-env
- (lmap car bindings)))
+ (map car bindings)))
(expr* `(,keyword
,(lamlift/bindings
inner-env
expr*))
\f
(define (lamlift/bindings binding-env body-env bindings)
- (lmap (lambda (binding)
- (let ((name (car binding))
- (value (cadr binding)))
- (list
- name
- (if (not (LAMBDA/? value))
- (lamlift/expr body-env value)
- (call-with-values
- (lambda ()
- (lamlift/lambda** 'DYNAMIC ; bindings are dynamic
- body-env
- value))
+ (map (lambda (binding)
+ (let ((name (car binding))
+ (value (cadr binding)))
+ (list
+ name
+ (if (not (LAMBDA/? value))
+ (lamlift/expr body-env value)
+ (call-with-values
+ (lambda ()
+ (lamlift/lambda** 'DYNAMIC ; bindings are dynamic
+ body-env
+ value))
(lambda (value* lambda-body-env)
(let ((binding
(or (lamlift/binding/find
(set-lamlift/env/binding! lambda-body-env binding)
(set-lamlift/binding/value! binding lambda-body-env)
value*)))))))
- bindings))
+ bindings))
(define (lamlift/analyze! env)
(lamlift/decide-split! env)
(define (lamlift/decide/letrec! letrec-env)
(define (decide-remaining-children! child-bindings-done)
- (let ((children-done (lmap lamlift/binding/value child-bindings-done)))
+ (let ((children-done (map lamlift/binding/value child-bindings-done)))
(for-each (lambda (child)
(lamlift/decide!* (lamlift/env/children child)))
- children-done)
+ children-done)
(lamlift/decide!*
(delq* children-done (lamlift/env/children letrec-env)))))
(let ((env* (lamlift/binding/value binding)))
(eq? (lamlift/env/split? env*) 'NO))))))
(for-each
- (lambda (binding)
- (let ((env* (lamlift/binding/value binding)))
- ;; No bindings need be added before lifting this,
- ;; because all free references from a static frame
- ;; are to static variables and hence lexically
- ;; visible after lifting.
- (set-lamlift/env/extended! env* '())))
- splits)
+ (lambda (binding)
+ (let ((env* (lamlift/binding/value binding)))
+ ;; No bindings need be added before lifting this,
+ ;; because all free references from a static frame
+ ;; are to static variables and hence lexically
+ ;; visible after lifting.
+ (set-lamlift/env/extended! env* '())))
+ splits)
(decide-remaining-children! splits)))
(else
(lamlift/decide/letrec!/dynamic-frame letrec-env)
;; Should be modified to preserve complete alpha renaming
`(LAMBDA ,orig-lambda-list
(CALL (LOOKUP ,body-lambda-name)
- ,@(lmap (lambda (name)
- (if (or *after-cps-conversion?*
- (not (continuation-variable? name)))
- `(LOOKUP ,name)
- `(QUOTE #F)))
- lifted-lambda-list)))))
+ ,@(map (lambda (name)
+ (if (or *after-cps-conversion?*
+ (not (continuation-variable? name)))
+ `(LOOKUP ,name)
+ `(QUOTE #F)))
+ lifted-lambda-list)))))
(lift-stub?
(or
;; The stub can drift to a static frame, the stub is named,
#| -*-Scheme-*-
-$Id: rtlgen.scm,v 1.25 1995/04/27 02:48:47 adams Exp $
+$Id: rtlgen.scm,v 1.26 1995/04/29 01:03:15 adams Exp $
Copyright (c) 1994 Massachusetts Institute of Technology
(define (rtlgen/let* state bindings body rtlgen/body rtlgen/state/new-env)
(let* ((env (rtlgen/state/env state))
- (rands (rtlgen/expr* state (lmap cadr bindings))))
+ (rands (rtlgen/expr* state (map cadr bindings))))
(rtlgen/body (rtlgen/state/new-env
state
(map* env
#| -*-Scheme-*-
-$Id: staticfy.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+$Id: staticfy.scm,v 1.2 1995/04/29 01:05:08 adams Exp $
Copyright (c) 1994 Massachusetts Institute of Technology
(define-staticfier LETREC (env bindings body)
(let ((env* (staticfy/bind (staticfy/env/context env)
env
- (lmap car bindings))))
- `(LETREC ,(lmap (lambda (binding)
- (list (car binding)
- (staticfy/expr env* (cadr binding))))
- bindings)
+ (map car bindings))))
+ `(LETREC ,(map (lambda (binding)
+ (list (car binding)
+ (staticfy/expr env* (cadr binding))))
+ bindings)
,(staticfy/expr env* body))))
(define-staticfier QUOTE (env object)
(define-staticfier LET (env bindings body)
(if (eq? (staticfy/env/context env) 'DYNAMIC)
- `(LET ,(lmap (lambda (binding)
- (list (car binding)
- (staticfy/expr env (cadr binding))))
- bindings)
- ,(staticfy/expr (staticfy/bind 'DYNAMIC env (lmap car bindings))
+ `(LET ,(map (lambda (binding)
+ (list (car binding)
+ (staticfy/expr env (cadr binding))))
+ bindings)
+ ,(staticfy/expr (staticfy/bind 'DYNAMIC env (map car bindings))
body))
(staticfy/let* staticfy/letify
env
(define (staticfy/pseudo-letify rator bindings body)
`(CALL ,(staticfy/remember
- `(LAMBDA (,(car (cadr rator)) ,@(lmap car bindings))
+ `(LAMBDA (,(car (cadr rator)) ,@(map car bindings))
,body)
rator)
(QUOTE #F)
- ,@(lmap cadr bindings)))
+ ,@(map cadr bindings)))
\f
(define (staticfy/let* letify env bindings body)
- (let* ((bindings* (lmap (lambda (binding)
- (list (car binding)
- (staticfy/expr env (cadr binding))))
- bindings))
+ (let* ((bindings* (map (lambda (binding)
+ (list (car binding)
+ (staticfy/expr env (cadr binding))))
+ bindings))
(env* (staticfy/bind (staticfy/env/context env)
env
- (lmap car bindings)))
+ (map car bindings)))
(body* (staticfy/expr env* body)))
(call-with-values
- (lambda ()
- (list-split bindings*
- (lambda (binding*)
- (staticfy/simple? (cadr binding*)))))
- (lambda (simple hairy)
- (if (null? hairy)
- (letify bindings* body*)
- (begin
- (for-each
- (lambda (hairy)
- (let* ((name (car hairy))
- (binding (assq name (staticfy/env/bindings env*))))
- (for-each
- (lambda (ref)
- (form/rewrite!
- ref
- `(CALL (QUOTE ,%static-binding-ref)
- (QUOTE #F)
- (LOOKUP ,name)
- (QUOTE ,name))))
- (cdr binding))))
- hairy)
- (letify
- (lmap (lambda (binding*)
+ (lambda ()
+ (list-split bindings*
+ (lambda (binding*)
+ (staticfy/simple? (cadr binding*)))))
+ (lambda (simple hairy)
+ (if (null? hairy)
+ (letify bindings* body*)
+ (begin
+ (for-each
+ (lambda (hairy)
+ (let* ((name (car hairy))
+ (binding (assq name (staticfy/env/bindings env*))))
+ (for-each
+ (lambda (ref)
+ (form/rewrite!
+ ref
+ `(CALL (QUOTE ,%static-binding-ref)
+ (QUOTE #F)
+ (LOOKUP ,name)
+ (QUOTE ,name))))
+ (cdr binding))))
+ hairy)
+ (letify
+ (map (lambda (binding*)
(if (memq binding* simple)
simple
(let ((name (car binding*)))
(QUOTE ,%unassigned)
(QUOTE ,name))))))
bindings*)
- (beginnify
- (append
- (let ((actions*
- (lmap (lambda (hairy)
+ (beginnify
+ (append
+ (let ((actions*
+ (map (lambda (hairy)
(let ((name (car hairy)))
`(CALL (QUOTE ,%static-binding-set!)
(QUOTE #F)
,(cadr hairy)
(QUOTE ,name))))
hairy)))
- (case *order-of-argument-evaluation*
- ((ANY LEFT-TO-RIGHT) actions*)
- ((RIGHT-TO_LEFT) (reverse actions*))
- (else
- (configuration-error
- "Unknown order of argument evaluation"
- *order-of-argument-evaluation*))))
- (list body*))))))))))
+ (case *order-of-argument-evaluation*
+ ((ANY LEFT-TO-RIGHT) actions*)
+ ((RIGHT-TO_LEFT) (reverse actions*))
+ (else
+ (configuration-error
+ "Unknown order of argument evaluation"
+ *order-of-argument-evaluation*))))
+ (list body*))))))))))
\f
(define (staticfy/expr env expr)
(if (not (pair? expr))
(illegal expr))))
(define (staticfy/expr* env exprs)
- (lmap (lambda (expr)
- (staticfy/expr env expr))
- exprs))
+ (map (lambda (expr)
+ (staticfy/expr env expr))
+ exprs))
(define (staticfy/remember new old)
(code-rewrite/remember new old))
(define-integrable (staticfy/bind context env names)
(staticfy/env/make context
env
- (lmap list names)))
\ No newline at end of file
+ (map list names)))
\ No newline at end of file
projects / mit-scheme.git / commitdiff