;;; Interpreter for Stack Development

(printf "interp5.s Fri May 28 15:16:40 1993~%")

;;; now represent environments on the stack.

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

;;; environments

;; now env is an environment pointer, to be interpreted relative to
;; the stack found in vk.

;;; here we use stack-ref rather than stack-pop because we want this
;;; to be done non-destructively.

(define apply-env
  (lambda (ep var-sym vk)
    (if (memq 'apply-env debug-points)
      (begin
        (printf "apply-env: var-sym = ~s ep = ~s~%"
          var-sym ep)
        (debug-print vk ep)))
    (if (zero? ep)
      (apply-initial-env var-sym vk)
      (case (stack-ref vk ep)
        ((app-value-cont)
         (let ((formals (stack-ref vk (- ep 1)))
               (bp      (stack-ref vk (- ep 2)))
               (old-ep (stack-ref vk (- ep 3))))
           (letrec 
             ((loop
                (lambda (formals i)
                  (cond 
                    ((null? formals)
                     (apply-env old-ep var-sym vk))
                    ((eq? var-sym (car formals))
                     ;; found it at position i
                     (if (memq 'exit-apply-env debug-points)
                       (printf
                         "apply-env: variable found at ~s value = ~s val-env = ~s~%"
                         bp
                         (stack-ref vk (+ bp (* 2 i) 2))
                         (stack-ref vk (+ bp (* 2 i) 1))))
                     (apply-valcont vk
                       (stack-ref vk (+ bp (* 2 i) 2))
                       (stack-ref vk (+ bp (* 2 i) 1))))
                    (else
                      (loop (cdr formals) (+ 1 i)))))))
             (loop formals 1))))
        ((extend-rec)
         (let ((decls  (stack-ref vk (- ep 1)))
               (old-ep (stack-ref vk (- ep 2))))
           (letrec
             ((loop 
                (lambda (decls)
                  (cond 
                    ((null? decls)
                     (apply-env old-ep var-sym vk))
                    ((eq? var-sym (rec-decl->name (car decls)))
                     (apply-valcont vk (car decls) ep)) 
                    (else
                      (loop (cdr decls)))))))
             (loop decls))))
        (else
          (error 'apply-env
            "unknown environment frame ~s"
            (stack-ref vk ep)))))))

(define ribassoc
  (lambda (var-sym names vals vk)
    (letrec 
      ((loop
         (lambda (names vals)
           (cond 
             ((null? names)
              (error 'apply-env "unbound identifier ~s" var-sym))
             ((eq? var-sym (car names))
              (apply-valcont vk (caar vals) (cdar vals)))
             (else
               (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)          
        ; (eval-exp body (extend-rec decls env) vk)
        (let ((vk (make-extend-rec decls env vk)))
          (eval-exp body (stack->sp vk) 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)))))

;; args is now a base pointer

(define apply-proc
  (lambda (proc proc-env args vk)
    (let ((bp args))
    (record-case proc
      (prim-1 (unary-op)
        (let ((arg1 (stack-ref vk (+ bp 4)))
              (vk   (stack-set-sp bp  vk))) ; pop down to next continuation
          (apply-valcont vk
            (apply-unary-primop unary-op arg1)
            '*dummy*)))

      (prim-2 (binary-op)
        (let ((arg1 (stack-ref vk (+ bp 4)))
              (arg2 (stack-ref vk (+ bp 6)))
              (vk   (stack-set-sp bp vk)))
          (apply-valcont vk
            (apply-binary-primop binary-op arg1 arg2)
            '*dummy*)))

      (rec-decl (name formals body)
        (let ((env proc-env))
          (let ((vk (make-app-value-cont formals args env vk)))
            (eval-exp body (stack->sp vk) 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             ; builds extend-env, too.
  (lambda (formals args env vk)         ; args is really bp
    (stack-push 'app-value-cont formals args env vk)))

(define make-extend-rec
  (lambda (decls env vk)
    (stack-push 'extend-rec decls env vk)))

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

(define apply-valcont
  (lambda (vk val val-env)
    (if (memq 'apply-valcont debug-points)
      (begin
        (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 ak)
               (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 ak)))))))
          ((app-value-cont)
           (stack-pop 3 s
             (lambda (formals args env vk)
               (if (number? val)
                 (apply-valcont
                   (stack-set-sp args vk) ; pop off everything
                   val val-env)
                 (error 'apply-proc
                   "Procedure can't return non-number ~s"
                   v)))))
          ((extend-rec)
           (stack-pop 2 s
             (lambda (decls env vk)
               (apply-valcont vk val val-env))))
          ((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)))

;; only external call to apply-ak has args = '()
;; internal loop just walks down to bp.

(define apply-ak
  (lambda (ak args)  
    (let ((bp (stack->bp ak)))
      ;; the proc and proc-env are sitting at the bp, so need to get them
      ;; explicitly. 
      (let ((proc     (stack-ref ak (+ bp 2)))
            (proc-env (stack-ref ak (+ bp 1))))
        (apply-proc proc proc-env bp ak)))))


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

;;; The Initial Environment

(define build-init-env
  (lambda (entries)
    (cons                               ; new!
      (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))))

(define apply-initial-env
  (let ((init-env (build-init-env init-entries)))
    (lambda (var-sym vk)
      (ribassoc var-sym (car init-env) (cdr init-env) vk))))


(define make-init-env
  (lambda () 0))