(**************************************************************************)
(*                                                                        *)
(*  Heptagon                                                              *)
(*                                                                        *)
(*  Author : Marc Pouzet                                                  *)
(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
(*                                                                        *)
(**************************************************************************)

open Names
open Idents
open Location
open Misc
open Types
open Obc
open Obc_mapfold
open Global_mapfold

let mk_var_dec ?(loc=no_location) ident ty =
  { v_ident = ident; v_type = ty; v_loc = loc }

let mk_exp ?(loc=no_location) ty desc =
  { e_desc = desc; e_ty = ty; e_loc = loc }

let mk_exp_int ?(loc=no_location) desc =
  { e_desc = desc; e_ty = Initial.tint; e_loc = loc }

let mk_exp_bool ?(loc=no_location) desc =
  { e_desc = desc; e_ty = Initial.tbool; e_loc = loc }

let mk_pattern ?(loc=no_location) ty desc =
  { pat_desc = desc; pat_ty = ty; pat_loc = loc }

let mk_pattern_int ?(loc=no_location) desc =
  { pat_desc = desc; pat_ty = Initial.tint; pat_loc = loc }

let mk_pattern_exp ty desc =
  let pat = mk_pattern ty desc in
    mk_exp ty (Epattern pat)

let mk_evar ty id =
  mk_exp ty (Epattern (mk_pattern ty (Lvar id)))

let mk_evar_int id =
  mk_exp Initial.tint (Epattern (mk_pattern Initial.tint (Lvar id)))

let mk_block ?(locals=[]) eq_list =
  { b_locals = locals;
    b_body = eq_list }

let rec var_name x =
  match x.pat_desc with
    | Lvar x -> x
    | Lmem x -> x
    | Lfield(x,_) -> var_name x
    | Larray(l, _) -> var_name l

(** Returns whether an object of name n belongs to
    a list of var_dec. *)
let rec vd_mem n = function
  | [] -> false
  | vd::l -> vd.v_ident = n or (vd_mem n l)

(** Returns the var_dec object corresponding to the name n
    in a list of var_dec. *)
let rec vd_find n = function
  | [] -> Format.eprintf "Not found var %s@." (name n); raise Not_found
  | vd::l ->
      if vd.v_ident = n then vd else vd_find n l

(** Returns the type of a [var_dec list] *)
let vd_list_to_type vd_l = match vd_l with
  | [] -> Types.Tunit
  | [vd] -> vd.v_type
  | _ -> Tprod (List.map (fun vd -> vd.v_type) vd_l)

let pattern_list_to_type p_l = match p_l with
  | [] -> Types.Tunit
  | [p] -> p.pat_ty
  | _ -> Tprod (List.map (fun p -> p.pat_ty) p_l)

let pattern_of_exp e = match e.e_desc with
  | Epattern l -> l
  | _ -> assert false

let find_step_method cd =
  List.find (fun m -> m.m_name = Mstep) cd.cd_methods
let find_reset_method cd =
  List.find (fun m -> m.m_name = Mreset) cd.cd_methods

let obj_ref_name o =
  match o with
    | Oobj obj
    | Oarray (obj, _) -> obj

(** Input a block [b] and remove all calls to [Reset] method from it *)
let remove_resets b =
  let block funs _ b =
    let b,_ = Obc_mapfold.block funs () b in
    let is_not_reset a = match a with
      | Acall( _,_,Mreset,_) -> false
      | _ -> true
    in
    let b = { b with b_body = List.filter is_not_reset b.b_body } in
    b, ()
  in
  let funs = { Obc_mapfold.defaults with block = block } in
  let b,_ = block_it funs () b in
  b


(*
module Deps =
struct

  let deps_longname deps { qual = modn; } = S.add modn deps

  let deps_static_exp_desc funs deps sedesc =
    let (sedesc, deps) = Global_mapfold.static_exp_desc funs deps sedesc in
    match sedesc with
      | Svar ln -> (sedesc, deps_longname deps ln)
      | Sconstructor ln -> (sedesc, deps_longname deps ln)
      | Srecord fnel ->
        let add deps (ln, _) = deps_longname deps ln in
        (sedesc, List.fold_left add deps fnel)
      | Sop (ln, _) -> (sedesc, deps_longname deps ln)
      | _ -> raise Errors.Fallback

  let deps_lhsdesc funs deps ldesc =
    let (ldesc, deps) = Obc_mapfold.lhsdesc funs deps ldesc in
    match ldesc with
      | Lfield (_, ln) -> (ldesc, deps_longname deps ln)
      | _ -> raise Errors.Fallback

  let deps_edesc funs deps edesc =
    let (edesc, deps) = Obc_mapfold.edesc funs deps edesc in
    match edesc with
      | Eop (ln, _) -> (edesc, deps_longname deps ln)
      | Estruct (ln, fnel) ->
        let add deps (ln, _) = deps_longname deps ln in
        (edesc, List.fold_left add (deps_longname deps ln) fnel)
      | _ -> raise Errors.Fallback

  let deps_act funs deps act =
    let (act, deps) = Obc_mapfold.act funs deps act in
    match act with
      | Acase (_, cbl) ->
        let add deps (ln, _) = deps_longname deps ln in
        (act, List.fold_left add deps cbl)
      | _ -> raise Errors.Fallback

  let deps_obj_dec funs deps od =
    let (od, deps) = Obc_mapfold.obj_dec funs deps od in
    (od, deps_longname deps od.o_class)

  let deps_program p =
    let funs = { Obc_mapfold.defaults with
      global_funs = { Global_mapfold.defaults with
                        static_exp_desc = deps_static_exp_desc; };
      lhsdesc = deps_lhsdesc;
      edesc = deps_edesc;
      act = deps_act;
      obj_dec = deps_obj_dec;
    } in
    let (_, deps) = Obc_mapfold.program funs S.empty p in
    S.remove p.p_modname (S.remove Pervasives deps)
end
*)