;; A expval is
;;   * number, or
;;   * proc, or
;;   * continuation

;; We've dropped letrec to make things
;; simpler. Also, all primitives take two
;; arguments, and all functions take one.

;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;

(define the-lexical-spec
  '((whitespace (whitespace) 
                skip)
    (id (letter (arbno (or letter digit "?")))
        make-symbol)
    (number ((or "" "-" "+") digit (arbno digit))
            make-number)))

(define the-grammar
  '((program (expression) a-program)

    (expression ("proc" "(" id ")"
                 expression)
                proc-exp)
    (expression (number) lit-exp)
    (expression (id) var-exp)
    (expression
      (primitive "(" expression "," expression ")")
      primapp-exp)
    (expression ("let" id "=" expression
                 "in"
                 expression)
                let-exp)
    (expression ("(" expression expression ")")
                app-exp)
    (expression ("if" expression
                 "then" expression
                 "else" expression)
                if-exp)    

    ;; New:
    (expression ("letcc" id "in" expression)
		letcc-exp)
    (expression ("continue" expression expression)
		continue-exp)

    (primitive ("+")     add-prim)
    (primitive ("-")     subtract-prim)
    (primitive ("*")     mult-prim)))

(sllgen:make-define-datatypes the-lexical-spec
                              the-grammar)

(define-datatype
 proc proc?
 (closure (id symbol?)
          (body-exp expression?)
          (env environment?)))

(define (value? x)
  (or (number? x)
      (proc? x)))

(define-datatype
 continuation continuation?
 (done-cont)
 (app-arg-cont (rand expression?)
	       (env environment?)
	       (cont continuation?))
 (app-cont (rator value?)
	   (cont continuation?))
 (prim-other-cont (prim primitive?)
		  (arg2 expression?)
		  (env environment?)
		  (cont continuation?))
 (prim-cont (prim primitive?)
	    (arg1 value?)
	    (cont continuation?))
 (let-cont (id symbol?)
	   (body expression?)
	   (env environment?)
	   (cont continuation?))
 (if-cont (then expression?)
	  (else expression?)
	  (env environment?)
	  (cont continuation?))

 ;; For "continue" expressions:
 (cont-val-cont (result expression?)
		(env environment?))
 (cont-cont (cont continuation?))
 
 )

;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;

; eval-program : program -> expval
(define eval-program 
  (lambda (pgm)
    (cases program pgm
      (a-program (body)
        (eval-expression body (init-env) (done-cont))))))

; eval-expression : expression env cont -> 
(define eval-expression 
  (lambda (exp env cont)
    (show-trace exp env cont)
    (cases expression exp
      (lit-exp (datum) (apply-cont cont datum))
      (var-exp (id) (apply-cont cont (apply-env env id)))
      (primapp-exp (prim rand1 rand2)
        (eval-expression
         rand1 env
         (prim-other-cont prim rand2 env cont)))
      (proc-exp (id body-exp)
        (apply-cont cont (closure id body-exp env)))
      (app-exp (rator rand)
        (eval-expression 
         rator env
         (app-arg-cont rand env cont)))
      (if-exp (test then else)
        (eval-expression 
         test env
         (if-cont then else env cont)))
      (let-exp (id exp body-exp) 
        (eval-expression
         exp env
         (let-cont id body-exp env cont)))

      ;; New: 
      (letcc-exp (id body)
	(eval-expression
	 body (extend-env (list id)
			  (list cont)
			  env)
	 cont))
      (continue-exp (cont-exp val-exp)
        (eval-expression
	 cont-exp env
	 ;; We can forget the current cont, 
	 ;; because we won't need it!
	 (cont-val-cont val-exp env))))))

