CristalCaveGem » LustreC

open Ada_backend_common

let indent_size = 2

(** Log at level 2 a string message with some indentation.

   @param indent the indentation level

   @param info the message

**)

let log_str_level_two indent info =

  let str_indent = String.make (indent*indent_size) ' ' in

  let pp_message fmt = fprintf fmt "%s.. %s@." str_indent info in

  Log.report ~level:2 pp_message

(** 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 arg =

  let str = asprintf "%a" pp arg in

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

(** Write a new file with formatter

   @param destname folder where the file shoudl be created

   @param pp_filename function printing the filename

   @param pp_file function wich pretty print the file

   @param arg will be given to pp_filename and pp_file

**)

let write_file destname pp_filename pp_file arg =

  let path = asprintf "%s%a" destname pp_filename arg in

  pp_file fmt arg;

  pp_print_flush fmt ();

  log_str_level_two 2 (path^" generated")

(** Print the filename of a package by lowercasing it and appending

  an extension.

   @param extension the extension to append to the package name

   @param fmt the formatter

   @param fmt the machine corresponding to the package

**)

let pp_machine_filename extension fmt machine =

  fprintf fmt "%a.%s"

    (pp_lowercase pp_package_name) machine.mname

    extension

(** Exception raised when a machine contains a feature not supported by the

  Ada backend*)

(** Check that a machine match the requirement for an Ada compilation :

      - No constants.

   @param machine the machine to test

**)

(** Print the name of the ada project file.

   @param fmt the formater to print on

   @param main_machine the machine associated to the main node

**)

let pp_project_name fmt main_machine =

  fprintf fmt "%a.gpr" pp_package_name main_machine.mname

(** Main function of the Ada backend. It calls all the subfunction creating all

the file and fill them with Ada code representing the machines list given.

   @param basename useless

   @param prog useless

   @param prog list of machines to translate

   @param dependencies useless

**)

  (* Extract the main machine if there is one *)

  let main_machine = (match !Options.main_node with

  | "" -> None

  | main_node -> (

    match Machine_code_common.get_machine_opt main_node machines with

    | None -> begin

      Format.eprintf "Ada Code generation error: %a@." Error.pp_error_msg Error.Main_not_found;

      raise (Corelang.Error (Location.dummy_loc, Error.Main_not_found))

    end

    | Some m -> Some m

  )) in

  let destname = !Options.dest_dir ^ "/" in

  log_str_level_two 1 "Checking machines";

  log_str_level_two 1 "Generating ads";

  List.iter (write_file destname (pp_machine_filename "ads") Ads.pp_file) machines;

  log_str_level_two 1 "Generating adb";

  List.iter (write_file destname (pp_machine_filename "adb") Adb.pp_file) machines;

  (* If a main node is given we generate a main adb file and a project file *)

  log_str_level_two 1 "Generating wrapper files";

  match main_machine with

    | None -> log_str_level_two 2 "File not generated(no -node argument)";

    | Some machine -> begin

        write_file destname pp_project_name Wrapper.pp_project_file machine;

        write_file destname pp_main_filename Wrapper.pp_main_file machine;

      end

    fprintf fmt "NULL"

let pp_init_definition fmt m = pp_procedure_definition

      pp_init_procedure_name

      (pp_init_prototype m)

      pp_var_decl

      (pp_machine_instr m)

      fmt

      ([], m.minit)

let pp_step_definition fmt m = pp_procedure_definition

      pp_step_procedure_name

      (pp_step_prototype m)

      pp_var_decl

      (pp_machine_instr m)

      fmt

      ([], m.minit)

let pp_reset_definition fmt m = pp_procedure_definition

      pp_reset_procedure_name

      (pp_reset_prototype m)

      pp_var_decl

      (pp_machine_instr m)

      fmt

      ([], m.minit)

let pp_clear_definition fmt m = pp_procedure_definition

      pp_clear_procedure_name

      (pp_clear_prototype m)

      pp_var_decl

      (pp_machine_instr m)

      fmt

      ([], filter_reset m.minit)

let pp_file fmt machine =

(** Print a with statement to include an instance.

let pp_with_subinstance fmt instance =

  pp_with_node fmt (extract_node instance)

  pp_node_state_decl (fst instance) fmt (extract_node instance)

   @param m the machine

let pp_file fmt m =

  let instances, arrows = List.fold_left extract ([], []) m.minstances in

  let var_list = arrows@m.mmemory in

    (* Include all the subinstance*)

    (Utils.fprintf_list ~sep:";@," pp_with_subinstance) instances

    (*Begin the package*)

    (pp_begin_package false) m

    (*Declare the state type*)

    pp_private_type_decl pp_state_type

    (*Declare the init procedure*)

    (pp_init_prototype m) pp_init_procedure_name

    (*Declare the step procedure*)

    (pp_step_prototype m) pp_step_procedure_name

    (*Declare the reset procedure*)

    (pp_reset_prototype m) pp_reset_procedure_name

    (*Declare the clear procedure*)

    (pp_clear_prototype m) pp_clear_procedure_name

    (*Define the state type*)

    pp_type_decl (pp_state_type, pp_record)

    (*End the package*)

    pp_end_package m

(* Misc pretty print functions *)

let pp_clean_ada_identifier fmt name =

    fprintf fmt "%a" pp_clean_ada_identifier node.node_id

(** Print the name of the main procedure.

   @param fmt the formater to print on

   @param main_machine the machine associated to the main node

**)

let pp_main_procedure_name main_machine fmt =

  fprintf fmt "main"

(** Print the name of the main ada file.

   @param fmt the formater to print on

   @param main_machine the machine associated to the main node

**)

let pp_main_filename fmt main_machine =

  fprintf fmt "%t.adb" (pp_main_procedure_name main_machine)

(** Extract a node from an instance.

   @param instance the instance

**)

let extract_node instance =

  let (_, (node, _)) = instance in

  match node.top_decl_desc with 

    | Node nd         -> nd

    | _ -> assert false (*TODO*)

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

   @param fmt the formater to print on

   @param node the node

**)

let pp_with_node fmt node =

  fprintf fmt "private with %a" pp_package_name node

  fprintf fmt "%a" pp_clean_ada_identifier id.var_id

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

   @param instance name of the variable

   @param fmt the formater to print on

   @param instance node

**)

