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

(* $Id$ *)

open Format
open List
open Misc
open Names
open Ident
open Obc
open Modules
open Global
open C
open Location
open Printf

module Error =
struct
  type error =
    | Evar of string
    | Enode of string
    | Eno_unnamed_output

  let message loc kind =
    begin match kind with
      | Evar name ->
          eprintf "%aCode generation : The variable name '%s' is unbound.\n"
            output_location loc 
	    name
      | Enode name ->
          eprintf "%aCode generation : The node name '%s' is unbound.\n"
            output_location loc 
	    name
      | Eno_unnamed_output ->
          eprintf "%aCode generation : Unnamed outputs are not supported. \n"
            output_location loc 	  
    end;
    raise Misc.Error
end

let struct_name = function
  | Heptagon.Tid n -> n
  | _ -> assert false

let cname_of_name' name = match name with
  | Name n -> Name (cname_of_name n)
  | _ -> name

let rec print_list ff print sep l =
  match l with
    | [] -> ()
    | [x] -> print ff x
    | x :: l ->
        print ff x;
        fprintf ff "%s@ " sep;
        print_list ff print sep l

(* Function to deal with opened modules set. *)
type world = { mutable opened_modules : S.t }
let world = { opened_modules = S.empty }

let add_opened_module (m:string) = 
  world.opened_modules <- S.add (String.uncapitalize (cname_of_name m)) world.opened_modules
let get_opened_modules () =
  S.elements  world.opened_modules
let remove_opened_module (m:string) =
  world.opened_modules <- S.remove m world.opened_modules
let reset_opened_modules () =
  world.opened_modules <- S.empty

let shortname = function
  | Name(n) -> n
  | Modname(q) -> 
      if q.qual <> "Pervasives" then 
	add_opened_module q.qual;
      q.id

(** Returns the information concerning a node given by name. *) 
let node_info classln = 
  match classln with
    | Modname {qual = modname; id = modname_name } ->
	  begin try
            modname, find_value (Modname({qual = modname;
					  id = modname_name }))
	  with Not_found ->
	    (* name might be of the form Module.name, remove the module name*)
            let ind_name = (String.length modname) + 1 in
            let name = String.sub modname_name ind_name
              ((String.length modname_name)-ind_name) in
	      begin try
		modname, find_value (Modname({qual = modname;
					      id = name }))
	      with Not_found ->
		Error.message no_location (Error.Enode name)
	      end
	  end
    | Name n ->
        Error.message no_location (Error.Enode n)

let output_names_list sig_info = 
  let remove_option ad = match ad.a_name with
    | Some n -> n
    | None -> Error.message no_location Error.Eno_unnamed_output (*TODO fresh*)
  in
    List.map remove_option sig_info.info.outputs

(******************************)

(** {2 Translation from Obc to C using our AST.} *)

(** [fold_stm_list] is an utility function that transforms a list of statements
    into one statements using Cseq constructors. *)

(** [ctype_of_type mods oty] translates the Obc type [oty] to a C
    type. We assume that identified types have already been defined
    before use. [mods] is an accumulator for modules to be opened for
    each function (i.e., not opened by an "open" declaration). 
    We have to make a difference between function args and local vars
    because of arrays (when used as args, we use a pointer).
*)
let rec ctype_of_otype oty =
  match oty with
    | Tint -> Cty_int
    | Tfloat -> Cty_float
    | Tid id ->
          begin match shortname id with
              (* standard C practice: use int as boolean type. *)
            | "bool" -> Cty_int
            | "int" -> Cty_int
            | "float" -> Cty_float
            | id -> Cty_id id
          end
    | Tarray(ty, n) ->
	Cty_arr(n, ctype_of_otype ty)

let ctype_of_heptty ty =
  let ty = Merge.translate_btype ty in
  let ty = Translate.translate_type NamesEnv.empty ty in
    ctype_of_otype ty

let cvarlist_of_ovarlist vl =
  let cvar_of_ovar vd =
    let ty = ctype_of_otype vd.v_type in
    let ty = if vd.v_pass_by_ref then pointer_to ty else ty in
      name vd.v_name, ty 
  in
    List.map cvar_of_ovar vl

let copname = function
  | "="  -> "==" | "<>" -> "!=" | "&"  -> "&&" | "or" -> "||" | "+" -> "+"
  | "-" -> "-" | "*" -> "*" | "/" -> "/" | "*." -> "*" | "/." -> "/"
  | "+." -> "+" | "-." -> "-" | "<"  -> "<" | ">"  -> ">" | "<=" -> "<="
  | ">=" -> ">="
  | "~-" -> "-" | "not" -> "!"
  | op   -> op

(** Translates an Obc var_dec to a tuple (name, cty). *) 
let cvar_of_vd vd =
  name vd.v_name, ctype_of_otype vd.v_type

(** If idx_list = [e1;..;ep], returns the lhs e[e1]...[ep] *)
let rec csubscript_of_e_list e idx_list = 
  match idx_list with
    | [] -> e
    | idx::idx_list ->
	Carray (csubscript_of_e_list e idx_list, idx)

(** If idx_list = [i1;..;ip], returns the lhs e[i1]...[ip] *)
let csubscript_of_idx_list e idx_list = 
  csubscript_of_e_list e (List.map (fun i -> Cconst (Ccint i)) idx_list)