; apply-cont : cont expval -> 
(define (apply-cont cont val)
  (show-cont-trace cont val)
  (cases continuation cont
    (done-cont () val)
    (prim-other-cont (prim arg2 env cont)
      (eval-expression
       arg2 env
       (prim-cont prim val cont)))
    (prim-cont (prim arg1-val cont)
      (apply-cont cont (apply-primitive prim arg1-val val)))
    (app-arg-cont (rand env cont)
      (eval-expression
       rand env
       (app-cont val cont)))
    (app-cont (f cont)
      (apply-proc f val cont))
    (let-cont (id body env cont)
      (eval-expression
       body (extend-env
             (list id)
             (list val)
             env)
       cont))
    (if-cont (then else env cont)
      (eval-expression
       (if (zero? val) else then)
       env cont))

    ;; For "continue" expressions:
    (cont-val-cont (val-exp env)
      (eval-expression
       val-exp env
       (cont-cont val)))
    (cont-cont (saved-cont)
      (apply-cont saved-cont val))))

; apply-proc : proc expval cont -> 
(define (apply-proc func arg cont)
  (cases proc func
    (closure (id body-exp env)
      (eval-expression
       body-exp (extend-env
                 (list id)
                 (list arg)
                 env)
       cont))))

; apply-primitive : primitive expval expval -> expval
(define apply-primitive
  (lambda (prim arg1 arg2)
    (cases primitive prim
      (add-prim  () (+ arg1 arg2))
      (subtract-prim () (- arg1 arg2))
      (mult-prim  () (* arg1 arg2)))))

; init-env :  -> env
(define init-env
  (lambda () (empty-env)))

;;;;;;;;;;;;;;;; environments ;;;;;;;;;;;;;;;;

;; Abstract envrionment datatype implemenation.
;; (Restored to the original implementation.)

(define-datatype environment environment?
  (empty-env-record)
  (extended-env-record
    (syms (list-of symbol?))
    (vec vector?)    ; can use this for anything.
    (env environment?)))

; empty-env : -> env
(define empty-env
  (lambda ()
    (empty-env-record)))

; extend-env : list-of-sym list-of-expval env -> env 
(define extend-env
  (lambda (syms vals env)
    (extended-env-record syms (list->vector vals) env)))

