

(export (eval expand-once expand)


(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)"
(expand1 form (if (null? rest) user (car rest))))

(define (expand1 form env)
(if (and (pair? form)
      (symbol? (car form))
      (bound? env (car form)))
(let ((value (lookup env (car form))))
(if (syntax? value)
(apply (syntax-expander value) (cdr form))
form))
form))

(define (expand* form env)
(let ((xform (expand1 form env)))
(if (eq? form xform)
xform
(expand* xform env))))

(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 (expand form . rest)
"(form [env]) Expand the form to ground terms in the environment given (or USER)"
(define (inner form env)
(let ((form (expand* form env)))
(if (pair? form)
(case (car form)
((#!quote) form)
((#!lambda) 
(let ((xbody (cmap (lambda (f) (inner f env)) (cddr form))))
(if (eq? xbody (cddr form))
form
`(#!lambda ,(cadr form) ,@xbody))))
((primitive-let-syntax)
(let ((bindings (cadr form)))
(inner `(begin ,@(cddr form))
(extend-env env (map car bindings)
(map (lambda (binding)
     (make-syntax
     (eval (cadr binding) env))
  bindings))))))
;; if, begin, define, and set! are handled properly by the else case
(else (cmap (lambda (f) (inner f env)) form)))
form)))

(inner form (if (null? rest) user (car rest))))


(define (extend-env env names values)
(cons (map cons names values) env))

(define (lookup env id)
(if (environment? env)
(environment-ref env id)
(let ((pair (assq id (car env))))
(if pair
(cdr pair)
(lookup (cdr env) id)))))

(define (set env id value)
(if (environment? env)
(environment-set! env id value)
(let ((pair (assq id (car env))))
(if pair
(set-cdr! pair value)
(set (cdr env) id value)))))

(define (bound? env id)
(if (environment? env)
(environment-bound? env id)
(if (assq id (car env))
#t
(bound? (cdr env) id))))


(define (eval form env)
(let ((form (expand* form env)))
(if (pair? form)
(case (car form)
((#!quote)
(cadr form))
((#!if)
(if (eval (cadr form) env)
(eval (caddr form) env)
(eval (cadddr form) env)))
((#!set!)
(if (symbol? (cadr form))
(set env (cadr form) (eval (caddr form) env))
(error 'eval (cadr form) "Illegal identifier in SET!")))
((#!begin)
(if (null? (cdr form))
#!unspecified
(let loop ((first (cadr form))
        (rest (cddr form)))
(cond
((null? rest)
(eval first env))
(else
(eval first env)
(loop (car rest) (cdr rest)))))))
((#!lambda)
(let ((params (cadr form))
   (body `(#!begin ,@(cddr form))))
(let loop ((params params))
(if (pair? params)
(loop (cdr params))
(unless (or (null? params) (symbol? params))
(error 'eval (cadr form) "Illegal parameter list"))))
(lambda args
"An interpreted procedure"
(eval body
(let loop ((frame '())
        (args args)
     (params params))
(cond
((symbol? params)
(cons `((,params . ,args) ,@frame) env))
((null? params)
(cons frame env))
(else	; must be a pair, we tested above
(loop
`((,(car params) . ,(car args)) ,@frame)
(cdr args)
(cdr params)))))))))
((#!define)
(if (symbol? (cadr form))
(if (environment? env)
(environment-define! env (cadr form)
(eval (caddr form) env))
(error 'eval form "Misplaced DEFINE form."))
(error 'eval (cadr form) "Illegal identifier in DEFINE")))
(else
(let ((values (map (lambda (form) (eval form env)) form)))
(apply (car values) (cdr values)))))

;; FORM is not a pair
(cond
((symbol? form)
(lookup env form))
((or (boolean? form)
  (number? form)
  (string? form)
  (char? form))
form)
(else
(error 'eval form "Illegal expression -- should be quoted"))))))
) ; end export
     
;;; Eval.scheme
;;; Copyright Ó 1989, 1991 by Xerox Corporation.  All rights reserved.
;;; Last changed by Pavel on March 6, 1989 3:59:20 pm PST
;;; DO NOT RUN THIS CODE INTERPRETED!!
;;; Macro expansion
;;; Environment management
;;; Evaluation
;; Check parameter list now
 ÊÒ  •NewlineDelimiter
–(cedarcode) style™ ™JšœÐetœ7™FJ™9—J˜ JšœÏb"™&J˜ J˜ ˜!J˜ ™J˜ ˜!J˜€J˜1—J˜ ˜˜J˜J˜˜&˜J˜*J˜——J˜——J˜ ˜˜!˜J˜J˜———J˜ ˜J˜.˜J˜˜J˜˜J˜J˜J˜————J˜ šœ˜JšœQ˜Q˜˜ ˜šœ˜Jšœ˜šœ˜šœ<˜<šœ˜Jšœ˜Jšœ#˜#———˜˜˜˜"˜˜J˜—J˜—————JšÑbosD˜DJšœ.˜.—J˜———˜ J˜/———J˜ ™J˜ ˜%J˜#—J˜ ˜˜J˜˜!˜J˜
J˜————J˜ ˜˜J˜˜!˜J˜J˜————J˜ ˜˜J˜˜J˜J˜————J˜ ™J˜ ˜˜ ˜˜˜
J˜—˜˜J˜J˜——˜	˜J˜-J˜8——˜
˜J˜˜J˜˜˜J˜—˜J˜J˜!—————˜˜J˜#J™˜˜J˜˜,J˜5———˜J˜˜
˜˜J˜—˜˜J˜(—˜J˜—˜'˜J˜(J˜
J˜————————˜˜˜J˜=J˜,—J˜:——˜˜:J˜$———J˜ J˜˜˜J˜—˜J˜J˜J˜J˜—˜J˜@———————J˜— …—    À  ¬  