;; An expval is 
;;   * number, or
;;   * closure

;; A denval is an expval

;; The language:
;;  <expr> = <number>                        ;; a number
;;         | @<number>                       ;; looks up a value in the env
;;         | [<expr>]                        ;; creates a closure (1 arg)
;;         | call(<expr>, <expr>)            ;; applies a closure (1 arg)
;;         | ifzero(<expr>, <expr>, <expr>)  ;; branch
;;         | +(<expr>, <expr>)               ;; add
;;         | -(<expr>, <expr>)               ;; subtract
;;         | {[<expr>], <expr>}              ;; recursive local binding

;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;

(define the-lexical-spec
  '((whitespace (whitespace) 
                skip)
    (id (letter (arbno (or letter digit "?")))
        make-symbol)
    (number ((or "" "-" "+") digit (arbno digit))
            make-number)))

(define the-grammar
  '((expression (number) lit-exp)
    (expression ("@" number) lookup-exp)
    (expression ("[" expression "]") proc-exp)
    (expression ("call" "(" expression "," expression ")") app-exp)
    (expression ("ifzero" 
		 "(" expression 
		 "," expression 
		 "," expression ")") 
		ifzero-exp)
    (expression ("+" "(" expression "," expression ")") add-exp)
    (expression ("-" "(" expression "," expression ")") subtract-exp)
    (expression ("{" "[" expression "]" 
		 "," expression "}") 
		letrec-exp)))

(sllgen:make-define-datatypes the-lexical-spec
                              the-grammar)

(define-datatype
  closure closure?
  (a-closure (env environment?)
	     (body expression?)))

;;;;;;;;;;;;;;;; top level ;;;;;;;;;;;;;;;;

; read-eval-print : -> [loops forever]
(define read-eval-print
  (lambda ()
    ((sllgen:make-rep-loop "-->"
			   (lambda (x) (eval-expression x (empty-env)))
                           (sllgen:make-stream-parser
                            the-lexical-spec
                            the-grammar)))))

; run : string -> expval
;
; Takes a string respresting concrete syntax and
; evaluates it, returning the result.
;
;  (run "5") = _5_
;  (run "[1]") = _(a-closure (empty-env) (lit-exp 1))_
;  (run "call([@0], 1)") = _1_
;  (run "call([call(call(@0, @0), 10)], [[ifzero(@0,0,+(@0,call(call(@1, @1),-(@0,1))))]])") = 55
;
(define run
  (lambda (string)
    (eval-expression (scan&parse string) (empty-env))))

(define scan&parse
  (sllgen:make-string-parser the-lexical-spec the-grammar))

;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;

; eval-expression : expression env -> expval
;
; Evaluates an expression in the given environment.
;
;  (eval-expression (lit-exp 5) (empty-env)) = 5
;  (eval-expression (lookup-exp 1) 
;                   (extend-env 42 (extend-env 43 (empty-env)))) = 43
;  (eval-expression (app-exp (proc-exp (lookup-exp 0)) 
;                            (lit-exp 42)) 
;                   (empty-env)) = 42
;
(define eval-expression 
  (lambda (exp env)
    (cases expression exp
      (lit-exp (sym) sym)
      (lookup-exp (cn) (apply-env env cn))
      (proc-exp (body) (a-closure env body))
      (app-exp (rator rand)
	       (let ([func (eval-expression rator env)]
		     [arg (eval-expression rand env)])
		 (apply-proc func arg)))
      (ifzero-exp (test then else)
		  (if (zero? (eval-expression test env))
		      (eval-expression then env)
		      (eval-expression else env)))
      (add-exp (a b) (+ (eval-expression a env)
			(eval-expression b env)))
      (subtract-exp (a b) (- (eval-expression a env)
			     (eval-expression b env)))
      (letrec-exp (proc-body letrec-body)
		  (eval-expression letrec-body
				   (recursive-extend-env
				    proc-body
				    env))))))

; apply-proc : proc expval -> expval
(define (apply-proc func arg)
  (cases closure func
	 (a-closure (env body)
		    (eval-expression
		     body
		     (extend-env
		      arg
		      env)))))

;;;;;;;;;;;;;;;; environments ;;;;;;;;;;;;;;;;

;; Abstract envrionment datatype implementation.

(define (denval? x) 
  (or (number? x) (closure? x)))

(define-datatype environment environment?
  (empty-env-rec)
  (extended-env-rec
    (val denval?)
    (env environment?))
  (recursively-extended-env-rec
    (expr expression?)
    (old-env environment?)))

; empty-env : -> env
(define empty-env
  (lambda ()
    (empty-env-rec)))

; extend-env : denval env -> env 
(define extend-env
  (lambda (val env)
    (extended-env-rec val env)))

; recursive-extend-end : expr env -> env
(define recursive-extend-env
  (lambda (expr env)
    (recursively-extended-env-rec expr env)))

; apply-env : env num -> denval
(define apply-env
  (lambda (env cn)
    (cases environment env
      (empty-env-rec ()
        (eopl:error 'apply-env "lookup too deep"))
      (extended-env-rec (val env)
	(if (zero? cn)
            val
            (apply-env env (- cn 1))))
      (recursively-extended-env-rec (expr old-env)
	(if (zero? cn)
            (a-closure env expr)
            (apply-env old-env (- cn 1)))))))