let pp_node_state_decl name fmt node =

  let pp_package fmt = pp_package_name fmt node in

  let pp_type fmt = pp_package_access fmt (pp_package, pp_state_type) in

  let pp_name fmt = pp_clean_ada_identifier fmt name in

  pp_var_decl fmt (NoMode, pp_name, pp_type)

(** Print the prototype of a procedure with non input/outputs

   @param fmt the formater to print on

   @param name the name of the procedure

**)

let pp_simple_prototype fmt pp_name =

  fprintf fmt "procedure %t" pp_name

   @param fmt the formater to print on

   @param name the name of the procedure

let pp_base_prototype state_mode input output fmt pp_name =

   @param fmt the formater to print on

   @param pp_name name function printer

let pp_init_prototype m fmt pp_name =

  pp_base_prototype Out m.mstatic [] fmt pp_name

   @param fmt the formater to print on

   @param pp_name name function printer

let pp_step_prototype m fmt pp_name =

  pp_base_prototype InOut m.mstep.step_inputs m.mstep.step_outputs fmt pp_name

   @param fmt the formater to print on

   @param pp_name name function printer

let pp_reset_prototype m fmt pp_name =

  pp_base_prototype InOut m.mstatic [] fmt pp_name

   @param fmt the formater to print on

   @param pp_name name function printer

let pp_clear_prototype m fmt pp_name =

  pp_base_prototype InOut m.mstatic [] fmt pp_name

(* Procedure pretty print functions *)

(** Print the definition of a procedure

   @param pp_name the procedure name printer

   @param pp_prototype the prototype printer

   @param pp_instr local var printer

   @param pp_instr instruction printer

   @param fmt the formater to print on

   @param locals locals var list

   @param instrs instructions list

**)

let pp_procedure_definition pp_name pp_prototype pp_local pp_instr fmt (locals, instrs) =

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

    pp_prototype pp_name

    (Utils.pp_final_char_if_non_empty "@,  " locals)

    (Utils.fprintf_list ~sep:";@," pp_local) locals

    (Utils.pp_final_char_if_non_empty ";" locals)

    (Utils.fprintf_list ~sep:";@," pp_instr) instrs

    (Utils.pp_final_char_if_non_empty ";" instrs)

    pp_name

open Format

open Machine_code_types

open Ada_backend_common

(** Print the main procedure

   @param fmt the formater to print on

   @param machine the main machine

   @param locals list of local variable printers

   @param instrs list of instructions printer

**)

let pp_main_procedure_definition machine fmt (locals, instrs) =

    pp_procedure_definition

      (pp_main_procedure_name machine)

      pp_simple_prototype

      (fun fmt local -> fprintf fmt "%t" local)

      (fun fmt instr -> fprintf fmt "%t" instr)

      fmt

      (locals, instrs)

(** Print call to machine procedure on state.

   @param instance name of the variable

   @param fmt the formater to print on

   @param instance node

**)

let pp_node_init_call name fmt node =

  let pp_package fmt = pp_package_name fmt node in

  let pp_type fmt = pp_package_access fmt (pp_package, pp_state_type) in

  let pp_name fmt = pp_clean_ada_identifier fmt name in

  pp_var_decl fmt (NoMode, pp_name, pp_type)

(** Print the main file calling in a loop the step function of the main machine.

   @param fmt the formater to print on

   @param machine the main machine

**)

let pp_main_file fmt machine =

  let stateVar = "state" in

  let step_parameters = machine.mstep.step_inputs@machine.mstep.step_outputs in

  let pp_local_state_var_decl fmt = pp_node_state_decl stateVar fmt machine.mname in

  let apply_pp_var_decl var fmt = pp_machine_var_decl NoMode fmt var in

  let locals = List.map apply_pp_var_decl step_parameters in

  let locals = pp_local_state_var_decl::locals in

  let pp_init fmt =

    fprintf fmt "%a.init(%s)"

      pp_package_name machine.mname

      stateVar in

  let pp_loop fmt =

    fprintf fmt "while true loop@,  %a.step(@[%s,@ %a@]);@,end loop"

      pp_package_name machine.mname

      stateVar

      (Utils.fprintf_list ~sep:",@ " pp_var_name) step_parameters

      in

  let instrs = [pp_init; pp_loop] in

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

    pp_with_node machine.mname

    (pp_main_procedure_definition machine) (locals, instrs)

(** Print the gpr project file.

   @param fmt the formater to print on

   @param machine the main machine

**)

let pp_project_file fmt machine =

    fprintf fmt "project %a is@.  for Main use (\"%a\");@.end %a;"

      pp_package_name machine.mname

      pp_main_filename machine

      pp_package_name machine.mname