;; eval-cps1.scm

;; Here we've added apply-k.


(load "record.ss")

(define-record lit (datum))
(define-record varref (var))
(define-record lambda (formals body))
(define-record app (rator rands))
(define-record if (test-exp then-exp else-exp))

(define-record extended-env (formals args env))
;;(define-record closure (formals body env))


(define apply-k
  (lambda (k val)
    (k val)))

(define find-lexical-address-ONE
  (lambda (e cenv)
    (letrec
      ((find-lexical-address
	 (lambda (cenv)
	   (cond
	     ((eq? (car cenv) e)
	      0)
	     (else
	       (+ 1 (find-lexical-address (cdr cenv))))))))
      (find-lexical-address cenv))))

(define little-lookup
  (lambda (item item-list match-list)
    (list-ref match-list
      (find-lexical-address-ONE item item-list))))


(define apply-env
  (lambda (env sym k)
    (variant-case env
      (extended-env (formals args env)
	(if (memq sym formals)
	    (apply-k k (little-lookup sym formals args))
	    (apply-env env sym k)))
      (else (apply-k k (global-table sym))))))
     
;(define apply-closure
;  (lambda (closure args)
;    (variant-case closure
;      (closure (formals body env)
;        (eval-exp body
;          (make-extended-env
;            formals args env)))
;      (else (closure args)))))


(define global-table
  (let ((apply* (lambda (args k)
		  (apply-k k (* (car args) (cadr args)))))
	(apply+ (lambda (args k)
		  (apply-k k (+ (car args) (cadr args)))))
	(apply- (lambda (args k)
		  (apply-k k (- (car args) (cadr args)))))
	(apply-zero? (lambda (args k)
		       (apply-k k (if (zero? (car args))
			      1 0))))
	(apply-cons (lambda (args k)
		      (apply-k k (cons (car args) (cadr args)))))
	(apply-car (lambda (args k)
		      (apply-k k (car (car args)))))
	(apply-cdr (lambda (args k)
		      (apply-k k (cdr (car args))))))
    (lambda (sym)
      (case sym
	((cons) apply-cons)
	((car) apply-car)
	((cdr) apply-cdr)
	((zero?) apply-zero?)
	((X) 10)
	((V) 5)
	((D) 500)
	((C) 100)
	((I) 1)
	((M) 1000)
	((*) apply*)
	((+) apply+)
	((-) apply-)
	(else 
	  (error 'global-table "unbound variable: ~s" sym))))))
	  

(define eval-rands
  (lambda (rands env k)
    (cond
      ((null? rands) (apply-k k '()))
      (else
	(eval-exp
	  (car rands)
	  env
	  (lambda (arg)
	    (eval-rands
	      (cdr rands)
	      env
	      (lambda (args)
		(apply-k k (cons arg args))))))))))


(define eval-exp
  (letrec
    ((eval-exp
       (lambda (e env k)
	 (variant-case e
	   (lit (datum) (apply-k k datum))
	   (varref (var) (apply-env env var k))
	   (if (test-exp then-exp else-exp)
	       (eval-exp
		 test-exp
		 env
		 (lambda (b)
		   (if (zero? b)
		       (eval-exp
			 else-exp
			 env
			 k)
		       (eval-exp
			 then-exp
			 env
			 k)))))
	   (app (rator rands)
	     (eval-exp
	       rator
	       env
	       (lambda (proc)
		 (eval-rands
		   rands
		   env
		   (lambda (args)
		     (proc args k))))))
	   (lambda (formals body)
	     (apply-k k (lambda (args k)
		  (eval-exp
		    body
		    (make-extended-env
		      formals
		      args
		      env)
		    k))))
	   ))))
    (lambda (e env k)
      (eval-exp e env k))))


;; run is for testing
;; (it parses the exp and also supplies the global table as an arg to
;; eval-exp)

(define run
  (letrec
    ((parse-exp
       (lambda (e)
	 (cond
	   ((number? e) (make-lit e))
	   ((atom? e) (make-varref e))
	   ((and (list? e)		; a cheap hack
		 (eq? (car e) 'lambda))
	    (make-lambda (cadr e)	; formals
	      (parse-exp (caddr e))))	; body
	   ((and (list? e)		; a cheap hack
		 (eq? (car e) 'if))
	    (make-if
	      (parse-exp (cadr e)) ; test exp
	      (parse-exp (caddr e))	; then exp
	      (parse-exp (cadddr e))))	; else exp
	   (else			; else application
	     (make-app (parse-exp (car e)) ; operator
	       (map parse-exp (cdr e))))))))
    (lambda (unparsed-expression)
      (eval-exp (parse-exp unparsed-expression)
	global-table
	(lambda (x) x)))))