#| -*-Scheme-*-
-$Id: alpha.scm,v 1.5 1995/01/19 04:51:16 adams Exp $
+$Id: alpha.scm,v 1.6 1995/03/12 05:53:10 adams Exp $
Copyright (c) 1988-1994 Massachusetts Institute of Technology
(alphaconv/let-like 'LETREC state env bindings body))
(define (alphaconv/let-like keyword state env bindings body)
- (let* ((names (lmap car bindings))
+ (let* ((names (map car bindings))
(new-names (alphaconv/renamings env names))
(inner-env (alphaconv/env/extend env names new-names))
(expr-env (if (eq? keyword 'LETREC) inner-env env))
(illegal expr))
(let ((new-expr
(case (car expr)
- ((QUOTE)
- (alphaconv/quote state env expr))
- ((LOOKUP)
- (alphaconv/lookup state env expr))
- ((LAMBDA)
- (alphaconv/lambda state env expr))
- ((LET)
- (alphaconv/let state env expr))
- ((DECLARE)
- (alphaconv/declare state env expr))
- ((CALL)
- (alphaconv/call state env expr))
- ((BEGIN)
- (alphaconv/begin state env expr))
- ((IF)
- (alphaconv/if state env expr))
- ((LETREC)
- (alphaconv/letrec state env expr))
- ((SET!)
- (alphaconv/set! state env expr))
- ((UNASSIGNED?)
- (alphaconv/unassigned? state env expr))
- ((OR)
- (alphaconv/or state env expr))
- ((DELAY)
- (alphaconv/delay state env expr))
- ((ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
- (no-longer-legal expr))
+ ((QUOTE) (alphaconv/quote state env expr))
+ ((LOOKUP) (alphaconv/lookup state env expr))
+ ((LAMBDA) (alphaconv/lambda state env expr))
+ ((LET) (alphaconv/let state env expr))
+ ((DECLARE) (alphaconv/declare state env expr))
+ ((CALL) (alphaconv/call state env expr))
+ ((BEGIN) (alphaconv/begin state env expr))
+ ((IF) (alphaconv/if state env expr))
+ ((LETREC) (alphaconv/letrec state env expr))
+ ((SET!) (alphaconv/set! state env expr))
+ ((UNASSIGNED?) (alphaconv/unassigned? state env expr))
+ ((OR) (alphaconv/or state env expr))
+ ((DELAY) (alphaconv/delay state env expr))
(else
(illegal expr)))))
((alphaconv/state/remember state) new-expr expr)))
(define (alphaconv/expr* state env exprs)
- (lmap (lambda (expr)
- (alphaconv/expr state env expr))
- exprs))
+ (map (lambda (expr)
+ (alphaconv/expr state env expr))
+ exprs))
(define-integrable (alphaconv/remember new old)
(code-rewrite/remember new old))
#| -*-Scheme-*-
-$Id: applicat.scm,v 1.2 1995/02/02 19:35:50 adams Exp $
+$Id: applicat.scm,v 1.3 1995/03/12 05:57:14 adams Exp $
Copyright (c) 1994 Massachusetts Institute of Technology
(define-applicator LAMBDA (env lambda-list body)
`(LAMBDA ,lambda-list
- ,(applicat/expr (append (lmap (lambda (name)
- (list name false))
- (lambda-list->names lambda-list))
- env)
- body)))
+ ,(applicat/expr (append (map (lambda (name)
+ (list name false))
+ (lambda-list->names lambda-list))
+ env)
+ body)))
(define-applicator QUOTE (env object)
env ; ignored
(default))))
(define-applicator LET (env bindings body)
- `(LET ,(lmap (lambda (binding)
- (list (car binding)
- (applicat/expr env (cadr binding))))
- bindings)
+ `(LET ,(map (lambda (binding)
+ (list (car binding)
+ (applicat/expr env (cadr binding))))
+ bindings)
,(applicat/expr
- (append (lmap (lambda (binding)
- (list (car binding)
- (let ((value (cadr binding)))
- (and (pair? value)
- (eq? (car value) 'LAMBDA)))))
- bindings)
+ (append (map (lambda (binding)
+ (list (car binding)
+ (let ((value (cadr binding)))
+ (LAMBDA/? value))))
+ bindings)
env)
body)))
\f
(define-applicator LETREC (env bindings body)
(let ((env*
- (append (lmap (lambda (binding)
- (list (car binding)
- (let ((value (cadr binding)))
- (and (pair? value)
- (eq? (car value) 'LAMBDA)))))
- bindings)
+ (append (map (lambda (binding)
+ (list (car binding)
+ (let ((value (cadr binding)))
+ (LAMBDA/? value))))
+ bindings)
env)))
- `(LETREC ,(lmap (lambda (binding)
- (list (car binding)
- (applicat/expr env* (cadr binding))))
- bindings)
+ `(LETREC ,(map (lambda (binding)
+ (list (car binding)
+ (applicat/expr env* (cadr binding))))
+ bindings)
,(applicat/expr env* body))))
(define (applicat/expr env expr)
(if (not (pair? expr))
(illegal expr))
(case (car expr)
- ((QUOTE)
- (applicat/quote env expr))
- ((LOOKUP)
- (applicat/lookup env expr))
- ((LAMBDA)
- (applicat/lambda env expr))
- ((LET)
- (applicat/let env expr))
- ((DECLARE)
- (applicat/declare env expr))
- ((CALL)
- (applicat/call env expr))
- ((BEGIN)
- (applicat/begin env expr))
- ((IF)
- (applicat/if env expr))
- ((LETREC)
- (applicat/letrec env expr))
- ((SET! UNASSIGNED? OR DELAY
- ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
- (no-longer-legal expr))
+ ((QUOTE) (applicat/quote env expr))
+ ((LOOKUP) (applicat/lookup env expr))
+ ((LAMBDA) (applicat/lambda env expr))
+ ((LET) (applicat/let env expr))
+ ((DECLARE) (applicat/declare env expr))
+ ((CALL) (applicat/call env expr))
+ ((BEGIN) (applicat/begin env expr))
+ ((IF) (applicat/if env expr))
+ ((LETREC) (applicat/letrec env expr))
(else
(illegal expr))))
(define (applicat/expr* env exprs)
- (lmap (lambda (expr)
- (applicat/expr env expr))
- exprs))
+ (map (lambda (expr)
+ (applicat/expr env expr))
+ exprs))
(define (applicat/remember new old)
(code-rewrite/remember new old))
#| -*-Scheme-*-
-$Id: assconv.scm,v 1.5 1995/02/21 06:20:05 adams Exp $
+$Id: assconv.scm,v 1.6 1995/03/12 05:59:29 adams Exp $
Copyright (c) 1994 Massachusetts Institute of Technology
(lambda (shadowed body*)
`(LAMBDA ,(if (null? shadowed)
lambda-list
- (lmap (lambda (name)
- (if (memq name shadowed)
- (assconv/new-name 'IGNORED)
- name))
- lambda-list))
+ (map (lambda (name)
+ (if (memq name shadowed)
+ (assconv/new-name 'IGNORED)
+ name))
+ lambda-list))
,body*))))
(define-assignment-converter LET (env bindings body)
(call-with-values
(lambda ()
- (assconv/binding-body env (lmap car bindings) body))
+ (assconv/binding-body env (map car bindings) body))
(lambda (shadowed body*)
- `(LET ,(lmap (lambda (binding)
- (list (car binding)
- (assconv/expr env (cadr binding))))
- (if (null? shadowed)
- bindings
- (list-transform-negative bindings
- (lambda (binding)
- (memq (car binding) shadowed)))))
+ `(LET ,(map (lambda (binding)
+ (list (car binding)
+ (assconv/expr env (cadr binding))))
+ (if (null? shadowed)
+ bindings
+ (list-transform-negative bindings
+ (lambda (binding)
+ (memq (car binding) shadowed)))))
,body*))))
(define-assignment-converter LOOKUP (env name)
(illegal expr))))
(define (assconv/expr* env exprs)
- (lmap (lambda (expr)
- (assconv/expr env expr))
- exprs))
+ (map (lambda (expr)
+ (assconv/expr env expr))
+ exprs))
(define (assconv/remember new old)
(code-rewrite/remember new old)
(define (assconv/binding-body env names body)
;; (values shadowed-names body*)
- (let* ((frame (lmap assconv/binding/make names))
+ (let* ((frame (map assconv/binding/make names))
(env* (cons frame env))
(body* (assconv/expr env* body))
(assigned
(assconv/single-analyze ssa-candidates body*))
(lambda (let-like letrec-like)
(assconv/bind-cells
- (lmap assconv/binding/name (append let-like letrec-like))
+ (map assconv/binding/name (append let-like letrec-like))
(list-transform-negative assigned
(lambda (binding)
(or (memq binding let-like)
(for-each assconv/cellify! bindings)
(values
shadowed-names
- `(LET ,(lmap (lambda (binding)
- (let ((name (assconv/binding/name binding)))
- `(,(assconv/binding/cell-name binding)
- (CALL (QUOTE ,%make-cell)
- (QUOTE #F)
- (LOOKUP ,name)
- (QUOTE ,name)))))
- bindings)
+ `(LET ,(map (lambda (binding)
+ (let ((name (assconv/binding/name binding)))
+ `(,(assconv/binding/cell-name binding)
+ (CALL (QUOTE ,%make-cell)
+ (QUOTE #F)
+ (LOOKUP ,name)
+ (QUOTE ,name)))))
+ bindings)
,body)))))
(define (default)
\f
(define (assconv/letify keyword bindings body)
`(,keyword
- ,(lmap (lambda (binding)
- (let* ((ass (car (assconv/binding/assignments binding)))
- (value (set!/expr ass)))
+ ,(map (lambda (binding)
+ (let* ((ass (car (assconv/binding/assignments binding)))
+ (value (set!/expr ass)))
(form/rewrite! ass `(QUOTE ,%unassigned))
`(,(assconv/binding/name binding) ,value)))
bindings)
(if (not (pair? body))
(values '() '())
(let ((single-assignments
- (lmap (lambda (binding)
- (cons (car (assconv/binding/assignments binding))
- binding))
- ssa-candidates))
+ (map (lambda (binding)
+ (cons (car (assconv/binding/assignments binding))
+ binding))
+ ssa-candidates))
(finish
(lambda (bindings)
(values
#| -*-Scheme-*-
-$Id: laterew.scm,v 1.4 1995/02/26 16:28:48 adams Exp $
+$Id: laterew.scm,v 1.5 1995/03/12 05:44:38 adams Exp $
Copyright (c) 1994 Massachusetts Institute of Technology
(define-macro (define-late-rewriter keyword bindings . body)
(let ((proc-name (symbol-append 'LATEREW/ keyword)))
(call-with-values
- (lambda () (%matchup bindings '(handler) '(cdr form)))
- (lambda (names code)
- `(define ,proc-name
- (let ((handler (lambda ,names ,@body)))
- (named-lambda (,proc-name form)
- (laterew/remember ,code form))))))))
+ (lambda () (%matchup bindings '(handler) '(cdr form)))
+ (lambda (names code)
+ `(DEFINE ,proc-name
+ (LET ((HANDLER (LAMBDA ,names ,@body)))
+ (NAMED-LAMBDA (,proc-name FORM)
+ (LATEREW/REMEMBER ,code FORM))))))))
(define-late-rewriter LOOKUP (name)
`(LOOKUP ,name))
,(laterew/expr body)))
(define-late-rewriter LET (bindings body)
- `(LET ,(lmap (lambda (binding)
- (list (car binding)
- (laterew/expr (cadr binding))))
- bindings)
+ `(LET ,(map (lambda (binding)
+ (list (car binding)
+ (laterew/expr (cadr binding))))
+ bindings)
,(laterew/expr body)))
(define-late-rewriter LETREC (bindings body)
- `(LETREC ,(lmap (lambda (binding)
- (list (car binding)
- (laterew/expr (cadr binding))))
- bindings)
+ `(LETREC ,(map (lambda (binding)
+ (list (car binding)
+ (laterew/expr (cadr binding))))
+ bindings)
,(laterew/expr body)))
(define-late-rewriter QUOTE (object)
(if (not (pair? expr))
(illegal expr))
(case (car expr)
- ((QUOTE)
- (laterew/quote expr))
- ((LOOKUP)
- (laterew/lookup expr))
- ((LAMBDA)
- (laterew/lambda expr))
- ((LET)
- (laterew/let expr))
- ((DECLARE)
- (laterew/declare expr))
- ((CALL)
- (laterew/call expr))
- ((BEGIN)
- (laterew/begin expr))
- ((IF)
- (laterew/if expr))
- ((LETREC)
- (laterew/letrec expr))
+ ((QUOTE) (laterew/quote expr))
+ ((LOOKUP) (laterew/lookup expr))
+ ((LAMBDA) (laterew/lambda expr))
+ ((LET) (laterew/let expr))
+ ((DECLARE) (laterew/declare expr))
+ ((CALL) (laterew/call expr))
+ ((BEGIN) (laterew/begin expr))
+ ((IF) (laterew/if expr))
+ ((LETREC) (laterew/letrec expr))
(else
(illegal expr))))
(define (laterew/expr* exprs)
- (lmap (lambda (expr)
- (laterew/expr expr))
- exprs))
+ (map (lambda (expr)
+ (laterew/expr expr))
+ exprs))
(define (laterew/remember new old)
(code-rewrite/remember new old))
#| -*-Scheme-*-
-$Id: stackopt.scm,v 1.4 1995/01/20 22:23:42 adams Exp $
+$Id: stackopt.scm,v 1.5 1995/03/12 05:48:16 adams Exp $
Copyright (c) 1994 Massachusetts Institute of Technology
(define-stack-optimizer LET (state bindings body)
- `(LET ,(lmap (lambda (binding)
- (list (car binding)
- (stackopt/expr false (cadr binding))))
- bindings)
+ `(LET ,(map (lambda (binding)
+ (list (car binding)
+ (stackopt/expr false (cadr binding))))
+ bindings)
,(stackopt/expr state body)))
(define-stack-optimizer LETREC (state bindings body)
- `(LETREC ,(lmap (lambda (binding)
- (list (car binding)
- (stackopt/expr false (cadr binding))))
- bindings)
+ `(LETREC ,(map (lambda (binding)
+ (list (car binding)
+ (stackopt/expr false (cadr binding))))
+ bindings)
,(stackopt/expr state body)))
(define-stack-optimizer QUOTE (state object)
(if (not (pair? expr))
(illegal expr))
(case (car expr)
- ((QUOTE)
- (stackopt/quote state expr))
- ((LOOKUP)
- (stackopt/lookup state expr))
- ((LAMBDA)
- (stackopt/lambda state expr))
- ((LET)
- (stackopt/let state expr))
- ((DECLARE)
- (stackopt/declare state expr))
- ((CALL)
- (stackopt/call state expr))
- ((BEGIN)
- (stackopt/begin state expr))
- ((IF)
- (stackopt/if state expr))
- ((LETREC)
- (stackopt/letrec state expr))
- ((SET! UNASSIGNED? OR DELAY
- ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
- (no-longer-legal expr))
+ ((QUOTE) (stackopt/quote state expr))
+ ((LOOKUP) (stackopt/lookup state expr))
+ ((LAMBDA) (stackopt/lambda state expr))
+ ((LET) (stackopt/let state expr))
+ ((DECLARE) (stackopt/declare state expr))
+ ((CALL) (stackopt/call state expr))
+ ((BEGIN) (stackopt/begin state expr))
+ ((IF) (stackopt/if state expr))
+ ((LETREC) (stackopt/letrec state expr))
(else
(illegal expr))))
projects / mit-scheme.git / commitdiff