#| -*-Scheme-*-
-$Id: alpha.scm,v 1.3 1994/11/25 22:58:37 adams Exp $
+$Id: alpha.scm,v 1.4 1994/11/26 22:07:13 gjr Exp $
Copyright (c) 1988-1994 Massachusetts Institute of Technology
(define-macro (define-alphaconv keyword bindings . body)
(let ((proc-name (symbol-append 'ALPHACONV/ keyword)))
(call-with-values
- (lambda () (%matchup (cddr bindings) '(handler state env) '(cdr form)))
- (lambda (names code)
- `(define ,proc-name
- (let ((handler (lambda ,(cons* (car bindings) (cadr bindings) names) ,@body)))
- (named-lambda (,proc-name state env form)
- ,code)))))))
+ (lambda () (%matchup (cddr bindings) '(handler state env) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (named-lambda (,proc-name state env form)
+ ;; All handlers inherit FORM (and others) from the
+ ;; surrounding scope.
+ (let ((handler
+ (lambda ,(cons* (car bindings) (cadr bindings) names)
+ ,@body)))
+ ,code)))))))
(define-alphaconv LOOKUP (state env name)
- env ; ignored
+ state env ; ignored
`(LOOKUP ,(alphaconv/env/lookup name env)))
(define-alphaconv LAMBDA (state env lambda-list body)
(let* ((names (lambda-list->names lambda-list))
(new-names (alphaconv/renamings env names))
(env* (alphaconv/env/extend env names new-names)))
+ (alphaconv/remember-renames form env*)
`(LAMBDA ,(alphaconv/rename-lambda-list lambda-list new-names)
,(alphaconv/expr state env* body))))
(else
(loop (cdr ll) (cdr nn) (cons (car nn) result))))))
+(define (alphaconv/remember-renames form env*)
+ (let ((info (code-rewrite/original-form/previous form)))
+ (and info
+ (new-dbg-procedure? info)
+ (let ((block (new-dbg-procedure/block info)))
+ (and block
+ (for-each
+ (lambda (var)
+ (set-new-dbg-variable/name!
+ var
+ (alphaconv/env/lookup (new-dbg-variable/original-name var)
+ env*)))
+ (new-dbg-block/variables block)))))))
+
(define-alphaconv CALL (state env rator cont #!rest rands)
`(CALL ,(alphaconv/expr state env rator)
,(alphaconv/expr state env cont)
(new-names (alphaconv/renamings env names))
(inner-env (alphaconv/env/extend env names new-names))
(expr-env (if (eq? keyword 'LETREC) inner-env env))
- (bindings* (map (lambda (new-name binding)
- (list new-name
- (alphaconv/expr state expr-env (second binding))))
- new-names
- bindings)))
+ (bindings*
+ (map (lambda (new-name binding)
+ (list new-name
+ (alphaconv/expr state expr-env (second binding))))
+ new-names
+ bindings)))
`(,keyword ,bindings* ,(alphaconv/expr state inner-env body))))
(define-alphaconv QUOTE (state env object)
- env ; ignored
+ state env ; ignored
`(QUOTE ,object))
(define-alphaconv DECLARE (state env #!rest anything)
- env ; ignored
+ state env ; ignored
`(DECLARE ,@anything))
(define-alphaconv BEGIN (state env #!rest actions)
`(SET! ,(alphaconv/env/lookup name env) ,(alphaconv/expr state env value)))
(define-alphaconv UNASSIGNED? (state env name)
- env ; ignored
+ state env ; ignored
`(UNASSIGNED? ,(alphaconv/env/lookup name env)))
(define-alphaconv OR (state env pred alt)
#| -*-Scheme-*-
-$Id: dbgstr.scm,v 1.3 1994/11/25 23:03:33 adams Exp $
+$Id: dbgstr.scm,v 1.4 1994/11/26 22:05:20 gjr Exp $
Copyright (c) 1994 Massachusetts Institute of Technology
(define-structure (new-dbg-expression
(conc-name new-dbg-expression/)
- (constructor new-dbg-expression/make (expr)))
+ (constructor new-dbg-expression/make (expr))
+ (constructor new-dbg-expression/make2 (expr block)))
(expr false read-only true)
(block false read-only false))
(define-structure (new-dbg-variable
(conc-name new-dbg-variable/)
- (constructor new-dbg-variable/make (name block)))
- (name false read-only true)
+ (constructor new-dbg-variable/make (original-name block)))
+ (name original-name read-only false)
(original-name name read-only true)
(block false read-only false)
(original-block block read-only false)
#| -*-Scheme-*-
-$Id: envconv.scm,v 1.4 1994/11/26 00:23:24 jmiller Exp $
+$Id: envconv.scm,v 1.5 1994/11/26 22:06:52 gjr Exp $
Copyright (c) 1994 Massachusetts Institute of Technology
(envconv/new-reference env name `(SET! ,name ,value*))))
(define (envconv/lambda env form name)
- (let ((form*
- (let ((lambda-list (lambda/formals form))
- (body (lambda/body form)))
- (if (or (not (eq? (envconv/env/context env) 'TOP-LEVEL))
- (not *envconv/compile-by-procedures?*)
- *envconv/procedure-result?*
- (eq? form *envconv/top-level-program*))
- (envconv/lambda* 'ARBITRARY env lambda-list body)
- (envconv/compile-separately form name true env)))))
- (envconv/remember form*
- form
- (if (LAMBDA/? form*)
- (let* ((body (lambda/body form*))
- (body-info (code-rewrite/original-form body)))
- (cond ((not body-info) false)
- ((new-dbg-procedure? body-info)
- (new-dbg-block/parent
- (new-dbg-procedure/block body-info)))
- (else
- (new-dbg-expression/block body-info))))
- (envconv/env/block env)))))
-
-
-(define (envconv/lambda* context* env lambda-list body)
- (envconv/binding-body context*
- env
- ;; Ignore continuation
- (cdr (lambda-list->names lambda-list))
- body
- (lambda (body*)
- `(LAMBDA ,lambda-list
- ,body*))))
+ (let ((lambda-list (lambda/formals form))
+ (body (lambda/body form)))
+ (if (or (not (eq? (envconv/env/context env) 'TOP-LEVEL))
+ (not *envconv/compile-by-procedures?*)
+ *envconv/procedure-result?*
+ (eq? form *envconv/top-level-program*))
+ (envconv/lambda* 'ARBITRARY env form)
+ (envconv/compile-separately form name true env))))
+
+(define (envconv/lambda* context* env form)
+ (let ((lambda-list (lambda/formals form))
+ (body (lambda/body form)))
+ (let ((form*
+ (envconv/binding-body context*
+ env
+ ;; Ignore continuation
+ (cdr (lambda-list->names lambda-list))
+ body
+ (lambda (body*)
+ `(LAMBDA ,lambda-list
+ ,body*)))))
+ (envconv/remember form*
+ form
+ (if (LAMBDA/? form*)
+ (let* ((body (lambda/body form*))
+ (body-info
+ (code-rewrite/original-form body)))
+ (cond ((not body-info) false)
+ ((new-dbg-procedure? body-info)
+ (new-dbg-block/parent
+ (new-dbg-procedure/block body-info)))
+ (else
+ (new-dbg-expression/block body-info))))
+ (envconv/env/block env))))))
(define-environment-converter LET (env bindings body)
(let ((bindings* (lmap (lambda (binding)
(define-environment-converter CALL (env rator cont #!rest rands)
(define (default)
`(CALL ,(if (LAMBDA/? rator)
- (envconv/remember
- (envconv/lambda*
+ (envconv/lambda*
(if (eq? (envconv/env/context env) 'ARBITRARY)
'ARBITRARY
'ONCE-ONLY)
- env (lambda/formals rator) (lambda/body rator))
- rator
- (envconv/env/block env))
+ env rator)
(envconv/expr env rator))
-
,(envconv/expr env cont)
,@(envconv/expr* env rands)))
(envconv/lookup env expr))
((LAMBDA)
(envconv/lambda env expr name))
- ((LET)
- (envconv/let env expr))
((DECLARE)
(envconv/declare env expr))
((CALL)
(envconv/in-package env expr))
((THE-ENVIRONMENT)
(envconv/the-environment env expr))
- ((LETREC)
+#|
+ ((LET)
+ (envconv/let env expr))
+|#
+ ((LET LETREC)
(not-yet-legal expr))
(else
(illegal expr))))
#| -*-Scheme-*-
-$Id: expand.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+$Id: expand.scm,v 1.2 1994/11/26 22:05:28 gjr Exp $
Copyright (c) 1994 Massachusetts Institute of Technology
(define-expander SET! (name value)
`(SET! ,name ,(expand/expr value)))
+#|
(define-expander LAMBDA (lambda-list body)
(expand/rewrite/lambda lambda-list (expand/expr body)))
-
-(define (expand/rewrite/lambda lambda-list body)
- (cond ((memq '#!AUX lambda-list)
- => (lambda (tail)
- (let ((rest (list-prefix lambda-list tail))
- (auxes (cdr tail)))
- `(LAMBDA ,rest
- ,(if (null? auxes)
- body
- `(LET ,(lmap (lambda (aux)
- (list aux `(QUOTE ,%unassigned)))
- auxes)
- ,(expand/aux/sort auxes body)))))))
- (else
- `(LAMBDA ,lambda-list ,body))))
+|#
+
+(define (expand/lambda form)
+ (expand/remember
+ (let ((lambda-list (lambda/formals form))
+ (body (expand/expr (lambda/body form))))
+ (cond ((memq '#!AUX lambda-list)
+ => (lambda (tail)
+ (let ((rest (list-prefix lambda-list tail))
+ (auxes (cdr tail)))
+ (if (null? auxes)
+ `(LAMBDA ,rest ,body)
+ (let ((body*
+ `(LET ,(lmap (lambda (aux)
+ (list aux `(QUOTE ,%unassigned)))
+ auxes)
+ ,(expand/aux/sort auxes body))))
+ (expand/split-block body* form)
+ `(LAMBDA ,rest
+ ,body*))))))
+ (else
+ `(LAMBDA ,lambda-list ,body))))
+ form))
+
+(define (expand/split-block new-form form)
+ (let ((info (code-rewrite/original-form/previous form)))
+ (and info
+ (new-dbg-procedure? info)
+ (expand/remember*
+ new-form
+ (new-dbg-expression/make2 false
+ (new-dbg-procedure/block info))))))
(define-expander LET (bindings body)
(expand/let* expand/letify bindings body))
`(DECLARE ,@anything))
(define-expander CALL (rator cont #!rest rands)
- (if (and (pair? rator) (eq? (car rator) 'LAMBDA))
- (let ((result
- (let ((rator* (expand/rewrite/lambda (cadr rator) (caddr rator))))
- (expand/let* (lambda (bindings body)
- (expand/pseudo-letify rator bindings body))
- (expand/bindify (cadr rator*)
- (cons cont rands))
- (caddr rator*)))))
- (expand/remember (cadr result) rator)
- result)
- `(CALL ,(expand/expr rator)
- ,(expand/expr cont)
- ,@(expand/expr* rands))))
+ `(CALL ,(expand/expr rator)
+ ,(expand/expr cont)
+ ,@(expand/expr* rands)))
(define-expander BEGIN (#!rest actions)
(expand/code-compress (expand/expr* actions)))
(define (expand/remember new old)
(code-rewrite/remember new old))
+(define (expand/remember* new old)
+ (code-rewrite/remember* new old))
+
(define (expand/new-name prefix)
(new-variable prefix))
#| -*-Scheme-*-
-$Id: utils.scm,v 1.5 1994/11/26 17:43:21 adams Exp $
+$Id: utils.scm,v 1.6 1994/11/26 22:06:43 gjr Exp $
Copyright (c) 1994 Massachusetts Institute of Technology
(*unparse-string (substring name 1 (string-length name))))
((new-variable->index symbol)
=> (lambda (index)
+ index ; ignored
(*unparse-string name)
;;(*unparse-string kmp/pp-symbol-glue)
;;(*unparse-string (number->string index))
`(BEGIN ,@actions*)
(car actions*)))
((not (pair? (car actions)))
- (internal-warning "BEGINNIFY: Non-pair form in BEGIN:" (car actions))
+ (internal-warning "BEGINNIFY: Non-pair form in BEGIN:"
+ (car actions))
(loop (cdr actions)
(cons (car actions) actions*)))
((eq? (caar actions) 'BEGIN)
set
(loop (union (proc (car l)) set)
(cdr l)))))
-
-
+\f
(define (remove-duplicates l)
(let loop ((l l) (l* '()))
(cond ((null? l) (reverse! l*))
((memq (car set1) set2) #F)
(else (null-intersection? (cdr set1) set2))))
-\f
(define (list-split ol predicate)
;; (values yes no)
(let loop ((l (reverse ol))
(internal-error "vector-index: component not found"
vector name)))))
+(define (pair-up oone otwo)
+ (let loop ((one oone) (two otwo) (result '()))
+ (cond ((and (not (null? one))
+ (not (null? two)))
+ (loop (cdr one)
+ (cdr two)
+ (cons (cons (car one) (car two))
+ result)))
+ ((or (null? one)
+ (null? two))
+ (internal-error "pair-up: Mismatched lengths" oone otwo))
+ (else
+ (reverse! result)))))
\f
(define-structure (queue
(conc-name queue/)
projects / mit-scheme.git / commitdiff