CristalCaveGem » LustreC

let get_typed_submachines machines m =

  let instances = List.filter (fun (id, _) -> not (is_builtin_fun id)) m.mcalls in

  let submachines = List.map (get_machine machines) instances in

    instances submachines

  let typed_submachines =

    List.map (get_typed_submachines machines) machines in

  let _machines = List.combine typed_submachines machines in

  let _pp_filename ext fmt (typed_submachines, machine) =

  let get_instance identifier typed_submachines =

      List.assoc identifier typed_submachines

  (** Printing a call to a package function

      @param typed_submachines list of all typed machine instances of this machine

      @param pp_name printer for the function name

      @param identifier the instance identifier

      @param pp_args_opt optional printer for other arguments

  let pp_package_call typed_submachines pp_name fmt (identifier, pp_args_opt) =

    let (substitution, submachine) = get_instance identifier typed_submachines in

    let statefull = is_machine_statefull submachine in

    let pp_opt fmt = function

        | Some pp_args when statefull -> fprintf fmt ",@,%t" pp_args

        | Some pp_args -> pp_args fmt

        | None -> fprintf fmt ""

    in

    let pp_state fmt =

      if statefull then

        fprintf fmt "%t.%s" pp_state_name identifier

      else

        fprintf fmt ""

    in

    fprintf fmt "%a.%t(@[<v>%t%a@])"

      pp_name

      pp_state

      pp_opt pp_args_opt

      @param typed_submachines list of all typed machine instances of this machine

  let pp_machine_instr typed_submachines machine fmt instr =

      | MReset i ->

          pp_package_call typed_submachines pp_reset_procedure_name fmt (i, None)

      | MStep ([i0], i, vl) when is_builtin_fun i ->

      | MStep (il, i, vl) when List.mem_assoc i typed_submachines ->

        let pp_args fmt = fprintf fmt "@[%a@]%t@[%a@]"

          (Utils.fprintf_list ~sep:",@ " (pp_value machine)) vl

          (Utils.pp_final_char_if_non_empty ",@," il)

          (Utils.fprintf_list ~sep:",@ " (pp_access_var machine)) il

        in

        pp_package_call typed_submachines pp_step_procedure_name fmt (i, Some pp_args)

      | _ -> assert false

   @param typed_submachines list of all typed machine instances of this machine

let pp_step_definition typed_submachines fmt m = pp_procedure_definition

      (pp_machine_instr typed_submachines m)

   @param typed_submachines list of all typed machine instances of this machine

let pp_reset_definition typed_submachines fmt m = pp_procedure_definition

      (pp_machine_instr typed_submachines m)

   @param typed_submachines list of all typed machine instances of this machine

let pp_file fmt (typed_submachines, machine) =

  let pp_reset fmt =

    if is_machine_statefull machine then

      fprintf fmt "%a;@,@," (pp_reset_definition typed_submachines) machine

    else

      fprintf fmt ""

  in

  let aux pkgs (id, _) =

    try

      let (pkg, _) = List.assoc id ada_supported_funs in

      if List.mem pkg pkgs then

        pkgs

      else

        pkg::pkgs

    with Not_found -> pkgs

  in

  let packages = List.fold_left aux [] machine.mcalls in

  fprintf fmt "%a%t%a@,  @[<v>@,%t%a;@,@]@,%a;@."

    (* Include all the required packages*)

    (Utils.fprintf_list ~sep:";@," pp_with) packages

    (Utils.pp_final_char_if_non_empty ";@,@," packages)

    (*Begin the package*)

    (pp_begin_package true) machine

    (*Define the reset procedure*)

    pp_reset

    (*Define the step procedure*)

    (pp_step_definition typed_submachines) machine

    (*End the package*)

    pp_end_package machine

  fprintf fmt "@,  @[<v>record@,  @[<v>%a%t%t%a%t@]@,end record@]"

    (Utils.pp_final_char_if_non_empty ";" typed_instances)

    (fun fmt -> if var_list!=[] && typed_instances!= [] then fprintf fmt "@,@," else fprintf fmt "")

  A typed submachine is a (ident, typed_machine) with

    - ident: the name 

    - typed_machine: a (substitution, machine) with

      - machine: the submachine struct

      - substitution the instanciation of all its polymorphic types.

   @param typed_submachines list of all typed submachines of this machine

let pp_file fmt (typed_submachines, m) =

  let typed_machines = snd (List.split typed_submachines) in

  let typed_instances = List.filter is_submachine_statefull typed_submachines in

  let pp_state_decl_and_reset fmt = fprintf fmt "%a;@,@,%t;@,@,"

    (*Declare the state type*)

    pp_private_limited_type_decl pp_state_type

    (*Declare the reset procedure*)

    (pp_reset_prototype m)

  in

  let pp_private_section fmt = fprintf fmt "@,private@,@,%a%t%a;@,"

    (*Instantiate the polymorphic type that need to be instantiated*)

    (Utils.fprintf_list ~sep:";@," pp_new_package) typed_machines_to_instanciate

    (Utils.pp_final_char_if_non_empty ";@,@," typed_machines_to_instanciate)

    (*Define the state type*)

    pp_type_decl (pp_state_type, pp_record)

  in

  let pp_ifstatefull fmt pp =

    if is_machine_statefull m then

      fprintf fmt "%t" pp

    else

      fprintf fmt ""

  in

  fprintf fmt "@[<v>%a%t%a%a@,  @[<v>@,%a%a;@,%a@]@,%a;@.@]"

    (* Include all the subinstance package*)

    pp_ifstatefull pp_state_decl_and_reset

    (*Print the private section*)

    pp_ifstatefull pp_private_section

(** All the pretty print and aux functions common to the ada backend **)

let is_machine_statefull m = not m.mname.node_dec_stateless

let ada_supported_funs =

  [("sin", ("Ada.Numerics.Elementary_Functions", "Sin"));

   ("cos", ("Ada.Numerics.Elementary_Functions", "Cos"));

   ("tan", ("Ada.Numerics.Elementary_Functions", "Tan"))]

let is_builtin_fun ident =

  List.mem ident Basic_library.internal_funs ||

    List.mem_assoc ident ada_supported_funs

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

   @param fmt the formater to print on

   @param name the package name

**)

