(* A strict functional language with integers, first-order functions,
   and exceptions * sestoft@dina.kvl.dk 2001-03-14

   Does not admit mutually recursive function bindings.

   The interpreter is written in continuation-passing style, and
   implements tail calls in constant space.  To simplify argument
   evaluation, a function can take only one argument.
*)

app load ["Env"];

open Env;

fun int2bool 0 = false
  | int2bool _ = true

fun bool2int false = 0
  | bool2int true  = 1

datatype exn = 
    Exn of string

datatype expr = 
    CstI of int
  | CstB of bool
  | Var of string
  | Let of string * expr * expr
  | Prim of string * expr list
  | If of expr * expr * expr 
  | Letfun of string * string * expr * expr     (* (f, x, fbody, ebody) *)
  | Call of string * expr
  | Raise of exn
  | Handle of expr * exn * expr                 (* e1 handle exn => e2  *)

datatype value = 
    Int of int
  | RClo of string * string * expr * vfenv      (* (f, x, fbody, bodyenv) *)
withtype vfenv = (string, value) env;

datatype answer = 
    Success of int
  | Failure of string


(* This interpreter coEval1 takes the following arguments:

    * An expression e to evaluate.
    * An environment env in which to evalute it.
    * A success continuation cont which accepts as argument the value
      of the expression.

   It returns an answer: Success i or Failure s.  When the evaluation
   of e succeeds, it applies the success continuation to its result,
   and when e raises an exception (Exn s), it returns Failure s.
   Since there is no error continuation, there is no provision for
   handling raised exceptions.  
*)

local
fun coEval1 (e : expr) (env : vfenv) (cont : int -> answer) : answer =
    case e of 
        CstI i => cont i
      | CstB b => cont (bool2int b)
      | Var x  => (case lookup env x of 
                       Int i => cont i 
                     | _     => Failure "coEval1 Var")
      | Let(x, erhs, ebody) => 
            coEval1 erhs env (fn xval => 
			      let val env1 = bind1 env (x, Int xval)
			      in coEval1 ebody env1 cont end)
      | Prim(ope, [e1, e2]) => 
            coEval1 e1 env 
            (fn i1 =>
             coEval1 e2 env 
             (fn i2 =>
              case ope of
                  "*" => cont(i1 * i2)
                | "+" => cont(i1 + i2)
                | "-" => cont(i1 - i2)
                | "=" => cont(bool2int (i1 = i2))
                | "<" => cont(bool2int (i1 < i2))
                | _   => Failure "unknown primitive"))
      | Prim(ope, _) => Failure "primitive arity"
      | Letfun(f, x, fbody, ebody) => 
            let val env1 = bind1 env (f, RClo(f, x, fbody, env))
            in coEval1 ebody env1 cont end
      | Call(f, earg) => 
            (case lookup env f of
                 fclosure as RClo (f, x, fbody, env1) =>
                     coEval1 earg env  
                            (fn argv =>
			     let val env2 = bind1 env1 (f, fclosure)
				 val env3 = bind1 env2 (x, Int argv)
			     in coEval1 fbody env3 cont end)
               | _ => Failure "coEval1 Call")
      | If(e1, e2, e3) => 
	    coEval1 e1 env
	            (fn b => if int2bool b then coEval1 e2 env cont
			     else coEval1 e3 env cont)
      | Raise (Exn s) => Failure s
      | Handle(e1, exn, e2) => 
             Failure "Not implemented"
in
    fun eval1 e env = coEval1 e env (fn v => Success v)
end


(* This interpreter coEval2 takes the following arguments:

    * An expression e to evaluate.
    * An environment env in which to evalute it.
    * A success continuation cont which accepts as argument the value
      of the expression.
    * A error continuation econt, which is applied when an exception
      is thrown

   It returns an answer: Success i or Failure s.  When the evaluation
   of e succeeds, it applies the success continuation to its result,
   and when e raises an exception exn, it applies the failure
   continuation to exn.  The failure continuation may choose to handle
   the exception.  
*)

