Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / VHDL / vhdl_2_mini_vhdl_map.ml @ bd1f1929

History | View | Annotate | Download (46 KB)

1
open Vhdl_ast
2
open Mini_vhdl_ast
3
open Mini_vhdl_utils
4
open Vhdl_ast_fold_sensitivity
5

    
6
type db_tuple_t =
7
  {
8
    mutable entity: vhdl_entity_t;
9
    mutable architecture: vhdl_architecture_t;
10
    mutable architecture_signals: mini_vhdl_declaration_t list;
11
    mutable architecture_ports: vhdl_port_t list;
12
    mutable architecture_generics: vhdl_port_t list;
13
    mutable assigned_signals_names: vhdl_name_t list;
14
    mutable functions: (vhdl_name_t * vhdl_parameter_t list * vhdl_name_t) list;
15
    mutable memories: vhdl_name_t list;
16
    mutable contexts: vhdl_load_t list;
17
  }
18

    
19
type assoc_element_mode_t = Positional | Named | Named_arg
20

    
21
let get_sensitivity_list = object (self)
22
  inherit ['acc] fold_sensitivity as super
23
end
24

    
25
let _ = fun (_ : vhdl_cst_val_t)  -> () 
26
let _ = fun (_ : vhdl_type_t)  -> () 
27
let _ = fun (_ : vhdl_element_declaration_t)  -> () 
28
let _ = fun (_ : vhdl_subtype_indication_t)  -> () 
29
let _ = fun (_ : vhdl_discrete_range_t)  -> () 
30
let _ = fun (_ : vhdl_constraint_t)  -> () 
31
let _ = fun (_ : vhdl_definition_t)  -> () 
32
let _ = fun (_ : vhdl_expr_t)  -> () 
33
let _ = fun (_ : vhdl_name_t)  -> () 
34
let _ = fun (_ : vhdl_assoc_element_t)  -> () 
35
let _ = fun (_ : vhdl_element_assoc_t)  -> () 
36
let _ = fun (_ : vhdl_signal_attributes_t)  -> () 
37
let _ = fun (_ : vhdl_suffix_selection_t)  -> () 
38
let _ = fun (_ : vhdl_parameter_t)  -> () 
39
let _ = fun (_ : vhdl_subprogram_spec_t)  -> () 
40
let _ = fun (_ : vhdl_sequential_stmt_t)  -> () 
41
let _ = fun (_ : vhdl_if_case_t)  -> () 
42
let _ = fun (_ : vhdl_case_item_t)  -> () 
43
let _ = fun (_ : vhdl_declaration_t)  -> () 
44
let _ = fun (_ : vhdl_signal_selection_t)  -> () 
45
let _ = fun (_ : vhdl_declarative_item_t)  -> () 
46
let _ = fun (_ : vhdl_waveform_element_t)  -> ()
47
let _ = fun (_ : vhdl_signal_condition_t)  -> () 
48
let _ = fun (_ : vhdl_conditional_signal_t)  -> () 
49
let _ = fun (_ : vhdl_process_t)  -> () 
50
let _ = fun (_ : vhdl_selected_signal_t)  -> () 
51
let _ = fun (_ : vhdl_port_mode_t)  -> () 
52
let _ = fun (_ : vhdl_component_instantiation_t)  -> ()
53
let _ = fun (_ : vhdl_concurrent_stmt_t)  -> () 
54
let _ = fun (_ : vhdl_port_t)  -> () 
55
let _ = fun (_ : vhdl_entity_t)  -> () 
56
let _ = fun (_ : vhdl_package_t)  -> () 
57
let _ = fun (_ : vhdl_load_t)  -> () 
58
let _ = fun (_ : vhdl_architecture_t)  -> () 
59
let _ = fun (_ : vhdl_configuration_t)  -> () 
60
let _ = fun (_ : vhdl_design_file_t)  -> () 
61

    
62
class virtual vhdl_2_mini_vhdl_map =
63
  object (self)
64
    method virtual  string : string -> string
65
    method virtual  list : 'a . ('a -> 'a) -> 'a list -> 'a list
66
    method virtual  unit : unit -> unit
67
    method virtual  bool : bool -> bool
68
    method virtual  option : 'a . ('a -> 'a) -> 'a option -> 'a option
69
    method virtual  int : int -> int
70
    method virtual  vhdl_name_t : vhdl_name_t -> vhdl_name_t
71
    method virtual  vhdl_definition_t : vhdl_definition_t -> vhdl_definition_t
72
    method virtual  vhdl_port_t : vhdl_port_t -> vhdl_port_t
73
    method virtual  vhdl_expr_t : vhdl_expr_t -> vhdl_expr_t
74
    method virtual  vhdl_port_mode_t : vhdl_port_mode_t -> vhdl_port_mode_t
75
    method virtual  vhdl_element_declaration_t : vhdl_element_declaration_t -> vhdl_element_declaration_t
76
    method virtual  vhdl_subtype_indication_t : vhdl_subtype_indication_t -> vhdl_subtype_indication_t
77
    method virtual  vhdl_conditional_signal_t : vhdl_conditional_signal_t -> vhdl_conditional_signal_t
78
    method virtual  vhdl_selected_signal_t : vhdl_selected_signal_t -> vhdl_selected_signal_t
79
    method virtual  vhdl_signal_selection_t : vhdl_signal_selection_t -> vhdl_signal_selection_t
80
    method virtual  vhdl_suffix_selection_t : vhdl_suffix_selection_t -> vhdl_suffix_selection_t
81
    method virtual  vhdl_waveform_element_t : vhdl_waveform_element_t -> vhdl_waveform_element_t
82
    method virtual  vhdl_signal_condition_t : vhdl_signal_condition_t -> vhdl_signal_condition_t
83
    method virtual  vhdl_cst_val_t : vhdl_cst_val_t -> vhdl_cst_val_t
84
    method virtual  vhdl_subprogram_spec_t : vhdl_subprogram_spec_t -> vhdl_subprogram_spec_t
85
    method virtual  vhdl_discrete_range_t : vhdl_discrete_range_t -> vhdl_discrete_range_t
86
    method virtual  vhdl_parameter_t : vhdl_parameter_t -> vhdl_parameter_t
87
    method virtual  vhdl_declaration_t : vhdl_declaration_t -> mini_vhdl_declaration_t
88
    method virtual  vhdl_configuration_t : vhdl_configuration_t -> unit
89
    method virtual  vhdl_entity_t : vhdl_entity_t -> unit
90
    method virtual  vhdl_load_t : vhdl_load_t -> vhdl_load_t
91

    
92
    method virtual  vhdl_declarative_item_t : vhdl_declarative_item_t -> mini_vhdl_declarative_item_t
93
    method virtual  vhdl_process_t : vhdl_process_t -> mini_vhdl_process_t
94
    method virtual  vhdl_concurrent_stmt_t : vhdl_concurrent_stmt_t -> mini_vhdl_concurrent_stmt_t
95
    method virtual  vhdl_sequential_stmt_t : vhdl_sequential_stmt_t -> mini_vhdl_sequential_stmt_t
96
    method virtual  vhdl_design_file_t : vhdl_design_file_t -> mini_vhdl_design_file_t
97

    
98
    method virtual  vhdl_package_t : (vhdl_load_t list * vhdl_package_t) -> mini_vhdl_package_t
99
    method virtual  vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list *
100
                                  (vhdl_load_t list * vhdl_entity_t) list * 
101
                                  (vhdl_load_t list * vhdl_configuration_t) list *
102
                                  (vhdl_load_t list * vhdl_architecture_t)) -> mini_vhdl_component_t
