;;; Expand.scheme
;;; Copyright Ó 1988, 1989, 1991 by Xerox Corporation. All rights reserved.
;;; Michael Plass, January 20, 1989 3:55:49 pm PST
;;; Last changed by Pavel on March 22, 1989 3:15:53 pm PST
(define (expand-once form . rest)
"(form [env]) Do one step of the expansion of the given form in the given environment (or the USER environment if not provided)"
(let ((env (if (null? rest) user (car rest))))
(if (and (pair? form)
(symbol? (car form))
(environment-bound? env (car form)))
(let ((value (environment-ref env (car form))))
(if (syntax? value)
(apply (syntax-expander value) (cdr form))
form))
form)))
(define (expand form . rest)
"(form [env]) Expand the form to ground terms in the environment given (or USER)"
(let ((env (if (null? rest)
(define (cmap fn lst)
"conservative map; avoids cons where possible"
(if (null? lst)
lst
(let ((head (fn (car lst)))
(tail (cmap fn (cdr lst))))
(if (and (eq? head (car lst))
(eq? tail (cdr lst)))
lst
(cons head tail)))))
(define (inner form)
(let ((xform (expand-once form env)))
(if (eq? form xform)
(if (pair? form)
(case (car form)
((#!quote) form)
((#!lambda)
(let ((xbody (cmap inner (cddr form))))
(if (eq? xbody (cddr form))
form
`(#!lambda ,(cadr form) ,@xbody))))
((primitive-let-syntax)
(let ((new-env (make-environment "let-syntax" env)))
(for-each (lambda (binding)
(environment-define!
new-env
(car binding)
(make-syntax
(eval (cadr binding) user))))
(cadr form))
(expand `(begin ,@(cddr form)) new-env)))
;; if, begin, define, and set! are handled properly by the else case
(else (cmap inner form)))
form)
(inner xform))))
(inner form)))
(define (expand-file file-name-root)
"writes a version of the file with the syntax expanded to ground terms"
(let* ((input-file-name (string-append file-name-root ".scheme"))
(output-file-name (string-append file-name-root ".$cheme"))
(in (open-input-file input-file-name))
(out (open-output-file output-file-name)))
(let loop ((form (read in)))
(unless (eof-object? form)
(let ((xform (expand form user)))
(binary-write xform out)
(newline out)
(when (and (pair? xform)
(eq? (car xform) '#!define)
(pair? (cdr xform)))
(format #t "~S~%" (cadr xform)))
(loop (read in)))))
(close-input-port in)
(close-output-port out)))
(define *system-syntax-expander* expand)