open Value
open Run_dispatch
open Ident
open Lambda

let eval_unary_op = ref (fun _ -> assert false)
let eval_binary_op = ref (fun _ _ -> assert false)

let ops = Hashtbl.create 13
let register_op = Hashtbl.add ops
let eval_op = Hashtbl.find ops

(* To write tail-recursive map-like iteration *)

let make_accu () = Value.Pair(nil,Absent)
let get_accu a = snd (Obj.magic a)
let map f v = let acc0 = make_accu () in set_cdr (f acc0 v) nil; get_accu acc0

let dispatcher brs =
  match brs.brs_compiled with
    | Some d -> d
    | None ->
(*	Format.fprintf Format.std_formatter "Start compilation...@."; 
	let time = Unix.gettimeofday() in*)
	let x = Patterns.Compile.make_branches brs.brs_input brs.brs in
(*	let time = Unix.gettimeofday() -. time in
	if time > 1.0 then 
	  Format.fprintf Format.std_formatter "%a@." 
	    Patterns.Compile.print_dispatcher (fst x); 
	Format.fprintf Format.std_formatter "(%f ms).@." time; *)
	brs.brs_compiled <- Some x;
	x


let stack = ref (Array.create 1024 Value.Absent)
let frame = ref 0
let sp = ref 0


let dump ppf =
  Format.fprintf ppf "sp = %i   frame = %i@." !sp !frame;
  for i = 0 to !sp - 1 do
    Format.fprintf ppf "[%i]: " i;
    if i = !frame then Format.fprintf ppf "(FRAME)";
    Format.fprintf ppf "%a@." Value.print !stack.(i)
  done 

let ensure a i = 
  let n = Array.length !a in 
  if i = n then (
    let b = Array.create (max (n*2) i) Value.Absent in
    Array.blit !a 0 b 0 n;
    a := b
  )

let set a i x =
  ensure a i;
  !a.(i) <- x

let push x =
  set stack !sp x;
  incr sp

let pop () =
  decr sp;
  !stack.(!sp)

let get_global = ref (fun cu pos -> assert false)
let set_global = ref (fun cu pos -> assert false)
let get_external = ref (fun cu pos -> assert false)
let set_external = ref (fun cu pos -> assert false)

let get_slot cu pos = !get_global cu pos
let set_slot cu pos v = !set_global cu pos v

let eval_var env = function
  | Env i -> env.(i)
  | Stack i -> !stack.(!frame + i) 
  | Dummy -> Value.Absent
  | Global i -> !stack.(i)
  | Ext (cu,pos) as x ->
      if pos < 0 then (Obj.magic cu : Value.t) else
	let v = !get_global cu pos in
	let x = Obj.repr x in
	Obj.set_field x 0 (Obj.repr v);
	Obj.set_field x 1 (Obj.repr (-1));
	v
  | External (cu,pos) as x ->
      if pos < 0 then (Obj.magic cu : Value.t) else
	let v = !get_external cu pos in
	let x = Obj.repr x in
	Obj.set_field x 0 (Obj.repr v);
	Obj.set_field x 1 (Obj.repr (-1));
	v

let rec eval env = function
  | Var x -> eval_var env x
  | Apply (false,e1,e2) -> 
      let v1 = eval env e1 in
      let v2 = eval env e2 in
      eval_apply v1 v2
  | Apply (true,e1,e2) -> 
      let v1 = eval env e1 in
      let v2 = eval env e2 in
      eval_apply_tail_rec v1 v2
  | Abstraction (slots,iface,body) -> eval_abstraction env slots iface body
  | Const c -> Value.const c
  | Pair (e1,e2) -> 
      let v1 = eval env e1 in
      let v2 = eval env e2 in
      Value.Pair (v1,v2)
  | Xml (e1,e2,e3) -> 
      let v1 = eval env e1 in
      let v2 = eval env e2 in
      let v3 = eval env e3 in
      Value.Xml (v1,v2,v3)
  | Record r -> Value.Record (LabelMap.map (eval env) r)
  | String (i,j,s,q) -> Value.substring_utf8 i j s (eval env q)
  | Match (e,brs) -> eval_branches env brs (eval env e)

  | Map (arg,brs) -> eval_map env brs (eval env arg)
  | Xtrans (arg,brs) -> eval_xtrans env brs (eval env arg)
  | Try (arg,brs) -> eval_try env arg brs
  | Transform (arg,brs) -> eval_transform env brs (eval env arg) 
  | Dot (e, l) -> eval_dot l (eval env e)
  | RemoveField (e, l) -> eval_remove_field l (eval env e)
  | UnaryOp (op,e) -> !eval_unary_op op (eval env e)
  | BinaryOp (op,e1,e2) ->  
      let v1 = eval env e1 in
      let v2 = eval env e2 in
      !eval_binary_op op v1 v2
  | Validate (e, kind, schema, name) -> eval_validate env e kind schema name
  | Ref (e,t) -> eval_ref env e t
  | Op (op,args) -> eval_op op (List.map (eval env) args)

