CristalCaveGem » LustreC

(** Encapsulate a pretty print function to lower case its result when applied

   @param pp the pretty print function

   @param fmt the formatter

   @param arg the argument of the pp function

**)

let pp_lowercase pp fmt =

  let str = asprintf "%t" pp in

  fprintf fmt "%s" (String. lowercase_ascii str)

(** Print a filename by lowercasing the base and appending an extension.

   @param extension the extension to append to the package name

   @param fmt the formatter

   @param pp_name the file base name printer

**)

let pp_filename extension fmt pp_name =

  fprintf fmt "%t.%s"

    (pp_lowercase pp_name)

    extension

(** Print the name of the arrow package.

   @param fmt the formater to print on

**)

let pp_arrow_package_name fmt = fprintf fmt "Arrow"

(** Print the name of a package associated to a node.

let pp_package_name fmt machine =

  if String.equal Arrow.arrow_id machine.mname.node_id then

      fprintf fmt "%t" pp_arrow_package_name

  else

      fprintf fmt "%a" pp_clean_ada_identifier machine.mname.node_id

    pp_package_name machine

  fprintf fmt "end %a" pp_package_name machine

let pp_main_procedure_name fmt =

(** Print a with statement to include a machine.

   @param machine the machine

let pp_with_machine fmt machine =

  fprintf fmt "private with %a" pp_package_name machine

(** Print a limited private type declaration

(** Print the type of a polymorphic type.

   @param id the id of the polymorphic type

let pp_polymorphic_type fmt id =

  fprintf fmt "T_%i" id

(** Print a type.

   @param fmt the formater to print on

   @param type the type

**)

let pp_type fmt typ = 

  (match (Types.repr typ).Types.tdesc with

    | Types.Tbasic Types.Basic.Tint  -> pp_integer_type fmt

    | Types.Tunivar                  -> pp_polymorphic_type fmt typ.tid

    | _ -> eprintf "Type error : %a@." Types.print_ty typ; assert false (*TODO*)

(** Print the type of a variable.

   @param fmt the formater to print on

   @param id the variable

**)

let pp_var_type fmt id = 

  pp_type fmt id.var_type

(** Extract all the inputs and outputs.

   @param machine the machine

   @return a list of all the var_decl of a macine

**)

let get_all_vars_machine m =

  m.mmemory@m.mstep.step_inputs@m.mstep.step_outputs@m.mstatic

(** Check if a type is polymorphic.

   @param typ the type

   @return true if its polymorphic

**)

let is_Tunivar typ = (Types.repr typ).tdesc == Types.Tunivar

(** Find all polymorphic type : Types.Tunivar in a machine.

   @param machine the machine

   @return a list of id corresponding to polymorphic type

**)

let find_all_polymorphic_type m =

  let vars = get_all_vars_machine m in

  let extract id = id.var_type.tid in

  let polymorphic_type_vars =

    List.filter (function x-> is_Tunivar x.var_type) vars in

  List.sort_uniq (-) (List.map extract polymorphic_type_vars)

(** Print a package name with polymorphic types specified.

   @param substitution correspondance between polymorphic type id and their instantiation

   @param fmt the formater to print on

   @param machine the machine

**)

let pp_package_name_with_polymorphic substitution fmt machine =

  let polymorphic_types = find_all_polymorphic_type machine in

  assert(List.length polymorphic_types = List.length substitution);

  let substituion = List.sort_uniq (fun x y -> fst x - fst y) substitution in

  assert(List.for_all2 (fun poly1 (poly2, _) -> poly1 = poly2)

            polymorphic_types substituion);

  let instantiated_types = snd (List.split substitution) in

  fprintf fmt "%a%t%a"

    pp_package_name machine

    (Utils.pp_final_char_if_non_empty "_" instantiated_types)

    (Utils.fprintf_list ~sep:"_" pp_type) instantiated_types

(** Print variable declaration for a local state variable

(** Print the declaration of a state element of a machine.

   @param substitution correspondance between polymorphic type id and their instantiation

   @param name name of the variable

   @param machine the machine

let pp_node_state_decl substitution name fmt machine =

  let pp_package fmt = pp_package_name_with_polymorphic substitution fmt machine in