let pp_with fmt name =

  fprintf fmt "with %s" name

   @param state_mode_opt None if no state parameter required and some input/output mode for it else

let pp_base_prototype state_mode_opt input output fmt pp_name =

  let pp_var_decl_state fmt = match state_mode_opt with

    | None -> fprintf fmt ""

    | Some state_mode -> fprintf fmt "%a" pp_state_var_decl state_mode

  in

  fprintf fmt "procedure %t(@[<v>%t%t@[%a@]%t@[%a@])@]"

    pp_var_decl_state

    (fun fmt -> if state_mode_opt != None && input!=[] then

      fprintf fmt ";@," else fprintf fmt "")

    (fun fmt -> if (state_mode_opt != None || input!=[]) && output != [] then

      fprintf fmt ";@," else fprintf fmt "")

  let state_mode = if is_machine_statefull m then Some InOut else None in

  pp_base_prototype state_mode m.mstep.step_inputs m.mstep.step_outputs fmt pp_step_procedure_name

  let state_mode = if is_machine_statefull m then Some InOut else None in

  pp_base_prototype state_mode m.mstatic [] fmt pp_reset_procedure_name

  let state_mode = if is_machine_statefull m then Some Out else None in

  pp_base_prototype state_mode m.mstatic [] fmt pp_init_procedure_name

  let state_mode = if is_machine_statefull m then Some InOut else None in

  pp_base_prototype state_mode m.mstatic [] fmt pp_clear_procedure_name

(** Check if a submachine is statefull.

    @param submachine a submachine

    @return true if the submachine is statefull

**)

let is_submachine_statefull submachine =

    not (snd (snd submachine)).mname.node_dec_stateless

    | op, [v1] when  List.mem_assoc ident ada_supported_funs ->

      let pkg, name = try List.assoc ident ada_supported_funs

        with Not_found -> assert false in

      let pkg = pkg^(if String.equal pkg "" then "" else ".") in

        Format.fprintf fmt "%s%s(%a)" pkg name pp_value v1