;;; Interpreter for Stack Development

(printf "interp2.s Fri May 28 11:23:10 1993~%")

;;; no closures in this version--
;;; value continuations take 2 args

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

;;; 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)))
                  (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))
             (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) (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
          (lambda (val val-env)
            (if (true-value? val)
              (eval-exp exp1 env vk)
              (eval-exp exp2 env vk)))))
      (app-exp (rator rands)
        (apply-env env rator
          (lambda (proc proc-env)
            (eval-rands rands env           
              (lambda (args)
                (apply-proc proc proc-env args vk))))))
      (else (error 'eval-exp "Bad abstract syntax: ~s" exp)))))

(define eval-rands
  (lambda (rands env ak)
    (if (null? rands)
      (ak '())
      (eval-exp (car rands) env
        (lambda (first-arg first-arg-env)
          (eval-rands (cdr rands) env
            (lambda (other-args)
              (ak 
                (cons 
                  (cons first-arg first-arg-env)
                  other-args)))))))))

(define apply-proc
  (lambda (proc proc-env args vk)
    (record-case proc
      (prim-1 (unary-op)
        (vk (apply-unary-primop unary-op (car (car args)))
            '*dummy*))
      (prim-2 (binary-op)
        (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) 
            (lambda (val val-env)
              (if (number? val)
                (vk val val-env)
                (error 'apply-proc
                  "Procedure can't return non-number ~s"
                  v))))))
      (else (error 'apply-proc "Bad Procedure: ~s" proc)))))

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

;;; 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))))

(define init-env (build-init-env init-entries))  

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

;;; The initial continuation

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