;; Interpreter (by Amr Sabry)
;; implements proc using records (it would be ok to use Scheme's lambda)
;; implements assignments using Scheme's boxes
;; implements recursion using assignments
;; implements error using call/cc (the call/cc is in the read-eval-print loop)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Globals

(load "defsyn-appa.ss")
(load "abstract-syntax.ss")
(load "scanner.ss")
(load "parser.ss")
(load "streams.ss")
(load "rep.ss")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Portion of "rep.ss" that changed

(define eval-print
  (lambda (tree)
    (let ((result (call/cc
		    (lambda (k)
		      (set! init-cont k)
		      (eval-exp tree init-env)))))
      (if (not (or (define? tree)
		   (varassign? tree)))
	  (write result)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Interpreter

;; Run time values

(define-record prim-proc (prim-op))
(define-record closure (formals body env))

(define init-cont '*)   ;; assigned from the read-eval-print loop

(define true-value? (lambda (x) (not (zero? x))))

;; Environments

(define-record empty-env ())

(define-record ext-env (vars vals env))

(define init-env
  (make-ext-env
    '(+ - * add1 sub1 error catch)
    (map (lambda (x) (box (make-prim-proc x)))
	 '(+ - * add1 sub1 error catch))
    (make-empty-env)))

(define apply-env
  (lambda (env var)
    (variant-case env
      [ext-env (vars vals env)
	(if (memv var vars)
	    (cdr (assoc var (map cons vars vals)))
	    (apply-env env var))]
      [empty-env () (error "apply-env: Unbound variable" var)]
      [else (error "apply-env: Unknown environment" env)])))

(define update-env
  (lambda (env newvals)
    (variant-case env
      [ext-env (vars vals env)
	(for-each (lambda (cell new) (set-box! cell new))
	  vals newvals)]
      [else (error "update-env: Impossible")])))

;; Interpreter

(define eval-exps
  (lambda (exps env)
    (if (null? exps)
	'()
	(let ([expv (eval-exp (car exps) env)])
	  (cons expv (eval-exps (cdr exps) env))))))
	  
(define eval-exp
  (lambda (exp env)
    (variant-case exp
      [lit (datum) datum]
      [varref (var) (unbox (apply-env env var))]
      [if (test-exp then-exp else-exp)
	(if (true-value? (eval-exp test-exp env))
	    (eval-exp then-exp env)
	    (eval-exp else-exp env))]
      [let (decls body)
	(let* ([vars (map decl->var decls)]
	       [rhss (map decl->exp decls)]
	       [rhss-vals (map box (eval-exps rhss env))]
	       [new-env (make-ext-env vars rhss-vals env)])
	  (eval-exp body new-env))]
      [varassign (var exp)
	(set-box! (apply-env env var) (eval-exp exp env))]
      [begin (exp1 exp2) 
	(begin (eval-exp exp1 env) (eval-exp exp2 env))]
      [proc (formals body)
	(make-closure formals body env)]
      [app (rator rands)
	(let ([fun (eval-exp rator env)]
	      [args (eval-exps rands env)])
	  (apply-proc fun args))]
      [letrec (decls body)
	(let* ([vars (map decl->var decls)]
	       [rhss (map decl->exp decls)]
	       [holders (map (lambda (dummy) (box '**undefined**)) rhss)]
	       [new-env (make-ext-env vars holders env)]
	       [rhss-vals (eval-exps rhss new-env)])
	  (update-env new-env rhss-vals)
	  (eval-exp body new-env))]
      )))

(define apply-proc
  (lambda (proc args)
    (variant-case proc
      [prim-proc (prim-op) (apply-prim-op prim-op args)]
      [closure (formals body env)
	(eval-exp body
	  (make-ext-env formals (map box args) env))]
      [cont (k) (k (car args))]
      [else (error "apply-proc: Unknown procedure" proc)])))

(define apply-prim-op
  (lambda (p args)
    (case p
      [(+) (+ (car args) (cadr args))]
      [(-) (- (car args) (cadr args))]
      [(*) (* (car args) (cadr args))]
      [(add1) (+ (car args) 1)]
      [(sub1) (- (car args) 1)]
      '[(error) (init-cont (car args))]
      [(error) (error "Jumping out" (car args))]
      [(catch) (call/cc
		 (lambda (k)
		   (apply-proc (car args) (list (make-cont k)))))])))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;