;;; Interpreter for Stack Development

(printf "interp4.s Fri May 28 12:29:42 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 vk)
    '(printf "apply-env: var-sym = ~s env = ~s~%"
      var-sym env)
    '(debug-print 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)
    '(printf "eval-exp: exp = ~s env = ~s~%"
      exp env)
    '(debug-print 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)
    '(printf "eval-rands: rands = ~s env = ~s~%"
      rands env)
    '(debug-print 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)
    '(printf "apply-proc: proc = ~s proc-env = ~s args = ~s~%"
      proc proc-env args)
    '(debug-print 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 ()
    (let ((s (make-stack 200)))
      (stack-push 'final-valcont s))))

(define make-test-value-cont
  (lambda (exp1 exp2 env vk)
    (stack-push 'test-value exp1 exp2 env vk)))
    
(define make-first-arg-cont
  (lambda (rands env ak)
    (let ((bp (ak->bp ak))
          (vk (ak->vk ak)))
      ;; push bp explicitly
      (stack-push 'first-arg-cont rands env bp vk))))

(define make-app-value-cont 
  (lambda (vk)
    (stack-push 'app-value-cont vk)))

(define make-proc-cont
  (lambda (rands env vk)
    (stack-push 'proc-cont rands env vk)))

(define apply-valcont
  (lambda (vk val val-env)
    '(printf "apply-valcont: val = ~s val-env = ~s~%"
      val val-env)
    '(debug-print vk)
    (stack-pop 1 vk
      (lambda (tag s)
        (case tag
          ((final-valcont) 
           val)
          ((test-value)
           (stack-pop 3 s
             (lambda (exp1 exp2 env vk)
               (if (true-value? val)
                 (eval-exp exp1 env vk)
                 (eval-exp exp2 env vk)))))
          ((first-arg-cont)
           (stack-pop 3 s
             (lambda (rands env bp vk)
               '(printf "first-arg-cont: rands = ~s env = ~s bp = ~s~%~%"
                 rands env bp)
               (let ((first-arg val)(first-arg-env val-env))
                 (eval-rands (cdr rands) env
                   (make-other-args-cont first-arg first-arg-env 
                     ;; and reset the bp explicitly
                     (stack-set-bp bp vk)))))))
          ((app-value-cont)
           (stack-pop 0 s
             (lambda (vk)
               (if (number? val)
                 (apply-valcont vk val val-env)
                 (error 'apply-proc
                   "Procedure can't return non-number ~s"
                   v)))))
          ((proc-cont)
           (stack-pop 2 s
             (lambda (rands env vk)
               (let ((proc val) (proc-env val-env))
                 (eval-rands rands env 
		   (make-all-args-cont proc proc-env vk))))))
          (else
            (error 'apply-valcont
              "unknown continuation tag ~s"
              tag)))))))
               
;;; Args Continuations

(define make-all-args-cont
  (lambda (proc proc-env vk)
    ;; set bp = sp, then push rator and env
    (stack-push proc proc-env (vk->ak vk))))

(define make-other-args-cont
  (lambda (first-arg first-arg-env ak)
    (stack-push first-arg first-arg-env ak)))

(define apply-ak
  (lambda (ak args)  
    (let ((sp (stack->sp ak))
          (bp (stack->bp ak)))
      '(printf "apply-ak: args = ~s~%"
        args)
      '(debug-print ak)
      (if (= sp (+ bp 2))
        ;; then this is all-args-cont
        (stack-pop 2 ak
          (lambda (proc proc-env vk)
            '(printf "all-args-cont: proc = ~s proc-env = ~s~%"
              proc proc-env)
            '(debug-print vk)
            (apply-proc proc proc-env args (ak->vk ak))))
        ;; else it's an other-args-cont
        (stack-pop 2 ak
          (lambda (first-arg first-arg-env ak)
            (let ((other-args args))
              (apply-ak ak (cons 
                             (cons first-arg first-arg-env)
                             other-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))))