(** Creates the expression that checks that the indices 
    in idx_list are in the bounds. If idx_list=[e1;..;ep]
    and bounds = [n1;..;np], it returns 
    e1 <= n1 && .. && ep <= np *)
let rec bound_check_expr idx_list bounds = 
  match idx_list, bounds with
    | [idx], [n] ->
	Cbop ("<", idx, Cconst (Ccint n))
    | idx::idx_list, n::bounds ->
	Cbop ("&", Cbop ("<", idx, Cconst (Ccint n)), 
	      bound_check_expr idx_list bounds)
    | _, _ -> assert false

(** Generate the expression to copy [src] into [dest], where bounds
    represents the bounds of these two arrays. *)
let rec copy_array src dest bounds = 
  match bounds with
    | [] -> [Caffect (dest, Clhs src)]
    | n::bounds -> 
	let x = gen_symbol () in
	[Cfor(x, 0, n, 
	     copy_array (Carray (src, Clhs (Cvar x))) 
	       (Carray (dest, Clhs (Cvar x))) bounds)]

(** Returns the type associated with the name [n]
    in the environnement [var_env] (which is an association list
    mapping strings to cty). *)
let rec assoc_type n var_env =
  match var_env with
    | [] -> Error.message no_location (Error.Evar n)
    | (vn,ty)::var_env ->
	if vn = n then
	  ty
	else
	  assoc_type n var_env

(** Returns the type associated with the lhs [lhs]
    in the environnement [var_env] (which is an association list
    mapping strings to cty).*)
let rec assoc_type_lhs lhs var_env =
  match lhs with
    | Cvar x -> assoc_type x var_env
    | Carray (lhs, idx) -> 
	let ty = assoc_type_lhs lhs var_env in
	  array_base_ctype ty [1]
    | Cderef lhs -> assoc_type_lhs lhs var_env
    | Cfield(Cderef (Cvar "self"), x) -> assoc_type x var_env
    | Cfield(x, f) ->
	let ty = assoc_type_lhs x var_env in
	let { info = { arg = ty_arg; } } = find_field (longname f) in
	let n = struct_name ty_arg in
	let { info = { fields = fields } } = find_struct n in
	  ctype_of_heptty (List.assoc f fields)
    | _ -> Cty_int (*TODO: add more cases*)

(** Creates the expression dest <- src (copying arrays if necessary). *)
let rec create_affect_stm dest src ty =
  match ty  with 
    | Cty_arr (n, bty) ->
	let src = lhs_of_exp src in
	let x = gen_symbol () in
	  [Cfor(x, 0, n, 
		create_affect_stm (Carray (dest, Clhs (Cvar x))) 
		  (Clhs (Carray (src, Clhs (Cvar x)))) bty)]
    | _ -> [Caffect (dest, src)]

(** Returns the expression to use e as an argument of
    a function expecting a pointer as argument. *)
let address_of e =
  try 
    let lhs = lhs_of_exp e in
      match lhs with
	| Carray _ -> Clhs lhs
	| Cderef lhs -> Clhs lhs
	| _ -> Caddrof lhs
  with _ ->
    e

(** [cexpr_of_exp exp] translates the Obj action [exp] to a C expression. *)
let rec cexpr_of_exp var_env exp =
  match exp with
      (** Obj expressions that form valid C lhs are translated via clhs_of_exp. *)
    | Lhs _ | Array_select _  ->
        Clhs (clhs_of_exp var_env exp)
	  (** Constants, the easiest translation. *)
    | Const lit ->
        begin match lit with
          | Cint i -> Cconst (Ccint i)
          | Cfloat f -> Cconst (Ccfloat f)
          | Cconstr c -> Cconst (Ctag (shortname c))
	  | Carray(n,c) -> 
	      let cc = cexpr_of_exp var_env (Const c) in
		Carraylit (repeat_list cc n)
        end
      (** Operators *)
    | Op(op, exps) ->
        cop_of_op var_env op exps
	  (** Structure literals. *)
    | Struct (tyn, fl) ->
        let cexps = List.map (fun (_,e) -> cexpr_of_exp var_env e) fl in
	let ctyn = shortname tyn in
	  Cstructlit (ctyn, cexps)
    | Array e_list ->
	Carraylit (cexprs_of_exps var_env e_list)
	  
and cexprs_of_exps var_env exps =
  List.map (cexpr_of_exp var_env) exps 

and cop_of_op_aux var_env op_name cexps =
  match op_name with
    | Modname { qual = "Pervasives"; id = op } ->
          begin match op,cexps with
            | "~-", [e] -> Cuop ("-", e)
            | "not", [e] -> Cuop ("!", e)
            | (
                "=" | "<>"
              | "&" | "or"
              | "+" | "-" | "*" | "/"
              | "*." | "/." | "+." | "-."
              | "<" | ">" | "<=" | ">="), [el;er] ->
                Cbop (copname op, el, er)
            | _ -> Cfun_call(op, cexps)
          end 
    | Modname {qual = m; id = op} ->
	add_opened_module m;
        Cfun_call(op,cexps)
    | Name(op) ->
        Cfun_call(op,cexps)

and cop_of_op var_env op_name exps = 
  let cexps = cexprs_of_exps var_env exps in
    cop_of_op_aux var_env op_name cexps