and eval_abstraction env slots iface body =
  let local_env = Array.map (eval_var env) slots in
  let a = Value.Abstraction2 (local_env,iface,body) in
  local_env.(0) <- a;
  a

and eval_apply f arg =
  match f with
    | Value.Abstraction2 (local_env,_,body) -> 
	let saved_frame = !frame and saved_sp = !sp in 
	frame := !sp;
	let v = eval_branches local_env body arg in
	frame := saved_frame;
	sp := saved_sp;
	v
    | Value.Abstraction (_,f) -> f arg
    | _  -> assert false

and eval_apply_tail_rec f arg =
  match f with
    | Value.Abstraction2 (local_env,_,body) -> 
	sp := !frame;
	eval_branches local_env body arg
    | Value.Abstraction (_,f) -> f arg
    | _  -> assert false



and eval_branches env brs arg =
  let (disp, rhs) = dispatcher brs in
  let (code, bindings) = Run_dispatch.run_dispatcher disp arg in
  match rhs.(code) with 
    | Patterns.Compile.Match (bind,e) ->
	let saved_sp = !sp in
	List.iter 
	  (fun (_,i) -> push (if (i == -1) then arg else bindings.(i)))
	  bind;
 	if brs.brs_tail 
	then eval env e 
	else
	  let v = eval env e in
	  sp := saved_sp;
	  v
    | Patterns.Compile.Fail -> Value.Absent

and eval_ref env e t=
  Value.mk_ref (Types.descr t) (eval env e)

and eval_validate env e kind schema_name name = 
  let schema = Typer.get_schema schema_name in
  try
    let validate =
      match Schema_common.get_component kind name schema with
      | Schema_types.Type x -> Schema_validator.validate_type x schema
      | Schema_types.Element x -> Schema_validator.validate_element x schema
      | Schema_types.Attribute x ->
          assert false  (* TODO see schema/schema_validator.mli *)
(*           Schema_validator.validate_attribute x schema *)
      | Schema_types.Attribute_group x ->
          Schema_validator.validate_attribute_group x schema
      | Schema_types.Model_group x ->
          Schema_validator.validate_model_group x schema
    in
    validate (eval env e)
  with Schema_common.XSI_validation_error msg ->
    failwith' ("Schema validation failure: " ^ msg)

and eval_try env arg brs =
  let saved_frame = !frame and saved_sp = !sp in
  try eval env arg
  with (CDuceExn v) as exn ->
    frame := saved_frame;
    sp := saved_sp;
    match eval_branches env brs v with
      | Value.Absent -> raise exn
      | x -> x

and eval_map env brs v =
  map (eval_map_aux env brs) v

and eval_map_aux env brs acc = function
  | Value.Pair (x,y) -> 
      let x = eval_branches env brs x in
      let acc' = Value.Pair (x, Absent) in
      set_cdr acc acc';
      eval_map_aux env brs acc' y
  | Value.String_latin1 (_,_,_,_) | Value.String_utf8 (_,_,_,_) as v -> 
      eval_map_aux env brs acc (normalize v)
  | Value.Concat (x,y) ->
      let acc = eval_map_aux env brs acc x in
      eval_map_aux env brs acc y
  | _ -> acc

