;-----------------------------------------------------------------------
; lisp.scm
; David Boozer
; 25 January 2009 (modified)
;-----------------------------------------------------------------------
; Lisp interpreter, written in lisp.  The interpreter is capable of
; interpreting itself.
;-----------------------------------------------------------------------

(define lisp
  '(lambda (sexp env)
     (let ((ueval-sexp-helper
	    (lambda (f sexp env)
	      (let ((ueval-list
		     (lambda (lst env)
		       (map (lambda (x) (f f x env)) lst)))
		    (ueval-cond-helper
		     (lambda (g sexp env)
		       (if (f f (first (first sexp)) env)
			   (f f (second (first sexp)) env)
			   (g g (cdr sexp) env)))))
		(let ((ueval-let
		       (lambda (sexp env)
			 (f f (second sexp)
			    (append
			     (pair (map first (first sexp))
				   (ueval-list (map second (first sexp)) env))
			     env))))
		      (ueval-cond
		       (lambda (sexp env)
			 (ueval-cond-helper ueval-cond-helper sexp env))))
		  (cond
		   ((eqv? sexp 'eqv?) eqv?)
		   ((eqv? sexp 'list?) list?)
		   ((eqv? sexp 'null?) null?)
		   ((eqv? sexp 'symbol?) symbol?)
		   ((eqv? sexp 'cons) cons)
		   ((eqv? sexp 'cdr) cdr)
		   ((eqv? sexp 'car) car)
		   ((eqv? sexp 'first) first)
		   ((eqv? sexp 'second) second)
		   ((eqv? sexp 'third) third)
		   ((eqv? sexp 'fourth) fourth)
		   ((eqv? sexp 'assoc) assoc)
		   ((eqv? sexp 'pair) pair)
		   ((eqv? sexp 'append) append)
		   ((eqv? sexp 'map) map)
		   ((eqv? sexp 'apply) apply)
		   ((eqv? sexp '+) +)
		   ((eqv? sexp '-) -)
		   ((eqv? sexp '*) *)
		   ((list? sexp)
		    (cond
		     ((null? sexp) sexp)
		     ((eqv? (car sexp) 'quote) (second sexp))
		     ((eqv? (car sexp) 'let) (ueval-let (cdr sexp) env))
		     ((eqv? (car sexp) 'cond) (ueval-cond (cdr sexp) env))
		     ((eqv? (car sexp) 'if)
		      (if (f f (second sexp) env)
			  (f f (third sexp) env)
			  (f f (fourth sexp) env)))
		     ((eqv? (car sexp) 'lambda)
		      (lambda x (f f (third sexp)
				   (if (list? (second sexp))
				       (append (pair (second sexp) x) env)
				       (cons (cons (second sexp) x) env)))))
		     (#t (apply (f f (car sexp) env)
				(ueval-list (cdr sexp) env)))))
		   ((symbol? sexp) (cdr (assoc sexp env)))
		   (#t sexp)))))))
       (ueval-sexp-helper ueval-sexp-helper sexp env))))


; Demonstrate the lisp interpreter

((eval-top lisp)
 '(map (lambda (x) (cons x x)) '(a b c))
 ())

; Demonstrate the lisp interpreter interpreting itself

((eval-top lisp)
 (list lisp ''(map (lambda (x) (cons x x)) '(a b c)) ())
 ())