;;; Interpreter for lambda calculus expressions
;;;   - Lit and var expressions
;;;   - If expressions
;;;   - Applications
;;;   - Lambda expressions (multi bodied)
;;;   - call/cc
;;;   - break
;;;   - exit
;;;   - let
;;;   - set!
;;;   - define (but may appear anywhere)
;;;   - begin (converted to lambda/app in parser)

(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) (halt-cont))))


(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
           [label-exp (num exp) (eval-expression exp (label-cont num cont) env)]
	   [goto-exp (num) (goto num cont)]
	   [var-exp (id) (apply-cont cont (apply-env env id))]
	   [lit-exp (val) (apply-cont cont val)]
           [set-exp (sym val)
		    (eval-expression val (change-cont sym env cont) env)]
           [define-exp (sym val)
		    (eval-expression val (define-cont sym env cont) env)]
	   [break-exp (exps) (eval-expressions exps (break-cont cont) env)]
	   [exit-exp () (newline)]
           [lambda-exp (syms bodies)
		       (apply-cont cont (closure syms bodies env))]
           [let-exp (syms vals bodies)
		    (eval-expressions vals (let-cont syms bodies env cont) 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 goto
  (lambda (num cont)
    (cases continuation cont
	   [label-cont (n cont)
		       (if (eq? num n)
			   (apply-cont cont 0)
			   (goto num cont))]
	   [halt-cont ()
		      'error]
	   [rep-cont ()
		      'error]	   
	   [break-cont (cont)		       
 		      (goto num cont)]
	   [change-cont (sym env cont)
 		      (goto num cont)]
	   [define-cont (sym env cont)
 		      (goto num cont)]
	   [let-cont (syms bodies env cont)
 		      (goto num cont)]
	   [call/cc-cont (cont)
 		      (goto num cont)]
	   [eval-cont (exps cont env)
 		      (goto num cont)]
	   [eval-bodies-cont (exps cont env)
 		      (goto num cont)]
	   [proc-cont (cont)
 		      (goto num cont)]
	   [cons-cont (v cont)
 		      (goto num cont)]
	   [if-cont (true-exp false-exp cont env)
		    (goto num cont)])))



(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)]
      [(<) (< (car args) (cadr args))]
      [(list) args]
      [(cons) (cons (car args) (cadr args))]
      [(=) (= (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)))