and clhs_of_lhs var_env = function
  (** Each Obc variable corresponds to a real local C variable. *)
  | Var v -> 
      let n = name v in
      let ty = assoc_type n var_env in
	(match ty with
	  | Cty_ptr _ -> Cderef (Cvar n)
	  | _ -> Cvar n
	)
      (** Dereference our [self] struct holding the node's memory. *)
  | Mem v -> Cfield (Cderef (Cvar "self"), name v)
      (** Field access. /!\ Indexed Obj expression should be a valid lhs!  *)
  | Field (l, fn) -> Cfield(clhs_of_lhs var_env l, shortname fn)
  | Array (l, idx) -> 
      Carray(clhs_of_lhs var_env e, cexpr_of_exp var_env idx)

and clhss_of_lhss var_env lhss =
  List.map (clhs_of_lhs var_env) lhss

and clhs_of_exp var_env exp = match exp with
  | Lhs l -> clhs_of_lhs var_env l
        (** We were passed an expression that is not translatable to a valid C lhs?! *)
  | _ -> invalid_arg "clhs_of_exp: argument not a Var, Mem or Field"

let rec assoc_obj instance obj_env =
  match obj_env with
    | [] -> raise Not_found
    | od :: t ->
        if od.obj = instance
        then od
        else assoc_obj instance t

let assoc_cn instance obj_env =
  (assoc_obj instance obj_env).cls

let is_op = function
  | Modname { qual = "Pervasives"; id = _ } -> true
  | _ -> false

(** Creates the list of arguments to call a node. [targeting] is the targeting of 
    the called node, [mem] represents the node context and [args] the argument list.*)
let step_fun_call sig_info args mem =
  let rec add_targeting i l ads = 
    match l, ads with
    | [] ,[] -> []
    | e::l, ad::ads -> 
	let e =
	  if ad.a_pass_by_ref then 
	    (*this arg is targeted, use a pointer*)
	    address_of e
	  else
	    e
	in
	  e::(add_targeting (i+1) l ads)
    | _ , _ -> assert false
  in 
    (add_targeting 0 args sig_info.inputs)@[Caddrof mem]

(** Generate the statement to call [objn]. 
    [outvl] is a list of lhs where to put the results. 
    [args] is the list of expressions to use as arguments.
    [mem] is the lhs where is stored the node's context.*)
let generate_function_call var_env obj_env outvl objn args mem =
 (** Class name for the object to step. *)
  let classln = assoc_cn objn obj_env in
  let classn = shortname classln in
  let mod_classn, sig_info = node_info classln in

  let fun_call = 
    if is_op classln then
      cop_of_op_aux var_env classln args
    else
      (** The step function takes scalar arguments and its own internal memory
        holding structure. *)
      let args = step_fun_call sig_info.info args mem in
	(** Our C expression for the function call. *)
        Cfun_call (classn ^ "_step", args)
  in

    (** Act according to the length of our list. Step functions with
        multiple return values will return a structure, and we care of
        assigning each field to the corresponding local variable. *)
    match outvl with
      | [] -> [Csexpr fun_call]
      | [vr] when Heptagon.is_scalar_type (List.hd sig_info.info.outputs).a_type ->
	  [Caffect (vr, fun_call)] 
      | _ ->
          (* Remove options *)
          let out_sig = output_names_list sig_info in
          let create_affect outv out_name =
	    let ty = 
	      match outv with 
	      | Cvar x -> assoc_type x var_env 
	      | Carray(Cvar x, _) -> array_base_ctype (assoc_type x var_env) [1]
	      | Carray(Cfield(Cderef (Cvar "self"), x), _) -> 
		  array_base_ctype (assoc_type x var_env) [1]
	      | _ -> Cty_void (*we don't care about the type*)
	    in
              create_affect_stm outv
		(Clhs (Cfield (mem,
                               mod_classn ^ "_" ^ out_name))) ty in
	    (Csexpr fun_call)::(List.flatten (map2 create_affect outvl out_sig))

(** Create the statement dest = c where c = v^n^m... *)
let rec create_affect_const var_env dest c =
  match c with
    | Carray(n,c) -> 
	let x = gen_symbol () in
	  [ Cfor(x, 0, n, 
		create_affect_const var_env (Carray (dest, Clhs (Cvar x))) c) ]
    | _ -> [Caffect (dest, cexpr_of_exp var_env (Const c))]

let create_field_update x r f v (n,ty) =
  let ty = ctype_of_heptty ty in
  if n = f then 
    create_affect_stm (Cfield(x,n)) v ty
  else
    create_affect_stm (Cfield(x, n)) (Clhs (Cfield(r,n))) ty

(** [cstm_of_act obj_env mods act] translates the Obj action [act] to a list of C
    statements, using the association list [obj_env] to map object names to class
    names.  *)
let rec cstm_of_act var_env obj_env act =
  match act with
    (** Case on boolean values are converted to if instead of switch! *)
    | Case (c, [(Name "true", te); (Name "false", fe)])
    | Case (c, [(Name "false", fe); (Name "true", te)]) ->
        let cc = cexpr_of_exp var_env c in
        let cte = cstm_of_act var_env obj_env te in
        let cfe = cstm_of_act var_env obj_env fe in
        [Cif (cc, cte, cfe)]
    (** Translation of case into a C switch statement is simple enough: we just
        recursively translate obj expressions and statements to corresponding C
        constructs, and cautiously "shortnamize" constructor names. *)
    | Case (e, cl) ->
        (** [ccl_of_obccl] translates an Obc clause to a C clause. *)
        let ccl =
	  List.map (fun (c,act) -> shortname c, cstm_of_act var_env obj_env act) cl in
        [Cswitch (cexpr_of_exp var_env e, ccl)]
    (** For composition of statements, just recursively apply our translation
        function on sub-statements. *)
    | Comp (s1, s2) ->
        let cstm1 = cstm_of_act var_env obj_env s1 in
        let cstm2 = cstm_of_act var_env obj_env s2 in
          cstm1@cstm2
    (** Reinitialization of an object variable, extracting the reset function's
        name from our environment [obj_env]. *)
    | Reinit on ->
	let obj = assoc_obj on obj_env in
        let classn = shortname obj.cls in
	  if obj.n = 1 then
            [Csexpr (Cfun_call (classn ^ "_reset",
				[Caddrof (Cfield (Cderef (Cvar "self"), on))]))]
	  else 
	    let x = gen_symbol () in
	    let field = Cfield (Cderef (Cvar "self"), on) in
	    let elt = [Caddrof( Carray(field, Clhs (Cvar x)) )] in
	      [Cfor(x, 0, obj.n, 
		    [Csexpr (Cfun_call (classn ^ "_reset", elt ))] )]
    (** Special case for x = 0^n^n...*)
    | Assgn (vn, Const c) ->
	let vn = clhs_of_lhs var_env vn in
	  create_affect_const var_env vn c
    (** Purely syntactic translation from an Obc local variable to a C local
        one, with recursive translation of the rhs expression. *)
    | Assgn (vn, e) ->
	let vn = clhs_of_lhs var_env vn in
	let ty = assoc_type_lhs vn var_env in
        let ce = cexpr_of_exp var_env e in
          create_affect_stm vn ce ty
    (** Step functions applications can return multiple values, so we use a
        local structure to hold the results, before allocating to our
        variables. *)
    | Step_ap (outvl, objn, el) ->
	let args = cexprs_of_exps var_env el in
	let outvl = clhss_of_lhss var_env outvl in
	let mem = Cfield (Cderef (Cvar "self"), objn) in
	  generate_function_call var_env obj_env outvl objn args mem

    | Array_select_dyn (x, e, idx_list, bounds, defv) -> 
	let x = clhs_of_lhs var_env x in
	let ty = assoc_type_lhs x var_env in
	let e = cexpr_of_exp var_env e in
	let cexps = cexprs_of_exps var_env idx_list in
	let defv = cexpr_of_exp var_env defv in
	let c = bound_check_expr cexps bounds in
	  [Cif (c, 
		create_affect_stm x 
		  (Clhs (csubscript_of_e_list (lhs_of_exp e) cexps)) ty,
		create_affect_stm x defv ty)]

    | Array_select_slice (x, e, idx1, idx2) ->
	let x = clhs_of_lhs var_env x in
	let ty = assoc_type_lhs x var_env in
	let e = clhs_of_exp var_env e in
	let y = gen_symbol () in
	let index = Cbop ("+", Cconst (Ccint idx1), Clhs (Cvar y)) in
	  [Cfor(y, 0, idx2 - idx1 + 1, 
		create_affect_stm (Carray(x, index)) 
		  (Clhs (Carray(e, Clhs (Cvar y))))
		  (array_base_ctype ty [1]) )]

    | Array_iterate (outvl, Imap, f, n, e_list) ->
	let x = gen_symbol () in
	let cexps = cexprs_of_exps var_env e_list in
	let cexps = List.map (fun e -> Clhs (Carray(lhs_of_exp e, Clhs (Cvar x)))) cexps in
	let outvl = clhss_of_lhss var_env outvl in
	let outvl = List.map (fun n -> Carray(n, Clhs (Cvar x))) outvl in
	let mem = Carray (Cfield (Cderef (Cvar "self"), f), Clhs (Cvar x)) in
	let fcall = generate_function_call var_env obj_env outvl f cexps mem in
	  [ Cfor (x, 0, n, fcall) ]

    | Array_iterate (outvl, Ifold, f, n, e_list) ->
	let x = gen_symbol () in
	let cexps = cexprs_of_exps var_env e_list in
	  (* Use the accumulator as the last arg *)
	let cexps, acc_init = split_last cexps in
	let cexps = List.map (fun e -> Clhs (Carray(lhs_of_exp e, Clhs (Cvar x)))) cexps in
	let outvl = clhss_of_lhss var_env outvl in
	let mem = Carray (Cfield (Cderef (Cvar "self"), f), Clhs (Cvar x)) in
	  (match outvl with
	     | [] -> 
		 (* the accumulator is targeted, so it does not appear in the result. *)
		 let cexps = cexps@[acc_init] in
		 let fcall = generate_function_call var_env obj_env outvl f cexps mem in
		   [Cfor (x, 0, n, fcall) ]
	     | outvl -> 
		 let cexps = cexps@[Clhs (List.hd outvl)] in 
		 let fcall = generate_function_call var_env obj_env outvl f cexps mem in
		 let ty = assoc_type_lhs (List.hd outvl) var_env in
		   (create_affect_stm (List.hd outvl) acc_init ty) @ [Cfor (x, 0, n, fcall) ]
	  )

   | Array_iterate (outvl, Imapfold, f, n, e_list) ->
	let x = gen_symbol () in
	let cexps = cexprs_of_exps var_env e_list in
	  (* Use the accumulator as the last arg *)
	let cexps, acc_init = split_last cexps in
	let cexps = List.map (fun e -> Clhs (Carray(lhs_of_exp e, Clhs (Cvar x)))) cexps in
	let outvl = clhss_of_lhss var_env outvl in
	let mem = Carray (Cfield (Cderef (Cvar "self"), f), Clhs (Cvar x)) in

	  (* Check if the accumulator is targeted and does not appear in the output. *)
	let _, sig_info = node_info (assoc_cn f obj_env) in	  
	let acc_is_targeted = (is_empty outvl) 
	  or (last_element sig_info.info.inputs).a_pass_by_ref in
	  if acc_is_targeted then (
	    (* no accumulator in output *)
	    let outvl = List.map (fun e -> Carray(e, Clhs (Cvar x))) outvl in
	    let cexps = cexps@[acc_init] in
	    let fcall = generate_function_call var_env obj_env outvl f cexps mem in
	      [Cfor (x, 0, n, fcall) ]
	  ) else (
	    (* use the last output as accumulator *)
	    let outvl = incomplete_map (fun e -> Carray(e, Clhs (Cvar x))) outvl in
	    let cexps = cexps@[(Clhs (last_element outvl))] in 
	    let ty = assoc_type_lhs (last_element outvl) var_env in
	    let fcall = generate_function_call var_env obj_env outvl f cexps mem in
	      (create_affect_stm (last_element outvl) acc_init ty)@[Cfor (x, 0, n, fcall) ] 
	  )

   | Array_concat (x, e1, e2) ->
       let x = clhs_of_lhs var_env x in
       let e1 = clhs_of_exp var_env e1 in
       let e2 = clhs_of_exp var_env e2 in
       let ty1 = assoc_type_lhs e1 var_env in
       let ty2 = assoc_type_lhs e2 var_env in
	 (match ty1, ty2 with
	    | Cty_arr(n1, t1), Cty_arr(n2, t2) ->
		let y1 = gen_symbol () in
		let y2 = gen_symbol () in
		let index = Cbop ("+", Cconst (Ccint n1), Clhs (Cvar y2)) in
		  [Cfor(y1, 0, n1, 
			create_affect_stm (Carray(x, Clhs (Cvar y1))) 
			  (Clhs (Carray(e1, Clhs (Cvar y1))))
			  t1 );
		   Cfor(y2, 0, n2, 
			create_affect_stm (Carray(x, index)) 
			  (Clhs (Carray(e2, Clhs (Cvar y2))))
			  t2 )] 
	    | _, _ -> assert false
	 )

   | Field_update(x, e1, f, e2) -> 
       (* Find the description of the struct type *)
       let { info = { arg = ty_arg; res = ty_res } } = find_field f in
       let n = struct_name ty_arg in
       let { info = { fields = fields } } = find_struct n in
	 (* Translate exps *)
       let f = shortname f in
       let x = clhs_of_lhs var_env x in
       let e1 = clhs_of_exp var_env e1 in
       let e2 = cexpr_of_exp var_env e2 in
	 (* create the final exp*)
	 if x = e1 then ( (* only modify one field *)
	   let ty = ctype_of_heptty (List.assoc f fields) in
	     create_affect_stm  (Cfield(x, f)) e2 ty
	 ) else
	   List.flatten (List.map (create_field_update x e1 f e2) fields)

          (** Well, Nothing translates to no instruction. *)
    | Nothing -> []
      
(** [main_def_of_class_def cd] generated a main() function that repeatedly reads
    data from standard input and then outputs result of [cd.step]. *)
(* TODO: refactor into something more readable. *)
let main_def_of_class_def cd =
  (** Generates scanf statements, conversion to enums and declarations of
      buffers needed for reading enum tags. *)
  let scanf_and_vardecl_of_param vd =
    let (formats, expr, need_buf) = match vd.v_type with
      | Tint -> ("%d", Caddrof (Cvar (name vd.v_name)), None)
      | Tid (Name "int"| Modname {qual="Pervasives";id="int"}) ->
          ("%d", Caddrof (Cvar (name vd.v_name)), None)
      | Tid (Name "bool"| Modname {qual="Pervasives";id="bool"}) ->
          ("%d", Caddrof (Cvar (name vd.v_name)), None)
      | Tfloat -> ("%f", Caddrof (Cvar (name vd.v_name)), None)
          (* TODO: distinguish struct and enums AND switch to sscanf *)
      | Tid ((Name sid) |
                 (Modname { id = sid })) -> ("%s",
                                             Clhs (Cvar ((name vd.v_name) ^ "_buf")),
                                             Some ((name vd.v_name) ^ "_buf", sid)) 
      | Tarray(ty, n) -> assert false
    in
    let scane =
      let puts_arg = Printf.sprintf "%s ? " (name vd.v_name) in
      Csblock { var_decls = [];
                block_body = [Csexpr (Cfun_call ("printf",
                                                 [Cconst (Cstrlit puts_arg)]));
                              Csexpr (Cfun_call ("scanf",
                                                 [Cconst (Cstrlit formats);
                                                  expr]));]; } in
    match need_buf with
      | None -> ([scane], [])
      | Some (bufn, tyn) -> ([scane;
                              Csexpr (Cfun_call (tyn ^ "_of_string",
                                                 [Clhs (Cvar bufn)]))],
                             [(bufn, Cty_arr (20, Cty_char))]) in
  let (scanf_calls, scanf_decls) =
    split (map scanf_and_vardecl_of_param cd.step.inp) in
  (** Generates printf statements and buffer declarations needed for printing
      resulting values of enum types. *)
  let printf_and_vardecl_of_result f vd =
    let (formats, expr, need_buf) = match vd.v_type with
      | Tint -> ("%d", f vd.v_name, None)
      | Tfloat -> ("%f", f vd.v_name, None)
      | Tid (Name "bool"| Modname {qual="Pervasives"; id="bool"}) ->
          ("%d", f vd.v_name, None)
      | Tid (Name "int"| Modname {qual="Pervasives"; id="int"}) ->
          ("%d", f vd.v_name, None)
      | Tid (Name sid | Modname {id = sid}) ->
          ("%s", Cfun_call ("string_of_" ^ sid,
                            [f vd.v_name;
                             Clhs (Cvar ((name vd.v_name) ^ "_buf"))]), Some (sid)) 
      | Tarray (ty, n) -> assert false
    in
    (Csexpr (Cfun_call ("printf",
                        [Cconst (Cstrlit ("=> " ^ formats ^ "\\t")); expr])),
     match need_buf with
       | None -> []
       | Some id -> [((name vd.v_name) ^ "_buf", Cty_arr (20, Cty_char))]) in
  let (printf_calls, printf_decls) =
    split (map (printf_and_vardecl_of_result
                  (fun n -> match cd.step.out with
                     | [vd] -> Clhs (Cvar "res")
                     | _ -> Clhs (Cfield (Cvar "res", name n)))) cd.step.out) in
  let cinp = cvarlist_of_ovarlist cd.step.inp in
  let cout =
    begin match cd.step.out with
      | [] -> []
      | [vd] -> [("res", ctype_of_otype vd.v_type)]
      | _ -> [("res", Cty_id (cd.cl_id ^ "_res"))]
    end in
  let varlist =
    ("mem", Cty_id (cd.cl_id ^ "_mem"))
    :: cinp
    @ cout
    @ concat scanf_decls
    @ concat printf_decls in
  (** The main function loops (while (1) { ... }) reading arguments for our node
      and prints the results. *)
  let body =
    let funcall =
      let args =
        map (fun vd -> Clhs (Cvar (name vd.v_name))) cd.step.inp
        @ [Caddrof (Cvar ("mem"))] in
      Cfun_call (cd.cl_id ^ "_step", args) in
    concat scanf_calls
    @ [Caffect (Cvar "res", funcall)]
    @ printf_calls
    @ [Csexpr (Cfun_call ("puts", [Cconst (Cstrlit "")]));
       Csexpr (Cfun_call ("fflush", [Clhs (Cvar "stdout")]))] in
  (** Do not forget to initialize memory via reset. *)
  let init_mem =
    Csexpr (Cfun_call (cd.cl_id ^ "_reset", [Caddrof (Cvar "mem")])) in
  Cfundef {
    f_name = "main";
    f_retty = Cty_int;
    f_args = [("argc", Cty_int); ("argv", Cty_ptr (Cty_ptr Cty_char))];
    f_body = {
      var_decls = varlist;
      block_body = [init_mem;
                    Cwhile (Cconst (Ccint 1), body)];
    }
  }

(** Builds the argument list of step function*)
let step_fun_args n sf = 
  let args = cvarlist_of_ovarlist sf.inp in
    args
      @[("self", Cty_ptr (Cty_id (n ^ "_mem")))]

(** [fun_def_of_step_fun name obj_env mods sf] returns a C function definition
    [name ^ "_out"] corresponding to the Obc step function [sf]. The object name
    <-> class name mapping [obj_env] is needed to translate internal steps and
    reset calls. A step function can have multiple return values, whereas C does
    not allow such functions. When it is the case, we declare a structure with a
    field by return value. A scalar result is directly returned. *)
let fun_def_of_step_fun name obj_env mem sf =
  let fun_name = name ^ "_step" in
  (** Its arguments, translating Obc types to C types and adding our internal
      memory structure. *)
  let args = step_fun_args name sf in
  (** Its normal local variables. *)
  let local_vars = List.map cvar_of_vd sf.local in
  (** Local variables containing return values. *)
  let ret_vars =
    if List.length sf.out = 1 && Obc.is_scalar_type (List.hd sf.out) then
      List.map cvar_of_vd sf.out
    else
      []
  in

  (** Return type, depending on the number of return values of our function. *)
  let retty =
    match sf.out with
      | [] -> Cty_void
      | [v] -> 
	  if Obc.is_scalar_type v then
	    ctype_of_otype v.v_type
	  else 
	    Cty_void
      | _ -> Cty_void in
  (** Controllable variables valuations *)
  let use_ctrlr, ctrlr_calls =
    match sf.controllables with
    | [] -> false, []
    | c_list ->
	let args_inputs_state =
	  List.map (fun (arg_name,_) -> Clhs(Cvar(arg_name))) args in
	let addr_controllables =
	  List.map (fun { v_name = c_name } -> Caddrof(Cvar(Ident.name c_name))) c_list in
	let args_ctrlr =
	  args_inputs_state @ addr_controllables in
	let funname = name ^ "_controller" in
	let funcall = Cfun_call(funname,args_ctrlr) in
	true,
	[Csexpr(funcall)] in
  (** The body *)
  let mems = List.map cvar_of_vd (mem@sf.out) in
  let var_env = args @ mems @ local_vars in
  let body = cstm_of_act var_env obj_env sf.bd in

  (** Our epilogue: affect each local variable holding a return value to
      the correct structure field. *)
  let epilogue = match sf.out with
    | [] -> []
    | [vd] when Obc.is_scalar_type (List.hd sf.out) -> 
	[Creturn (Clhs (Cvar (Ident.name vd.v_name)))] 
    | out -> [] in  

 (** Substitute the return value variables with the corresponding
  context field*)
  let map = Csubst.assoc_map_for_fun sf in
  let body = List.map (Csubst.subst_stm map) (body@epilogue) in

  use_ctrlr,
  Cfundef {
    f_name = fun_name;
    f_retty = retty;
    f_args = args;
    f_body = {
      var_decls = ret_vars @ local_vars;
      block_body = ctrlr_calls @ body
    }
  }

(** [mem_decl_of_class_def cd] returns a declaration for a C structure holding
    internal variables and objects of the Obc class definition [cd]. *)
let mem_decl_of_class_def cd =
  (** This one just translates the class name to a struct name following the
      convention we described above. *)
  let struct_field_of_obj_dec l od =
    if is_op od.cls then
      l
    else
      let clsname = shortname od.cls in
      let ty = Cty_id ((cname_of_name clsname) ^ "_mem") in
      let ty = if od.n <> 1 then Cty_arr (od.n, ty) else ty in 
	(od.obj, ty)::l
  in
	
  (** Fields corresponding to normal memory variables. *)
  let mem_fields = List.map cvar_of_vd cd.mem in
  (** Fields corresponding to object variables. *)
  let obj_fields = List.fold_left struct_field_of_obj_dec [] cd.objs in
  (** Fields corresponding to output variables. *) 
  let out_fields =
    if (List.length cd.step.out) <> 1 or
      not (Obc.is_scalar_type (List.hd cd.step.out)) then 
	List.map cvar_of_vd cd.step.out
    else
      []
  in
    Cdecl_struct (cd.cl_id ^ "_mem", mem_fields @ obj_fields @ out_fields)

(** [reset_fun_def_of_class_def cd] returns the defintion of the C function
    tasked to reset the class [cd]. *)
let reset_fun_def_of_class_def cd =
  let var_env = List.map cvar_of_vd cd.mem in 
  let body = cstm_of_act var_env cd.objs cd.reset in
  Cfundef {
    f_name = (cd.cl_id ^ "_reset");
    f_retty = Cty_void;
    f_args = [("self", Cty_ptr (Cty_id (cd.cl_id ^ "_mem")))];
    f_body = {
      var_decls = [];
      block_body = body;
    }
  }

(** [cdecl_and_cfun_of_class_def cd] translates the class definition [cd] to
    a C program. *)
let cdefs_and_cdecls_of_class_def cd =
  (** We keep the state of our class in a structure, holding both internal
      variables and the state of other nodes. For a class named ["cname"], the
      structure will be called ["cname_mem"]. *)
  let memory_struct_decl = mem_decl_of_class_def cd in
  (** Our main() function will be generated only if the current class definition
      corresponds to the simulation_node. *)
  let main_def = match !simulation_node with
    | Some nn when nn = cd.cl_id -> [main_def_of_class_def cd]
    | _ -> [] in
  let obj_env =
    List.map (fun od -> { od with cls = cname_of_name' od.cls }) cd.objs in
  let use_ctrlr,step_fun_def
    = fun_def_of_step_fun cd.cl_id obj_env cd.mem cd.step in
  (** C function for resetting our memory structure. *)
  let reset_fun_def = reset_fun_def_of_class_def cd in
  let res_fun_decl = cdecl_of_cfundef reset_fun_def in
  let step_fun_decl = cdecl_of_cfundef step_fun_def in
  memory_struct_decl,
  use_ctrlr,
  ([res_fun_decl;step_fun_decl],
   reset_fun_def :: step_fun_def :: main_def)

let decls_of_type_decl otd =
  let name = otd.t_name in
  match otd.t_desc with
    | Type_abs -> [] (*assert false*)
    | Type_enum nl ->
        [Cdecl_enum (otd.t_name, nl);
         Cdecl_function (name ^ "_of_string",
                         Cty_id name,
                         [("s", Cty_ptr Cty_char)]);
         Cdecl_function ("string_of_" ^ name,
                         Cty_ptr Cty_char,
                         [("x", Cty_id name); ("buf", Cty_ptr Cty_char)])]
    | Type_struct fl ->
	let decls = List.map (fun (n,ty) -> n, ctype_of_otype ty) fl in
          [Cdecl_struct (otd.t_name, decls)];;

(** Translates an Obc type declaration to its C counterpart. *)
let cdefs_and_cdecls_of_type_decl otd =
  let name = otd.t_name in
  match otd.t_desc with
    | Type_abs -> [], [] (*assert false*)
    | Type_enum nl ->
        let of_string_fun = Cfundef
          { f_name = name ^ "_of_string";
            f_retty = Cty_id name;
            f_args = [("s", Cty_ptr Cty_char)];
            f_body =
              { var_decls = [];
                block_body =
                  let gen_if t =
                    let funcall = Cfun_call ("strcmp", [Clhs (Cvar "s");
                                                        Cconst (Cstrlit t)]) in
                    let cond = Cbop ("==", funcall, Cconst (Ccint 0)) in
                    Cif (cond, [Creturn (Cconst (Ctag t))], []) in
                  map gen_if nl; }
          }
        and to_string_fun = Cfundef
          { f_name = "string_of_" ^ name;
            f_retty = Cty_ptr Cty_char;
            f_args = [("x", Cty_id name); ("buf", Cty_ptr Cty_char)];
            f_body =
              { var_decls = [];
                block_body =
                  let gen_clause t =
                    let fun_call =
                      Cfun_call ("strcpy", [Clhs (Cvar "buf");
                                            Cconst (Cstrlit t)]) in
                    (t, [Csexpr fun_call]) in
                  [Cswitch (Clhs (Cvar "x"), map gen_clause nl);
                   Creturn (Clhs (Cvar "buf"))]; }
          } in
        ([of_string_fun; to_string_fun],
         [Cdecl_enum (otd.t_name, nl); cdecl_of_cfundef of_string_fun;
          cdecl_of_cfundef to_string_fun])
    | Type_struct fl ->
	let decls = List.map (fun (n,ty) -> n, ctype_of_otype ty) fl in
        let decl = Cdecl_struct (otd.t_name, decls) in
          ([], [decl])

(** [cfile_list_of_oprog oprog] translates the Obc program [oprog] to a list of
    C source and header files. *)
let cfile_list_of_oprog name oprog =
  let opened_modules = oprog.o_opened in

  let header_and_source_of_class_def (deps,acc_cfiles) cd =
    reset_opened_modules ();
    List.iter add_opened_module opened_modules;
    List.iter add_opened_module deps;

    let cfile_name = String.uncapitalize cd.cl_id in
    let mem_cdecl,use_ctrlr,(cdecls, cdefs) = cdefs_and_cdecls_of_class_def cd in
      
    let cfile_mem = cfile_name ^ "_mem" in
      add_opened_module cfile_mem;
      if use_ctrlr then 
	add_opened_module (cfile_name ^ "_controller");
      remove_opened_module name;
      
    let acc_cfiles = acc_cfiles @
      [ (cfile_mem ^ ".h", Cheader (get_opened_modules (),[mem_cdecl]));
	(cfile_name ^ ".h", Cheader (get_opened_modules (), cdecls));
       (cfile_name ^ ".c", Csource cdefs)] in
    deps@[cfile_name],acc_cfiles in

    reset_opened_modules ();
    List.iter add_opened_module opened_modules;
    let cdefs_and_cdecls = List.map cdefs_and_cdecls_of_type_decl oprog.o_types in
    remove_opened_module name;

  let (cty_defs, cty_decls) = List.split (List.rev cdefs_and_cdecls) in
  let filename_types = name ^ "_types" in
  let types_h = (filename_types ^ ".h",
                 Cheader (get_opened_modules (), concat cty_decls)) in
  let types_c = (filename_types ^ ".c", Csource (concat cty_defs)) in
  let _,cfiles =
    List.fold_left
      header_and_source_of_class_def
      ([filename_types],[types_h;types_c])
      oprog.o_defs in
  cfiles

let global_file_header name prog =
  let step_fun_decl cd =
    let _,s = fun_def_of_step_fun cd.cl_id cd.objs cd.mem cd.step in
	   cdecl_of_cfundef s 
  in
    reset_opened_modules ();
    List.iter add_opened_module prog.o_opened;
    
    let ty_decls = List.map decls_of_type_decl prog.o_types in
    let ty_decls = List.concat ty_decls in
    let mem_step_fun_decls = List.map mem_decl_of_class_def prog.o_defs in
    let reset_fun_decls = 
      List.map (fun cd -> cdecl_of_cfundef (reset_fun_def_of_class_def cd)) prog.o_defs in
    let step_fun_decls = List.map step_fun_decl prog.o_defs in
      
      (name ^ ".h", Cheader (get_opened_modules (),
                             ty_decls
                             @ mem_step_fun_decls
                             @ reset_fun_decls
                             @ step_fun_decls))
	
(******************************)

let sanitize_identifier modname id = match id with
  | "bool" -> "bool" | "int" -> "int" | "float" -> "float"
  | "true" -> "true" | "false" -> "false"
  | op   -> modname ^ "_" ^ cname_of_name op

let translate name prog =
  let modname = (Filename.basename name) in
  let prog =
    Rename.rename_program (sanitize_identifier (String.capitalize modname)) prog in
  begin match !simulation_node with
    | None -> ()
    | Some s -> simulation_node := Some (String.capitalize name ^ "_" ^ s)
  end;
  let res =
    (global_file_header modname prog) :: (cfile_list_of_oprog modname prog) in
  if !Misc.verbose then Printf.printf "Translation into C code done.\n";
  res