;;; Continuation-passing interpreter
;;; representing continuations as an ADT
;;; and supporting globally angelic choice.

(module interp (lib "eopl.ss" "eopl")
  
  (require "drscheme-init.scm")

  (require "lang.scm")
  (require "data-structures.scm")
  (require "environments.scm")
  (require "threads.scm")

  (provide value-of-program value-of)

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

  ;; the-top-level-environment : Env

  (define the-top-level-environment (init-env))

  ;; value-of-program : program -> Answer

  (define value-of-program 
    (lambda (pgm)
      (cases program pgm
        (a-program (defns exp)
          (set! the-top-level-environment
                (extend-env-with-defns defns (init-env)))
          (kill-all-threads!)
          (fork-thread! (make-thread exp
                                     the-top-level-environment
                                     (top-level-cont)
                                     #f))
          (let ((answer (value-of-next-thread)))
            (kill-all-threads!)
            answer)))))

  ;; extend-env-with-defns : Listof[definition] * Env -> Env

  (define extend-env-with-defns
    (lambda (defns env)
      (cond ((null? defns)
             env)
            (else
             (cases definition (car defns)
               (proc-definition (id bvars body)
                 (extend-env-with-defns
                  (cdr defns)
                  (extend-env id
                              (proc-val (procedure bvars body))
                              env))))))))

  ;; value-of-next-thread :  -> Answer

  (define value-of-next-thread
    (lambda ()
      (let* ((current-thread (this-thread))
             (exp (thread-exp current-thread))
             (env (thread-env current-thread))
             (cont (thread-cont current-thread)))
        (value-of-thread exp env cont))))

  ;; value-of : Exp * Env * Cont -> Answer

  (define value-of
    (lambda (exp env cont)
      (suspend! (this-thread) exp env cont)
      (reschedule!)
      (value-of-next-thread)))

  ;; value-of-thread : Exp * Env * Cont -> Answer

  (define value-of-thread
    (lambda (exp env cont)
      (cases expression exp

        (lit-exp (num) (apply-cont cont (num-val num)))

        (var-exp (id)
          (let ((val (apply-env env id)))
            (if (expval? val)
                (apply-cont cont val)
                (eopl:error 'value-of "Unbound variable"))))

        (binop-exp (op exp1 exp2)
          (value-of exp1
                    env
                    (binop-cont1 op exp2 env cont)))

        (if-exp (exp1 exp2 exp3)
          (value-of exp1
                    env
                    (if-cont exp2 exp3 env cont)))

        (call-exp (rator rands)
          (value-of rator
                    env
                    (call-cont1 rands env cont)))

        (choose-exp (exp1 exp2)
          (fork-thread! (make-thread exp1 env cont (this-thread)))
          (value-of exp2 env cont))

        (choose/cut-exp (exp1 exp2)
          (let* ((ref1 (vector #f #f))
                 (ref2 (vector #f #f))
                 (cont1 (cut-cont cont ref1))
                 (cont2 (cut-cont cont ref2))
                 (th1 (make-thread exp1 env cont1 (this-thread)))
                 (th2 (make-thread exp2 env cont2 (this-thread))))
            (vector-set! ref1 0 th1)
            (vector-set! ref1 1 th2)
            (vector-set! ref2 0 th2)
            (vector-set! ref2 1 th1)
            (fork-thread! th1)
            (fork-thread! th2)
            (kill-this-thread!)
            (value-of-next-thread)))

        (fail-exp ()
          (kill-this-thread!)
          (value-of-next-thread))

        )))

  ;; values-of : Listof[Exp] * Env * MCont -> Answer

  (define values-of
    (lambda (exps env mcont)
      (cond ((null? exps)
             (apply-mcont mcont '()))
            (else
             (value-of (car exps)
                       env
                       (call-cont2 exps env mcont))))))

  ;; apply-binop : binop * ExpVal * ExpVal * Cont -> Answer

  (define apply-binop
    (lambda (op val1 val2 cont)
      (apply-cont
       cont
       (cases binop op
         (op-plus    () (num-val (+ (expval->num val1)
                                    (expval->num val2))))
         (op-minus   () (num-val (- (expval->num val1)
                                    (expval->num val2))))
         (op-times   () (num-val (* (expval->num val1)
                                    (expval->num val2))))
         (op-less    () (bool-val (< (expval->num val1)
                                     (expval->num val2))))
         (op-equal   () (bool-val (= (expval->num val1)
                                     (expval->num val2))))
         (op-greater () (bool-val (> (expval->num val1)
                                     (expval->num val2))))))))

  ;; apply-procedure : Proc * ExpVal * Cont -> Answer

  (define apply-procedure
    (lambda (proc1 args cont)
      (cases proc proc1
        (procedure (bvars body)
          (value-of body
                    (extend-env* bvars args the-top-level-environment)
                    cont)))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;; Continuations.
  ;;
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define-datatype continuation continuation?
    (top-level-cont)
    (binop-cont1 (op binop?)
                 (exp2 expression?)
                 (env environment?)
                 (cont continuation?))
    (binop-cont2 (op binop?)
                 (val1 expval?)
                 (cont continuation?))
    (if-cont (exp2 expression?)
             (exp3 expression?)
             (env environment?)
             (cont continuation?))
    (call-cont1 (rands (list-of expression?))
                (env environment?)
                (cont continuation?))
    (call-cont2 (rands (list-of expression?))
                (env environment?)
                (mcont mcontinuation?))
    (cut-cont (cont continuation?)
              (ref vector?)))

  (define-datatype mcontinuation mcontinuation?
    (call-mcont1 (proc proc?)
                 (cont continuation?))
    (call-mcont2 (val expval?)
                 (mcont mcontinuation?)))

  ;; apply-cont : Cont * ExpVal -> Answer

  (define apply-cont
    (lambda (cont val)
      (cases continuation cont
       (top-level-cont ()
         val)
       (binop-cont1 (op exp2 env cont)
         (value-of exp2
                   env
                   (binop-cont2 op val cont)))
       (binop-cont2 (op val1 cont)
         (apply-binop op val1 val cont))
       (if-cont (exp2 exp3 env cont)
         (if (expval->bool val)
             (value-of exp2 env cont)
             (value-of exp3 env cont)))
       (call-cont1 (rands env cont)
         (let ((proc (expval->proc val)))
           (values-of rands
                      env
                      (call-mcont1 proc cont))))
       (call-cont2 (rands env mcont)
         (values-of (cdr rands)
                    env
                    (call-mcont2 val mcont)))
       (cut-cont (cont ref)
         (let ((th1 (vector-ref ref 0))
               (th2 (vector-ref ref 1)))
           (kill-subthreads! th1)
           (kill-thread! th2)
           (apply-cont cont val))))))

  ;; apply-mcont : MCont * Listof[ExpVal] -> Answer

  (define apply-mcont
    (lambda (mcont vals)
      (cases mcontinuation mcont
       (call-mcont1 (proc cont)
         (apply-procedure proc vals cont))
       (call-mcont2 (val mcont)
         (apply-mcont mcont (cons val vals))))))
  
  (define (environment? x) #t)

  )