;; eval-set.scm

;; this is based on eval-cc7.scm
;;
;; adding set!


;; registers

(define k* 'nobinding)
(define acc* 'nobinding)    ; was val
(define env* 'nobinding)
(define exp* 'nobinding)
(define rands* 'nobinding)
(define sym* 'nobinding)
(define proc* 'nobinding)
(define args* 'nobinding)

;; rest

(define *k-trace* #f)

(define k-trace
  (lambda ()
    (for-each display
      '("Kontinuation tracing enabled."
	 #\newline))
    (set! *k-trace* #t)))

(define stop-k-trace
  (lambda ()
    (for-each display
      '("Kontinuation tracing disabled."
	 #\newline))
    (set! *k-trace* #f)))

(define show-k-trace
  (lambda (k)
    (if *k-trace*
	(begin
	  (display (vector-ref (car k) 0))		; name
	  (newline)))))
  
; (run
;     '((lambda (n) 
;         ((lambda (!)
;            (! n !))
;          (lambda (n bang)
;            (if (zero? n)
;                1
;                (* n (bang (- n 1) bang))))))
;       5))                                   
;
; This generates 135 calls to 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 letcc (var exp))
(define-record varassign (var exp))

(define-record extended-env (formals args env))
(define-record closure (formals body env))
(define-record continuation-closure (kont)) ; NEW
(define-record primitive (sym))


;; This is used to add a single var (and a single arg) to the env. 

(define make-extended-env/1
  (lambda (var arg env)
    (make-extended-env (list var) (list arg) env)))



;; records for continuations

(define-record post-test-frame (then-exp else-exp env))
(define-record post-rator-frame (rands env))
(define-record post-rands-frame (proc))
(define-record post-rest-rands-frame (a))
(define-record post-first-rands-frame (rands env))
(define-record final-frame (jumpout))
(define-record post-varassign-exp-frame (var env))


(define apply-k*
  (lambda ()
    (show-k-trace k*)
    (let ((frame (car k*)))
      (set! k* (cdr k*))
      (variant-case frame
	(final-frame (jumpout) (jumpout acc*))
	(post-test-frame (then-exp else-exp env)
	  (if (zero? acc*)
	      (begin
		(set! env* env)
		(set! exp* else-exp)
		(eval-exp))
	      (begin
		(set! env* env)
		(set! exp* then-exp)
		(eval-exp))))
	(post-rator-frame (rands env)
	  (set! k* (cons (make-post-rands-frame acc*) k*))
	  (set! env* env)
	  (set! rands* rands)
	  (eval-rands))
	(post-rands-frame (proc)
	  (set! proc* proc)
	  (set! args* acc*)
	  (apply-closure))
	(post-rest-rands-frame (a)
	  (set! acc* (cons a acc*)))
	(post-first-rands-frame (rands env)
	  (set! k* (cons (make-post-rest-rands-frame acc*) k*))
	  (set! env* env)
	  (set! rands* (cdr rands))
	  (eval-rands))
	(post-varassign-exp-frame (var env)
	  (set! sym* var)
	  (set! env* env)
	  (apply-env!))
	(else (error 'apply-frame "Not a valid continuation: ~s" frame))))))


;; 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)))))


(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 ()
    (variant-case env*
      (extended-env (formals args env)
	(if (memq sym* formals)
	    (set! acc* (unbox (little-lookup sym* formals args)))
	    (begin
	      (set! env* env)
	      (apply-env))))
      (else
	(set! acc* (unbox (global-table sym*)))
	))))

(define apply-env!
  (lambda ()
    (variant-case env*
      (extended-env (formals args env)
	(if (memq sym* formals)
	    (set-box! (little-lookup sym* formals args) acc*)
	    (begin
	      (set! env* env)
	      (apply-env))))
      (else
	(set-box! (global-table sym*) acc*)
	))))
     

(define apply-closure
  (lambda ()
    (variant-case proc*
      (closure (formals body env)
	(set! env* (make-extended-env formals (map box args*) env))
	(set! exp* body)
	(eval-exp))
      (primitive (sym)
	(set! acc* (apply-primitive sym args*))
	)
      (continuation-closure (kont)
	(set! k* kont)
	(set! acc* (car args*)))
      (else
	(error 'apply-closure "Invalid closure type: ~s" proc*)))))


(define global-table
  (let ((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)))
	(apply-zero? (box (make-primitive 'zero?)))
	(apply- (box (make-primitive '-)))
	(boxed-true (box 1))
	(boxed-false (box 0)))
    (lambda (sym)
      (case sym
	((cons) apply-cons)
	((car) apply-car)
	((cdr) apply-cdr)
	((zero?) apply-zero?)
	((*) apply*)
	((+) apply+)
	((-) apply-)
	((true) boxed-true)
	((false) boxed-false)
	(else 
	  (error 'global-table "unbound variable: ~s" sym))))))
	  

(define eval-rands
  (lambda ()
    (cond
      ((null? rands*)
       (set! acc* '()))
      (else
	(set! k* (cons (make-post-first-rands-frame rands* env*) k*))
	(set! exp* (car rands*))
	(eval-exp)))))


(define eval-exp
  (lambda ()
    (variant-case exp*
      (lit (datum)
	(set! acc* datum))
      (varref (var)
	(set! sym* var)
	(apply-env))

      (varassign (var exp)
	(set! k* (cons (make-post-varassign-exp-frame var env*) k*))
	(set! exp* exp)
	(eval-exp))

      (if (test-exp then-exp else-exp)
	  (set! k* (cons (make-post-test-frame then-exp else-exp env*) k*))
	  (set! exp* test-exp)
	  (eval-exp))
      (app (rator rands)
	(set! k* (cons (make-post-rator-frame rands env*) k*))
	(set! exp* rator)
	(eval-exp))
      (letcc (var exp)
	(set! env* (make-extended-env/1
		     var
		     (box (make-continuation-closure k*))
		     env*))
	(set! exp* exp)
	(eval-exp))
      (lambda (formals body)
	(set! acc* (make-closure formals body 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) 'letcc))
	    (make-letcc (cadr e)	; var
	      (parse-exp (caddr e))))	; exp
	   ((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
	   ((and (list? e)		; a cheap hack
		 (eq? (car e) 'set!))
	    (make-varassign
	      (cadr e)			; var
	      (parse-exp (caddr e))))	; exp
	   (else			; else application
	     (make-app (parse-exp (car e)) ; operator
	       (map parse-exp (cdr e))))))))
    (lambda (unparsed-expression)
      (letrec
	((loop (lambda ()
		 (apply-k*)
		 (loop))))
	(letcc
	  escape-to-scheme
	  (begin
	      (set! k* (cons (make-final-frame escape-to-scheme) '()))
	      (set! env* global-table)
	      (set! exp* (parse-exp unparsed-expression))
	      (eval-exp)
	      (loop)))))))