(* A meta-circular CBV interpreter for PNF *)
(* Models user function values with explicit closures. *)

module Pnfinterp :
sig 
  type value = 
      Vint of int 
    | Vrecord of (Pnf.label * value) list
    | Vvariant of Pnf.label * value
    | Vfn of (value -> value) (* primitive functions *)
    | Vclos of Pnf.id * Pnf.exp * value Env.env ref (* user-defined functions *)

  val evaluate : Pnf.exp -> value
end =
struct
  open Pnf

(* Values manipulated by the interpreter. *)
  type value = 
      Vint of int 
    | Vrecord of (label * value) list
    | Vvariant of label * value
    | Vfn of (value -> value) (* primitive functions *)
    | Vclos of id * exp * value Env.env ref (* user-defined functions *)

(* Various exceptions raised if invalid program is interpreted. *)
  exception Bad_exp
  exception Bad_app
  exception Bad_primarg
  exception Bad_switch
  exception Bad_select
  exception Bad_fix


(* The main interpreter loop. *)
  let rec eval (env:value Env.env) : exp -> value =
    let rec trivial (e:trexp) =
      match e with
	Var (id,_) -> Env.lookup env id
      | Abs((id,_),e1) -> Vclos(id,e1,ref env)
      | Int i -> Vint i
    and eval0 (e: exp) : value = 
      match e with
	Triv trexp -> trivial trexp
      |	Let((x,_),a,b) ->
	  let a' = eval0 a in
	  eval (Env.extend env x a') b
      |	App(tre1,tre2) -> apply (trivial tre1) (trivial tre2)
      |	Fix (fs,e2) ->
	  let knotenv = ref env in
	  let ext env ((fid,_),e0) = 
	    match e0 with
	      Abs((id,_),e1) -> Env.extend env fid (Vclos(id,e1,knotenv)) 
	    | _ -> raise Bad_fix in
	  let newenv = List.fold_left ext (!knotenv) fs in
	  knotenv := newenv;
	  eval newenv e2
      | Record el ->  Vrecord(List.map (fun (l,tre) -> (l,trivial tre)) el) 
      | Select(l, tre) ->  
	  begin
	    match trivial tre with
	      Vrecord(vl) ->
		begin
		  try List.assoc l vl  
		  with Not_found -> raise Bad_select
		end
	    | _ -> raise Bad_select
	  end
      | Variant(l,tre) -> Vvariant(l,trivial tre)
      | Switch(tre, el) ->
	  begin
	    match trivial tre with
	      Vvariant(l,v) ->
		begin
		  try 
		    let tre = List.assoc l el in
		    apply (trivial tre) v
		  with Not_found -> raise Bad_switch
		end
	    | _ ->  raise Bad_switch
	  end in
    eval0

  and apply v1 v2 =
    match v1 with
      Vclos (id,exp,env) -> eval (Env.extend (!env) id v2) exp
    | Vfn f -> f v2
    | _ -> raise Bad_app
	  

(* Initial environment defining primitive operations *)
  let initial_env =
    let vFalse = eval Env.empty (Tcore2pnf.translate Tcore.eFalse) in
    let vTrue = eval Env.empty (Tcore2pnf.translate Tcore.eTrue)in
    let vFst = eval Env.empty (Tcore2pnf.translate Tcore.eFst) in
    let vSnd = eval Env.empty (Tcore2pnf.translate Tcore.eSnd) in
    let iadd_prim = 
      Vfn (fun v -> 
        match (apply vFst v,apply vSnd v) with
          (Vint i1,Vint i2) -> Vint(i1+i2)
        | _ -> raise Bad_primarg) in
    let imul_prim = 
      Vfn (fun v -> 
        match (apply vFst v,apply vSnd v) with
          (Vint i1,Vint i2) -> Vint(i1*i2)
        | _ -> raise Bad_primarg) in
    let ieql_prim =
      Vfn (fun v ->
        match (apply vFst v,apply vSnd v) with
	  (Vint i1,Vint i2) -> if i1 = i2 then vTrue else vFalse
	| _ -> raise Bad_primarg) in
    List.fold_left2 Env.extend Env.empty Tcore.primops [iadd_prim;imul_prim;ieql_prim] 

(* The top level evaluator *)
  let evaluate (e : exp) : value = eval initial_env e

end