;; The following Scheme evaluator is based on a routine
described in <a
href="http://mitpress.mit.edu/sicp/full-text/book/book-Z-H-26.html#%_sec_4.1">Section 4.1</a> of Abelson and Sussman's <a
href="http://mitpress.mit.edu/sicp/full-text/book/book.html">
<cite>Structure and Interpretation of Computer Programs.</cite></a>
<xmp>
(define lookup
  (lambda (var env)
    (if (null? env)
        (error 'lookup "Variable is undefined.")
        (let ((val (assoc var (car env))))
          (if val
              (car (cdr val))
              (lookup var (cdr env)))))))

;; adds defn to first frame of env
(define add-defn!
  (lambda (var val env)
    (set-car! env (cons (list var val) (car env)))
    'ok))

(define lookup!
  (lambda (var val env)
    (if (null? env)
        (error 'lookup! "Variable is undefined.")
        (let ((old (assoc var (car env))))
          (if old
              (set-car! (cdr old) val)
              (lookup! var val (cdr env)))))
    'ok))

(define make-frame
  (lambda (vars vals)
    (map list vars vals)))

(define make-function
  (lambda (args body env)
    (list 'function args body env)))

(define function?
  (lambda (sexpr)
    (and (pair? sexpr)
         (eq? (car sexpr) 'function))))

(define function-args
  (lambda (func)
    (cadr func)))

(define function-body
  (lambda (func)
    (caddr func)))

(define function-env
  (lambda (func)
    (cadddr func)))

(define quote?
  (lambda (sexpr)
    (eq? (car sexpr) 'quote)))

(define quote-argument
  (lambda (sexpr)
    (cadr sexpr)))

(define if?
  (lambda (sexpr)
    (eq? (car sexpr) 'if)))

(define if-condition
  (lambda (sexpr)
    (cadr sexpr)))

(define if-consequent
  (lambda (sexpr)
    (caddr sexpr)))

(define if-alternative
  (lambda (sexpr)
    (cadddr sexpr)))

(define define?
  (lambda (sexpr)
    (eq? (car sexpr) 'define)))

(define define-var
  (lambda (sexpr)
    (cadr sexpr)))

(define define-val
  (lambda (sexpr)
    (caddr sexpr)))

(define set!?
  (lambda (sexpr)
    (eq? (car sexpr) 'set!)))

(define set!-var
  (lambda (sexpr)
    (cadr sexpr)))

(define set!-val
  (lambda (sexpr)
    (caddr sexpr)))

(define lambda?
  (lambda (sexpr)
    (eq? (car sexpr) 'lambda)))

(define lambda-args
  (lambda (sexpr)
    (cadr sexpr)))

(define lambda-body
  (lambda (sexpr)
    (cddr sexpr)))

(define let?
  (lambda (sexpr)
    (eq? (car sexpr) 'let)))

(define let-args
  (lambda (sexpr)
    (map car (cadr sexpr))))

(define let-vals
  (lambda (sexpr)
    (map cadr (cadr sexpr))))

(define let-body
  (lambda (sexpr)
    (cddr sexpr)))

(define let->lambda
  (lambda (sexpr)
    `((lambda ,(let-args sexpr) ,@(let-body sexpr)) ,@(let-vals sexpr))))

(define begin?
  (lambda (sexpr)
    (eq? (car sexpr) 'begin)))

(define begin-body
  (lambda (sexpr)
    (cdr sexpr)))

(define application-func
  (lambda (sexpr)
    (car sexpr)))

(define application-args
  (lambda (sexpr)
    (cdr sexpr)))

(define meta-eval
  (lambda (sexpr env)
    (cond ((number? sexpr) sexpr)
          ((symbol? sexpr) (lookup sexpr env))
          ((quote? sexpr) (quote-argument sexpr))
          ((define? sexpr)
           (add-defn! (define-var sexpr) 
                      (meta-eval (define-val sexpr) env)
                      env))
          ((set!? sexpr)
           (lookup! (set!-var sexpr)
                    (meta-eval (set!-val sexpr) env)
                    env))
          ((if? sexpr)
           (if (meta-eval (if-condition sexpr) env)
               (meta-eval (if-consequent sexpr) env)
               (meta-eval (if-alternative sexpr) env)))
          ((lambda? sexpr)
           (make-function (lambda-args sexpr)
                          (lambda-body sexpr) 
                          env))
	  ((begin? sexpr)
	   (eval-sequence (begin-body sexpr) env))
          ((let? sexpr)
           (meta-eval (let->lambda sexpr) env))
          (else
           (meta-apply (meta-eval (application-func sexpr) env)
                       (map (lambda (arg) (meta-eval arg env))
                            (application-args sexpr)))))))

(define eval-sequence
  (lambda (body env)
    (cond ((null? (cdr body))
	   (meta-eval (car body) env))
	  (else
	   (meta-eval (car body) env)
	   (eval-sequence (cdr body) env)))))

(define meta-apply
  (lambda (func vals)
    (if (procedure? func)
	(apply func vals)
	(eval-sequence (function-body func)
		       (cons (make-frame (function-args func) vals) 
			     (function-env func))))))

(define global-env 
  `(((car ,car) (cdr ,cdr) (cons ,cons) (eq? ,eq?)
     (+ ,+) (- ,-) (* ,*) (/ ,/) (> ,>) (apply ,meta-apply) 
     (number? ,number?) (symbol? ,symbol?) (pair? ,pair?))))

(define scheme
  (lambda ()
    (letrec
      ((loop 
        (lambda ()
          (display "$ ")
          (let ((input (read)))
	    (cond ((equal? input '(exit))
		   (void))
		  (else
		   (display (meta-eval input global-env))
		   (newline)
		   (loop)))))))
      (display "Welcome to Scheme!")
      (newline)
      (loop))))
</xmp>