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.