local
fun coEval2 (e : expr) (env : vfenv) 
            (cont : int -> answer) (econt : exn -> answer) : answer =
    case e of 
        CstI i => cont i
      | CstB b => cont (bool2int b)
      | Var x  => (case lookup env x of 
                       Int i => cont i 
                     | _     => Failure "coEval2 Var")
      | Let(x, erhs, ebody) => 
            coEval2 erhs env (fn xval => 
			      let val env1 = bind1 env (x, Int xval)
			      in coEval2 ebody env1 cont econt end)
                             econt
      | Prim(ope, [e1, e2]) => 
            coEval2 e1 env 
            (fn i1 =>
             coEval2 e2 env 
             (fn i2 =>
              case ope of
                  "*" => cont(i1 * i2)
                | "+" => cont(i1 + i2)
                | "-" => cont(i1 - i2)
                | "=" => cont(bool2int (i1 = i2))
                | "<" => cont(bool2int (i1 < i2))
                | _   => Failure "unknown primitive") econt) econt
      | Prim(ope, _) => Failure "primitive arity"
      | Letfun(f, x, fbody, ebody) => 
            let val env1 = bind1 env (f, RClo(f, x, fbody, env))
            in coEval2 ebody env1 cont econt end
      | Call(f, earg) => 
            (case lookup env f of
                 fclosure as RClo (f, x, fbody, env1) =>
                     coEval2 earg env  
                     (fn argv =>
                      let val env2 = bind1 env1 (f, fclosure)
                          val env3 = bind1 env2 (x, Int argv)
                      in coEval2 fbody env3 cont econt end) econt
               | _ => Failure "coEval2 Call")
      | If(e1, e2, e3) => 
            coEval2 e1 env (fn b =>
                          if int2bool b then coEval2 e2 env cont econt
                          else coEval2 e3 env cont econt) econt
      | Raise exn => econt exn
      | Handle(e1, exn, e2) => 
             let fun econt1 exn1 =
                     if exn1 = exn then coEval2 e2 env cont econt
                                   else econt exn1
             in coEval2 e1 env cont econt1 end

in
    (* The top-level error continuation returns the continuation, 
       adding the text Uncaught exception *)

    fun eval2 e env = 
        coEval2 e env 
               (fn v => Success v) 
               (fn (Exn s) => Failure ("Uncaught exception: " ^ s))
end


(* Examples in abstract syntax *)

val ex1 = Letfun("f1", "x", Prim("+", [Var "x", CstI 1]), 
                 Call("f1", CstI 12));

(* Factorial *)

val ex2 = Letfun("fac", "x", 
                 If(Prim("=", [Var "x", CstI 0]),
                    CstI 1,
                    Prim("*", [Var "x", 
                               Call("fac", Prim("-", [Var "x", CstI 1]))])),
                 Call("fac", Var "n"));

val fac10 = eval1 ex2 (Env.fromList [("n", Int 10)]);

(* Example: deep recursion to check for constant-space tail recursion *)

val exdeep = Letfun("deep", "x", 
                    If(Prim("=", [Var "x", CstI 0]),
                       CstI 1,
                       Call("deep", Prim("-", [Var "x", CstI 1]))),
                    Call("deep", Var "n"));
    
fun rundeep n = eval1 exdeep (Env.fromList [("n", Int n)]);

(* Example: throw an exception inside expression *)

val ex3 = Prim("*", [CstI 11, Raise (Exn "outahere")]);

(* Example: throw an exception and handle it *)

val ex4 = Handle(Prim("*", [CstI 11, Raise (Exn "Outahere")]),
                 Exn "Outahere", 
		 CstI 999);

(* Example: throw an exception in a called function *)

val ex5 = 
    Letfun("fac", "x", 
           If(Prim("<", [Var "x", CstI 0]),
              Raise (Exn "negative x in fac"),
              If(Prim("<", [Var "x", CstI 0]),
                 CstI 1,
                 Prim("*", [Var "x", 
                            Call("fac", Prim("-", [Var "x", CstI 1]))]))),
           Call("fac", CstI ~10));

(* Example: throw an exception but don't handle it *)

val ex6 = Handle(Prim("*", [CstI 11, Raise (Exn "Outahere")]),
                 Exn "Noway", 
		 CstI 999);