Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / Ada / ada_backend.ml @ 826063db

History | View | Annotate | Download (4.63 KB)

1
(********************************************************************)
2
(*                                                                  *)
3
(*  The LustreC compiler toolset   /  The LustreC Development Team  *)
4
(*  Copyright 2012 -    --   ONERA - CNRS - INPT - ISAE-SUPAERO     *)
5
(*                                                                  *)
6
(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)
7
(*  under the terms of the GNU Lesser General Public License        *)
8
(*  version 2.1.                                                    *)
9
(*                                                                  *)
10
(********************************************************************)
11

    
12
open Format
13
open Machine_code_types
14

    
15
open Ada_backend_common
16

    
17
let indent_size = 2
18

    
19
(** Log at level 2 a string message with some indentation.
20
   @param indent the indentation level
21
   @param info the message
22
**)
23
let log_str_level_two indent info =
24
  let str_indent = String.make (indent*indent_size) ' ' in
25
  let pp_message fmt = fprintf fmt "%s.. %s@." str_indent info in
26
  Log.report ~level:2 pp_message;
27
  Format.pp_print_flush Format.err_formatter ()
28

    
29
(** Write a new file with formatter
30
   @param destname folder where the file shoudl be created
31
   @param pp_filename function printing the filename
32
   @param pp_file function wich pretty print the file
33
   @param arg will be given to pp_filename and pp_file
34
**)
35
let write_file destname pp_filename pp_file arg =
36
  let path = asprintf "%s%a" destname pp_filename arg in
37
  let out = open_out path in
38
  let fmt = formatter_of_out_channel out in
39
  log_str_level_two 2 ("generating "^path);
40
  pp_file fmt arg;
41
  pp_print_flush fmt ();
42
  close_out out
43

    
44

    
45
(** Exception raised when a machine contains a feature not supported by the
46
  Ada backend*)
47
exception CheckFailed of string
48

    
49

    
50
(** Check that a machine match the requirement for an Ada compilation :
51
      - No constants.
52
   @param machine the machine to test
53
**)
54
let check machine =
55
  match machine.mconst with
56
    | [] -> ()
57
    | _ -> raise (CheckFailed "machine.mconst should be void")
58

    
59

    
60
let get_typed_submachines machines m =
61
  let instances = List.filter (fun (id, _) -> not (is_builtin_fun id)) m.mcalls in
62
  let submachines = List.map (get_machine machines) instances in
63
  List.map2
64
    (fun instance submachine ->
65
      let ident = (fst instance) in
66
      ident, (get_substitution m ident submachine, submachine))
67
    instances submachines
68

    
69
(** Main function of the Ada backend. It calls all the subfunction creating all
70
the file and fill them with Ada code representing the machines list given.
71
   @param basename name of the lustre file
72
   @param prog useless
73
   @param prog list of machines to translate
74
   @param dependencies useless
75
**)
76
let translate_to_ada basename prog machines dependencies =
77
  let module Ads = Ada_backend_ads.Main in
78
  let module Adb = Ada_backend_adb.Main in
79
  let module Wrapper = Ada_backend_wrapper.Main in
80

    
81
  let typed_submachines =
82
    List.map (get_typed_submachines machines) machines in
83

    
84
  let _machines = List.combine typed_submachines machines in
85

    
86
  let _pp_filename ext fmt (typed_submachine, machine) =
87
    pp_machine_filename ext fmt machine in
88

    
89
  (* Extract the main machine if there is one *)
90
  let main_machine = (match !Options.main_node with
91
  | "" -> None
92
  | main_node -> (
93
    match Machine_code_common.get_machine_opt machines main_node with
94
    | None -> begin
95
      Format.eprintf "Ada Code generation error: %a@." Error.pp_error_msg Error.Main_not_found;
96
      raise (Corelang.Error (Location.dummy_loc, Error.Main_not_found))
97
    end
98
    | Some m -> Some m
99
  )) in
100

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

    
103
  log_str_level_two 1 "Checking machines";
104
  List.iter check machines;
105

    
106
  log_str_level_two 1 "Generating ads";
107
  List.iter (write_file destname (_pp_filename "ads") Ads.pp_file) _machines;
108

    
109
  log_str_level_two 1 "Generating adb";
110
  List.iter (write_file destname (_pp_filename "adb") Adb.pp_file) _machines;
111

    
112
  (* If a main node is given we generate a main adb file and a project file *)
113
  log_str_level_two 1 "Generating wrapper files";
114
  (match main_machine with
115
    | None -> ()
116
    | Some machine ->
117
        write_file destname pp_main_filename (Wrapper.pp_main_adb (get_typed_submachines machines machine)) machine;
118
        write_file destname (Wrapper.pp_project_name (basename^"_exe")) (Wrapper.pp_project_file machines basename) main_machine);
119
  write_file destname Wrapper.pp_project_configuration_name Wrapper.pp_project_configuration_file basename;
120
  write_file destname (Wrapper.pp_project_name (basename^"_lib")) (Wrapper.pp_project_file machines basename) None;
121

    
122

    
123
(* Local Variables: *)
124
(* compile-command:"make -C ../../.." *)
125
(* End: *)