;; see roots_of_lisp.ps for a similar approach

(setq *global-env* nil)
(setq *the-false-value* (cons `false `boolean))

(defun evaluate (e env)
  (cond
   ((symbolp e) (lookup e env))
   ((atom e) e)
   ((listp e)
    (cond
     ((eq (car e) `lambda) (build-function (cadr e) (cddr e)))
     ((eq (car e) `quote) (cadr e))
     ((eq (car e) `set) (update (cadr e) (evaluate (caddr e) env) env))
     ((eq (car e) `if) (if (not (eq (evaluate (cadr e) env)
                                    *the-false-value*))
                           (evaluate (caddr e) env)
                         (evaluate (cadddr e) env)))))
   (t (error "undefined")) ) )

(defun evlis (l env)
  (cond 
   ((null l) nil)
   (t (cons (evaluate (car l) env) 
            (evlis (cdr l) env))) ) )

(defun eprogn (p env)
  (cond
   ((null p) nil)
   (t (evaluate (car p) env) (eprogn (cdr p) env))))

;;***********************************************************************
;; ENVIRONMENT

(defun lookup (s env)
  (cond 
   ((null env) nil)
   ((eq s (caar env)) (cdar env))
   ( t (lookup s (cdr env)))))

(defun insert (sym val)
  (setq *global-env* (cons (cons sym val) *global-env*)))

(defun update (sym val env)
  (cond
   ((null env) (error "no such variable to update"))
   ((eq sym (caar env)) (setcdr (car env) val))
   (t (update sym val (cdr env))) ))

(defun extend (vars vals env)
  (cond 
   ((null vars) (if (not (null vals)) (error "formals/actuals mismatch") env))
   (t (cons (cons (car vars) (car vals)) (extend (cdr vars) (cdr vals) env)))))

(defun build-function (formals body)
  (cons formals body))