;;; Interpreter for lambda calculus expressions
;;;   - Lit and var expressions
;;;   - If expressions
;;;   - Applications
;;;   - Lambda expressions (multi bodied)
;;;   - call/cc
;;;   - break
;;;   - exit

(load "chez-init.ss")
(load "env.ss")
(load "cont.ss")
(load "parser.ss")
(define (rl) (load "interpreter.ss"))

(define eval-one-exp
  (lambda (exp)
    (top-level-eval (parse-expression exp))))


(define rep
  (lambda ()
    (display ">> ")
    (top-level-eval (parse-expression (read))
		    (rep-cont))))


(define top-level-eval
  (lambda (form cont)
    (eval-expression form cont global-env)))

(define eval-expression
  (lambda (exp cont env)
    (cases expression exp
	   [var-exp (id) (apply-cont cont (apply-env env id))]
	   [lit-exp (val) (apply-cont cont val)]
	   [break-exp (val) (eval-expression val (rep-cont) env)]
	   [exit-exp () (newline)]
           [lambda-exp (syms bodies)
		       (apply-cont cont (closure syms bodies env))]
	   [call/cc-exp (receiver)
			(eval-expression receiver (call/cc-cont cont) env)]
	   [app-exp (all-of-it)
		    (eval-expressions all-of-it
				      (proc-cont cont)
				      env)]  
	   [if-exp (test-exp true-exp false-exp)
		   (eval-expression test-exp
				    (if-cont true-exp false-exp cont env)
				    env)])))

(define eval-expressions
  (lambda (exps k env)
    (if (null? exps)
	(apply-cont k '())
	(eval-expression (car exps) 
			 (eval-cont (cdr exps) k env)
			 env))))

(define eval-bodies
  (lambda (exps k env)
    (if (null? (cdr exps))
	(eval-expression (car exps) k env)
	(eval-expression (car exps) 
			 (eval-bodies-cont (cdr exps) k env)
			 env))))


(define apply-procedure
  (lambda (procedure args cont)
    (cases proc procedure
	   [closure (ids bodies env)
		    (eval-bodies bodies cont (extend-env ids args env))]
	   [acontinuation (cont)
			  (apply-cont cont (car args))]
	   [primitive (name)
		      (apply-cont cont (apply-primitive-procedure name args))])))



(define apply-primitive-procedure
  (lambda (name args)
    (case name
      [(+) (apply + args)]
      [(*) (apply * args)]
      [(/) (apply / args)]
      [(-) (apply - args)]
      [(list) args]
      [(cons) (cons (car args) (cadr args))]
      [(car) (caar args)]
      [(cdr) (cdar args)]
      [(display) (car args)])))



(define-datatype proc proc?
  [closure
   (ids (list-of symbol?))
   (bodies (list-of expression?))
   (env pair?)]
  [acontinuation
   (cont continuation?)]
  [primitive
   (name symbol?)])


(define primitive-procedure-names '(+ - * / display list cons car cdr))

(define global-env
  (extend-env primitive-procedure-names
	      (map primitive primitive-procedure-names)
	      (empty-env)))