Revision fd834769
Added by Guillaume DAVY over 5 years ago
src/backends/Ada/ada_backend.ml | ||
---|---|---|
12 | 12 |
open Format |
13 | 13 |
open Machine_code_types |
14 | 14 |
|
15 |
let gen_ada destname print suffix machine = |
|
16 |
(* Next line permit to get the final package name mostly to clean the |
|
17 |
identifier for Ada *) |
|
18 |
let name = asprintf "%a" Ada_backend_common.pp_package_name machine.mname in |
|
19 |
let name = String.lowercase_ascii name in |
|
20 |
let path = destname ^ name ^ suffix in |
|
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 |
|
|
28 |
(** Encapsulate a pretty print function to lower case its result when applied |
|
29 |
@param pp the pretty print function |
|
30 |
@param fmt the formatter |
|
31 |
@param arg the argument of the pp function |
|
32 |
**) |
|
33 |
let pp_lowercase pp fmt arg = |
|
34 |
let str = asprintf "%a" pp arg in |
|
35 |
fprintf fmt "%s" (String. lowercase_ascii str) |
|
36 |
|
|
37 |
(** Write a new file with formatter |
|
38 |
@param destname folder where the file shoudl be created |
|
39 |
@param pp_filename function printing the filename |
|
40 |
@param pp_file function wich pretty print the file |
|
41 |
@param arg will be given to pp_filename and pp_file |
|
42 |
**) |
|
43 |
let write_file destname pp_filename pp_file arg = |
|
44 |
let path = asprintf "%s%a" destname pp_filename arg in |
|
21 | 45 |
let out = open_out path in |
22 | 46 |
let fmt = formatter_of_out_channel out in |
23 |
print fmt machine; |
|
47 |
pp_file fmt arg; |
|
48 |
pp_print_flush fmt (); |
|
24 | 49 |
close_out out; |
25 |
Log.report ~level:2 (fun fmt -> fprintf fmt " .. %s generated @." path) |
|
50 |
log_str_level_two 2 (path^" generated") |
|
51 |
|
|
26 | 52 |
|
53 |
(** Print the filename of a package by lowercasing it and appending |
|
54 |
an extension. |
|
55 |
@param extension the extension to append to the package name |
|
56 |
@param fmt the formatter |
|
57 |
@param fmt the machine corresponding to the package |
|
58 |
**) |
|
59 |
let pp_machine_filename extension fmt machine = |
|
60 |
fprintf fmt "%a.%s" |
|
61 |
(pp_lowercase pp_package_name) machine.mname |
|
62 |
extension |
|
63 |
|
|
64 |
(** Exception raised when a machine contains a feature not supported by the |
|
65 |
Ada backend*) |
|
27 | 66 |
exception CheckFailed of string |
28 | 67 |
|
68 |
|
|
69 |
(** Check that a machine match the requirement for an Ada compilation : |
|
70 |
- No constants. |
|
71 |
@param machine the machine to test |
|
72 |
**) |
|
29 | 73 |
let check machine = |
30 | 74 |
match machine.mconst with |
31 | 75 |
| [] -> () |
32 | 76 |
| _ -> raise (CheckFailed "machine.mconst should be void") |
33 | 77 |
|
78 |
(** Print the name of the ada project file. |
|
79 |
@param fmt the formater to print on |
|
80 |
@param main_machine the machine associated to the main node |
|
81 |
**) |
|
82 |
let pp_project_name fmt main_machine = |
|
83 |
fprintf fmt "%a.gpr" pp_package_name main_machine.mname |
|
84 |
|
|
85 |
(** Main function of the Ada backend. It calls all the subfunction creating all |
|
86 |
the file and fill them with Ada code representing the machines list given. |
|
87 |
@param basename useless |
|
88 |
@param prog useless |
|
89 |
@param prog list of machines to translate |
|
90 |
@param dependencies useless |
|
91 |
**) |
|
34 | 92 |
let translate_to_ada basename prog machines dependencies = |
35 | 93 |
let module Ads = Ada_backend_ads.Main in |
36 | 94 |
let module Adb = Ada_backend_adb.Main in |
37 | 95 |
let module Wrapper = Ada_backend_wrapper.Main in |
38 | 96 |
|
39 |
let destname = !Options.dest_dir ^ "/" in |
|
97 |
(* Extract the main machine if there is one *) |
|
98 |
let main_machine = (match !Options.main_node with |
|
99 |
| "" -> None |
|
100 |
| main_node -> ( |
|
101 |
match Machine_code_common.get_machine_opt main_node machines with |
|
102 |
| None -> begin |
|
103 |
Format.eprintf "Ada Code generation error: %a@." Error.pp_error_msg Error.Main_not_found; |
|
104 |
raise (Corelang.Error (Location.dummy_loc, Error.Main_not_found)) |
|
105 |
end |
|
106 |
| Some m -> Some m |
|
107 |
)) in |
|
40 | 108 |
|
41 |
Log.report ~level:2 (fun fmt -> fprintf fmt " .. Checking machines@.");
|
|
109 |
let destname = !Options.dest_dir ^ "/" in
|
|
42 | 110 |
|
111 |
log_str_level_two 1 "Checking machines"; |
|
43 | 112 |
List.iter check machines; |
44 | 113 |
|
45 |
Log.report ~level:2 (fun fmt -> fprintf fmt " .. Generating ads@."); |
|
114 |
log_str_level_two 1 "Generating ads"; |
|
115 |
List.iter (write_file destname (pp_machine_filename "ads") Ads.pp_file) machines; |
|
46 | 116 |
|
47 |
List.iter (gen_ada destname Ads.print ".ads") machines; |
|
117 |
log_str_level_two 1 "Generating adb"; |
|
118 |
List.iter (write_file destname (pp_machine_filename "adb") Adb.pp_file) machines; |
|
48 | 119 |
|
49 |
Log.report ~level:2 (fun fmt -> fprintf fmt " .. Generating adb@."); |
|
120 |
(* If a main node is given we generate a main adb file and a project file *) |
|
121 |
log_str_level_two 1 "Generating wrapper files"; |
|
122 |
match main_machine with |
|
123 |
| None -> log_str_level_two 2 "File not generated(no -node argument)"; |
|
124 |
| Some machine -> begin |
|
125 |
write_file destname pp_project_name Wrapper.pp_project_file machine; |
|
126 |
write_file destname pp_main_filename Wrapper.pp_main_file machine; |
|
127 |
end |
|
50 | 128 |
|
51 |
List.iter (gen_ada destname Adb.print ".adb") machines |
|
52 | 129 |
|
53 | 130 |
(* Local Variables: *) |
54 | 131 |
(* compile-command:"make -C ../../.." *) |
src/backends/Ada/ada_backend_adb.ml | ||
---|---|---|
22 | 22 |
struct |
23 | 23 |
|
24 | 24 |
let pp_machine_instr machine fmt instr = |
25 |
fprintf fmt "instruction" |
|
26 |
|
|
25 |
fprintf fmt "NULL" |
|
27 | 26 |
|
28 | 27 |
(** Keep only the MReset from an instruction list. |
29 | 28 |
@param list to filter |
... | ... | |
32 | 31 |
(fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) |
33 | 32 |
instr_list |
34 | 33 |
|
35 |
(** Print the definition of a procedure |
|
36 |
@param fmt the formater to print on |
|
37 |
@param m the machine |
|
38 |
@param pp_procedure_name the procedure name printer |
|
39 |
@param pp_prototype the prototype printer |
|
40 |
@param instrs the instructions of the procedure |
|
41 |
**) |
|
42 |
let pp_procedure_definition fmt (m, pp_procedure_name, pp_prototype, instrs) = |
|
43 |
let pp_instr = pp_machine_instr m in |
|
44 |
fprintf fmt "%a is@,begin@, @[<v>%a%t@]@,end %t" |
|
45 |
pp_prototype m |
|
46 |
(Utils.fprintf_list ~sep:";@," pp_instr) instrs |
|
47 |
(Utils.pp_final_char_if_non_empty ";" instrs) |
|
48 |
pp_procedure_name |
|
49 |
|
|
50 | 34 |
(** Print the definition of the init procedure from a machine. |
51 | 35 |
@param fmt the formater to print on |
52 | 36 |
@param machine the machine |
53 | 37 |
**) |
54 |
let pp_init_definition fmt m = |
|
55 |
pp_procedure_definition fmt |
|
56 |
(m, pp_init_procedure_name, pp_init_prototype, m.minit) |
|
38 |
let pp_init_definition fmt m = pp_procedure_definition |
|
39 |
pp_init_procedure_name |
|
40 |
(pp_init_prototype m) |
|
41 |
pp_var_decl |
|
42 |
(pp_machine_instr m) |
|
43 |
fmt |
|
44 |
([], m.minit) |
|
57 | 45 |
|
58 | 46 |
(** Print the definition of the step procedure from a machine. |
59 | 47 |
@param fmt the formater to print on |
60 | 48 |
@param machine the machine |
61 | 49 |
**) |
62 |
let pp_step_definition fmt m = |
|
63 |
pp_procedure_definition fmt |
|
64 |
(m, pp_step_procedure_name, pp_step_prototype, m.minit) |
|
50 |
let pp_step_definition fmt m = pp_procedure_definition |
|
51 |
pp_step_procedure_name |
|
52 |
(pp_step_prototype m) |
|
53 |
pp_var_decl |
|
54 |
(pp_machine_instr m) |
|
55 |
fmt |
|
56 |
([], m.minit) |
|
65 | 57 |
|
66 | 58 |
(** Print the definition of the reset procedure from a machine. |
67 | 59 |
@param fmt the formater to print on |
68 | 60 |
@param machine the machine |
69 | 61 |
**) |
70 |
let pp_reset_definition fmt m = |
|
71 |
pp_procedure_definition fmt |
|
72 |
(m, pp_reset_procedure_name, pp_reset_prototype, filter_reset m.minit) |
|
62 |
let pp_reset_definition fmt m = pp_procedure_definition |
|
63 |
pp_reset_procedure_name |
|
64 |
(pp_reset_prototype m) |
|
65 |
pp_var_decl |
|
66 |
(pp_machine_instr m) |
|
67 |
fmt |
|
68 |
([], m.minit) |
|
73 | 69 |
|
74 | 70 |
(** Print the definition of the clear procedure from a machine. |
75 | 71 |
@param fmt the formater to print on |
76 | 72 |
@param machine the machine |
77 | 73 |
**) |
78 |
let pp_clear_definition fmt m = |
|
79 |
pp_procedure_definition fmt |
|
80 |
(m, pp_clear_procedure_name, pp_clear_prototype, filter_reset m.minit) |
|
74 |
let pp_clear_definition fmt m = pp_procedure_definition |
|
75 |
pp_clear_procedure_name |
|
76 |
(pp_clear_prototype m) |
|
77 |
pp_var_decl |
|
78 |
(pp_machine_instr m) |
|
79 |
fmt |
|
80 |
([], filter_reset m.minit) |
|
81 | 81 |
|
82 | 82 |
(** Print the package definition(adb) of a machine. |
83 | 83 |
@param fmt the formater to print on |
84 | 84 |
@param machine the machine |
85 | 85 |
**) |
86 |
let print fmt machine =
|
|
86 |
let pp_file fmt machine =
|
|
87 | 87 |
fprintf fmt "%a@, @[<v>@,%a;@,@,%a;@,@,%a;@,@,%a;@,@]@,%a;@." |
88 | 88 |
(pp_begin_package true) machine (*Begin the package*) |
89 | 89 |
pp_init_definition machine (*Define the init procedure*) |
src/backends/Ada/ada_backend_ads.ml | ||
---|---|---|
22 | 22 |
module Main = |
23 | 23 |
struct |
24 | 24 |
|
25 |
(** Print name of a node associated to an instance.
|
|
25 |
(** Print a with statement to include an instance.
|
|
26 | 26 |
@param fmt the formater to print on |
27 | 27 |
@param instance the instance |
28 | 28 |
**) |
29 |
let pp_instance_node_name fmt instance = |
|
30 |
let (_, (node, _)) = instance in |
|
31 |
let node = match node.top_decl_desc with |
|
32 |
| Node nd -> nd |
|
33 |
| _ -> assert false (*TODO*) in |
|
34 |
pp_package_name fmt node |
|
29 |
let pp_with_subinstance fmt instance = |
|
30 |
pp_with_node fmt (extract_node instance) |
|
35 | 31 |
|
36 | 32 |
(** Print the declaration of a state element of a subinstance of a machine. |
37 | 33 |
@param fmt the formater to print on |
38 | 34 |
@param instance the instance |
39 | 35 |
**) |
40 | 36 |
let pp_machine_subinstance_state_decl fmt instance = |
41 |
let (name, (node, static)) = instance in |
|
42 |
let pp_package fmt = pp_instance_node_name fmt instance in |
|
43 |
let pp_type fmt = pp_package_access fmt (pp_package, pp_state_type) in |
|
44 |
let pp_name fmt = print_clean_ada_identifier fmt name in |
|
45 |
pp_var_decl fmt (NoMode, pp_name, pp_type) |
|
37 |
pp_node_state_decl (fst instance) fmt (extract_node instance) |
|
46 | 38 |
|
47 | 39 |
(** Print the state record for a machine. |
48 | 40 |
@param fmt the formater to print on |
... | ... | |
55 | 47 |
(Utils.fprintf_list ~sep:";@;" (pp_machine_var_decl NoMode)) var_list |
56 | 48 |
(Utils.pp_final_char_if_non_empty ";" var_list) |
57 | 49 |
|
58 |
(** Print a with statement to include an instance. |
|
59 |
@param fmt the formater to print on |
|
60 |
@param instance the instance |
|
61 |
**) |
|
62 |
let pp_with_subinstance fmt instance = |
|
63 |
fprintf fmt "private with %a" pp_instance_node_name instance |
|
64 |
|
|
65 | 50 |
(** Print the package declaration(ads) of a machine. |
66 | 51 |
@param fmt the formater to print on |
67 |
@param machine the machine
|
|
52 |
@param m the machine |
|
68 | 53 |
**) |
69 |
let print fmt machine =
|
|
54 |
let pp_file fmt m =
|
|
70 | 55 |
(* Take apart the arrow instance from the instance list and transform them |
71 | 56 |
into simple boolean variable *) |
72 | 57 |
let extract (instances, arrows) instance = |
... | ... | |
75 | 60 |
(instances, (dummy_var_decl name Type_predef.type_bool)::arrows) |
76 | 61 |
else |
77 | 62 |
(instance::instances, arrows) in |
78 |
let instances, arrows = List.fold_left extract ([], []) machine.minstances in
|
|
63 |
let instances, arrows = List.fold_left extract ([], []) m.minstances in |
|
79 | 64 |
(* Add the boolean variable reated for arrow instance to the list of all variable *) |
80 |
let var_list = arrows@machine.mmemory in
|
|
65 |
let var_list = arrows@m.mmemory in |
|
81 | 66 |
let pp_record fmt = pp_state_record_definition fmt (var_list, instances) in |
82 | 67 |
fprintf fmt "@[<v>%a%t@,%a@, @[<v>@,%a;@,@,%a;@,@,%a;@,@,%a;@,@,%a;@,@,private@,@,%a;@,@]@,%a;@.@]" |
83 |
(Utils.fprintf_list ~sep:";@," pp_with_subinstance) instances (* Include all the subinstance*) |
|
68 |
|
|
69 |
(* Include all the subinstance*) |
|
70 |
(Utils.fprintf_list ~sep:";@," pp_with_subinstance) instances |
|
84 | 71 |
(Utils.pp_final_char_if_non_empty ";@," instances) |
85 |
(pp_begin_package false) machine (*Begin the package*) |
|
86 |
pp_private_type_decl pp_state_type (*Declare the state type*) |
|
87 |
pp_init_prototype machine (*Declare the init procedure*) |
|
88 |
pp_step_prototype machine (*Declare the step procedure*) |
|
89 |
pp_reset_prototype machine (*Declare the reset procedure*) |
|
90 |
pp_clear_prototype machine (*Declare the clear procedure*) |
|
91 |
pp_type_decl (pp_state_type, pp_record) (*Define the state type*) |
|
92 |
pp_end_package machine (*End the package*) |
|
72 |
|
|
73 |
(*Begin the package*) |
|
74 |
(pp_begin_package false) m |
|
75 |
|
|
76 |
(*Declare the state type*) |
|
77 |
pp_private_type_decl pp_state_type |
|
78 |
|
|
79 |
(*Declare the init procedure*) |
|
80 |
(pp_init_prototype m) pp_init_procedure_name |
|
81 |
|
|
82 |
(*Declare the step procedure*) |
|
83 |
(pp_step_prototype m) pp_step_procedure_name |
|
84 |
|
|
85 |
(*Declare the reset procedure*) |
|
86 |
(pp_reset_prototype m) pp_reset_procedure_name |
|
87 |
|
|
88 |
(*Declare the clear procedure*) |
|
89 |
(pp_clear_prototype m) pp_clear_procedure_name |
|
90 |
|
|
91 |
(*Define the state type*) |
|
92 |
pp_type_decl (pp_state_type, pp_record) |
|
93 |
|
|
94 |
(*End the package*) |
|
95 |
pp_end_package m |
|
93 | 96 |
|
94 | 97 |
end |
src/backends/Ada/ada_backend_common.ml | ||
---|---|---|
7 | 7 |
|
8 | 8 |
(** All the pretty print functions common to the ada backend **) |
9 | 9 |
|
10 |
(* Misc pretty print functions *) |
|
10 | 11 |
|
11 | 12 |
(** Print a cleaned an identifier for ada exportation : Ada names must not start by an |
12 | 13 |
underscore and must not contain a double underscore |
13 | 14 |
@param var name to be cleaned*) |
14 |
let print_clean_ada_identifier fmt name =
|
|
15 |
let pp_clean_ada_identifier fmt name =
|
|
15 | 16 |
let base_size = String.length name in |
16 | 17 |
assert(base_size > 0); |
17 | 18 |
let rec remove_double_underscore s = function |
... | ... | |
29 | 30 |
in |
30 | 31 |
fprintf fmt "%s%s" prefix name |
31 | 32 |
|
32 |
|
|
33 | 33 |
(* Package pretty print functions *) |
34 | 34 |
|
35 | 35 |
(** Print the name of a package associated to a machine. |
... | ... | |
37 | 37 |
@param machine the machine |
38 | 38 |
**) |
39 | 39 |
let pp_package_name fmt node = |
40 |
fprintf fmt "%a" print_clean_ada_identifier node.node_id
|
|
40 |
fprintf fmt "%a" pp_clean_ada_identifier node.node_id
|
|
41 | 41 |
|
42 | 42 |
(** Print the ada package introduction sentence it can be used for body and |
43 | 43 |
declaration. Boolean parameter body should be true if it is a body delcaration. |
... | ... | |
65 | 65 |
let pp_package_access fmt (package, item) = |
66 | 66 |
fprintf fmt "%t.%t" package item |
67 | 67 |
|
68 |
(** Print the name of the main procedure. |
|
69 |
@param fmt the formater to print on |
|
70 |
@param main_machine the machine associated to the main node |
|
71 |
**) |
|
72 |
let pp_main_procedure_name main_machine fmt = |
|
73 |
fprintf fmt "main" |
|
74 |
|
|
75 |
(** Print the name of the main ada file. |
|
76 |
@param fmt the formater to print on |
|
77 |
@param main_machine the machine associated to the main node |
|
78 |
**) |
|
79 |
let pp_main_filename fmt main_machine = |
|
80 |
fprintf fmt "%t.adb" (pp_main_procedure_name main_machine) |
|
81 |
|
|
82 |
(** Extract a node from an instance. |
|
83 |
@param instance the instance |
|
84 |
**) |
|
85 |
let extract_node instance = |
|
86 |
let (_, (node, _)) = instance in |
|
87 |
match node.top_decl_desc with |
|
88 |
| Node nd -> nd |
|
89 |
| _ -> assert false (*TODO*) |
|
90 |
|
|
91 |
(** Print a with statement to include a node. |
|
92 |
@param fmt the formater to print on |
|
93 |
@param node the node |
|
94 |
**) |
|
95 |
let pp_with_node fmt node = |
|
96 |
fprintf fmt "private with %a" pp_package_name node |
|
97 |
|
|
98 |
|
|
68 | 99 |
(* Type pretty print functions *) |
69 | 100 |
|
70 | 101 |
(** Print a type declaration |
... | ... | |
148 | 179 |
@param id the variable |
149 | 180 |
**) |
150 | 181 |
let pp_var_name fmt id = |
151 |
fprintf fmt "%a" print_clean_ada_identifier id.var_id
|
|
182 |
fprintf fmt "%a" pp_clean_ada_identifier id.var_id
|
|
152 | 183 |
|
153 | 184 |
(** Print a variable declaration |
154 | 185 |
@param mode input/output mode of the parameter |
... | ... | |
183 | 214 |
let pp_type = pp_state_type in |
184 | 215 |
pp_var_decl fmt (mode, pp_name, pp_type) |
185 | 216 |
|
217 |
(** Print the declaration of a state element of node. |
|
218 |
@param instance name of the variable |
|
219 |
@param fmt the formater to print on |
|
220 |
@param instance node |
|
221 |
**) |
|
222 |
let pp_node_state_decl name fmt node = |
|
223 |
let pp_package fmt = pp_package_name fmt node in |
|
224 |
let pp_type fmt = pp_package_access fmt (pp_package, pp_state_type) in |
|
225 |
let pp_name fmt = pp_clean_ada_identifier fmt name in |
|
226 |
pp_var_decl fmt (NoMode, pp_name, pp_type) |
|
186 | 227 |
|
187 | 228 |
(* Prototype pretty print functions *) |
188 | 229 |
|
... | ... | |
198 | 239 |
(** Print the clear of the init procedure **) |
199 | 240 |
let pp_clear_procedure_name fmt = fprintf fmt "clear" |
200 | 241 |
|
242 |
(** Print the prototype of a procedure with non input/outputs |
|
243 |
@param fmt the formater to print on |
|
244 |
@param name the name of the procedure |
|
245 |
**) |
|
246 |
let pp_simple_prototype fmt pp_name = |
|
247 |
fprintf fmt "procedure %t" pp_name |
|
248 |
|
|
201 | 249 |
(** Print the prototype of a machine procedure. The first parameter is always |
202 | 250 |
the state, state_modifier specify the modifier applying to it. The next |
203 | 251 |
parameters are inputs and the last parameters are the outputs. |
204 |
@param fmt the formater to print on |
|
205 |
@param name the name of the procedure |
|
206 | 252 |
@param state_mode the input/output mode for the state parameter |
207 | 253 |
@param input list of the input parameter of the procedure |
208 | 254 |
@param output list of the output parameter of the procedure |
255 |
@param fmt the formater to print on |
|
256 |
@param name the name of the procedure |
|
209 | 257 |
**) |
210 |
let pp_simple_prototype fmt (pp_name, state_mode, input, output) =
|
|
258 |
let pp_base_prototype state_mode input output fmt pp_name =
|
|
211 | 259 |
fprintf fmt "procedure %t(@[<v>%a%t@[%a@]%t@[%a@])@]" |
212 | 260 |
pp_name |
213 | 261 |
pp_state_var_decl state_mode |
... | ... | |
217 | 265 |
(Utils.fprintf_list ~sep:";@ " (pp_machine_var_decl Out)) output |
218 | 266 |
|
219 | 267 |
(** Print the prototype of the init procedure of a machine. |
220 |
@param fmt the formater to print on |
|
221 | 268 |
@param m the machine |
269 |
@param fmt the formater to print on |
|
270 |
@param pp_name name function printer |
|
222 | 271 |
**) |
223 |
let pp_init_prototype fmt m =
|
|
224 |
pp_simple_prototype fmt (pp_init_procedure_name, Out, m.mstatic, [])
|
|
272 |
let pp_init_prototype m fmt pp_name =
|
|
273 |
pp_base_prototype Out m.mstatic [] fmt pp_name
|
|
225 | 274 |
|
226 | 275 |
(** Print the prototype of the step procedure of a machine. |
227 |
@param fmt the formater to print on |
|
228 | 276 |
@param m the machine |
277 |
@param fmt the formater to print on |
|
278 |
@param pp_name name function printer |
|
229 | 279 |
**) |
230 |
let pp_step_prototype fmt m =
|
|
231 |
pp_simple_prototype fmt (pp_step_procedure_name, InOut, m.mstep.step_inputs, m.mstep.step_outputs)
|
|
280 |
let pp_step_prototype m fmt pp_name =
|
|
281 |
pp_base_prototype InOut m.mstep.step_inputs m.mstep.step_outputs fmt pp_name
|
|
232 | 282 |
|
233 | 283 |
(** Print the prototype of the reset procedure of a machine. |
234 |
@param fmt the formater to print on |
|
235 | 284 |
@param m the machine |
285 |
@param fmt the formater to print on |
|
286 |
@param pp_name name function printer |
|
236 | 287 |
**) |
237 |
let pp_reset_prototype fmt m =
|
|
238 |
pp_simple_prototype fmt (pp_reset_procedure_name, InOut, m.mstatic, [])
|
|
288 |
let pp_reset_prototype m fmt pp_name =
|
|
289 |
pp_base_prototype InOut m.mstatic [] fmt pp_name
|
|
239 | 290 |
|
240 | 291 |
(** Print the prototype of the clear procedure of a machine. |
241 |
@param fmt the formater to print on |
|
242 | 292 |
@param m the machine |
293 |
@param fmt the formater to print on |
|
294 |
@param pp_name name function printer |
|
243 | 295 |
**) |
244 |
let pp_clear_prototype fmt m = |
|
245 |
pp_simple_prototype fmt (pp_clear_procedure_name, InOut, m.mstatic, []) |
|
296 |
let pp_clear_prototype m fmt pp_name = |
|
297 |
pp_base_prototype InOut m.mstatic [] fmt pp_name |
|
298 |
|
|
299 |
|
|
300 |
(* Procedure pretty print functions *) |
|
301 |
|
|
302 |
(** Print the definition of a procedure |
|
303 |
@param pp_name the procedure name printer |
|
304 |
@param pp_prototype the prototype printer |
|
305 |
@param pp_instr local var printer |
|
306 |
@param pp_instr instruction printer |
|
307 |
@param fmt the formater to print on |
|
308 |
@param locals locals var list |
|
309 |
@param instrs instructions list |
|
310 |
**) |
|
311 |
let pp_procedure_definition pp_name pp_prototype pp_local pp_instr fmt (locals, instrs) = |
|
312 |
fprintf fmt "@[<v>%a is%t@[<v>%a%t@]@,begin@, @[<v>%a%t@]@,end %t@]" |
|
313 |
pp_prototype pp_name |
|
314 |
(Utils.pp_final_char_if_non_empty "@, " locals) |
|
315 |
(Utils.fprintf_list ~sep:";@," pp_local) locals |
|
316 |
(Utils.pp_final_char_if_non_empty ";" locals) |
|
317 |
(Utils.fprintf_list ~sep:";@," pp_instr) instrs |
|
318 |
(Utils.pp_final_char_if_non_empty ";" instrs) |
|
319 |
pp_name |
|
320 |
|
src/backends/Ada/ada_backend_wrapper.ml | ||
---|---|---|
9 | 9 |
(* *) |
10 | 10 |
(********************************************************************) |
11 | 11 |
|
12 |
open Format |
|
13 |
|
|
14 |
open Machine_code_types |
|
15 |
open Ada_backend_common |
|
16 |
|
|
12 | 17 |
module Main = |
13 | 18 |
struct |
19 |
|
|
20 |
(** Print the main procedure |
|
21 |
@param fmt the formater to print on |
|
22 |
@param machine the main machine |
|
23 |
@param locals list of local variable printers |
|
24 |
@param instrs list of instructions printer |
|
25 |
**) |
|
26 |
let pp_main_procedure_definition machine fmt (locals, instrs) = |
|
27 |
pp_procedure_definition |
|
28 |
(pp_main_procedure_name machine) |
|
29 |
pp_simple_prototype |
|
30 |
(fun fmt local -> fprintf fmt "%t" local) |
|
31 |
(fun fmt instr -> fprintf fmt "%t" instr) |
|
32 |
fmt |
|
33 |
(locals, instrs) |
|
34 |
|
|
35 |
(** Print call to machine procedure on state. |
|
36 |
@param instance name of the variable |
|
37 |
@param fmt the formater to print on |
|
38 |
@param instance node |
|
39 |
**) |
|
40 |
let pp_node_init_call name fmt node = |
|
41 |
let pp_package fmt = pp_package_name fmt node in |
|
42 |
let pp_type fmt = pp_package_access fmt (pp_package, pp_state_type) in |
|
43 |
let pp_name fmt = pp_clean_ada_identifier fmt name in |
|
44 |
pp_var_decl fmt (NoMode, pp_name, pp_type) |
|
45 |
|
|
46 |
(** Print the main file calling in a loop the step function of the main machine. |
|
47 |
@param fmt the formater to print on |
|
48 |
@param machine the main machine |
|
49 |
**) |
|
50 |
let pp_main_file fmt machine = |
|
51 |
let stateVar = "state" in |
|
52 |
let step_parameters = machine.mstep.step_inputs@machine.mstep.step_outputs in |
|
53 |
let pp_local_state_var_decl fmt = pp_node_state_decl stateVar fmt machine.mname in |
|
54 |
let apply_pp_var_decl var fmt = pp_machine_var_decl NoMode fmt var in |
|
55 |
let locals = List.map apply_pp_var_decl step_parameters in |
|
56 |
let locals = pp_local_state_var_decl::locals in |
|
57 |
let pp_init fmt = |
|
58 |
fprintf fmt "%a.init(%s)" |
|
59 |
pp_package_name machine.mname |
|
60 |
stateVar in |
|
61 |
let pp_loop fmt = |
|
62 |
fprintf fmt "while true loop@, %a.step(@[%s,@ %a@]);@,end loop" |
|
63 |
pp_package_name machine.mname |
|
64 |
stateVar |
|
65 |
(Utils.fprintf_list ~sep:",@ " pp_var_name) step_parameters |
|
66 |
in |
|
67 |
let instrs = [pp_init; pp_loop] in |
|
68 |
fprintf fmt "@[<v>%a;@,@,%a;@]" |
|
69 |
pp_with_node machine.mname |
|
70 |
(pp_main_procedure_definition machine) (locals, instrs) |
|
71 |
|
|
72 |
|
|
73 |
(** Print the gpr project file. |
|
74 |
@param fmt the formater to print on |
|
75 |
@param machine the main machine |
|
76 |
**) |
|
77 |
let pp_project_file fmt machine = |
|
78 |
fprintf fmt "project %a is@. for Main use (\"%a\");@.end %a;" |
|
79 |
pp_package_name machine.mname |
|
80 |
pp_main_filename machine |
|
81 |
pp_package_name machine.mname |
|
82 |
|
|
14 | 83 |
end |
Also available in: Unified diff
Ada: Add the generation of the wrapper file : the main ada file and the project. It is called
only if the main node option is given to lustrec. This feature implied some refactoring. Also
added some OCaml Doc to undocummented functions.