Project

General

Profile

Revision 3de9f6e4 src/backends/Ada/ada_backend_ads.ml

View differences:

src/backends/Ada/ada_backend_ads.ml
29 29
   @param ident the identifier of the subinstance
30 30
   @param submachine the submachine of the subinstance
31 31
**)
32
let pp_machine_subinstance_state_decl fmt (substitution, ident, submachine) =
32
let pp_machine_subinstance_state_decl fmt (ident, (substitution, submachine)) =
33 33
  pp_node_state_decl substitution ident fmt submachine
34 34

  
35 35
(** Print the state record for a machine.
36 36
   @param fmt the formater to print on
37 37
   @param var_list list of all state var
38
   @param typed_submachines list of pairs of instantiated types and machine
38
   @param typed_instances list typed instances
39 39
**)
40
let pp_state_record_definition fmt (var_list, typed_submachines) =
40
let pp_state_record_definition fmt (var_list, typed_instances) =
41 41
  fprintf fmt "@,  @[<v>record@,  @[<v>%a%t%a%t@]@,end record@]"
42 42
    (Utils.fprintf_list ~sep:";@;" pp_machine_subinstance_state_decl)
43
    typed_submachines
44
    (Utils.pp_final_char_if_non_empty ";@," typed_submachines)
43
    typed_instances
44
    (Utils.pp_final_char_if_non_empty ";@," typed_instances)
45 45
    (Utils.fprintf_list ~sep:";@;" (pp_machine_var_decl NoMode))
46 46
    var_list
47 47
    (Utils.pp_final_char_if_non_empty ";" var_list)
......
71 71
(** Print a new statement instantiating a generic package.
72 72
   @param fmt the formater to print on
73 73
   @param substitutions the instanciation substitution
74
   @param ident the name of the instance, useless in this function
75
   @param submachine the submachine to instanciate
74
   @param machine the machine to instanciate
76 75
**)
77
let pp_new_package fmt (substitutions, ident, submachine) =
76
let pp_new_package fmt (substitutions, machine) =
78 77
  fprintf fmt "package %a is new %a @[<v>(%a)@]"
79
    (pp_package_name_with_polymorphic substitutions) submachine
80
    pp_package_name submachine
78
    (pp_package_name_with_polymorphic substitutions) machine
79
    pp_package_name machine
81 80
    (Utils.fprintf_list ~sep:",@," pp_generic_instanciation) substitutions
82 81

  
83 82
let pp_eexpr fmt eexpr = fprintf fmt "true"
......
122 121
      fmt
123 122
      m.mspec
124 123

  
124
(** Remove duplicates from a list according to a given predicate.
125
   @param eq the predicate defining equality
126
   @param l the list to parse
127
**)
128
let remove_duplicates eq l =
129
  let aux l x = if List.exists (eq x) l then l else x::l in
130
  List.fold_left aux [] l
131

  
132

  
133
(** Compare two typed machines.
134
**)
135
let eq_typed_machine (subst1, machine1) (subst2, machine2) =
136
  (String.equal machine1.mname.node_id machine2.mname.node_id) &&
137
  (List.for_all2 (fun a b -> pp_eq_type (snd a) (snd b)) subst1 subst2)
138

  
139

  
125 140
(** Print the package declaration(ads) of a machine.
141
  It requires the list of all typed instance.
142
  A typed submachine instance is (ident, type_machine) with ident
143
  the instance name and typed_machine is (substitution, machine) with machine
144
  the machine associated to the instance and substitution the instanciation of
145
  all its polymorphic types.
126 146
   @param fmt the formater to print on
147
   @param typed_instances list of all typed machine instances of this machine
127 148
   @param m the machine
128 149
**)
129
let pp_file machines fmt m =
130
  let submachines = List.map (get_machine machines) m.minstances in
131
  let names = List.map fst m.minstances in
132
  let var_list = m.mmemory in
133
  let typed_submachines = List.map2
134
    (fun instance submachine ->
135
      let ident = (fst instance) in
136
      get_substitution m ident submachine, ident, submachine)
137
    m.minstances submachines in
138
  let extract_identifier (subst, _, submachine) =
139
    submachine.mname.node_id^"####"^(String.concat "####" (List.map (function (_, typ) -> (asprintf "%a" pp_type typ)) subst))
140
  in
141
  let identifiers = List.map extract_identifier typed_submachines in
142
  let typed_submachines_identified = List.combine identifiers typed_submachines in
143
  let typed_submachines_identified_set = List.fold_left (fun l x -> if List.mem_assoc (fst x) l then l else x::l) [] typed_submachines_identified in
144
  let submachines_set = List.map (function (_, (_, _, machine)) -> machine) typed_submachines_identified_set in
145
  let typed_submachines_set = snd (List.split typed_submachines_identified_set) in
146
  let pp_record fmt =
147
    pp_state_record_definition fmt (var_list, typed_submachines) in
148
  let typed_submachines_filtered =
149
    List.filter (function (l, _, _) -> l != []) typed_submachines_set in
150
let pp_file fmt (typed_instances, m) =
151
  let typed_machines = snd (List.split typed_instances) in
152
  let typed_machines_set = remove_duplicates eq_typed_machine typed_machines in
153
  
154
  let machines_to_import = snd (List.split typed_machines_set) in
155

  
150 156
  let polymorphic_types = find_all_polymorphic_type m in
157
  
158
  let typed_machines_to_instanciate =
159
    List.filter (fun (l, _) -> l != []) typed_machines_set in
160
  
161
  let pp_record fmt =
162
    pp_state_record_definition fmt (m.mmemory, typed_instances) in
163
  
164
  
151 165
  fprintf fmt "@[<v>%a%t%a%a@,  @[<v>@,%a;@,@,%t;@,@,%a;@,@,private@,@,%a%t%a;@,@]@,%a;@.@]"
152 166
    
153 167
    (* Include all the subinstance*)
154
    (Utils.fprintf_list ~sep:";@," pp_with_machine) submachines_set
155
    (Utils.pp_final_char_if_non_empty ";@,@," submachines_set)
168
    (Utils.fprintf_list ~sep:";@," pp_with_machine) machines_to_import
169
    (Utils.pp_final_char_if_non_empty ";@,@," machines_to_import)
156 170
    
157 171
    pp_generic polymorphic_types
158 172
    
......
168 182
    (*Declare the step procedure*)
169 183
    pp_step_prototype_contract m
170 184
    
171
    (*Instantiate the polymorphic type that need to be instantiate*)
172
    (Utils.fprintf_list ~sep:";@," pp_new_package) typed_submachines_filtered
173
    (Utils.pp_final_char_if_non_empty ";@,@," typed_submachines_filtered)
185
    (*Instantiate the polymorphic type that need to be instantiated*)
186
    (Utils.fprintf_list ~sep:";@," pp_new_package) typed_machines_to_instanciate
187
    (Utils.pp_final_char_if_non_empty ";@,@," typed_machines_to_instanciate)
174 188
    
175 189
    (*Define the state type*)
176 190
    pp_type_decl (pp_state_type, pp_record)

Also available in: Unified diff