;; eval4.scm  

;; Changed apply-env (added empty-env).  Changed "run" also.

; > (load "scheme/eval3.scm")
; > (run
;     '((lambda (n) 
;         ((lambda (!)
;            (! n !))
;          (lambda (n bang)
;            (if (zero? n)
;                1
;                (* n (bang (- n 1) bang))))))
;       8))
; 40320
; > (run '(set! true 100))
; > (run '((lambda (x) true)
;          (set! true 998)))
; 998
; > (run '((lambda (x) zero?)
;          (set! true 998)))
; #2(primitive zero?)
; > (run '((lambda (x) zero?)
;          (set! zero? 1239)))
; 1239
; > (run '((lambda (x) zero?)
;          (set! zero? *)))
; #2(primitive *)
; > (run '((lambda (x) (zero? 3 4))
;          (set! zero? *)))
; 12
; > 
;


(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 varassign (var exp))
(define-record closure (formals body env))
(define-record extended-env (formals args env))
(define-record empty-env ())

;; NEW:

(define-record primitive (sym))

;;

(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)
    (variant-case env
      (extended-env (formals args env)
	(if (memq sym formals)
	    (little-lookup sym formals args)
	    (apply-env env sym)))
      (empty-env ()
	(global-table sym))
      (else (error 'apply-env "Something bad happened.")))))
     

;; Note the addition to apply-closure...

(define apply-closure
  (lambda (closure args)
    (variant-case closure
      (closure (formals body env)
	(eval-exp body
	  (make-extended-env
	    formals (map box args) env)))
      (primitive (sym)
	(apply-primitive sym args)))))

;; NEW:    This is a major hack!  We really shouldn't use scheme's
;; "apply", but instead have a giant case statement which switches on
;; sym and has in it the code for applying all the primitive
;; functions. 

(define apply-primitive
  (lambda (sym args)
    (case sym
      ((zero?)
       (let ((x (apply (eval sym) args)))
	 (if x 1 0)))
      (else	     
	(apply (eval sym) args)))))

;;

;; NOTE how global-table has changed.

(define global-table
  (let ((apply* (box (make-primitive '*)))
	(apply+ (box (make-primitive '+)))
	(apply- (box (make-primitive '-)))
	(apply-cons (box (make-primitive 'cons)))
	(apply-car (box (make-primitive 'car)))
	(apply-cdr (box (make-primitive 'cdr)))
	(boxed1 (box 1))
	(boxed0 (box 0))
	(apply-zero? (box (make-primitive 'zero?))))
    (lambda (sym)
      (case sym
	((cons) apply-cons)
	((car) apply-car)
	((cdr) apply-cdr)
	((zero?) apply-zero?)
	((*) apply*)
	((+) apply+)
	((-) apply-)
	((true) boxed1)
	((false) boxed0)
	(else 
	  (error 'global-table "unbound variable: ~s" sym))))))
	  

(define eval-exp
  (letrec
    ((eval-exp
       (lambda (e env)
	 (variant-case e
	   (lit (datum) datum)
	   (varref (var) (unbox (apply-env env var)))
	   (app (rator rands)
	     (apply-closure (eval-exp rator env)
	       (map (lambda (x)
		      (eval-exp x env))
		 rands)))
	   (lambda (formals body)
	     (make-closure formals body env))
	   (if (test-exp then-exp else-exp)
	       (cond
		 ((zero? (eval-exp test-exp env))
		  (eval-exp else-exp env))
		 (else
		   (eval-exp then-exp env))))
	   (varassign (var exp)
	     (set-box!
	       (apply-env env var)
	       (eval-exp exp env)))))))
    (lambda (e env) 
      (eval-exp e env))))


;; 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) 'set!))
	    (make-varassign (cadr e)	; var
	      (parse-exp (caddr e))))	; expression
	   ((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) 
	(make-empty-env)))))