103
    method virtual  vhdl_component_instantiation_t : vhdl_component_instantiation_t -> mini_vhdl_component_instantiation_t
104
    method virtual  declarative_items_declarations : vhdl_declarative_item_t list -> vhdl_declaration_t list
105
    method virtual  declarative_items_definitions : vhdl_declarative_item_t list -> vhdl_definition_t list
106
    method virtual  declarative_items_uses : vhdl_declarative_item_t list -> vhdl_load_t list
107
    method virtual  filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) -> 
108
                           (vhdl_load_t list * vhdl_entity_t)
109

    
110
(*************************
111
 * Begin vhdl_name_t helpers
112
 *)
113
    method simplify_name_t : vhdl_name_t -> vhdl_name_t=
114
      fun n ->
115
        let lower a = String.lowercase_ascii a in
116
        let n = self#lower_vhdl_name_t n in
117
        match n with
118
        | Selected (a::[]) -> self#simplify_name_t a
119
        | Selected (NoName::tl) -> self#simplify_name_t (Selected tl)
120
        | Selected ((Simple (s))::tl) ->  if (lower s = "work")
121
                                          then self#simplify_name_t (Selected tl)
122
                                          else n
123
        | Selected ((Identifier (s))::tl) -> if (lower s = "work")
124
                                             then self#simplify_name_t (Selected tl)
125
                                             else n
126
        | _ -> n
127

    
128
    method lower_vhdl_name_t : vhdl_name_t -> vhdl_name_t=
129
      fun x  ->
130
        let lower a = String.lowercase_ascii a in
131
        match x with
132
        | Simple a -> Simple (lower a)
133
        | Identifier a -> Identifier (lower a)
