;;; MIT 6.001 lecture notes, Nov 5, 1998.
;;; a meta-circular evaluator which can evaluate itself.

(define mc-eval (lambda (exp env)
		  (cond ((number? exp) exp)                     ;base-case
			((symbol? exp) (lookup exp env))        ;base case
			((eq? (car exp) 'quote) (car (cdr exp)));special forms
			((eq? (car exp) 'cond) (evcond (cdr exp) env))
			((eq? (car exp) 'begin) (evseq (cdr exp) env))
			((eq? (car exp) 'lambda) (list 'proc (cdr exp) env))
			((eq? (car exp) 'define) (evdefine (cdr exp) env))
			(else (mc-apply (mc-eval (car exp) env)
					(evlist (cdr exp) env))))))

(define mc-apply (lambda (fun args)
		   (cond ((not (pair? fun)) (apply fun args))   ;ground out
			 ((eq? (car fun) 'proc)
			  (mc-eval (car (cdr (car (cdr fun))))  ;procedure body
				   (bind (car (car (cdr fun)))  ;formal params
					 args                   ;supplied args
					 (car (cdr (cdr fun))))));saved env
			 (else (error '"Unknown function")))))

(define evlist (lambda (lst env)        ;map evaluator over list
		 (cond ((null? lst) '())
		       (else (cons (mc-eval (car lst) env)
				   (evlist (cdr lst) env))))))

(define evcond (lambda (clauses env)
		 (cond ((null? clauses) '())
		       ((eq? 'else (car (car clauses))) (evseq (cdr (car clauses)) env))
		       ((mc-eval (car (car clauses)) env) (evseq (cdr (car clauses)) env))
		       (else (evcond (cdr clauses) env)))))

(define evseq (lambda (clauses env)
		(cond ((null? (cdr clauses)) (mc-eval (car clauses) env))
		      (else (mc-eval (car clauses) env)
			    (evseq (cdr clauses) env)))))

(define evdefine (lambda (body env)     ;mutate the first frame
		   (begin (set-cdr! (car env)
				    (cons (cons (car body) (mc-eval (car (cdr body)) env))
					  (cdr (car env))))
			  (car body))))

(define bind (lambda (params values env) ;add a new frame
	       (cons (cons 'frame (make-frame-body params values)) env)))

(define make-frame-body (lambda (params values) ;frame body is an association list
			  (cond ((null? params)
				 (cond ((null? values) '())
				       (else (error '"Too many values supplied"))))
				((null? values) (error '"Too few values supplied"))
				(else (cons (cons (car params) (car values))
					    (make-frame-body (cdr params) (cdr values)))))))

(define lookup (lambda (var env)
		 (cond ((null? env) (error '"Unbound variable" var)) ;not in any frames
		       (else ((lambda (binding)
				(cond ((null? binding)         ;check each frame
				       (lookup var (cdr env))) ;in turn
				      (else (cdr binding))))   ;(<varname> . <value>)
			      (find-binding var (cdr (car env))))))))

(define find-binding (lambda (var frame-body) ;this is just assq
		       (cond ((null? frame-body) '())
			     ((eq? var (car (car frame-body))) (car frame-body))
			     (else (find-binding var (cdr frame-body))))))

(define global-env
  (list (list 'frame
              (cons '+ +) (cons '- -) (cons '= =) (cons '* *)
              (cons 'car car) (cons 'cdr cdr) (cons 'cons cons) (cons 'list list) 
              (cons 'set-car! set-car!) (cons 'set-cdr! set-cdr!)
              (cons 'null? null?) (cons 'eq? eq?) (cons 'pair? pair?) (cons 'not not)
              (cons 'number? number?) (cons 'symbol? symbol?)
              (cons 'error error) (cons 'apply apply))))