and eval_transform env brs v =
  map (eval_transform_aux env brs) v

and eval_transform_aux env brs acc = function
  | Value.Pair (x,y) -> 
      (match eval_branches env brs x with 
	 | Value.Absent -> eval_transform_aux env brs acc y
	 | x -> eval_transform_aux env brs (append_cdr acc x) y)
  | Value.String_latin1 (_,_,_,q) | Value.String_utf8 (_,_,_,q) as v -> 
      if not brs.brs_accept_chars
      then eval_transform_aux env brs acc v
      else eval_transform_aux env brs acc (normalize v)
  | Value.Concat (x,y) ->
      let acc = eval_transform_aux env brs acc x in
      eval_transform_aux env brs acc y
  | _ -> acc


and eval_xtrans env brs v =
  map (eval_xtrans_aux env brs) v

and eval_xtrans_aux env brs acc = function
  | Value.String_utf8 (s,i,j,q) as v ->
      if not brs.brs_accept_chars
      then 
	let acc' = Value.String_utf8 (s,i,j, Absent) in
	set_cdr acc acc';
	eval_xtrans_aux env brs acc' q
      else eval_xtrans_aux env brs acc (normalize v)
  | Value.String_latin1 (s,i,j,q) as v ->
      if not brs.brs_accept_chars
      then 
	let acc' = Value.String_latin1 (s,i,j, Absent) in
	set_cdr acc acc';
	eval_xtrans_aux env brs acc' q
      else eval_xtrans_aux env brs acc (normalize v)
  | Value.Concat (x,y) ->
      let acc = eval_xtrans_aux env brs acc x in
      eval_xtrans_aux env brs acc y
  | Value.Pair (x,y) -> 
      let acc = 
	match eval_branches env brs x with
	  | Value.Absent -> 
	      let x = match x with
		| Value.Xml (tag, attr, child) -> 
		    let child = eval_xtrans env brs child in
		    Value.Xml (tag, attr, child)
		| x -> x in
	      let acc' = Value.Pair (x, Absent) in
	      set_cdr acc acc';
	      acc'
	  | x -> append_cdr acc x
      in
      eval_xtrans_aux env brs acc y
  | _ -> acc

and eval_dot l = function
  | Value.Record r -> LabelMap.assoc l r
  | v -> 
      Value.print Format.std_formatter v;
      failwith ("Cannot find field " ^ (Label.to_string (LabelPool.value l)))

and eval_remove_field l = function
  | Value.Record r -> Value.Record (LabelMap.remove l r)
  | _ -> assert false




let eval_expr e = 
  assert (!frame = 0);
  ignore (eval [||] e)

let var v =
  assert (!frame = 0);
  eval_var [||] v

let eval_split p =
  assert (!frame = 0);

  let comp = Patterns.Compile.make_branches 
	       (Types.descr (Patterns.accept p)) [ p, () ] in
  let (disp, bind) = 
    match comp with
      | (disp, [| Patterns.Compile.Match (l, ()) |]) -> (disp,l)
      | _ -> assert false in
  
  let v = pop () in
  let (_, bindings) = Run_dispatch.run_dispatcher disp v in
  List.iter (fun (_,i) -> push (if (i == -1) then v else bindings.(i))) bind
  
let protect_eval f x =
  assert (!frame = 0);
  let old_sp = !sp in
  try f x
  with exn -> frame := 0; sp := old_sp; raise exn

let expr =
  protect_eval (eval [||])

let eval = 
  protect_eval
    (function
       | Push e -> push (eval [||] e)
       | Pop -> ignore (pop ())
       | Split p -> eval_split p
       | SetGlobal (cu,i) -> !set_global cu i (pop ())
    )

let code_items = 
  protect_eval (List.iter eval)


let new_stack f x =
  let old_stack = !stack and old_frame = !frame and old_sp = !sp in
  stack := Array.create 1024 Value.Absent;
  frame := 0;
  sp := 0;
  let restore () = stack := old_stack; frame := old_frame; sp := old_sp in
  try let v = f x in  restore (); v
  with exn -> restore (); raise exn