134
        | Selected a -> Selected (self#list self#lower_vhdl_name_t a)
135
        | Index { id; exprs } ->
136
            let id = self#lower_vhdl_name_t id  in
137
            let exprs = self#list self#vhdl_expr_t exprs  in
138
            Index { id; exprs }
139
        | Slice { id; range } ->
140
            let id = self#lower_vhdl_name_t id  in
141
            let range = self#vhdl_discrete_range_t range  in
142
            Slice { id; range }
143
        | Attribute { id; designator; expr } ->
144
            let id = self#lower_vhdl_name_t id  in
145
            let designator = self#lower_vhdl_name_t designator  in
146
            let expr = self#vhdl_expr_t expr  in
147
            Attribute { id; designator; expr }
148
        | Function { id; assoc_list } ->
149
            let id = self#lower_vhdl_name_t id  in
150
            let assoc_list = self#list self#vhdl_assoc_element_t assoc_list in
151
            Function { id; assoc_list }
152
        | NoName  -> NoName
153
        | Open -> Open
154
 
155
    method to_string_vhdl_name_t : vhdl_name_t -> string=
156
      fun x  ->
157
        match x with
158
        | Simple a -> a
159
        | Identifier a -> a
160
        | Selected a -> String.concat "." (List.map self#to_string_vhdl_name_t a)
161
        | Index { id; exprs } -> self#to_string_vhdl_name_t id
162
        | Slice { id; range } -> self#to_string_vhdl_name_t id
163
        | Attribute { id; designator; expr } -> self#to_string_vhdl_name_t id
164
        | Function { id; assoc_list } -> self#to_string_vhdl_name_t id
165
        | NoName  -> "NoName"
166
        | Open -> "Open"
167

    
168
    method flatten_vhdl_name_t : vhdl_name_t -> vhdl_name_t=
169
      fun x  ->
170
        match x with
171
        | Simple a -> Simple (a)
172
        | Identifier a -> Simple (a)
173
        | Selected (hd::tl) -> Simple (String.concat "__" ((self#to_string_vhdl_name_t (self#flatten_vhdl_name_t hd))::[self#to_string_vhdl_name_t (self#flatten_vhdl_name_t (Selected (tl)))]))
174
        | _ -> failwith ("Impossible to flatten name value [" ^ self#to_string_vhdl_name_t x ^ "]")
175

    
176
    method postfix_flatten_vhdl_name_t : vhdl_name_t -> string -> vhdl_name_t=
177
      fun x  ->
178
        fun postfix ->
179
          let flattened = self#flatten_vhdl_name_t x in
180
          match flattened with
181
          | Simple a -> Simple (a ^ postfix)
182
          | Identifier a -> Identifier (a ^ postfix)
183
          | _ -> failwith ("Impossible to postfix name value [" ^ self#to_string_vhdl_name_t x ^ "]")
184
 
185

    
186
(*************************
187
 * End vhdl_name_t helpers
188
 *)
189

    
190
(*************************
191
 * Begin DB helpers
192
 *)
193
    val mutable db : db_tuple_t list = []
194
    val mutable db_current : db_tuple_t = {
195
      entity = { e_name = NoName; generics = []; ports = []; e_declaration = []; stmts = [] };
196
      architecture = { a_name = NoName; entity = NoName; a_declarations = []; a_body = [] };
197
      architecture_signals = [];
198
      architecture_ports = [];
199
      architecture_generics = [];
200
      assigned_signals_names = [];
201
      functions = [];
202
      memories = [];
203
      contexts = [];
204
    }
205

    
206
    method get_db : db_tuple_t list = db
207

    
208
    method db_get_current : db_tuple_t = db_current
209
    method db_set_current : db_tuple_t -> unit=
210
      fun x -> db_current <- x
211

    
212
    method db_add_tuple : db_tuple_t -> unit=
213
      fun x -> db <- x::db
214

    
215
    method db_get : vhdl_architecture_t -> (vhdl_entity_t * vhdl_load_t list)=
216
      fun x ->
217
        let rec find a dbl =
218
          match dbl with
219
          | [] -> failwith ("No matching tuple in DB for architecture [" ^ self#to_string_vhdl_name_t x.a_name ^ "]")
220
          | e::tl -> if (e.architecture = a) then (e.entity, e.contexts) else find a tl in find x db
221

    
222
    method get_tuple_from_archi_and_entity_name : (vhdl_name_t * vhdl_name_t) -> db_tuple_t=
223
      fun (a_name,e_name) ->
224
        let a_name = self#simplify_name_t a_name in
225
        let e_name = self#simplify_name_t e_name in
226
        let rec find (a_name,e_name) dbl =
227
          match dbl with
228
          | [] -> failwith ("No matching tuple in DB for architecture [" ^ self#to_string_vhdl_name_t a_name ^
229
                           "] and entity [" ^ self#to_string_vhdl_name_t e_name ^ "]")
230
          | e::tl -> 
231
              let inner_e_arch_name = self#simplify_name_t e.architecture.a_name in
232
              let inner_e_ent_name = self#simplify_name_t e.entity.e_name in
233
              if ((inner_e_arch_name = a_name) && (inner_e_ent_name = e_name)) 
234
              then e 
235
              else find (a_name,e_name) tl in 
236
        find (a_name,e_name) db
237

    
238
    method filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) -> 
239
                           (vhdl_load_t list * vhdl_entity_t) =
240
      fun ( entities_pair, filter_name ) ->
241
      let rec filter ep n = match ep with
242
      | [] -> failwith ("Impossible to find an entity with name [" ^ self#to_string_vhdl_name_t filter_name ^ "]")
243
      | (c,{e_name; generics; ports; e_declaration; stmts})::tl -> 
244
          if (e_name = n) then 
245
            List.hd ep
246
          else filter (List.tl ep) n in
247
      filter entities_pair filter_name
248
(*******************
249
 * End DB helpers
250
 *)
251

    
252
(*******************
253
 * Begin declarative_item_t projections
254
 *)
255
    method declarative_items_declarations : vhdl_declarative_item_t list -> vhdl_declaration_t list =
256
      fun x ->
257
        match x with
258
        | {use_clause=_; di_declaration=Some a; di_definition=_}::tl -> a::(self#declarative_items_declarations tl)
259
        | _::tl -> self#declarative_items_declarations tl
260
        | [] -> []
261

    
262
    method declarative_items_definitions : vhdl_declarative_item_t list -> vhdl_definition_t list =
263
      fun x ->
264
        match x with
265
        | {use_clause=_; di_declaration=_; di_definition=Some a}::tl -> a::(self#declarative_items_definitions tl)
266
        | _::tl -> self#declarative_items_definitions tl
267
        | [] -> []
268

    
269
    method declarative_items_uses : vhdl_declarative_item_t list -> vhdl_load_t list =
270
      fun x ->
271
        match x with
272
        | {use_clause=Some a; di_declaration=_; di_definition=_}::tl -> a::(self#declarative_items_uses tl)
273
        | _::tl -> self#declarative_items_uses tl
274
        | [] -> []
275
(******************
276
 * End declarative_item_t projections
277
 *)
278

    
279
(*****************
280
 * Begin names_t extraction (assigned signals)
281
 *)
282
    method mini_vhdl_concurrent_stmt_t_assigned_signals_names : mini_vhdl_concurrent_stmt_t -> vhdl_name_t list=
283
      fun x ->
284
        match x with
285
        | MiniProcess a -> List.sort_uniq compare (
286
            List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names a.p_body)
287
          )
288
        | MiniComponentInst a ->
289
            let out_ports_positions = get_ports_pos a.entity.ports OutPort 0 in
290
            let inout_ports_positions = get_ports_pos a.entity.ports InoutPort 0 in
291
            let assigned_out_ports_names = List.map (fun x -> x.actual_designator) a.port_map in
292
            let out_ports_pos = out_ports_positions@inout_ports_positions in
293
            List.map (List.nth (remove_opt assigned_out_ports_names)) out_ports_pos
294

    
295
    method mini_vhdl_sequential_stmt_t_assigned_signals_names :
296
      mini_vhdl_sequential_stmt_t -> vhdl_name_t list=
297
      fun x  ->
298
        match x with
299
        | MiniVarAssign { label; lhs; rhs } -> []
300
        | MiniSigSeqAssign { label; lhs; rhs } -> [lhs]
301
        | MiniSigCondAssign { label; lhs; rhs; delay} -> [lhs]
302
        | MiniSigSelectAssign { label; lhs; sel; branches; delay } -> [lhs]
303
        | MiniIf { label; if_cases; default } -> 
304
            let if_cases_stmts = List.flatten (List.map (fun x -> x.if_block_mini) if_cases) in
305
            List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names (if_cases_stmts@default))
306
        | MiniCase { label; guard; branches } ->
307
            let case_branches_stmts = List.flatten (List.map (fun x -> x.when_stmt_mini) branches) in
308
            List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names case_branches_stmts)
309
        | MiniProcedureCall { label; name; assocs } -> [] (* TODO: resolve this *)
310
        | _ -> []
311

    
312
(****************
313
 *End names_t extraction
314
 *)
315

    
316
(*****************
317
 * Begin Implicit memories explicitation
318
 *)
319

    
320
    method mini_vhdl_concurrent_stmt_t_memories : vhdl_name_t list -> mini_vhdl_concurrent_stmt_t -> vhdl_name_t list=
321
      fun assigned_signals -> fun x ->
322
        match x with
323
        | MiniProcess a -> List.flatten (List.map (self#memories assigned_signals []) a.p_body)
324
        | MiniComponentInst a -> [] (* Nothing to be reported here as memories are checked for each component *)
325

    
326
    method memories: vhdl_name_t list -> vhdl_name_t list -> mini_vhdl_sequential_stmt_t -> vhdl_name_t list=
327
      fun assigned_signals -> fun mems -> fun x ->
328
        match x with
329
        | MiniIf { label; if_cases; default } ->
330
            let if_cases_stmts = List.map (fun x -> x.if_block_mini) if_cases in
331
            let if_cases_assigned_signals = 
332
              List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names (List.flatten (if_cases_stmts@[default])) in
333
            let if_cases_memories = List.flatten (List.map (fun x -> List.flatten (List.map (self#memories assigned_signals []) x)) (if_cases_stmts@[default])) in
334
            let mems = if_cases_memories@mems in
335
            (match default with
336
              | [] -> (List.flatten if_cases_assigned_signals)@mems
337
              | _ -> mems)
338
        | MiniCase { label; guard; branches } ->
339
            let case_branches_stmts = List.map (fun x -> x.when_stmt_mini) branches in
340
         (*   let case_assigned_signals = List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names (List.flatten (case_branches_stmts)) in *)
341
            let cases_memories = List.flatten (List.map (fun x -> List.flatten (List.map (self#memories assigned_signals []) x)) (case_branches_stmts)) in
342
            cases_memories@mems
343
        | _ -> mems
344

    
345
(****************
346
 *End memories explicitation
347
 *)
348

    
349
(****************
350
 * Begin Association element resolution
351
 *)
352

    
353
    method vhdl_assoc_element_t_mode : vhdl_assoc_element_t -> assoc_element_mode_t=
354
      fun { formal_name; formal_arg; actual_name; actual_designator; actual_expr } ->
355
        match (formal_name, formal_arg) with
356
        | (None, None) -> Positional
357
        | (Some NoName, Some NoName) -> Positional
358
        | (_, None) -> Named
359
        | (_, Some NoName) -> Named
360
        | _ -> Named_arg
361
        
362
    method vhdl_assoc_simplify : vhdl_assoc_element_t -> vhdl_assoc_element_t=
363
      fun elem ->
364
        let mode = self#vhdl_assoc_element_t_mode elem in
365
        match mode with
366
        | Positional -> elem
367
        | Named -> {formal_name=None; 
368
                    formal_arg=None; 
369
                    actual_name=elem.actual_name; 
370
                    actual_designator=elem.actual_designator; 
371
                    actual_expr=elem.actual_expr }
372
        | Named_arg -> 
373
            match elem.formal_name with
374
            | None -> failwith "Unreachable error (Named arg assoc_element_t without formal name) - vhdl_assoc_resolve"
375
            | Some a -> {formal_name=None; 
376
                         formal_arg=None; 
377
                         actual_name= Some (Function {id=a; 
378
                                                      assoc_list=
379
                                                        [{formal_name=None; 
380
                                                          formal_arg=None; 
381
                                                          actual_name=elem.actual_name; 
382
                                                          actual_designator=elem.actual_designator; 
383
                                                          actual_expr=elem.actual_expr }]}); 
384
                         actual_designator=None; 
385
                         actual_expr=None}
386

    
387
    method vhdl_assoc_element_t_resolve : vhdl_assoc_element_t list -> vhdl_name_t list -> vhdl_assoc_element_t list=
388
      fun elements -> fun names ->
389
        let rec index_of e l i =
390
          match l with [] -> failwith "Unreachable error (Non existing element in self list index_of) - map_ports" 
391
                       | hd::tl -> if hd = e then i else index_of e tl (i+1) in
392
        let modes = List.map self#vhdl_assoc_element_t_mode elements in
393
        let match_assoc_mode a m = match m with
394
        | Positional -> (index_of a elements 0, a)
395
        | Named -> 
396
            (match a.formal_name with
397
            | None -> failwith "Unreachable error (Named assoc_element_t without formal name) - map_ports"
398
            | Some e -> (find_vhdl_name_t names e, a))
399
        | Named_arg -> 
400
            (match a.formal_arg with
401
            | None -> failwith "Unreachable error (Named_arg assoc_element_t without formal arg) - map_ports"
402
            | Some e -> (find_vhdl_name_t names e, a)) in
403
        let positioned = List.map2 (match_assoc_mode) elements modes in
404
        let compare_index_assoc_pairs a b = compare (fst a) (fst b) in
405
        let ordered_elements = List.map snd (List.sort compare_index_assoc_pairs positioned) in
406
        List.map self#vhdl_assoc_simplify ordered_elements
407

    
408
(****************
409
 * End Association element resolution
410
 *)
411

    
412
    method vhdl_cst_val_t : vhdl_cst_val_t -> vhdl_cst_val_t=
413
      fun x  ->
414
        match x with
415
        | CstInt a -> let a = self#int a  in CstInt a
416
        | CstStdLogic a -> let a = self#string a  in CstStdLogic a
417
        | CstLiteral a -> let a = self#string a  in CstLiteral a
418

    
419
    method vhdl_type_t : vhdl_type_t -> vhdl_type_t=
420
      fun x  ->
421
        match x with
422
        | Base a -> let a = self#string a  in Base a
423
        | Range (a,b,c) ->
424
            let a = self#option self#string a  in
425
            let b = self#int b  in let c = self#int c  in Range (a, b, c)
426
        | Bit_vector (a,b) ->
427
            let a = self#int a  in let b = self#int b  in Bit_vector (a, b)
428
        | Array { indexes; const; definition } ->
429
            let indexes = self#list self#lower_vhdl_name_t indexes  in
430
            let const = self#option self#vhdl_constraint_t const  in
431
            let definition = self#vhdl_subtype_indication_t definition  in
432
            Array { indexes; const; definition }
433
        | Record a ->
434
            let a = self#list self#vhdl_element_declaration_t a  in Record a
435
        | Enumerated a ->
436
            let a = self#list self#lower_vhdl_name_t a  in Enumerated a
437
        | Void  -> Void
438

    
439
    method vhdl_element_declaration_t :
440
      vhdl_element_declaration_t -> vhdl_element_declaration_t=
441
      fun { ed_names; definition }  ->
442
        let ed_names = self#list self#lower_vhdl_name_t ed_names  in
443
        let definition = self#vhdl_subtype_indication_t definition  in
444
        { ed_names; definition }
445

    
446
    method vhdl_subtype_indication_t :
447
      vhdl_subtype_indication_t -> vhdl_subtype_indication_t=
448
      fun { si_name; functionName; const }  ->
449
        let si_name = self#lower_vhdl_name_t si_name  in
450
        let functionName = self#lower_vhdl_name_t functionName  in
451
        let const = self#vhdl_constraint_t const  in
452
        { si_name; functionName; const }
453

    
454
    method vhdl_discrete_range_t :
455
      vhdl_discrete_range_t -> vhdl_discrete_range_t=
456
      fun x  ->
457
        match x with
458
        | SubDiscreteRange a ->
459
            let a = self#vhdl_subtype_indication_t a  in SubDiscreteRange a
460
        | NamedRange a -> let a = self#lower_vhdl_name_t a  in NamedRange a
461
        | DirectedRange { direction; from; _to } ->
462
            let direction = self#string direction  in
463
            let from = self#vhdl_expr_t from  in
464
            let _to = self#vhdl_expr_t _to  in
465
            DirectedRange { direction; from; _to }
466

    
467
    method vhdl_constraint_t : vhdl_constraint_t -> vhdl_constraint_t=
468
      fun x  ->
469
        match x with
470
        | RefConstraint { ref_name } ->
471
            let ref_name = self#lower_vhdl_name_t ref_name  in
472
            RefConstraint { ref_name }
473
        | RangeConstraint { range } ->
474
            let range = self#vhdl_discrete_range_t range  in
475
            RangeConstraint { range }
476
        | IndexConstraint { ranges } ->
477
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
478
            IndexConstraint { ranges }
479
        | ArrayConstraint { ranges; sub } ->
480
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
481
            let sub = self#vhdl_constraint_t sub  in
482
            ArrayConstraint { ranges; sub }
483
        | RecordConstraint  -> RecordConstraint
484
        | NoConstraint  -> NoConstraint
485

    
486
    method vhdl_definition_t : vhdl_definition_t -> vhdl_definition_t=
487
      fun x  ->
488
        match x with
489
        | Type { name; definition } ->
490
            let name = self#lower_vhdl_name_t name  in
491
            let definition = self#vhdl_type_t definition  in
492
            Type { name; definition }
493
        | Subtype { name; typ } ->
494
            let name = self#lower_vhdl_name_t name  in
495
            let typ = self#vhdl_subtype_indication_t typ  in
496
            Subtype { name; typ }
497

    
498
    method vhdl_expr_t : vhdl_expr_t -> vhdl_expr_t=
499
      fun x  ->
500
        match x with
501
        | Call a -> let a = self#lower_vhdl_name_t a  in Call a
502
        | Cst { value; unit_name } ->
503
            let value = self#vhdl_cst_val_t value  in
504
            let unit_name = self#option self#lower_vhdl_name_t unit_name  in
505
            Cst { value; unit_name }
506
        | Op { id; args } ->
507
            let id = self#string id  in
508
            let args = self#list self#vhdl_expr_t args  in Op { id; args }
509
        | IsNull  -> IsNull
510
        | Time { value; phy_unit } ->
511
            let value = self#int value  in
512
            let phy_unit = self#string phy_unit  in Time { value; phy_unit }
513
        | Sig { name; att } ->
514
            let name = self#lower_vhdl_name_t name  in
515
            let att = self#option self#vhdl_signal_attributes_t att  in
516
            Sig { name; att }
517
        | SuffixMod { expr; selection } ->
518
            let expr = self#vhdl_expr_t expr  in
519
            let selection = self#vhdl_suffix_selection_t selection  in
520
            SuffixMod { expr; selection }
521
        | Aggregate { elems } ->
522
            let elems = self#list self#vhdl_element_assoc_t elems  in
523
            Aggregate { elems }
524
        | QualifiedExpression { type_mark; aggregate; expression } ->
525
            let type_mark = self#lower_vhdl_name_t type_mark  in
526
            let aggregate = self#list self#vhdl_element_assoc_t aggregate  in
527
            let expression = self#option self#vhdl_expr_t expression  in
528
            QualifiedExpression { type_mark; aggregate; expression }
529
        | Others  -> Others
530

    
531
    method vhdl_name_t : vhdl_name_t -> vhdl_name_t=
532
      fun x  ->
533
        match x with
534
        | Simple a -> let a = self#string a  in Simple a
535
        | Identifier a -> let a = self#string a  in Identifier a
536
        | Selected a -> let a = self#list self#lower_vhdl_name_t a  in Selected a
537
        | Index { id; exprs } ->
538
            let id = self#lower_vhdl_name_t id  in
539
            let exprs = self#list self#vhdl_expr_t exprs  in
540
            Index { id; exprs }
541
        | Slice { id; range } ->
542
            let id = self#lower_vhdl_name_t id  in
543
            let range = self#vhdl_discrete_range_t range  in
544
            Slice { id; range }
545
        | Attribute { id; designator; expr } ->
546
            let id = self#lower_vhdl_name_t id  in
547
            let designator = self#lower_vhdl_name_t designator  in
548
            let expr = self#vhdl_expr_t expr  in
549
            Attribute { id; designator; expr }
550
        | Function { id; assoc_list } ->
551
            let id = self#lower_vhdl_name_t id  in
552
            let assoc_list = self#list self#vhdl_assoc_element_t assoc_list in
553
            (* TODO: get function declaration and resolve assoc elements *)
554
 (*       let entity_ports_names = List.flatten (List.map port_t_names_proj entity.ports) in
555
        let port_map = self#vhdl_assoc_element_t_resolve port_map entity_ports_names in *)
556
            Function { id; assoc_list }
557
        | NoName  -> NoName
558
        | Open -> Open
559

    
560
    method vhdl_assoc_element_t :
561
      vhdl_assoc_element_t -> vhdl_assoc_element_t=
562
      fun
563
        { formal_name; formal_arg; actual_name; actual_designator;
564
          actual_expr }
565
         ->
566
        let formal_name = self#option self#vhdl_name_t formal_name  in
567
        let formal_arg = self#option self#vhdl_name_t formal_arg  in
568
        let actual_name = self#option self#vhdl_name_t actual_name  in
569
        let actual_designator = self#option self#vhdl_name_t actual_designator  in
570
        let actual_expr = self#option self#vhdl_expr_t actual_expr  in
571
        { formal_name; formal_arg; actual_name; actual_designator; actual_expr }
572

    
573
    method vhdl_element_assoc_t :
574
      vhdl_element_assoc_t -> vhdl_element_assoc_t=
575
      fun { choices; expr }  ->
576
        let choices = self#list self#vhdl_expr_t choices  in
577
        let expr = self#vhdl_expr_t expr  in { choices; expr }
578

    
579
    method vhdl_signal_attributes_t :
580
      vhdl_signal_attributes_t -> vhdl_signal_attributes_t=
581
      fun x  -> match x with | SigAtt a -> let a = self#string a  in SigAtt a
582

    
583
    method vhdl_suffix_selection_t : vhdl_suffix_selection_t -> vhdl_suffix_selection_t=
584
      fun x  ->
585
        match x with
586
        | Idx a -> let a = self#int a  in Idx a
587
        | SuffixRange (a,b) ->
588
            let a = self#int a  in let b = self#int b  in SuffixRange (a, b)
589

    
590
    method vhdl_parameter_t : vhdl_parameter_t -> vhdl_parameter_t=
591
      fun { parameter_names; parameter_mode; parameter_typ; init_val }  ->
592
        let parameter_names = self#list self#lower_vhdl_name_t parameter_names  in
593
        let parameter_mode = self#list self#string parameter_mode  in
594
        let parameter_typ = self#vhdl_subtype_indication_t parameter_typ  in
595
        let init_val = self#option self#vhdl_cst_val_t init_val  in
596
        { parameter_names; parameter_mode; parameter_typ; init_val }
597

    
598
    method vhdl_subprogram_spec_t :
599
      vhdl_subprogram_spec_t -> vhdl_subprogram_spec_t=
600
      fun { ss_name; subprogram_type; typeMark; parameters; isPure }  ->
601
        let ss_name = self#string ss_name  in
602
        let subprogram_type = self#string subprogram_type  in
603
        let typeMark = self#lower_vhdl_name_t typeMark  in
604
        let parameters = self#list self#vhdl_parameter_t parameters  in
605
        let isPure = self#bool isPure  in
606
        { ss_name; subprogram_type; typeMark; parameters; isPure }
607

    
608
    method vhdl_sequential_stmt_t :
609
      vhdl_sequential_stmt_t -> mini_vhdl_sequential_stmt_t=
610
      fun x  ->
611
        match x with
612
        | VarAssign { label; seqs_lhs; rhs } ->
613
            let label = self#option self#lower_vhdl_name_t label in
614
            let lhs = self#lower_vhdl_name_t seqs_lhs  in
615
            let rhs = self#vhdl_expr_t rhs  in 
616
            MiniVarAssign { label; lhs; rhs }
617
        | SigSeqAssign { label; seqs_lhs; rhs } ->
618
            let label = self#option self#lower_vhdl_name_t label in
619
            let lhs = self#lower_vhdl_name_t seqs_lhs  in
620
            let rhs = self#list self#vhdl_waveform_element_t rhs in
621
            MiniSigSeqAssign { label; lhs; rhs }
622
        | If { label; if_cases; default } ->
623
            let label = self#option self#lower_vhdl_name_t label in
624
            let if_cases = List.map self#vhdl_if_case_t if_cases  in
625
            let default = List.map self#vhdl_sequential_stmt_t default  in
626
            MiniIf { label; if_cases; default }
627
        | Case { label; guard; branches } ->
628
            let label = self#option self#lower_vhdl_name_t label in
629
            let guard = self#vhdl_expr_t guard  in
630
            let branches = List.map self#vhdl_case_item_t branches  in
631
            MiniCase { label; guard; branches }
632
        | Exit { label; loop_label; condition } ->
633
            let label = self#option self#lower_vhdl_name_t label in
634
            let loop_label = self#option self#string loop_label  in
635
            let condition = self#option self#vhdl_expr_t condition  in
636
            MiniExit { label; loop_label; condition }
637
        | Assert { label; cond; report; severity } ->
638
            let label = self#option self#lower_vhdl_name_t label in
639
            let cond = self#vhdl_expr_t cond  in
640
            let report = self#vhdl_expr_t report  in
641
            let severity = self#vhdl_expr_t severity  in
642
            MiniAssert { label; cond; report; severity }
643
        | ProcedureCall { label; name; assocs } ->
644
            let label = self#option self#lower_vhdl_name_t label in
645
            let name = self#lower_vhdl_name_t name  in
646
            let assocs = self#list self#vhdl_assoc_element_t assocs  in
647
            (* TODO: get procedure declaration and map assoc_elements *)
648
            MiniProcedureCall { label; name; assocs }
649
        | Wait { sensitivity } -> MiniWait { sensitivity }
650
        | Null { label } ->
651
            let label = self#option self#lower_vhdl_name_t label in
652
            MiniNull { label }
653
        | Return { label; expr } ->
654
            let label = self#option self#lower_vhdl_name_t label  in
655
            let expr = self#option self#vhdl_expr_t expr in
656
            MiniReturn { label; expr }
657

    
658
    method vhdl_if_case_t : vhdl_if_case_t -> mini_vhdl_if_case_t=
659
      fun { if_cond; if_block }  ->
660
        let if_cond = self#vhdl_expr_t if_cond  in
661
        let if_block_mini = List.map self#vhdl_sequential_stmt_t if_block  in
662
        { if_cond; if_block_mini }
663

    
664
    method vhdl_case_item_t : vhdl_case_item_t -> mini_vhdl_case_item_t=
665
      fun { when_cond; when_stmt }  ->
666
        let when_cond = self#list self#vhdl_expr_t when_cond  in
667
        let when_stmt_mini = List.map self#vhdl_sequential_stmt_t when_stmt  in
668
        { when_cond; when_stmt_mini }
669

    
670
    method vhdl_declaration_t : vhdl_declaration_t -> mini_vhdl_declaration_t=
671
      fun x  ->
672
        match x with
673
        | VarDecl { names; typ; init_val } ->
674
            let names = self#list self#lower_vhdl_name_t names  in
675
            let typ = self#vhdl_subtype_indication_t typ  in
676
            let init_val = self#vhdl_expr_t init_val  in
677
            MiniVarDecl { names; typ; init_val }
678
        | CstDecl { names; typ; init_val } ->
679
            let names = self#list self#lower_vhdl_name_t names  in
680
            let typ = self#vhdl_subtype_indication_t typ  in
681
            let init_val = self#vhdl_expr_t init_val  in
682
            MiniCstDecl { names; typ; init_val }
683
        | SigDecl { names; typ; init_val } ->
684
            let names = self#list self#lower_vhdl_name_t names  in
685
            let typ = self#vhdl_subtype_indication_t typ  in
686
            let init_val = self#vhdl_expr_t init_val  in
687
            MiniSigDecl { names; typ; init_val }
688
        | ComponentDecl { name; generics; ports } ->
689
            let name = self#lower_vhdl_name_t name  in
690
            let generics = self#list self#vhdl_port_t generics  in
691
            let ports = self#list self#vhdl_port_t ports  in
692
            MiniComponentDecl { name; generics; ports }
693
        | Subprogram { spec; decl_part; stmts } ->
694
            let spec = self#vhdl_subprogram_spec_t spec  in
695
            let decl_part = List.map self#vhdl_declaration_t decl_part  in
696
            let stmts = List.map self#vhdl_sequential_stmt_t stmts  in
697
            (* TODO: Explicit memories *)
698
            MiniSubprogram { spec; decl_part; stmts }
699

    
700
    method vhdl_declarative_item_t :
701
      vhdl_declarative_item_t -> mini_vhdl_declarative_item_t=
702
      fun { use_clause; di_declaration; di_definition }  ->
703
        let use_clause = self#option self#vhdl_load_t use_clause  in
704
        let declaration = 
705
          match di_declaration with
706
          | None -> None
707
          | Some a -> Some (self#vhdl_declaration_t a) in
708
        let definition = self#option self#vhdl_definition_t di_definition  in
709
        { use_clause; declaration; definition }
710

    
711
    method vhdl_waveform_element_t :
712
      vhdl_waveform_element_t -> vhdl_waveform_element_t=
713
      fun { value; we_delay }  ->
714
        let value = self#option self#vhdl_expr_t value  in
715
        let we_delay = self#option self#vhdl_expr_t we_delay  in { value; we_delay }
716

    
717
    method vhdl_signal_condition_t :
718
      vhdl_signal_condition_t -> vhdl_signal_condition_t=
719
      fun { sc_expr; cond }  ->
720
        let sc_expr = self#list self#vhdl_waveform_element_t sc_expr  in
721
        let cond = self#option self#vhdl_expr_t cond  in { sc_expr; cond }
722

    
723
    method vhdl_signal_selection_t :
724
      vhdl_signal_selection_t -> vhdl_signal_selection_t=
725
      fun { ss_expr; when_sel }  ->
726
        let ss_expr = self#list self#vhdl_waveform_element_t ss_expr  in
727
        let when_sel = self#list self#vhdl_expr_t when_sel  in
728
        { ss_expr; when_sel }
729

    
730
    method vhdl_conditional_signal_t :
731
      vhdl_conditional_signal_t -> vhdl_conditional_signal_t=
732
      fun { cs_postponed; cs_label; cs_lhs; rhs; cs_delay }  ->
733
        let cs_postponed = self#bool cs_postponed  in
734
        let cs_label = self#option self#lower_vhdl_name_t cs_label  in
735
        let cs_lhs = self#lower_vhdl_name_t cs_lhs  in
736
        let rhs = self#list self#vhdl_signal_condition_t rhs  in
737
        let cs_delay = self#vhdl_expr_t cs_delay  in
738
        { cs_postponed; cs_label; cs_lhs; rhs; cs_delay }
739

    
740
    method vhdl_process_t : vhdl_process_t -> mini_vhdl_process_t=
741
      fun { id; p_declarations; active_sigs; p_body }  ->
742
        let id = self#lower_vhdl_name_t id  in
743
        let p_declarations = List.map self#vhdl_declarative_item_t p_declarations  in
744
        let active_sigs = self#list self#lower_vhdl_name_t active_sigs  in
745
        let p_body = List.map self#vhdl_sequential_stmt_t p_body  in
746
        (* TODO: Explicit memories *)
747
        let postponed = false in
748
        let label = None in
749
        { id; p_declarations; active_sigs; p_body; postponed; label }
750

    
751
    method vhdl_selected_signal_t :
752
      vhdl_selected_signal_t -> vhdl_selected_signal_t=
753
      fun { ss_postponed; ss_label; ss_lhs; sel; branches; ss_delay }  ->
754
        let ss_postponed = self#bool ss_postponed  in
755
        let ss_label = self#option self#lower_vhdl_name_t ss_label  in
756
        let ss_lhs = self#lower_vhdl_name_t ss_lhs  in
757
        let sel = self#vhdl_expr_t sel  in
758
        let branches = self#list self#vhdl_signal_selection_t branches  in
759
        let ss_delay = self#option self#vhdl_expr_t ss_delay  in
760
        { ss_postponed; ss_label; ss_lhs; sel; branches; ss_delay }
761

    
762
    method vhdl_port_mode_t : vhdl_port_mode_t -> vhdl_port_mode_t=
763
      fun x  -> x
764

    
765
    method vhdl_component_instantiation_t :
766
      vhdl_component_instantiation_t -> mini_vhdl_component_instantiation_t=
767
        fun { ci_name; inst_unit; inst_unit_type; archi_name; generic_map; port_map }  ->
768
        let ci_name = self#lower_vhdl_name_t ci_name  in
769
        let archi_name = self#option self#lower_vhdl_name_t archi_name  in
770
        let inst_unit = self#lower_vhdl_name_t inst_unit in
771
        let db_tuple = match archi_name with
772
          | None -> failwith ("Component [" ^ self#to_string_vhdl_name_t ci_name ^ "] is not an entity")
773
          | Some a -> self#get_tuple_from_archi_and_entity_name (a, inst_unit) in (* Get corresponding tuple in db *)
774
        let archi = db_tuple.architecture in
775
        let entity = db_tuple.entity in
776
        let generic_map = self#list self#vhdl_assoc_element_t generic_map  in
777
        let port_map = self#list self#vhdl_assoc_element_t port_map  in
778
        let port_t_names_proj : vhdl_port_t -> vhdl_name_t list= fun x -> x.port_names in
779
        (* port_map resolution *)
780
        let entity_ports_names = List.flatten (List.map port_t_names_proj entity.ports) in
781
        let port_map = self#vhdl_assoc_element_t_resolve port_map entity_ports_names in
782
        (* generic_map resolution *)
783
        let entity_generics_names = List.flatten (List.map port_t_names_proj entity.generics) in
784
        let generic_map = self#vhdl_assoc_element_t_resolve generic_map entity_generics_names in
785
        { ci_name; archi; entity; generic_map; port_map }
786

    
787
    method vhdl_concurrent_stmt_t :
788
      vhdl_concurrent_stmt_t -> mini_vhdl_concurrent_stmt_t=
789
      fun x  ->
790
        match x with
791
        | SigAssign a -> 
792
            MiniProcess {
793
              id = self#postfix_flatten_vhdl_name_t a.cs_lhs "__implicit_process";
794
              p_declarations = [];
795
              active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x [];
796
              p_body = (MiniSigCondAssign {
797
                label = None;
798
                lhs = a.cs_lhs;
799
                rhs = a.rhs;
800
                delay = match a.cs_delay with | IsNull -> None | _ -> Some a.cs_delay
801
              })::[];
802
              postponed = a.cs_postponed;
803
              label = a.cs_label
804
            }
805
        | Process a -> let a = self#vhdl_process_t a  in 
806
            MiniProcess a
807
        | SelectedSig a -> 
808
            MiniProcess {
809
              id = self#postfix_flatten_vhdl_name_t a.ss_lhs "__implicit_process";
810
              p_declarations = [];
811
              active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x [];
812
              p_body = (MiniSigSelectAssign {
813
                label = None;
814
                lhs = a.ss_lhs;
815
                sel = a.sel;
816
                branches = a.branches;
817
                delay = a.ss_delay
818
              })::[];
819
              postponed = a.ss_postponed;
820
              label = a.ss_label
821
            }
822
        | ComponentInst a -> let a = self#vhdl_component_instantiation_t a  in 
823
            MiniComponentInst a
824

    
825
    method vhdl_port_t : vhdl_port_t -> vhdl_port_t=
826
      fun { port_names; port_mode; port_typ; port_expr }  ->
827
        let port_names = self#list self#lower_vhdl_name_t port_names  in
828
        let port_mode = self#vhdl_port_mode_t port_mode  in
829
        let port_typ = self#vhdl_subtype_indication_t port_typ  in
830
        let port_expr = self#vhdl_expr_t port_expr  in { port_names; port_mode; port_typ; port_expr }
831

    
832
    method vhdl_entity_t : vhdl_entity_t -> unit =
833
      fun { e_name; generics; ports; e_declaration; stmts }  -> ()
834

    
835
    method vhdl_package_t : (vhdl_load_t list * vhdl_package_t) -> mini_vhdl_package_t=
836
      fun ( ctxs, {p_name; shared_defs; shared_decls; shared_uses })  ->
837
        let p_name = self#lower_vhdl_name_t p_name  in
838
        let shared_defs = self#list self#vhdl_definition_t shared_defs  in
839
        let shared_decls = List.map self#vhdl_declaration_t shared_decls  in
840
        let shared_uses = self#list self#vhdl_load_t shared_uses @ ctxs in
841
        { p_name; shared_defs; shared_decls; shared_uses }
842

    
843
    method vhdl_load_t : vhdl_load_t -> vhdl_load_t=
844
      fun x  ->
845
        match x with
846
        | Library a -> let a = self#list self#lower_vhdl_name_t a  in Library a
847
        | Use a -> let a = self#list self#lower_vhdl_name_t a  in Use a
848

    
849
    method vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list *
850
                                  (vhdl_load_t list * vhdl_entity_t) list * 
851
                                  (vhdl_load_t list * vhdl_configuration_t) list *
852
                                  (vhdl_load_t list * vhdl_architecture_t)) -> mini_vhdl_component_t=
853
      fun ( packs_pairs, ents_pairs, confs_pairs, (arch_ctx, arch) ) ->
854
        let names = arch.a_name::(arch.entity::[])  in
855
        let (ref_ent_ctx,ref_ent) = self#filter_entity (ents_pairs, arch.entity) in
856
        (* Get contexts from referenced entity/archi pair *)
857
        let contexts = 
858
          ref_ent_ctx @ (* Referenced entity context elements *)
859
          arch_ctx @ (* Architecture context elements *)
860
          self#declarative_items_uses ref_ent.e_declaration @ (* Referenced entity inner context elements *)
861
          self#declarative_items_uses arch.a_declarations in (* Architecture inner context elements *)
862
        (* Get declarations from referenced entity/archi pair *)
863
        let declarations = 
864
          self#declarative_items_declarations ref_ent.e_declaration @ (* Referenced entity inner declarations *)
865
          self#declarative_items_declarations arch.a_declarations in (* Architecture inner declarations *)
866
        (* Get definitions from referenced entity/archi pair *)
867
        let definitions =
868
          self#declarative_items_definitions ref_ent.e_declaration @ (* Referenced entity inner definitions *)
869
          self#declarative_items_definitions arch.a_declarations in (* Architecture inner definitions *)
870
        (* Get concurrent statements from referenced entity/archi pair *)
871
        let c_body = 
872
          List.map self#vhdl_concurrent_stmt_t ref_ent.stmts @ (* Referenced entity concurrent statement *)
873
          List.map self#vhdl_concurrent_stmt_t arch.a_body in (* Architecture concurrent statements *)
874
        (* Get generics *)
875
        let generics = ref_ent.generics in (* Referenced entity generics *)
876
        (* Get ports *)
877
        let ports = ref_ent.ports in (* Referenced entity ports *)
878
        (* Translate declarations *)
879
        let c_declarations = List.map self#vhdl_declaration_t declarations in
880
        let (signals, subprograms) = 
881
          let rec find_decls c_declarations acc_s acc_p = 
882
            match c_declarations with
883
            | [] -> (acc_s, acc_p)
884
            | (MiniSigDecl (s))::tl -> find_decls tl ((MiniSigDecl (s))::acc_s) (acc_p)
885
            | (MiniSubprogram (s))::tl -> find_decls tl (acc_s) ((MiniSubprogram (s))::acc_p)
886
            | _::tl -> find_decls tl acc_s acc_p in find_decls c_declarations [] [] in
887
        let assigned_signals_names = List.flatten (List.map self#mini_vhdl_concurrent_stmt_t_assigned_signals_names c_body) in
888
        let functions = List.map (
889
          fun x -> match x with MiniSubprogram (s) -> (Simple s.spec.ss_name, s.spec.parameters, s.spec.typeMark) | _ -> failwith "Unreachable error (map on subprograms)"
890
        ) subprograms in
891
        let memories = List.flatten (List.map (self#mini_vhdl_concurrent_stmt_t_memories assigned_signals_names) c_body) in
892
        let new_tuple = { entity=ref_ent; 
893
                          architecture=arch; 
894
                          architecture_signals=signals;
895
                          architecture_ports=ports;
896
                          architecture_generics=generics;
897
                          assigned_signals_names=assigned_signals_names;
898
                          functions=functions;
899
                          memories=memories;
900
                          contexts=contexts } in
901
        self#db_add_tuple new_tuple;
902
        self#db_set_current new_tuple;
903
        { names; generics=generics; ports=ports; contexts=contexts; c_declarations=c_declarations; definitions=definitions; c_body=c_body }
904

    
905
    method vhdl_configuration_t :
906
      vhdl_configuration_t -> unit= self#unit
907

    
908
    method vhdl_design_file_t : vhdl_design_file_t -> mini_vhdl_design_file_t=
909
      fun { design_units }  ->
910
        let rec inline_df l packs ents archs confs = match l with
911
          | [] -> (List.rev packs, List.rev ents, List.rev archs, List.rev confs)
912
          | {contexts = c; library = lib}::tl -> match lib with
913
            | Package p -> inline_df tl ((c,p)::packs) ents archs confs
914
            | Entities e -> inline_df tl packs ((c,e)::ents) archs confs
915
            | Architecture a -> inline_df tl packs ents ((c,a)::archs) confs
916
            | Configuration conf -> inline_df tl packs ents archs ((c,conf)::confs) in
917
        let (p,e,a,con) = inline_df design_units [] [] [] [] in
918
        let app x = self#vhdl_architecture_t (p,e,con,x) in
919
        let components = List.map app a in
920
        let packages = List.map self#vhdl_package_t p in
921
        { components; packages }
922

    
923
(**
924
 * Second pass for:
925
 * functions/procedures call association list resolution
926
 * May not be necessary (functions can be provided as input of generic association list resolution
927
*)
928

    
929
    method sndpass_mini_vhdl_component_t : mini_vhdl_component_t -> mini_vhdl_component_t=
930
      fun { names; generics; ports; contexts; c_declarations; definitions; c_body } ->
931
        (* TODO: resolve association list for function/procedures calls *)
932
      { names; generics; ports; contexts; c_declarations; definitions; c_body }
933

    
934
    method sndpass_mini_vhdl_design_file_t : mini_vhdl_design_file_t -> mini_vhdl_design_file_t=
935
      fun { components; packages } ->
936
        let components = List.map self#sndpass_mini_vhdl_component_t components in
937
        { components; packages }
938

    
939
  end