Revision 61e0c3c4
Added by Guillaume DAVY about 4 years ago
src/backends/Ada/ada_backend_common.ml | ||
---|---|---|
14 | 14 |
|
15 | 15 |
let is_machine_statefull m = not m.mname.node_dec_stateless |
16 | 16 |
|
17 |
(*TODO Check all this function with unit test, improve this system and |
|
18 |
add support for : "cbrt", "erf", "log10", "pow", "atan2". |
|
19 |
*) |
|
17 | 20 |
let ada_supported_funs = |
18 |
[("sin", ("Ada.Numerics.Elementary_Functions", "Sin")); |
|
19 |
("cos", ("Ada.Numerics.Elementary_Functions", "Cos")); |
|
20 |
("tan", ("Ada.Numerics.Elementary_Functions", "Tan"))] |
|
21 |
[("sqrt", ("Ada.Numerics.Elementary_Functions", "Sqrt")); |
|
22 |
("log", ("Ada.Numerics.Elementary_Functions", "Log")); |
|
23 |
("exp", ("Ada.Numerics.Elementary_Functions", "Exp")); |
|
24 |
("pow", ("Ada.Numerics.Elementary_Functions", "**")); |
|
25 |
("sin", ("Ada.Numerics.Elementary_Functions", "Sin")); |
|
26 |
("cos", ("Ada.Numerics.Elementary_Functions", "Cos")); |
|
27 |
("tan", ("Ada.Numerics.Elementary_Functions", "Tan")); |
|
28 |
("asin", ("Ada.Numerics.Elementary_Functions", "Arcsin")); |
|
29 |
("acos", ("Ada.Numerics.Elementary_Functions", "Arccos")); |
|
30 |
("atan", ("Ada.Numerics.Elementary_Functions", "Arctan")); |
|
31 |
("sinh", ("Ada.Numerics.Elementary_Functions", "Sinh")); |
|
32 |
("cosh", ("Ada.Numerics.Elementary_Functions", "Cosh")); |
|
33 |
("tanh", ("Ada.Numerics.Elementary_Functions", "Tanh")); |
|
34 |
("asinh", ("Ada.Numerics.Elementary_Functions", "Arcsinh")); |
|
35 |
("acosh", ("Ada.Numerics.Elementary_Functions", "Arccosh")); |
|
36 |
("atanh", ("Ada.Numerics.Elementary_Functions", "Arctanh")); |
|
37 |
|
|
38 |
("ceil", ("", "Float'Ceiling")); |
|
39 |
("floor", ("", "Float'Floor")); |
|
40 |
("fmod", ("", "Float'Remainder")); |
|
41 |
("round", ("", "Float'Rounding")); |
|
42 |
("trunc", ("", "Float'Truncation")); |
|
43 |
|
|
44 |
("fabs", ("", "abs"));] |
|
21 | 45 |
|
22 | 46 |
let is_builtin_fun ident = |
23 | 47 |
List.mem ident Basic_library.internal_funs || |
... | ... | |
82 | 106 |
|
83 | 107 |
(* Package pretty print functions *) |
84 | 108 |
|
109 |
(** Return true if its the arrow machine |
|
110 |
@param machine the machine to test |
|
111 |
*) |
|
112 |
let is_arrow machine = String.equal Arrow.arrow_id machine.mname.node_id |
|
113 |
|
|
85 | 114 |
(** Print the name of the arrow package. |
86 | 115 |
@param fmt the formater to print on |
87 | 116 |
**) |
88 | 117 |
let pp_arrow_package_name fmt = fprintf fmt "Arrow" |
89 | 118 |
|
90 |
(** Print the name of a package associated to a node. |
|
91 |
@param fmt the formater to print on |
|
92 |
@param machine the machine |
|
93 |
**) |
|
94 |
let pp_package_name_from_node fmt node = |
|
95 |
if String.equal Arrow.arrow_id node.node_id then |
|
96 |
fprintf fmt "%t" pp_arrow_package_name |
|
97 |
else |
|
98 |
fprintf fmt "%a" pp_clean_ada_identifier node.node_id |
|
99 |
|
|
100 | 119 |
(** Print the name of a package associated to a machine. |
101 | 120 |
@param fmt the formater to print on |
102 | 121 |
@param machine the machine |
103 | 122 |
**) |
104 | 123 |
let pp_package_name fmt machine = |
105 |
pp_package_name_from_node fmt machine.mname |
|
124 |
if is_arrow machine then |
|
125 |
fprintf fmt "%t" pp_arrow_package_name |
|
126 |
else |
|
127 |
fprintf fmt "%a" pp_clean_ada_identifier machine.mname.node_id |
|
106 | 128 |
|
107 | 129 |
(** Print the ada package introduction sentence it can be used for body and |
108 | 130 |
declaration. Boolean parameter body should be true if it is a body delcaration. |
... | ... | |
177 | 199 |
try |
178 | 200 |
List.find (function m -> m.mname.node_id=id) machines |
179 | 201 |
with |
180 |
Not_found -> assert false |
|
202 |
Not_found -> assert false (*TODO*)
|
|
181 | 203 |
|
182 | 204 |
|
183 | 205 |
(* Type pretty print functions *) |
... | ... | |
246 | 268 |
| Types.Tbasic Types.Basic.Tint -> pp_integer_type fmt |
247 | 269 |
| Types.Tbasic Types.Basic.Treal -> pp_float_type fmt |
248 | 270 |
| Types.Tbasic Types.Basic.Tbool -> pp_boolean_type fmt |
249 |
| Types.Tunivar -> pp_polymorphic_type fmt typ.tid |
|
271 |
| Types.Tunivar -> pp_polymorphic_type fmt typ.Types.tid
|
|
250 | 272 |
| Types.Tbasic _ -> eprintf "Tbasic@."; assert false (*TODO*) |
251 | 273 |
| Types.Tconst _ -> eprintf "Tconst@."; assert false (*TODO*) |
252 | 274 |
| Types.Tclock _ -> eprintf "Tclock@."; assert false (*TODO*) |
... | ... | |
261 | 283 |
(*| _ -> eprintf "Type error : %a@." Types.print_ty typ; assert false *) |
262 | 284 |
) |
263 | 285 |
|
286 |
(** Return a default ada constant for a given type. |
|
287 |
@param cst_typ the constant type |
|
288 |
**) |
|
289 |
let default_ada_cst cst_typ = match cst_typ with |
|
290 |
| Types.Basic.Tint -> Const_int 0 |
|
291 |
| Types.Basic.Treal -> Const_real (Num.num_of_int 0, 0, "0.0") |
|
292 |
| Types.Basic.Tbool -> Const_tag tag_false |
|
293 |
|
|
294 |
(** Make a default value from a given type. |
|
295 |
@param typ the type |
|
296 |
**) |
|
297 |
let mk_default_value typ = |
|
298 |
match (Types.repr typ).Types.tdesc with |
|
299 |
| Types.Tbasic t -> mk_val (Cst (default_ada_cst t)) typ |
|
300 |
| _ -> assert false (*TODO*) |
|
264 | 301 |
|
265 | 302 |
(** Test if two types are the same. |
266 | 303 |
@param typ1 the first type |
... | ... | |
472 | 509 |
@param pp_name name function printer |
473 | 510 |
**) |
474 | 511 |
let pp_reset_prototype m fmt = |
475 |
let state_mode = if is_machine_statefull m then Some InOut else None in
|
|
512 |
let state_mode = if is_machine_statefull m then Some Out else None in |
|
476 | 513 |
pp_base_prototype state_mode m.mstatic [] fmt pp_reset_procedure_name |
477 | 514 |
|
478 | 515 |
(** Print the prototype of the init procedure of a machine. |
... | ... | |
685 | 722 |
let pp_ada_const fmt c = |
686 | 723 |
match c with |
687 | 724 |
| Const_int i -> pp_print_int fmt i |
688 |
| Const_real (c, e, s) -> pp_print_string fmt s |
|
725 |
| Const_real (c, e, s) -> |
|
726 |
fprintf fmt "%s.0*1.0e-%i" (Num.string_of_num c) e |
|
689 | 727 |
| Const_tag t -> pp_ada_tag fmt t |
690 | 728 |
| Const_string _ | Const_modeid _ -> |
691 | 729 |
(Format.eprintf |
... | ... | |
788 | 826 |
| _ -> |
789 | 827 |
raise (Ada_not_supported |
790 | 828 |
"unsupported: Ada_backend.adb.pp_value does not support this value type") |
829 |
|
|
830 |
|
|
831 |
(** Print the filename of a machine package. |
|
832 |
@param extension the extension to append to the package name |
|
833 |
@param fmt the formatter |
|
834 |
@param machine the machine corresponding to the package |
|
835 |
**) |
|
836 |
let pp_machine_filename extension fmt machine = |
|
837 |
pp_filename extension fmt (function fmt -> pp_package_name fmt machine) |
|
838 |
|
|
839 |
let pp_main_filename fmt _ = pp_filename "adb" fmt pp_main_procedure_name |
Also available in: Unified diff
Ada:
- Correct the merge with lustrec-seal
- Improve support for builtin function(still work to do)
- Add generation of a gpr file for lib(without main).
- Add var initialisation in the reset, still work to do.