Project

General

Profile

« Previous | Next » 

Revision 61e0c3c4

Added by Guillaume DAVY about 4 years ago

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.

View differences:

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