Project

General

Profile

Revision fd834769 src/backends/Ada/ada_backend_ads.ml

View differences:

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

Also available in: Unified diff