Revision 09d7b39f
Added by Guillaume DAVY about 4 years ago
| src/backends/Ada/ada_backend_common.ml | ||
|---|---|---|
| 8 | 8 |
(** Exception for unsupported features in Ada backend **) |
| 9 | 9 |
exception Ada_not_supported of string |
| 10 | 10 |
|
| 11 |
(** All the pretty print functions common to the ada backend **) |
|
| 11 |
(** All the pretty print and aux functions common to the ada backend **)
|
|
| 12 | 12 |
|
| 13 | 13 |
(* Misc pretty print functions *) |
| 14 | 14 |
|
| 15 |
let is_machine_statefull m = not m.mname.node_dec_stateless |
|
| 16 |
|
|
| 17 |
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 |
|
|
| 22 |
let is_builtin_fun ident = |
|
| 23 |
List.mem ident Basic_library.internal_funs || |
|
| 24 |
List.mem_assoc ident ada_supported_funs |
|
| 15 | 25 |
|
| 16 | 26 |
(** Print a cleaned an identifier for ada exportation : Ada names must not start by an |
| 17 | 27 |
underscore and must not contain a double underscore |
| ... | ... | |
| 133 | 143 |
let pp_private_with fmt pp_pakage_name = |
| 134 | 144 |
fprintf fmt "private with %t" pp_pakage_name |
| 135 | 145 |
|
| 146 |
(** Print a with statement to include a package. |
|
| 147 |
@param fmt the formater to print on |
|
| 148 |
@param name the package name |
|
| 149 |
**) |
|
| 150 |
let pp_with fmt name = |
|
| 151 |
fprintf fmt "with %s" name |
|
| 152 |
|
|
| 136 | 153 |
(** Print a with statement to include a machine. |
| 137 | 154 |
@param fmt the formater to print on |
| 138 | 155 |
@param machine the machine |
| ... | ... | |
| 411 | 428 |
(** Print the prototype of a machine procedure. The first parameter is always |
| 412 | 429 |
the state, state_modifier specify the modifier applying to it. The next |
| 413 | 430 |
parameters are inputs and the last parameters are the outputs. |
| 414 |
@param state_mode the input/output mode for the state parameter
|
|
| 431 |
@param state_mode_opt None if no state parameter required and some input/output mode for it else
|
|
| 415 | 432 |
@param input list of the input parameter of the procedure |
| 416 | 433 |
@param output list of the output parameter of the procedure |
| 417 | 434 |
@param fmt the formater to print on |
| 418 | 435 |
@param name the name of the procedure |
| 419 | 436 |
**) |
| 420 |
let pp_base_prototype state_mode input output fmt pp_name = |
|
| 421 |
fprintf fmt "procedure %t(@[<v>%a%t@[%a@]%t@[%a@])@]" |
|
| 437 |
let pp_base_prototype state_mode_opt input output fmt pp_name = |
|
| 438 |
let pp_var_decl_state fmt = match state_mode_opt with |
|
| 439 |
| None -> fprintf fmt "" |
|
| 440 |
| Some state_mode -> fprintf fmt "%a" pp_state_var_decl state_mode |
|
| 441 |
in |
|
| 442 |
fprintf fmt "procedure %t(@[<v>%t%t@[%a@]%t@[%a@])@]" |
|
| 422 | 443 |
pp_name |
| 423 |
pp_state_var_decl state_mode |
|
| 424 |
(Utils.pp_final_char_if_non_empty ";@," input) |
|
| 444 |
pp_var_decl_state |
|
| 445 |
(fun fmt -> if state_mode_opt != None && input!=[] then |
|
| 446 |
fprintf fmt ";@," else fprintf fmt "") |
|
| 425 | 447 |
(Utils.fprintf_list ~sep:";@ " (pp_machine_var_decl In)) input |
| 426 |
(Utils.pp_final_char_if_non_empty ";@," output) |
|
| 448 |
(fun fmt -> if (state_mode_opt != None || input!=[]) && output != [] then |
|
| 449 |
fprintf fmt ";@," else fprintf fmt "") |
|
| 427 | 450 |
(Utils.fprintf_list ~sep:";@ " (pp_machine_var_decl Out)) output |
| 428 | 451 |
|
| 429 | 452 |
(** Print the prototype of the step procedure of a machine. |
| ... | ... | |
| 432 | 455 |
@param pp_name name function printer |
| 433 | 456 |
**) |
| 434 | 457 |
let pp_step_prototype m fmt = |
| 435 |
pp_base_prototype InOut m.mstep.step_inputs m.mstep.step_outputs fmt pp_step_procedure_name |
|
| 458 |
let state_mode = if is_machine_statefull m then Some InOut else None in |
|
| 459 |
pp_base_prototype state_mode m.mstep.step_inputs m.mstep.step_outputs fmt pp_step_procedure_name |
|
| 436 | 460 |
|
| 437 | 461 |
(** Print the prototype of the reset procedure of a machine. |
| 438 | 462 |
@param m the machine |
| ... | ... | |
| 440 | 464 |
@param pp_name name function printer |
| 441 | 465 |
**) |
| 442 | 466 |
let pp_reset_prototype m fmt = |
| 443 |
pp_base_prototype InOut m.mstatic [] fmt pp_reset_procedure_name |
|
| 467 |
let state_mode = if is_machine_statefull m then Some InOut else None in |
|
| 468 |
pp_base_prototype state_mode m.mstatic [] fmt pp_reset_procedure_name |
|
| 444 | 469 |
|
| 445 | 470 |
(** Print the prototype of the init procedure of a machine. |
| 446 | 471 |
@param m the machine |
| ... | ... | |
| 448 | 473 |
@param pp_name name function printer |
| 449 | 474 |
**) |
| 450 | 475 |
let pp_init_prototype m fmt = |
| 451 |
pp_base_prototype Out m.mstatic [] fmt pp_init_procedure_name |
|
| 476 |
let state_mode = if is_machine_statefull m then Some Out else None in |
|
| 477 |
pp_base_prototype state_mode m.mstatic [] fmt pp_init_procedure_name |
|
| 452 | 478 |
|
| 453 | 479 |
(** Print the prototype of the clear procedure of a machine. |
| 454 | 480 |
@param m the machine |
| ... | ... | |
| 456 | 482 |
@param pp_name name function printer |
| 457 | 483 |
**) |
| 458 | 484 |
let pp_clear_prototype m fmt = |
| 459 |
pp_base_prototype InOut m.mstatic [] fmt pp_clear_procedure_name |
|
| 485 |
let state_mode = if is_machine_statefull m then Some InOut else None in |
|
| 486 |
pp_base_prototype state_mode m.mstatic [] fmt pp_clear_procedure_name |
|
| 460 | 487 |
|
| 461 | 488 |
(** Print a one line comment with the final new line character to avoid |
| 462 | 489 |
commenting anything else. |
| ... | ... | |
| 468 | 495 |
fprintf fmt "-- %s@," s |
| 469 | 496 |
|
| 470 | 497 |
(* Functions which computes the substitution for polymorphic type *) |
| 498 |
|
|
| 499 |
|
|
| 500 |
(** Check if a submachine is statefull. |
|
| 501 |
@param submachine a submachine |
|
| 502 |
@return true if the submachine is statefull |
|
| 503 |
**) |
|
| 504 |
let is_submachine_statefull submachine = |
|
| 505 |
not (snd (snd submachine)).mname.node_dec_stateless |
|
| 506 |
|
|
| 471 | 507 |
(** Find a submachine step call in a list of instructions. |
| 472 | 508 |
@param ident submachine instance ident |
| 473 | 509 |
@param instr_list List of instruction sto search |
| ... | ... | |
| 719 | 755 |
Format.fprintf fmt "(%a %s %a)" pp_value v1 "/=" pp_value v2 |
| 720 | 756 |
| op, [v1; v2] -> |
| 721 | 757 |
Format.fprintf fmt "(%a %s %a)" pp_value v1 op pp_value v2 |
| 758 |
| op, [v1] when List.mem_assoc ident ada_supported_funs -> |
|
| 759 |
let pkg, name = try List.assoc ident ada_supported_funs |
|
| 760 |
with Not_found -> assert false in |
|
| 761 |
let pkg = pkg^(if String.equal pkg "" then "" else ".") in |
|
| 762 |
Format.fprintf fmt "%s%s(%a)" pkg name pp_value v1 |
|
| 722 | 763 |
| fun_name, _ -> |
| 723 | 764 |
(Format.eprintf "internal compilation error: basic function %s@." fun_name; assert false) |
| 724 | 765 |
|
Also available in: Unified diff
Ada: Add generation of step calls and refactor prototypes and ads printing to handle staless
instance.