;;; Interpreter for Stack Development

;;; introduce continuation interface

;;; ****************************************************************

;;; environments

(define extend-env 
  (lambda (names vals old-env)
    (make-extended-env names vals old-env)))

(define extend-rec
  (lambda (decls env)
    (make-extended-rec-env decls env)))

;; apply-env takes a continuation

(define apply-env
  (lambda (env var-sym vk)
    (record-case env
      (empty-env ()
	(error 'apply-env "unbound identifier ~s" var-sym))
      (extended-env (names vals old-env)
	(if (memq var-sym names)
	  (ribassoc var-sym names vals vk)
          (apply-env old-env var-sym vk)))
      (extended-rec-env (decls old-env)
        (letrec
          ((loop 
             (lambda (decls)
               (cond 
                 ((null? decls)
                  (apply-env old-env var-sym vk))
                 ((eq? var-sym (rec-decl->name (car decls)))
                  (apply-valcont vk (car decls) env))  ; no more make-closure
                 (else
                   (loop (cdr decls)))))))
          (loop decls)))
      (else
        (error 'apply-env
          "unknown environment frame ~s"
          env)))))

(define ribassoc
  (lambda (var-sym names vals vk)
    (letrec 
      ((loop
         (lambda (names vals)
           ;; dont need a null test, since we've already done memq
           (if (eq? var-sym (car names))
             (apply-valcont vk (caar vals) (cdar vals))
             (loop (cdr names) (cdr vals))))))
      (loop names vals))))

;;; ****************************************************************

;;; The Interpreter Proper

(define eval-exp
  (lambda (exp env vk)
    (record-case exp
      (lit-exp (constant) (apply-valcont vk constant '*dummy*))
      (var-exp (id) (apply-env env id vk))
      (letrec-exp (decls body)          ; letrec instead of proc
        (eval-exp body (extend-rec decls env) vk))
      (if-exp (test-exp exp1 exp2)
        (eval-exp test-exp env
          (make-test-value-cont exp1 exp2 env vk)))
      (app-exp (rator rands)
        (apply-env env rator
          (make-proc-cont rands env vk)))
      (else (error 'eval-exp "Bad abstract syntax: ~s" exp)))))

(define eval-rands
  (lambda (rands env ak)
    (if (null? rands)
      (apply-ak ak '())
      (eval-exp (car rands) env
        (make-first-arg-cont rands env ak)))))

(define apply-proc
  (lambda (proc proc-env args vk)
    (record-case proc
      (prim-1 (unary-op)
        (apply-valcont vk (apply-unary-primop unary-op (car (car args)))
            '*dummy*))
      (prim-2 (binary-op)
        (apply-valcont vk (apply-binary-primop binary-op
              (car (car args)) (car (cadr args)))
            '*dummy*))
      (rec-decl (name formals body)
        (let ((env proc-env))
          (eval-exp body (extend-env formals args env) 
            (make-app-value-cont vk))))
      (else (error 'apply-proc "Bad Procedure: ~s" proc)))))

;;; ****************************************************************

;;; Value Continuations

(define make-init-cont
  (lambda ()
    (lambda (val val-env) val)))

(define make-test-value-cont
  (lambda (exp1 exp2 env vk)
    (lambda (val val-env)
      (if (true-value? val)
        (eval-exp exp1 env vk)
        (eval-exp exp2 env vk)))))

(define make-first-arg-cont
  (lambda (rands env ak)
    (lambda (first-arg first-arg-env)
      (eval-rands (cdr rands) env
        (make-other-args-cont first-arg first-arg-env ak)))))

(define make-app-value-cont 
  (lambda (vk)
    (lambda (val val-env)
      (if (number? val)
        (apply-valcont vk val val-env)
        (error 'apply-proc
          "Procedure can't return non-number ~s"
          v)))))

(define make-proc-cont
  (lambda (rands env vk)
    (lambda (proc proc-env)
      (eval-rands rands env
        (make-all-args-cont proc proc-env vk)))))

(define apply-valcont
  (lambda (vk val val-env)
    (vk val val-env)))


;;; Args Continuations

(define make-all-args-cont
  (lambda (proc proc-env vk)
    (lambda (args)
      (apply-proc proc proc-env args vk))))

(define make-other-args-cont
  (lambda (first-arg first-arg-env ak)
    (lambda (other-args)
      (apply-ak ak (cons 
            (cons first-arg first-arg-env)
            other-args)))))

(define apply-ak
  (lambda (ak args)  
    (ak args)))

;;; *****************************************************************

;;; The Initial Environment

(define build-init-env
  (lambda (entries)
    (extend-env
      (map car entries)
      (map (lambda (entry)
             (let ((op (cadr entry))
                   (arity (caddr entry)))
               (cond
                 ((= arity 1) (cons (make-prim-1 op) '*dummy*))
                 ((= arity 2) (cons (make-prim-2 op) '*dummy*))
                 (else (error 'build-init-env
                         "unknown arity in entry ~s" entry)))))
           entries)
      (make-empty-env))))


;;; ****************************************************************

;;; toplevel

(define run
  (lambda (string)
    (eval-exp (scan&parse string) (make-init-env) (make-init-cont))))