; apply-env : env sym -> expval
(define apply-env
  (lambda (env sym)
    (cases environment env
      (empty-env-record ()
        (eopl:error 'apply-env "No binding for ~s" sym))
      (extended-env-record (syms vals env)
        (let ((position (env-find-position sym syms)))
          (if (number? position)
              (vector-ref vals position)
              (apply-env env sym)))))))

;; Environment helper functions

; env-find-position : sym list-of-symbols -> num-or-#f
(define env-find-position 
  (lambda (sym los)
    (list-find-position sym los)))

; list-find-position : sym list-of-symbols -> num-or-#f
(define list-find-position
  (lambda (sym los)
    (list-index (lambda (sym1) (eqv? sym1 sym)) los)))

; list-index : pred list-of-symbols -> num-or-#f
(define list-index
  (lambda (pred ls)
    (cond
      ((null? ls) #f)
      ((pred (car ls)) 0)
      (else (let ((list-index-r 
                   (list-index pred (cdr ls))))
              (if (number? list-index-r)
                (+ list-index-r 1)
                #f))))))

;;;;;;;;;;;;;;;; top level ;;;;;;;;;;;;;;;;

; read-eval-print : -> [loops forever]
(define read-eval-print
  (lambda ()
    ((sllgen:make-rep-loop "-->"
			   eval-program
                           (sllgen:make-stream-parser
                            the-lexical-spec
                            the-grammar)))))

(define scan&parse
  (sllgen:make-string-parser the-lexical-spec
                             the-grammar))

(define (run string)
  (eval-program (scan&parse string)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tracing

(define (print-expr exp)
  (cases expression exp
    (lit-exp (v) (printf "~a" v))
    (var-exp (id) (printf "~a" id))
    (primapp-exp (prim rand1 rand2)
                 (printf "~a("
                  (cases primitive prim
                    (add-prim  () '+)
                    (subtract-prim () '-)
                    (mult-prim  () '*)))
                 (print-expr rand1)
                 (printf ", ")
                 (print-expr rand2)
                 (printf ")"))
    (proc-exp (id body)
              (printf "proc(")
              (printf "~a" id)
              (printf ")")
              (print-expr body))
    (app-exp (rator rand)
             (printf "(")
             (print-expr rator)
             (printf " ")
             (print-expr rand)
             (printf ")"))
    (if-exp (test then else)
            (printf "if ")
            (print-expr test)
            (printf " then ")
            (print-expr then)
            (printf " else ")
            (print-expr else))
    (let-exp (id exp body-exp)
             (printf "let")
             (printf " ~a=" id)
             (print-expr exp)
             (printf " in ")
             (print-expr body-exp))
    (letcc-exp (id body-exp)
	       (printf "letcc")
	       (printf " ~a" id)
	       (printf " in ")
	       (print-expr body-exp))
    (continue-exp (cont-exp val-exp)
		  (printf "continue ")
		  (print-expr cont-exp)
		  (printf " ")
		  (print-expr val-exp))))

(define (print-env env)
  (cases environment env
    (empty-env-record () (printf "{}"))
    (extended-env-record 
     (syms vals old-env)
     (printf "{")
     (for-each (lambda (sym val)
                 (printf "~a=" sym)
		 (print-value val)
		 (printf ", "))
               syms (vector->list vals))
     (print-env old-env)
     (printf "}"))))

(define (print-value v)
  (cond
    [(proc? v)
     (cases proc v
       (closure 
        (id body-expr env)
        (printf "<")
        (printf "~a" id)
        (printf ", ")
        (print-expr body-expr)
        (printf ", ")
        (print-env env)
        (printf ">")))]
    [(continuation? v)
     (print-cont v)]
    [else
     (printf "~a" v)]))

(define (print-cont k)
  (cases continuation k
    (done-cont () (printf "[done]"))
    (prim-other-cont (prim arg2 env k)
      (printf "[primother ")
      (printf "~a, "
              (cases primitive prim
                (add-prim  () '+)
                (subtract-prim () '-)
                (mult-prim  () '*)))
      (print-expr arg2)
      (printf ", ")
      (print-env env)
      (printf ", ")
      (print-cont k)
      (printf "]"))
    (prim-cont (prim arg1-val k)
      (printf "[prim ")
      (printf "~a, "
              (cases primitive prim
                (add-prim  () '+)
                (subtract-prim () '-)
                (mult-prim  () '*)))
      (print-value arg1-val)
      (printf ", ")
      (print-cont k)
      (printf "]"))
    (app-arg-cont (rand env k)
      (printf "[apparg ")
      (print-expr rand)
      (printf ", ")
      (print-env env)
      (printf ", ")
      (print-cont k)
      (printf "]"))
    (app-cont (f k)
      (printf "[app ")
      (print-value f)
      (printf ", ")
      (print-cont k)
      (printf "]"))
    (let-cont (id body env k)
      (printf "[let ~a, " id)
      (print-expr body)
      (printf ", ")
      (print-env env)
      (printf ", ")
      (print-cont k)
      (printf "]"))
    (if-cont (then else env k)
      (printf "[if ")
      (print-expr then)
      (printf ", ") 
      (print-expr else)
      (printf ", ")
      (print-env env)
      (printf ", ")
      (print-cont k)
      (printf "]"))
    (cont-val-cont (val-exp env)
      (printf "[contval ")
      (print-expr val-exp)
      (printf ", ")
      (print-env env)
      (printf "]"))
    (cont-cont (cont)
      (printf "[cont ")
      (print-cont cont)
      (printf "]"))
))

(define (show-trace exp env k)
  (printf "eval --------~n")
  (printf " exp: ")
  (print-expr exp)
  (newline)
  (printf " env: ")
  (print-env env)
  (newline)
  (printf " cnt: ")
  (print-cont k)
  (newline))

(define (show-cont-trace k v)
  (printf "cont --------~n")
  (printf " val: ")
  (print-value v)
  (newline)
  (printf " cnt: ")
  (print-cont k)
  (newline))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define sum-program
  "let sum = proc(sum)
              proc(n)
                if n
                   then +(n, ((sum sum) -(n, 1)))
                   else 0
    in ((sum sum) 3)")

(define letcc-program
  ;; Sets up a sum, and then escapes before adding:
  "letcc escape
    in let sum = proc(sum)
                  proc(n)
                    if n
                       then +(n, ((sum sum) -(n, 1)))
                       else continue escape 0
    in ((sum sum) 3)")