Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / VHDL / vhdl_2_mini_vhdl_map.ml @ 08cbfc23

History | View | Annotate | Download (44.9 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_library_unit_t)  -> () 
61
let _ = fun (_ : vhdl_design_unit_t)  -> () 
62
let _ = fun (_ : vhdl_design_file_t)  -> () 
63

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

    
96
    method virtual  vhdl_declarative_item_t : vhdl_declarative_item_t -> mini_vhdl_declarative_item_t
97
    method virtual  vhdl_process_t : vhdl_process_t -> mini_vhdl_process_t
98
    method virtual  vhdl_concurrent_stmt_t : vhdl_concurrent_stmt_t -> mini_vhdl_concurrent_stmt_t
99
    method virtual  vhdl_sequential_stmt_t : vhdl_sequential_stmt_t -> mini_vhdl_sequential_stmt_t
100
    method virtual  vhdl_design_file_t : vhdl_design_file_t -> mini_vhdl_design_file_t
101

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

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

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

    
172
    method flatten_vhdl_name_t : vhdl_name_t -> vhdl_name_t=
173
      fun x  ->
174
        match x with
175
        | Simple a -> Simple (a)
176
        | Identifier a -> Simple (a)
177
        | 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)))]))
178
        | _ -> failwith ("Impossible to flatten name value [" ^ self#to_string_vhdl_name_t x ^ "]")
179

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

    
190
(*************************
191
 * End vhdl_name_t helpers
192
 *)
193

    
194
(*************************
195
 * Begin DB helpers
196
 *)
197
    val mutable db : db_tuple_t list = []
198
    val mutable db_current : db_tuple_t = {
199
      entity = { name = NoName; generics = []; ports = []; declaration = []; stmts = [] };
200
      architecture = { name = NoName; entity = NoName; declarations = []; body = [] };
201
      architecture_signals = [];
202
      architecture_ports = [];
203
      architecture_generics = [];
204
      assigned_signals_names = [];
205
      functions = [];
206
      memories = [];
207
      contexts = [];
208
    }
209

    
210
    method get_db : db_tuple_t list = db
211

    
212
    method db_get_current : db_tuple_t = db_current
213
    method db_set_current : db_tuple_t -> unit=
214
      fun x -> db_current <- x
215

    
216
    method db_add_tuple : db_tuple_t -> unit=
217
      fun x -> db <- x::db
218

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

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

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

    
256
(*******************
257
 * Begin declarative_item_t projections
258
 *)
259
    method declarative_items_declarations : vhdl_declarative_item_t list -> vhdl_declaration_t list =
260
      fun x ->
261
        match x with
262
        | {use_clause=_; declaration=Some a;definition=_}::tl -> a::(self#declarative_items_declarations tl)
263
        | _::tl -> self#declarative_items_declarations tl
264
        | [] -> []
265

    
266
    method declarative_items_definitions : vhdl_declarative_item_t list -> vhdl_definition_t list =
267
      fun x ->
268
        match x with
269
        | {use_clause=_; declaration=_;definition=Some a}::tl -> a::(self#declarative_items_definitions tl)
270
        | _::tl -> self#declarative_items_definitions tl
271
        | [] -> []
272

    
273
    method declarative_items_uses : vhdl_declarative_item_t list -> vhdl_load_t list =
274
      fun x ->
275
        match x with
276
        | {use_clause=Some a; declaration=_;definition=_}::tl -> a::(self#declarative_items_uses tl)
277
        | _::tl -> self#declarative_items_uses tl
278
        | [] -> []
279
(******************
280
 * End declarative_item_t projections
281
 *)
282

    
283
(*****************
284
 * Begin names_t extraction (assigned signals)
285
 *)
286
    method mini_vhdl_concurrent_stmt_t_assigned_signals_names : mini_vhdl_concurrent_stmt_t -> vhdl_name_t list=
287
      fun x ->
288
        match x with
289
        | Process a -> List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names a.body)
290
        | ComponentInst a -> []
291

    
292
    method mini_vhdl_sequential_stmt_t_assigned_signals_names :
293
      mini_vhdl_sequential_stmt_t -> vhdl_name_t list=
294
      fun x  ->
295
        match x with
296
        | VarAssign { label; lhs; rhs } -> []
297
        | SigSeqAssign { label; lhs; rhs } -> [lhs]
298
        | SigCondAssign { label; lhs; rhs; delay} -> [lhs]
299
        | SigSelectAssign { label; lhs; sel; branches; delay } -> [lhs]
300
        | If { label; if_cases; default } -> 
301
            let if_cases_stmts = List.flatten (List.map (fun x -> x.if_block) if_cases) in
302
            List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names (if_cases_stmts@default))
303
        | Case { label; guard; branches } ->
304
            let case_branches_stmts = List.flatten (List.map (fun x -> x.when_stmt) branches) in
305
            List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names case_branches_stmts)
306
        | ProcedureCall { label; name; assocs } -> [] (* TODO: resolve this *)
307
        | _ -> []
308

    
309
(****************
310
 *End names_t extraction
311
 *)
312

    
313
(*****************
314
 * Begin Implicit memories explicitation
315
 *)
316

    
317
    method mini_vhdl_concurrent_stmt_t_memories : vhdl_name_t list -> mini_vhdl_concurrent_stmt_t -> vhdl_name_t list=
318
      fun assigned_signals -> fun x ->
319
        match x with
320
        | Process a -> List.flatten (List.map (self#memories assigned_signals []) a.body)
321
        | ComponentInst a -> []
322

    
323
    method memories: vhdl_name_t list -> vhdl_name_t list -> mini_vhdl_sequential_stmt_t -> vhdl_name_t list=
324
      fun assigned_signals -> fun mems -> fun x ->
325
        match x with
326
        | If { label; if_cases; default } ->
327
            let if_cases_stmts = List.map (fun x -> x.if_block) if_cases in
328
            let if_cases_assigned_signals = 
329
              List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names (List.flatten (if_cases_stmts@[default])) in
330
            let if_cases_memories = List.flatten (List.map (fun x -> List.flatten (List.map (self#memories assigned_signals []) x)) (if_cases_stmts@[default])) in
331
            let mems = if_cases_memories@mems in
332

    
333
            (match default with
334
              | [] -> (List.flatten if_cases_assigned_signals)@mems
335
              | _ -> mems)
336
        | Case { label; guard; branches } ->
337
            let case_branches_stmts = List.map (fun x -> x.when_stmt) branches in
338
         (*   let case_assigned_signals = List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names (List.flatten (case_branches_stmts)) in *)
339
            let cases_memories = List.flatten (List.map (fun x -> List.flatten (List.map (self#memories assigned_signals []) x)) (case_branches_stmts)) in
340
            cases_memories@mems
341
        | _ -> mems
342

    
343
(****************
344
 *End memories explicitation
345
 *)
346

    
347
(****************
348
 * Begin Association element resolution
349
 *)
350

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

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

    
406
(****************
407
 * End Association element resolution
408
 *)
409

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

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

    
437
    method vhdl_element_declaration_t :
438
      vhdl_element_declaration_t -> vhdl_element_declaration_t=
439
      fun { names; definition }  ->
440
        let names = self#list self#lower_vhdl_name_t names  in
441
        let definition = self#vhdl_subtype_indication_t definition  in
442
        { names; definition }
443

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

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

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

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

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

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

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

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

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

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

    
588
    method vhdl_parameter_t : vhdl_parameter_t -> vhdl_parameter_t=
589
      fun { names; mode; typ; init_val }  ->
590
        let names = self#list self#lower_vhdl_name_t names  in
591
        let mode = self#list self#string mode  in
592
        let typ = self#vhdl_subtype_indication_t typ  in
593
        let init_val = self#option self#vhdl_cst_val_t init_val  in
594
        { names; mode; typ; init_val }
595

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

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

    
655
    method vhdl_if_case_t : vhdl_if_case_t -> mini_vhdl_if_case_t=
656
      fun { if_cond; if_block }  ->
657
        let if_cond = self#vhdl_expr_t if_cond  in
658
        let if_block = List.map self#vhdl_sequential_stmt_t if_block  in
659
        { if_cond; if_block }
660

    
661
    method vhdl_case_item_t : vhdl_case_item_t -> mini_vhdl_case_item_t=
662
      fun { when_cond; when_stmt }  ->
663
        let when_cond = self#list self#vhdl_expr_t when_cond  in
664
        let when_stmt = List.map self#vhdl_sequential_stmt_t when_stmt  in
665
        { when_cond; when_stmt }
666

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

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

    
708
    method vhdl_waveform_element_t :
709
      vhdl_waveform_element_t -> vhdl_waveform_element_t=
710
      fun { value; delay }  ->
711
        let value = self#option self#vhdl_expr_t value  in
712
        let delay = self#option self#vhdl_expr_t delay  in { value; delay }
713

    
714
    method vhdl_signal_condition_t :
715
      vhdl_signal_condition_t -> vhdl_signal_condition_t=
716
      fun { expr; cond }  ->
717
        let expr = self#list self#vhdl_waveform_element_t expr  in
718
        let cond = self#option self#vhdl_expr_t cond  in { expr; cond }
719

    
720
    method vhdl_signal_selection_t :
721
      vhdl_signal_selection_t -> vhdl_signal_selection_t=
722
      fun { expr; when_sel }  ->
723
        let expr = self#list self#vhdl_waveform_element_t expr  in
724
        let when_sel = self#list self#vhdl_expr_t when_sel  in
725
        { expr; when_sel }
726

    
727
    method vhdl_conditional_signal_t :
728
      vhdl_conditional_signal_t -> vhdl_conditional_signal_t=
729
      fun { postponed; label; lhs; rhs; delay }  ->
730
        let postponed = self#bool postponed  in
731
        let label = self#lower_vhdl_name_t label  in
732
        let lhs = self#lower_vhdl_name_t lhs  in
733
        let rhs = self#list self#vhdl_signal_condition_t rhs  in
734
        let delay = self#vhdl_expr_t delay  in
735
        { postponed; label; lhs; rhs; delay }
736

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

    
748
    method vhdl_selected_signal_t :
749
      vhdl_selected_signal_t -> vhdl_selected_signal_t=
750
      fun { postponed; label; lhs; sel; branches; delay }  ->
751
        let postponed = self#bool postponed  in
752
        let label = self#lower_vhdl_name_t label  in
753
        let lhs = self#lower_vhdl_name_t lhs  in
754
        let sel = self#vhdl_expr_t sel  in
755
        let branches = self#list self#vhdl_signal_selection_t branches  in
756
        let delay = self#option self#vhdl_expr_t delay  in
757
        { postponed; label; lhs; sel; branches; delay }
758

    
759
    method vhdl_port_mode_t : vhdl_port_mode_t -> vhdl_port_mode_t=
760
      fun x  -> x
761

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

    
784
    method vhdl_concurrent_stmt_t :
785
      vhdl_concurrent_stmt_t -> mini_vhdl_concurrent_stmt_t=
786
      fun x  ->
787
        match x with
788
        | SigAssign a -> 
789
            Process {
790
              id = self#postfix_flatten_vhdl_name_t a.lhs "__implicit_process";
791
              declarations = [];
792
              active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x [];
793
              body = (SigCondAssign {
794
                label = None;
795
                lhs = a.lhs;
796
                rhs = a.rhs;
797
                delay = match a.delay with | IsNull -> None | _ -> Some a.delay
798
              })::[];
799
              postponed = a.postponed;
800
              label = match a.label with | NoName -> None | _ -> Some a.label
801
            }
802
        | Process a -> let a = self#vhdl_process_t a  in Process a
803
        | SelectedSig a -> 
804
            Process {
805
              id = self#postfix_flatten_vhdl_name_t a.lhs "__implicit_process";
806
              declarations = [];
807
              active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x [];
808
              body = (SigSelectAssign {
809
                label = None;
810
                lhs = a.lhs;
811
                sel = a.sel;
812
                branches = a.branches;
813
                delay = a.delay
814
              })::[];
815
              postponed = a.postponed;
816
              label = match a.label with | NoName -> None | _ -> Some a.label
817
            }
818
        | ComponentInst a -> let a = self#vhdl_component_instantiation_t a  in ComponentInst a
819

    
820
    method vhdl_port_t : vhdl_port_t -> vhdl_port_t=
821
      fun { names; mode; typ; expr }  ->
822
        let names = self#list self#lower_vhdl_name_t names  in
823
        let mode = self#vhdl_port_mode_t mode  in
824
        let typ = self#vhdl_subtype_indication_t typ  in
825
        let expr = self#vhdl_expr_t expr  in { names; mode; typ; expr }
826

    
827
    method vhdl_entity_t : vhdl_entity_t -> unit =
828
      fun { name; generics; ports; declaration; stmts }  -> ()
829

    
830
    method vhdl_package_t : (vhdl_load_t list * vhdl_package_t) -> mini_vhdl_package_t=
831
      fun ( ctxs, {name; shared_defs; shared_decls; shared_uses })  ->
832
        let name = self#lower_vhdl_name_t name  in
833
        let shared_defs = self#list self#vhdl_definition_t shared_defs  in
834
        let shared_decls = List.map self#vhdl_declaration_t shared_decls  in
835
        let shared_uses = self#list self#vhdl_load_t shared_uses @ ctxs in
836
        { name; shared_defs; shared_decls; shared_uses }
837

    
838
    method vhdl_load_t : vhdl_load_t -> vhdl_load_t=
839
      fun x  ->
840
        match x with
841
        | Library a -> let a = self#list self#lower_vhdl_name_t a  in Library a
842
        | Use a -> let a = self#list self#lower_vhdl_name_t a  in Use a
843

    
844
    method vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list *
845
                                  (vhdl_load_t list * vhdl_entity_t) list * 
846
                                  (vhdl_load_t list * vhdl_configuration_t) list *
847
                                  (vhdl_load_t list * vhdl_architecture_t)) -> mini_vhdl_component_t=
848
      fun ( packs_pairs, ents_pairs, confs_pairs, (arch_ctx, arch) ) ->
849
        let names = arch.name::(arch.entity::[])  in
850
        let (ref_ent_ctx,ref_ent) = self#filter_entity (ents_pairs, arch.entity) in
851
        let contexts =
852
          ref_ent_ctx @ (* Referenced entity context elements *)
853
          arch_ctx @ (* Architecture context elements *)
854
          self#declarative_items_uses ref_ent.declaration @ (* Referenced entity inner context elements *)
855
          self#declarative_items_uses arch.declarations in (* Architecture inner context elements *)
856
        let declarations = 
857
          self#declarative_items_declarations ref_ent.declaration @ (* Referenced entity inner declarations *)
858
          self#declarative_items_declarations arch.declarations in (* Architecture inner declarations *)
859
        let definitions =
860
          self#declarative_items_definitions ref_ent.declaration @ (* Referenced entity inner definitions *)
861
          self#declarative_items_definitions arch.declarations in (* Architecture inner definitions *)
862
        let body = 
863
          List.map self#vhdl_concurrent_stmt_t ref_ent.stmts @ (* Referenced entity concurrent statement *)
864
          List.map self#vhdl_concurrent_stmt_t arch.body in (* Architecture concurrent statements *)
865
        let generics = ref_ent.generics in (* Referenced entity generics *)
866
        let ports = ref_ent.ports in (* Referenced entity ports *)
867
        let declarations = List.map self#vhdl_declaration_t declarations in
868
        let (signals, subprograms) = 
869
          let rec find_decls declarations acc_s acc_p = 
870
            match declarations with
871
            | [] -> (acc_s, acc_p)
872
            | (SigDecl (s))::tl -> find_decls tl ((SigDecl (s))::acc_s) (acc_p)
873
            | (Subprogram (s))::tl -> find_decls tl (acc_s) ((Subprogram (s))::acc_p)
874
            | _::tl -> find_decls tl acc_s acc_p in find_decls declarations [] [] in
875
        let assigned_signals_names = List.flatten (List.map self#mini_vhdl_concurrent_stmt_t_assigned_signals_names body) in
876
        let functions = List.map (
877
          fun x -> match x with Subprogram (s) -> (Simple s.spec.name, s.spec.parameters, s.spec.typeMark) | _ -> failwith "Unreachable error (map on subprograms)"
878
        ) subprograms in
879
        let memories = List.flatten (List.map (self#mini_vhdl_concurrent_stmt_t_memories assigned_signals_names) body) in
880
        let new_tuple = { entity=ref_ent; 
881
                          architecture=arch; 
882
                          architecture_signals=signals;
883
                          architecture_ports=ports;
884
                          architecture_generics=generics;
885
                          assigned_signals_names=assigned_signals_names;
886
                          functions=functions;
887
                          memories=memories;
888
                          contexts=contexts } in
889
        self#db_add_tuple new_tuple;
890
        self#db_set_current new_tuple;
891
        { names; generics=generics; ports=ports; contexts=contexts; declarations=declarations; definitions=definitions; body=body }
892

    
893
    method vhdl_configuration_t :
894
      vhdl_configuration_t -> unit= self#unit
895

    
896
    method vhdl_library_unit_t : vhdl_library_unit_t -> unit=
897
      fun x  -> ()
898

    
899
    method vhdl_design_unit_t : vhdl_design_unit_t -> unit=
900
      fun { contexts; library }  -> ()
901

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

    
917
(**
918
 * Second pass for:
919
   * functions/procedures call association list resolution
920
*)
921

    
922
    method sndpass_mini_vhdl_component_t : mini_vhdl_component_t -> mini_vhdl_component_t=
923
      fun { names; generics; ports; contexts; declarations; definitions; body } ->
924
        (* TODO: resolve association list for function/procedures calls *)
925
      { names; generics; ports; contexts; declarations; definitions; body }
926

    
927
    method sndpass_mini_vhdl_design_file_t : mini_vhdl_design_file_t -> mini_vhdl_design_file_t=
928
      fun { components; packages } ->
929
        let components = List.map self#sndpass_mini_vhdl_component_t components in
930
        { components; packages }
931

    
932
  end