(*An Unstaged and  Staged Interprter For Featherweight Java.
 *Copyright Anthony Castanares, 2005
 *)

Trx.init_times ()  

let empty = []

(* The BNF for Featherweight Java
 *)
type var       = string
type className = string
type methName  = string
type fieldName = string

type exp = 
    Var of var 
  | Inv of exp * methName * exp list 
  | Sel of exp * fieldName
  | New of className * exp list

type methDef    = var list * exp
type classDecl  = className * fieldName list * (methName *  methDef) list 
type classTable = (className * classDecl) list
type program    = classTable * exp

type 'a value = Obj of className * 'a value list 

exception EvalError of string

(* lookup : symbol -> (symbol * 'a) list -> 'a *)
let rec lookup k' x =
  match x with 
    ((k,v)::l) -> if k=k' then Some v else lookup k' l
  | _          -> None

(* zip : ('a list * 'b list) -> ('a * 'b) list *)
let rec zip (a,b) =
  match (a,b) with
    (x::xs, y::ys) -> (x,y) :: zip (xs,ys)
  | _              -> []

(* lookupField: class table -> field name ->      *)
(*       (class name * field value list) -> value *)

let rec lookupField table fieldname (classname,fieldvaluelist) =
  match lookup classname table with 
      None -> raise(EvalError("Error: class not found - Field: "^classname))
    | Some (super,fields,_) ->
 	let rec search (a,b) = 
          match (a,b) with
            (name::namelist, value::valuelist) ->
		         if fieldname=name then value else search (namelist,valuelist)
            |([],valuelist) ->
		         lookupField table fieldname (super,valuelist)
	         | (_,[]) ->
		         raise(EvalError("Error: Some fields not defined."))
	in search (fields,fieldvaluelist)

(* Old method lookup function required for unstaged interpreter
 *(string * (string * 'a * ('b * 'c) list)) list -> 'b -> string -> 'c 
 *)
let rec lookupMeth table methodname classname =
  match lookup classname table with
  |  None -> raise(EvalError("Error: class not found - Method: "^classname))
  | Some (super,_,meths) ->
        match lookup methodname meths with
        |  Some x -> x
        | None   -> lookupMeth table methodname super

(*Unstaged Interpreter
 * (className *
 *  (className * fieldName list * (methName * (var list * exp)) list))
 *    list -> (var * 'a value) list -> exp -> 'a value = <fun>      
 *)
let rec interp table =
  let interpT env =
    let rec interpTE =
      fun a -> match a with
          Var x -> let v' = lookup x env in
       (match v' with
       Some v -> v
          | None   ->
         raise(EvalError("Error: variable not found: "^x)))
   | Inv (objexp,methodname,arglist) ->
       let v = (interpTE objexp) in
       let classname = match v with
      (Obj (c,_)) -> c in
       let z = lookupMeth table methodname classname
       and argvallist = (List.map interpTE arglist) in
            let (varlist,evalmeth) = z in
         interp table (("this",v)::(zip (varlist,argvallist))) evalmeth
   | Sel (objexp,fieldname)    ->
       let Obj (classname,fieldvaluelist) = (interpTE objexp)
       in (lookupField table fieldname (classname,fieldvaluelist))
   | New (classname,fieldvalueslist)   ->
       Obj (classname, (List.map interpTE fieldvalueslist))
    in interpTE
  in interpT
   
(***   END OF UNSTAGED INTERPRETER  ***)
   
(**********************************************************)
(**********************************************************)

(***   BEGINING OF STAGED INTERPRETER **)

(*  mapp : ('a -> ('b, 'c) code) -> 'a list -> ('b, 'c list) code  *)
   
let rec mapp (f:'a -> ('c, 'b) code) (l:'a list) : ('c, 'b list) code = 
        match l with 
        | [] -> .<[]>.
        | (h::t) ->  .< .~(f h) :: .~(mapp f t) >. 

(* lookupNewMethod :
 *    string -> 'a -> (string * ('b * 'c * ('a * 'd))) list -> 'd
 *)
        
let rec lookupNewMethod cName mName table = 
   match table with
   | (cN, (sC, feilds, (methName,methFun)))::tail ->
      if (cN = cName) then
         if (mName = methName) then
            methFun
         else raise(EvalError("Method not found in " ^ cName))
      else lookupNewMethod cName mName tail
   | [] -> raise(EvalError("Method not found"))

(*Conversion function, self explainatory:
 * ('a, 'b) code list -> ('a, 'b list) code
 *)
let rec listOfCode_2_CodeOfList l =
   match l with
   |[] -> .<[]>.
   |(hd::tail) -> .<.~hd :: .~(listOfCode_2_CodeOfList tail)>.

(*Staged Interprter:
 * ('a,
 *  (className *
 *      (className * fieldName list *
 *           (methName * ('b value -> 'b value list -> 'b value))))
 *              list) code -> 
 *              (var * ('a, 'b value) code) list -> exp -> ('a, 'b
 *                value) code
 *)

let rec interpS (table:('b, (className * (className * fieldName list *
          (methName * ('a value -> 'a value list -> 'a value)))) list) code) 
      env a = 
   match a with 
	| Sel (objexp,fieldname)    -> 
       .< let Obj (classname,fieldvaluelist) = .~(interpS table env objexp)
	    in (lookupField (.~table) fieldname (classname,fieldvaluelist))>. 
   | Var x -> let v' = lookup x env in
	    (match v' with
        | Some v -> v
	     | None   -> .<raise(EvalError("Error: variable not found: "^x))>.)
   | New (classname,fieldvalueslist)   ->
 	       let l = fieldvalueslist in 
          let f = (interpS table env) in  
          let tl = mapp f l in
          .<(Obj (classname, .~tl ))>. 
   | Inv (objexp,methodname,arglist) -> 
         let args = (List.map (interpS table env) arglist) in (*do before!*)
       .<let v = .~(interpS table env objexp) in
          match v with
           Obj(c,_) -> 
            let fun_method = lookupNewMethod c methodname (.~table) in
            let new_args = .~(listOfCode_2_CodeOfList args) in
            fun_method v new_args >.

(* interface :
 *  ('a,
 *    (className *
 *        (className * fieldName list *
 *             (methName * ('b value -> 'b value list -> 'b value))))
 *                list)
 *                  code ->
 *                    (var * ('a, 'b value) code) list ->
 *                      exp -> ('a, 'b value list -> 'b value) code = <fun>
 *)                       
let rec interface table env a = 
   match a with
   | Inv (objexp, methodname, []) -> 
       .<fun x -> 
         let v = .~(interpS table env objexp) in
          match v with
           Obj(c,_) -> 
            let fun_method = lookupNewMethod c methodname (.~table) in
            (*let new_args = .~(listOfCode_2_CodeOfList args) in*) (*do before!*)
            fun_method v x >.
           
   
(*Function to simply evaluate the body of a method.
 * var list ->
 *   exp ->
 *     ('a,
 *        (className *
 *            (className * fieldName list *
 *                 (methName * ('b value -> 'b value list -> 'b value))))
 *                    list) code ->
 *                        ('a, 'b value) code -> 
 *                        ('a, 'b value) code list ->
 *                        ('a, 'b value) code
 *)
let evalMeth arglist body 
    (table:('b, (className * (className * fieldName list *
      (methName * ('a value -> 'a value list -> 'a value)))) list) code)=
   fun this -> fun args -> 
      (interpS table (("this",this)::(zip (arglist, args))) body)

      
(* f2l : ('a, 'b list) code -> int -> ('a, 'b) code list
 *)
let rec f2l a n =
   if (n = 0) then [] else
      .<(List.hd .~a)>.:: (f2l .<(List.tl .~a)>. (n-1))


(* mkTable:
 * ('b, (className * (className * fieldName list *
 *    (methName * ('a value -> 'a value list -> 'a value)))) list) code
 *)
          
let rec mkTable (old_class_table: classTable) 
  (x : ('b, (className * (className * fieldName list *
   (methName * ('a value -> 'a value list -> 'a value)))) list) code) 
  : ('b, (className * (className * fieldName list * 
        (methName * ('a value -> 'a value list -> 'a value)))) list) code
 = match old_class_table with
   | (className, 
       (superClass, fieldList, 
          (methName,(varList,methBody))::methTail))::tail ->
            let n = List.length varList in
            .<(className, (superClass, fieldList, (methName, 
            fun t -> fun a -> 
              .~(evalMeth varList methBody x .<t>. (f2l .<a>. n)))))
               :: (.~(mkTable tail x))>.
    | (className, (superClass, fieldList, []))::tail ->
        .<(className,
            (superClass,fieldList, 
               ("null", fun t -> fun a -> t))) :: (.~(mkTable tail x))>.
    | [] -> .<[]>.

(* topLevel : classTable -> exp -> ('a, 'b value) code *)
    
let topLevel old_c_table expression = 
   .<let rec table = .~(mkTable old_c_table .<table>.) in
      .~(interface .<table>. [] expression)>.

(* END OF STAGED INTERPRETER *)

(*================================*)

(* START OF CLASS DECLARATIONS *)

(* Root of the Class Heirarchy                           *)
(* class myObject { }                                    *)

let myObj : className = "myObject"
let myObject : classDecl = ("",[],empty)

let myObj2 : className = "myObject2"
let myObject2 : classDecl = ("",[],empty)

(* Class Thunk to Memoize Values                         *)
(* class thunk ext myObject                              *)
(*   { myObject val; myObject get () { this.val } }      *)

let thunkk : className = "thunk"
let thunk : classDecl = ("myObject", ["val"],
        [("get", ([], Sel (Var "this", "val")))])


(* Boolean Class, True, False Classes                    *)
(* class bool ext myObject                               *)
(*   { myObject if (thunk x, thunk y) { this.if(x,y) } } *)
(* class true ext bool                                   *)
(*        { myObject if (thunk x, thunk y) { x.get() } } *)
(* class myFalse ext bool                                *)
(*        { myObject if (thunk x, thunk y) { y.get() } } *)

let booll : className = "bool"
let bool : classDecl = ("myObject", [],
       [("if", (["x";"y"], Inv (Var "this", "if", [Var "x";Var "y"])))])

let myT : className = "myTrue"
let myTrue : classDecl = ("thunk", [],
         [("if", (["x";"y"], Inv (Var "x", "get", [])))])

let myF : className = "myFalse"
let myFalse : classDecl = ("thunk", [],
          [("if", (["x";"y"], Inv (Var "y", "get", [])))])

(* End of Class Declarations *)

(* BEGIN EXAMPLES *)

let classTable : classTable =[
   ("myObject",myObject);("thunk",thunk);("myFalse",myFalse)];;

let exp1unstaged : exp = (Inv
 (New
   ("thunk",[New("thunk",[New("myObject",[])])]),
    "get",
      [New ("thunk", [New ("myObject2", [])])]));;

let exp1staged : exp = (Inv
 (New
   ("thunk",[New("thunk",[New("myObject",[])])]),
    "get",
      []));;

let arg_list1 = [New ("thunk", [New ("myObject2", [])])];;

let exp2unstaged : exp = (Inv(New("myFalse",[New("thunk",[New("myObject",[])]);New("myObject2",[])]),"if",[New ("thunk", [New ("myObject", [])]); 
    New ("thunk", [New ("myObject2", [])])]));;

let exp2staged : exp = (Inv(New("myFalse",[New("thunk",[New("myObject",[])]);New("myObject2",[])]),"if",[]));;

let arg_list2 = 
   [New ("thunk", [New ("myObject", [])]); 
    New ("thunk", [New ("myObject2", [])])];;

(***)
let numm : className = "num"
let num :classDecl = ("myObject",
     [], [ ("ifz", (["z";"s"], Inv (Var "z", "get", [])))]);;

let zeroo : className = "zero"
let zero : classDecl = ("num", [], []);;

let classTable3 : classTable = 
   [("myObject",myObject);("thunk",thunk);
    ("myFalse",myFalse);("num",num);("zero",zero)];;

let exp3unstaged : exp =
   (Inv(New("num",[New("thunk",[New("myObject",[])]);New("myObject2",[])]),
    "ifz",
    [New("thunk",[New("myObject",[])]);New("myObject2",[])]));;

let exp3staged : exp = 
   (Inv(New("num",[New("thunk",[New("myObject",[])]);New("myObject2",[])]),
       "ifz",
           []));;

let arg_list3 = [New("thunk",[New("myObject",[])]);New("myObject2",[])];;

(***)

(* START OF TIMING EXPERIMENTS *)

let unstaged_exp1 = Trx.time 10000 "Example #1 unstaged"
     (fun () -> (interp classTable [] exp1unstaged));;

let code_exp1 = Trx.time 10000 "Example #1 stage 1"
     (fun () -> (topLevel classTable exp1staged));;

let compile_exp1 = Trx.time 100 "Example #1 compiling"
     (fun () -> .!code_exp1);;

let new_args_interp_exp1 = (List.map(interp classTable []) arg_list1);;

let stage2_exp1 = Trx.time 10000 "Example #1 stage2"
     (fun () -> compile_exp1 new_args_interp_exp1)
     
(****)
let unstaged_exp2 = Trx.time 10000 "Example #2 unstaged" 
     (fun () -> (interp classTable [] exp2unstaged));;

let code_exp2 = Trx.time 10000 "Example #2 stage 1" 
     (fun () -> (topLevel classTable exp2staged));;

let compile_exp2 = Trx.time 100 "Example #2 compiling"
     (fun () -> .!code_exp2);;

let new_args_interp_exp2 = (List.map(interp classTable []) arg_list2);;

let stage2_exp2 = Trx.time 10000 "Example #2 stage 2"
     (fun () -> compile_exp2 new_args_interp_exp2)

(****)
let unstaged_exp3 = Trx.time 10000 "Example #3 unstaged" 
     (fun () -> (interp classTable3 [] exp3unstaged));;

let code_exp3 = Trx.time 10000 "Example #3 stage 1" 
     (fun () -> (topLevel classTable3 exp3staged));;

let compile_exp3 = Trx.time 100 "Example #3 compiling"
     (fun () -> .!code_exp3);;

let new_args_interp_exp3 = (List.map(interp classTable3 []) arg_list3);;

let stage2_exp3 = Trx.time 10000 "Example #3 stage 2"
     (fun () -> compile_exp3 new_args_interp_exp3)

(****)

let _ = Trx.print_times ()