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

(define trace? #t)

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

    (expression ("try" expression
                 "handle" expression)
                try-exp)
    (expression ("raise" expression)
                raise-exp)
    
    (expression ("spawn" expression)
                spawn-exp)
    
    (expression ("letcc" id "in" expression)
		letcc-exp)
    (expression ("continue" expression expression)
		continue-exp)

    (primitive ("+")     add-prim)
    (primitive ("-")     subtract-prim)
    (primitive ("*")     mult-prim)
    (primitive ("print") print-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?))
 
 (try-cont (body expression?)
           (env environment?)
           (cont continuation?))
 (handle-cont (handler proc?)
              (cont continuation?))
 
 (raise-cont (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)
    (if (time-to-swap!?)
        (swap-thread! 'eval (list exp env cont))
        (do-eval-expression exp env cont))))

; do-eval-expression : expression env cont -> 
(define do-eval-expression 
  (lambda (exp env cont)
    (if trace?
        (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)))
      
      ;; try and raise
      (try-exp (body handler)
         (eval-expression
          handler env
          (try-cont body env cont)))
      (raise-exp (expr)
          (eval-expression
           expr env
           (raise-cont cont)))
      
      ;; spawn
      (spawn-exp (exp)
          (begin
            (queue-thread! 'eval (list exp env (done-cont)))
            (apply-cont cont 1)))

      ;; letcc
      (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)
  (if (time-to-swap!?)
      (swap-thread! 'cont (list cont val))
      (do-apply-cont cont val)))
         
; do-apply-cont : cont expval -> 
(define (do-apply-cont cont val)
  (if trace?
      (show-cont-trace cont val))
  (cases continuation cont
    (done-cont () (thread-done! 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))
    
    ;; Try and raise
    (try-cont (body env cont)
       (if (proc? val)
           (eval-expression 
            body env
            (handle-cont val cont))
           (eopl:error 'try "handler is not a proc: ~a"
                       val)))
    (handle-cont (handler cont)
       (apply-cont cont val))
    (raise-cont (cont)
       (find-handler val 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))
      (print-prim () (begin
                       (eopl:printf "~a: ~a~n" arg1 arg2)
                       1)))))

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

; find-handler : expval cont -> 
(define (find-handler val cont)
  (cases continuation cont
    (handle-cont (handler cont)
      (apply-proc handler val cont))
    (done-cont ()
      (eopl:error 'raise
                  "unhandled exception: ~a"
                  val))
    ;; All others: look in the rest
    (prim-other-cont (prim arg2 env cont)
      (find-handler val cont))                     
    (prim-cont (prim arg1-val cont)
      (find-handler val cont))                     
    (app-arg-cont (rand env cont)
      (find-handler val cont))                     
    (app-cont (f cont)
      (find-handler val cont))                     
    (let-cont (id body env cont)
      (find-handler val cont))                     
    (if-cont (then else env cont)
      (find-handler val cont))                     
    (try-cont (body env cont)
      (find-handler val cont))                     
    (raise-cont (cont)
      (find-handler val cont))                     
    (cont-val-cont (val-exp env)
      (find-handler val cont))                     
    (cont-cont (saved-cont)
      (find-handler val cont))))
    
;;;;;;;;;;;;;;;; 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))))))

;;;;;;;;;;;;;;;; threads ;;;;;;;;;;;;;;;;

;; A mode is either 'eval or 'cont

(define TIME-SLICE 50)

(define thread-queue '())
(define clock 0)

; queue-thread! : mode arg-list -> void
;  adds a thread to the run queue
(define (queue-thread! mode args)
  (set! thread-queue (append thread-queue
                             (list (cons mode args)))))

; time-to-swap!? : -> boolean
;  increments the clock and reports whether it's
;  time to swap
(define (time-to-swap!?)
  (set! clock (+ clock 1))
  (>= clock TIME-SLICE))

; swap-thread! : mode arg-list -> 
;  swaps this thread out and another one in
(define (swap-thread! current-mode current-args)
  (queue-thread! current-mode current-args)
  (start-first-thread!))

; start-first-thread! : -> 
;  removes the first thread from the thread queue and
;  starts executing it
(define (start-first-thread!)
  (set! clock 0)
  (let ([first (car thread-queue)])
    (set! thread-queue (cdr thread-queue))
    (if (eq? 'eval (car first))
        (do-eval-expression (cadr first) (caddr first) (cadddr first))
        (do-apply-cont (cadr first) (caddr first)))))

; thread-done! : int -> 
;  prints a thread's result and swaps another in
(define (thread-done! val)
  (if (null? thread-queue)
      val
      (start-first-thread!)))
  
;;;;;;;;;;;;;;;; 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) (eopl:printf "~a" v))
    (var-exp (id) (eopl:printf "~a" id))
    (primapp-exp (prim rand1 rand2)
                 (eopl:printf "~a("
                  (cases primitive prim
                    (add-prim  () '+)
                    (subtract-prim () '-)
                    (mult-prim  () '*)
                    (print-prim () 'print)))
                 (print-expr rand1)
                 (eopl:printf ", ")
                 (print-expr rand2)
                 (eopl:printf ")"))
    (proc-exp (id body)
              (eopl:printf "proc(")
              (eopl:printf "~a" id)
              (eopl:printf ")")
              (print-expr body))
    (app-exp (rator rand)
             (eopl:printf "(")
             (print-expr rator)
             (eopl:printf " ")
             (print-expr rand)
             (eopl:printf ")"))
    (if-exp (test then else)
            (eopl:printf "if ")
            (print-expr test)
            (eopl:printf " then ")
            (print-expr then)
            (eopl:printf " else ")
            (print-expr else))
    (let-exp (id exp body-exp)
             (eopl:printf "let")
             (eopl:printf " ~a=" id)
             (print-expr exp)
             (eopl:printf " in ")
             (print-expr body-exp))
    (try-exp (body-exp handle-exp)
             (eopl:printf "try ")
             (print-expr body-exp)
             (eopl:printf " handle ")
             (print-expr handle-exp))
    (raise-exp (exp)
               (eopl:printf "raise ")
               (print-expr exp))
    (spawn-exp (exp)
               (eopl:printf "spawn ")
               (print-expr exp))
    (letcc-exp (id body-exp)
	       (eopl:printf "letcc")
	       (eopl:printf " ~a" id)
	       (eopl:printf " in ")
	       (print-expr body-exp))
    (continue-exp (cont-exp val-exp)
		  (eopl:printf "continue ")
		  (print-expr cont-exp)
		  (eopl:printf " ")
		  (print-expr val-exp))))

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

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

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

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

(define (show-cont-trace k v)
  (eopl:printf "cont --------~n")
  (eopl:printf " val: ")
  (print-value v)
  (newline)
  (eopl: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 raise-program
  "let esum = proc(esum)
              proc(n)
                if n
                   then +(n, ((esum esum) -(n, 1)))
                   else raise 0
    in -(try ((esum esum) 3) handle proc(x)x, 1)")

(define thread-program
  "let f = proc(id) 
             let loop = proc(loop)
                         proc(n) if -(n,0)
                                  then let d = print(id, n)
                                        in ((loop loop) -(n, 1))
                                  else 0
               in ((loop loop) 10)
      in let a = spawn (f 1)
          in let b = spawn (f 2)
              in (f 3)")

(define escape-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)")

(define resume-program  
  "let f = letcc k in
             proc(g)
              continue k g
    in (f proc(x)x)")