;;; Interpreter for Stack Development

;;; Initial interpreter

(printf "interp1.s Fri May 28 11:16:52 1993~%")

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

;;; 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 k)
    (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 k)
          (apply-env old-env var-sym k)))
      (extended-rec-env (decls old-env)
        (letrec
          ((loop 
             (lambda (decls)
               (cond 
                 ((null? decls)
                  (apply-env old-env var-sym k))
                 ((eq? var-sym (rec-decl->name (car decls)))
                  (k (make-closure (car decls) env)))
                 (else
                   (loop (cdr decls)))))))
          (loop decls)))
      (else
        (error 'apply-env
          "unknown environment frame ~s"
          env)))))

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

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

;;; The Interpreter Proper

(define eval-exp
  (lambda (exp env k)
    (record-case exp
      (lit-exp (constant) (k constant))
      (var-exp (id) (apply-env env id k))
      (letrec-exp (decls body)          ; letrec instead of proc
        (eval-exp body (extend-rec decls env) k))
      (if-exp (test-exp exp1 exp2)
        (eval-exp test-exp env
          (lambda (v)
            (if (true-value? v)
              (eval-exp exp1 env k)
              (eval-exp exp2 env k)))))
      (app-exp (rator rands)
        (apply-env env rator            ; evaluate operator first
          (lambda (proc)
            (eval-rands rands env       ; then operands
              (lambda (args)
                (apply-proc proc args k))))))
      (else (error 'eval-exp "Bad abstract syntax: ~s" exp)))))

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

(define apply-proc
  (lambda (proc args k)
    (record-case proc
      (prim-1 (unary-op)
        (k (apply-unary-primop unary-op (car args))))
      (prim-2 (binary-op)
        (k (apply-binary-primop binary-op
             (car args) (cadr args))))
      (closure (rec-decl env)
        (let ((body (rec-decl->body rec-decl))
              (formals (rec-decl->formals rec-decl)))
          (eval-exp body (extend-env formals args env) 
            (lambda (v)
              (if (number? v)
                (k v)
                (error 'apply-proc
                  "Procedure can't return non-number ~s"
                  v))))))
      (else (error 'apply-proc "Bad Procedure: ~s" proc)))))

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

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

;;; The initial continuation

(define make-init-cont
  (lambda ()
    (lambda (v) v)))

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

;;; End of interp1.s