Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / VHDL / vhdl_2_mini_vhdl_map.ml @ 010428a7

History | View | Annotate | Download (38.6 KB)

1
open Vhdl_ast
2
open Mini_vhdl_ast
3
open Vhdl_ast_fold_sensitivity
4

    
5
type db_tuple_t =
6
  {
7
    mutable entity: vhdl_entity_t;
8
    mutable architecture: vhdl_architecture_t;
9
    mutable architecture_signals: mini_vhdl_declaration_t list;
10
    mutable architecture_ports: vhdl_port_t list;
11
    mutable architecture_generics: vhdl_port_t list;
12
    mutable assigned_names: vhdl_name_t list;
13
    mutable contexts: vhdl_load_t list;
14
  }
15

    
16
let get_sensitivity_list = object (self)
17
  inherit ['acc] fold_sensitivity as super
18
end
19

    
20
let _ = fun (_ : vhdl_cst_val_t)  -> () 
21
let _ = fun (_ : vhdl_type_t)  -> () 
22
let _ = fun (_ : vhdl_element_declaration_t)  -> () 
23
let _ = fun (_ : vhdl_subtype_indication_t)  -> () 
24
let _ = fun (_ : vhdl_discrete_range_t)  -> () 
25
let _ = fun (_ : vhdl_constraint_t)  -> () 
26
let _ = fun (_ : vhdl_definition_t)  -> () 
27
let _ = fun (_ : vhdl_expr_t)  -> () 
28
let _ = fun (_ : vhdl_name_t)  -> () 
29
let _ = fun (_ : vhdl_assoc_element_t)  -> () 
30
let _ = fun (_ : vhdl_element_assoc_t)  -> () 
31
let _ = fun (_ : vhdl_array_attributes_t)  -> () 
32
let _ = fun (_ : vhdl_signal_attributes_t)  -> () 
33
let _ = fun (_ : vhdl_string_attributes_t)  -> () 
34
let _ = fun (_ : vhdl_suffix_selection_t)  -> () 
35
let _ = fun (_ : 'basetype vhdl_type_attributes_t)  -> () 
36
let _ = fun (_ : vhdl_parameter_t)  -> () 
37
let _ = fun (_ : vhdl_subprogram_spec_t)  -> () 
38
let _ = fun (_ : vhdl_sequential_stmt_t)  -> () 
39
let _ = fun (_ : vhdl_if_case_t)  -> () 
40
let _ = fun (_ : vhdl_case_item_t)  -> () 
41
let _ = fun (_ : vhdl_declaration_t)  -> () 
42
let _ = fun (_ : vhdl_signal_selection_t)  -> () 
43
let _ = fun (_ : vhdl_declarative_item_t)  -> () 
44
let _ = fun (_ : vhdl_waveform_element_t)  -> ()
45
let _ = fun (_ : vhdl_signal_condition_t)  -> () 
46
let _ = fun (_ : vhdl_conditional_signal_t)  -> () 
47
let _ = fun (_ : vhdl_process_t)  -> () 
48
let _ = fun (_ : vhdl_selected_signal_t)  -> () 
49
let _ = fun (_ : vhdl_port_mode_t)  -> () 
50
let _ = fun (_ : vhdl_component_instantiation_t)  -> ()
51
let _ = fun (_ : vhdl_concurrent_stmt_t)  -> () 
52
let _ = fun (_ : vhdl_port_t)  -> () 
53
let _ = fun (_ : vhdl_entity_t)  -> () 
54
let _ = fun (_ : vhdl_package_t)  -> () 
55
let _ = fun (_ : vhdl_load_t)  -> () 
56
let _ = fun (_ : vhdl_architecture_t)  -> () 
57
let _ = fun (_ : vhdl_configuration_t)  -> () 
58
let _ = fun (_ : vhdl_library_unit_t)  -> () 
59
let _ = fun (_ : vhdl_design_unit_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_library_unit_t : vhdl_library_unit_t -> unit
91
    method virtual  vhdl_load_t : vhdl_load_t -> vhdl_load_t
92
    method virtual  vhdl_design_unit_t : vhdl_design_unit_t -> unit
93

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

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

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

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

    
195
    method get_db : db_tuple_t list = db
196

    
197
    method db_add_tuple : db_tuple_t -> unit=
198
      fun x -> db <- x::db
199

    
200
    method db_get : vhdl_architecture_t -> (vhdl_entity_t * vhdl_load_t list)=
201
      fun x ->
202
        let rec find a dbl =
203
          match dbl with
204
          | [] -> failwith ("No matching tuple in DB for architecture [" ^ self#to_string_vhdl_name_t x.name ^ "]")
205
          | e::tl -> if (e.architecture = a) then (e.entity, e.contexts) else find a tl in find x db
206

    
207
    method get_tuple_from_archi_and_entity_name : (vhdl_name_t * vhdl_name_t) -> db_tuple_t=
208
      fun (a_name,e_name) ->
209
        let a_name = self#simplify_name_t a_name in
210
        let e_name = self#simplify_name_t e_name in
211
        let rec find (a_name,e_name) dbl =
212
          match dbl with
213
          | [] -> failwith ("No matching tuple in DB for architecture [" ^ self#to_string_vhdl_name_t a_name ^
214
                           "] and entity [" ^ self#to_string_vhdl_name_t e_name ^ "]")
215
          | e::tl -> 
216
              let inner_e_arch_name = self#simplify_name_t e.architecture.name in
217
              let inner_e_ent_name = self#simplify_name_t e.entity.name in
218
              if ((inner_e_arch_name = a_name) && (inner_e_ent_name = e_name)) 
219
              then e 
220
              else find (a_name,e_name) tl in 
221
        find (a_name,e_name) db
222

    
223
    method filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) -> 
224
                           (vhdl_load_t list * vhdl_entity_t) =
225
      fun ( entities_pair, filter_name ) ->
226
      let rec filter ep n = match ep with
227
      | [] -> failwith ("Impossible to find an entity with name [" ^ self#to_string_vhdl_name_t filter_name ^ "]")
228
      | (c,{name; generics; ports; declaration; stmts})::tl -> 
229
          if (name = n) then 
230
            List.hd ep
231
          else filter (List.tl ep) n in
232
      filter entities_pair filter_name
233
(*******************
234
 * End DB helpers
235
 *)
236

    
237
(*******************
238
 * Begin declarative_item_t projections
239
 *)
240
    method declarative_items_declarations : vhdl_declarative_item_t list -> vhdl_declaration_t list =
241
      fun x ->
242
        match x with
243
        | {use_clause=_; declaration=Some a;definition=_}::tl -> a::(self#declarative_items_declarations tl)
244
        | _::tl -> self#declarative_items_declarations tl
245
        | [] -> []
246

    
247
    method declarative_items_definitions : vhdl_declarative_item_t list -> vhdl_definition_t list =
248
      fun x ->
249
        match x with
250
        | {use_clause=_; declaration=_;definition=Some a}::tl -> a::(self#declarative_items_definitions tl)
251
        | _::tl -> self#declarative_items_definitions tl
252
        | [] -> []
253

    
254
    method declarative_items_uses : vhdl_declarative_item_t list -> vhdl_load_t list =
255
      fun x ->
256
        match x with
257
        | {use_clause=Some a; declaration=_;definition=_}::tl -> a::(self#declarative_items_uses tl)
258
        | _::tl -> self#declarative_items_uses tl
259
        | [] -> []
260
(******************
261
 * End declarative_item_t projections
262
 *)
263

    
264
(*****************
265
 * Begin names_t extraction
266
 *)
267
    method mini_vhdl_concurrent_stmt_t_assigned_signals_names : mini_vhdl_concurrent_stmt_t -> vhdl_name_t list=
268
      fun x ->
269
        match x with
270
        | Process a -> List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names a.body)
271
        | ComponentInst a -> []
272

    
273
    method mini_vhdl_sequential_stmt_t_assigned_signals_names :
274
      mini_vhdl_sequential_stmt_t -> vhdl_name_t list=
275
      fun x  ->
276
        match x with
277
        | VarAssign { label; lhs; rhs } -> [lhs]
278
        | SigSeqAssign { label; lhs; rhs } -> [lhs]
279
        | SigCondAssign { label; lhs; rhs; delay} -> [lhs]
280
        | SigSelectAssign { label; lhs; sel; branches; delay } -> [lhs]
281
        | If { label; if_cases; default } -> 
282
            let if_cases_stmts = List.flatten (List.map (fun x -> x.if_block) if_cases) in
283
            List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names (if_cases_stmts@default))
284
        | Case { label; guard; branches } ->
285
            let case_branches_stmts = List.flatten (List.map (fun x -> x.when_stmt) branches) in
286
            List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names case_branches_stmts)
287
        | ProcedureCall { label; name; assocs } -> [] (* TODO: resolve this *)
288
        | _ -> []
289
(****************
290
 *End names_t extraction
291
 *)
292

    
293
    method vhdl_cst_val_t : vhdl_cst_val_t -> vhdl_cst_val_t=
294
      fun x  ->
295
        match x with
296
        | CstInt a -> let a = self#int a  in CstInt a
297
        | CstStdLogic a -> let a = self#string a  in CstStdLogic a
298
        | CstLiteral a -> let a = self#string a  in CstLiteral a
299

    
300
    method vhdl_type_t : vhdl_type_t -> vhdl_type_t=
301
      fun x  ->
302
        match x with
303
        | Base a -> let a = self#string a  in Base a
304
        | Range (a,b,c) ->
305
            let a = self#option self#string a  in
306
            let b = self#int b  in let c = self#int c  in Range (a, b, c)
307
        | Bit_vector (a,b) ->
308
            let a = self#int a  in let b = self#int b  in Bit_vector (a, b)
309
        | Array { indexes; const; definition } ->
310
            let indexes = self#list self#lower_vhdl_name_t indexes  in
311
            let const = self#option self#vhdl_constraint_t const  in
312
            let definition = self#vhdl_subtype_indication_t definition  in
313
            Array { indexes; const; definition }
314
        | Record a ->
315
            let a = self#list self#vhdl_element_declaration_t a  in Record a
316
        | Enumerated a ->
317
            let a = self#list self#lower_vhdl_name_t a  in Enumerated a
318
        | Void  -> Void
319

    
320
    method vhdl_element_declaration_t :
321
      vhdl_element_declaration_t -> vhdl_element_declaration_t=
322
      fun { names; definition }  ->
323
        let names = self#list self#lower_vhdl_name_t names  in
324
        let definition = self#vhdl_subtype_indication_t definition  in
325
        { names; definition }
326

    
327
    method vhdl_subtype_indication_t :
328
      vhdl_subtype_indication_t -> vhdl_subtype_indication_t=
329
      fun { name; functionName; const }  ->
330
        let name = self#lower_vhdl_name_t name  in
331
        let functionName = self#lower_vhdl_name_t functionName  in
332
        let const = self#vhdl_constraint_t const  in
333
        { name; functionName; const }
334

    
335
    method vhdl_discrete_range_t :
336
      vhdl_discrete_range_t -> vhdl_discrete_range_t=
337
      fun x  ->
338
        match x with
339
        | SubDiscreteRange a ->
340
            let a = self#vhdl_subtype_indication_t a  in SubDiscreteRange a
341
        | NamedRange a -> let a = self#lower_vhdl_name_t a  in NamedRange a
342
        | DirectedRange { direction; from; _to } ->
343
            let direction = self#string direction  in
344
            let from = self#vhdl_expr_t from  in
345
            let _to = self#vhdl_expr_t _to  in
346
            DirectedRange { direction; from; _to }
347

    
348
    method vhdl_constraint_t : vhdl_constraint_t -> vhdl_constraint_t=
349
      fun x  ->
350
        match x with
351
        | RefConstraint { ref_name } ->
352
            let ref_name = self#lower_vhdl_name_t ref_name  in
353
            RefConstraint { ref_name }
354
        | RangeConstraint { range } ->
355
            let range = self#vhdl_discrete_range_t range  in
356
            RangeConstraint { range }
357
        | IndexConstraint { ranges } ->
358
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
359
            IndexConstraint { ranges }
360
        | ArrayConstraint { ranges; sub } ->
361
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
362
            let sub = self#vhdl_constraint_t sub  in
363
            ArrayConstraint { ranges; sub }
364
        | RecordConstraint  -> RecordConstraint
365
        | NoConstraint  -> NoConstraint
366

    
367
    method vhdl_definition_t : vhdl_definition_t -> vhdl_definition_t=
368
      fun x  ->
369
        match x with
370
        | Type { name; definition } ->
371
            let name = self#lower_vhdl_name_t name  in
372
            let definition = self#vhdl_type_t definition  in
373
            Type { name; definition }
374
        | Subtype { name; typ } ->
375
            let name = self#lower_vhdl_name_t name  in
376
            let typ = self#vhdl_subtype_indication_t typ  in
377
            Subtype { name; typ }
378

    
379
    method vhdl_expr_t : vhdl_expr_t -> vhdl_expr_t=
380
      fun x  ->
381
        match x with
382
        | Call a -> let a = self#lower_vhdl_name_t a  in Call a
383
        | Cst { value; unit_name } ->
384
            let value = self#vhdl_cst_val_t value  in
385
            let unit_name = self#option self#lower_vhdl_name_t unit_name  in
386
            Cst { value; unit_name }
387
        | Op { id; args } ->
388
            let id = self#string id  in
389
            let args = self#list self#vhdl_expr_t args  in Op { id; args }
390
        | IsNull  -> IsNull
391
        | Time { value; phy_unit } ->
392
            let value = self#int value  in
393
            let phy_unit = self#string phy_unit  in Time { value; phy_unit }
394
        | Sig { name; att } ->
395
            let name = self#lower_vhdl_name_t name  in
396
            let att = self#option self#vhdl_signal_attributes_t att  in
397
            Sig { name; att }
398
        | SuffixMod { expr; selection } ->
399
            let expr = self#vhdl_expr_t expr  in
400
            let selection = self#vhdl_suffix_selection_t selection  in
401
            SuffixMod { expr; selection }
402
        | Aggregate { elems } ->
403
            let elems = self#list self#vhdl_element_assoc_t elems  in
404
            Aggregate { elems }
405
        | QualifiedExpression { type_mark; aggregate; expression } ->
406
            let type_mark = self#lower_vhdl_name_t type_mark  in
407
            let aggregate = self#list self#vhdl_element_assoc_t aggregate  in
408
            let expression = self#option self#vhdl_expr_t expression  in
409
            QualifiedExpression { type_mark; aggregate; expression }
410
        | Others  -> Others
411

    
412
    method vhdl_name_t : vhdl_name_t -> vhdl_name_t=
413
      fun x  ->
414
        match x with
415
        | Simple a -> let a = self#string a  in Simple a
416
        | Identifier a -> let a = self#string a  in Identifier a
417
        | Selected a -> let a = self#list self#lower_vhdl_name_t a  in Selected a
418
        | Index { id; exprs } ->
419
            let id = self#lower_vhdl_name_t id  in
420
            let exprs = self#list self#vhdl_expr_t exprs  in
421
            Index { id; exprs }
422
        | Slice { id; range } ->
423
            let id = self#lower_vhdl_name_t id  in
424
            let range = self#vhdl_discrete_range_t range  in
425
            Slice { id; range }
426
        | Attribute { id; designator; expr } ->
427
            let id = self#lower_vhdl_name_t id  in
428
            let designator = self#lower_vhdl_name_t designator  in
429
            let expr = self#vhdl_expr_t expr  in
430
            Attribute { id; designator; expr }
431
        | Function { id; assoc_list } ->
432
            let id = self#lower_vhdl_name_t id  in
433
            let assoc_list = self#list self#vhdl_assoc_element_t assoc_list
434
               in
435
            Function { id; assoc_list }
436
        | NoName  -> NoName
437

    
438
    method vhdl_assoc_element_t :
439
      vhdl_assoc_element_t -> vhdl_assoc_element_t=
440
      fun
441
        { formal_name; formal_arg; actual_name; actual_designator;
442
          actual_expr }
443
         ->
444
        let formal_name = self#option self#lower_vhdl_name_t formal_name  in
445
        let formal_arg = self#option self#lower_vhdl_name_t formal_arg  in
446
        let actual_name = self#option self#lower_vhdl_name_t actual_name  in
447
        let actual_designator =
448
          self#option self#lower_vhdl_name_t actual_designator  in
449
        let actual_expr = self#option self#vhdl_expr_t actual_expr  in
450
        {
451
          formal_name;
452
          formal_arg;
453
          actual_name;
454
          actual_designator;
455
          actual_expr
456
        }
457

    
458
    method vhdl_element_assoc_t :
459
      vhdl_element_assoc_t -> vhdl_element_assoc_t=
460
      fun { choices; expr }  ->
461
        let choices = self#list self#vhdl_expr_t choices  in
462
        let expr = self#vhdl_expr_t expr  in { choices; expr }
463

    
464
    method vhdl_array_attributes_t :
465
      vhdl_array_attributes_t -> vhdl_array_attributes_t=
466
      fun x  ->
467
        match x with
468
        | AAttInt { id; arg } ->
469
            let id = self#string id  in
470
            let arg = self#int arg  in AAttInt { id; arg }
471
        | AAttAscending  -> AAttAscending
472

    
473
    method vhdl_signal_attributes_t :
474
      vhdl_signal_attributes_t -> vhdl_signal_attributes_t=
475
      fun x  -> match x with | SigAtt a -> let a = self#string a  in SigAtt a
476

    
477
    method vhdl_string_attributes_t :
478
      vhdl_string_attributes_t -> vhdl_string_attributes_t=
479
      fun x  ->
480
        match x with | StringAtt a -> let a = self#string a  in StringAtt a
481

    
482
    method vhdl_suffix_selection_t : vhdl_suffix_selection_t -> vhdl_suffix_selection_t=
483
      fun x  ->
484
        match x with
485
        | Idx a -> let a = self#int a  in Idx a
486
        | SuffixRange (a,b) ->
487
            let a = self#int a  in let b = self#int b  in SuffixRange (a, b)
488

    
489
    method vhdl_type_attributes_t :
490
      'a .
491
        ('a -> 'a) -> 'a vhdl_type_attributes_t -> 'a vhdl_type_attributes_t=
492
      fun _basetype  ->
493
        fun x  ->
494
          match x with
495
          | TAttNoArg { id } -> let id = self#string id  in TAttNoArg { id }
496
          | TAttIntArg { id; arg } ->
497
              let id = self#string id  in
498
              let arg = self#int arg  in TAttIntArg { id; arg }
499
          | TAttValArg { id; arg } ->
500
              let id = self#string id  in
501
              let arg = _basetype arg  in TAttValArg { id; arg }
502
          | TAttStringArg { id; arg } ->
503
              let id = self#string id  in
504
              let arg = self#string arg  in TAttStringArg { id; arg }
505

    
506
    method vhdl_parameter_t : vhdl_parameter_t -> vhdl_parameter_t=
507
      fun { names; mode; typ; init_val }  ->
508
        let names = self#list self#lower_vhdl_name_t names  in
509
        let mode = self#list self#string mode  in
510
        let typ = self#vhdl_subtype_indication_t typ  in
511
        let init_val = self#option self#vhdl_cst_val_t init_val  in
512
        { names; mode; typ; init_val }
513

    
514
    method vhdl_subprogram_spec_t :
515
      vhdl_subprogram_spec_t -> vhdl_subprogram_spec_t=
516
      fun { name; subprogram_type; typeMark; parameters; isPure }  ->
517
        let name = self#string name  in
518
        let subprogram_type = self#string subprogram_type  in
519
        let typeMark = self#lower_vhdl_name_t typeMark  in
520
        let parameters = self#list self#vhdl_parameter_t parameters  in
521
        let isPure = self#bool isPure  in
522
        { name; subprogram_type; typeMark; parameters; isPure }
523

    
524
    method vhdl_sequential_stmt_t :
525
      vhdl_sequential_stmt_t -> mini_vhdl_sequential_stmt_t=
526
      fun x  ->
527
        match x with
528
        | VarAssign { label; lhs; rhs } ->
529
            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in
530
            let lhs = self#lower_vhdl_name_t lhs  in
531
            let rhs = self#vhdl_expr_t rhs  in VarAssign { label; lhs; rhs }
532
        | SigSeqAssign { label; lhs; rhs } ->
533
            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in
534
            let lhs = self#lower_vhdl_name_t lhs  in
535
            let rhs = self#list self#vhdl_waveform_element_t rhs in
536
            SigSeqAssign { label; lhs; rhs }
537
        | If { label; if_cases; default } ->
538
            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in
539
            let if_cases = List.map self#vhdl_if_case_t if_cases  in
540
            let default = List.map self#vhdl_sequential_stmt_t default  in
541
            If { label; if_cases; default }
542
        | Case { label; guard; branches } ->
543
            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in
544
            let guard = self#vhdl_expr_t guard  in
545
            let branches = List.map self#vhdl_case_item_t branches  in
546
            Case { label; guard; branches }
547
        | Exit { label; loop_label; condition } ->
548
            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in
549
            let loop_label = self#option self#string loop_label  in
550
            let condition = self#option self#vhdl_expr_t condition  in
551
            Exit { label; loop_label; condition }
552
        | Assert { label; cond; report; severity } ->
553
            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in
554
            let cond = self#vhdl_expr_t cond  in
555
            let report = self#vhdl_expr_t report  in
556
            let severity = self#vhdl_expr_t severity  in
557
            Assert { label; cond; report; severity }
558
        | ProcedureCall { label; name; assocs } ->
559
            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in
560
            let name = self#lower_vhdl_name_t name  in
561
            let assocs = self#list self#vhdl_assoc_element_t assocs  in
562
            ProcedureCall { label; name; assocs }
563
        | Wait  -> Wait
564
        | Null { label } ->
565
            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in
566
            Null { label }
567
        | Return { label; expr } ->
568
            let label = self#option self#lower_vhdl_name_t label  in
569
            let expr = self#option self#vhdl_expr_t expr in
570
            Return { label; expr }
571

    
572
    method vhdl_if_case_t : vhdl_if_case_t -> mini_vhdl_if_case_t=
573
      fun { if_cond; if_block }  ->
574
        let if_cond = self#vhdl_expr_t if_cond  in
575
        let if_block = List.map self#vhdl_sequential_stmt_t if_block  in
576
        { if_cond; if_block }
577

    
578
    method vhdl_case_item_t : vhdl_case_item_t -> mini_vhdl_case_item_t=
579
      fun { when_cond; when_stmt }  ->
580
        let when_cond = self#list self#vhdl_expr_t when_cond  in
581
        let when_stmt = List.map self#vhdl_sequential_stmt_t when_stmt  in
582
        { when_cond; when_stmt }
583

    
584
    method vhdl_declaration_t : vhdl_declaration_t -> mini_vhdl_declaration_t=
585
      fun x  ->
586
        match x with
587
        | VarDecl { names; typ; init_val } ->
588
            let names = self#list self#lower_vhdl_name_t names  in
589
            let typ = self#vhdl_subtype_indication_t typ  in
590
            let init_val = self#vhdl_expr_t init_val  in
591
            VarDecl { names; typ; init_val }
592
        | CstDecl { names; typ; init_val } ->
593
            let names = self#list self#lower_vhdl_name_t names  in
594
            let typ = self#vhdl_subtype_indication_t typ  in
595
            let init_val = self#vhdl_expr_t init_val  in
596
            CstDecl { names; typ; init_val }
597
        | SigDecl { names; typ; init_val } ->
598
            let names = self#list self#lower_vhdl_name_t names  in
599
            let typ = self#vhdl_subtype_indication_t typ  in
600
            let init_val = self#vhdl_expr_t init_val  in
601
            SigDecl { names; typ; init_val }
602
        | ComponentDecl { name; generics; ports } ->
603
            let name = self#lower_vhdl_name_t name  in
604
            let generics = self#list self#vhdl_port_t generics  in
605
            let ports = self#list self#vhdl_port_t ports  in
606
            ComponentDecl { name; generics; ports }
607
        | Subprogram { spec; decl_part; stmts } ->
608
            let spec = self#vhdl_subprogram_spec_t spec  in
609
            let decl_part = List.map self#vhdl_declaration_t decl_part  in
610
            let stmts = List.map self#vhdl_sequential_stmt_t stmts  in
611
            Subprogram { spec; decl_part; stmts }
612

    
613
    method vhdl_declarative_item_t :
614
      vhdl_declarative_item_t -> mini_vhdl_declarative_item_t=
615
      fun { use_clause; declaration; definition }  ->
616
        let use_clause = self#option self#vhdl_load_t use_clause  in
617
        let declaration = 
618
          match declaration with
619
          | None -> None
620
          | Some a -> Some (self#vhdl_declaration_t a) in
621
        let definition = self#option self#vhdl_definition_t definition  in
622
        { use_clause; declaration; definition }
623

    
624
    method vhdl_waveform_element_t :
625
      vhdl_waveform_element_t -> vhdl_waveform_element_t=
626
      fun { value; delay }  ->
627
        let value = self#option self#vhdl_expr_t value  in
628
        let delay = self#option self#vhdl_expr_t delay  in { value; delay }
629

    
630
    method vhdl_signal_condition_t :
631
      vhdl_signal_condition_t -> vhdl_signal_condition_t=
632
      fun { expr; cond }  ->
633
        let expr = self#list self#vhdl_waveform_element_t expr  in
634
        let cond = self#option self#vhdl_expr_t cond  in { expr; cond }
635

    
636
    method vhdl_signal_selection_t :
637
      vhdl_signal_selection_t -> vhdl_signal_selection_t=
638
      fun { expr; when_sel }  ->
639
        let expr = self#list self#vhdl_waveform_element_t expr  in
640
        let when_sel = self#list self#vhdl_expr_t when_sel  in
641
        { expr; when_sel }
642

    
643
    method vhdl_conditional_signal_t :
644
      vhdl_conditional_signal_t -> vhdl_conditional_signal_t=
645
      fun { postponed; label; lhs; rhs; delay }  ->
646
        let postponed = self#bool postponed  in
647
        let label = self#lower_vhdl_name_t label  in
648
        let lhs = self#lower_vhdl_name_t lhs  in
649
        let rhs = self#list self#vhdl_signal_condition_t rhs  in
650
        let delay = self#vhdl_expr_t delay  in
651
        { postponed; label; lhs; rhs; delay }
652

    
653
    method vhdl_process_t : vhdl_process_t -> mini_vhdl_process_t=
654
      fun { id; declarations; active_sigs; body }  ->
655
        let id = self#lower_vhdl_name_t id  in
656
        let declarations = List.map self#vhdl_declarative_item_t declarations  in
657
        let active_sigs = self#list self#lower_vhdl_name_t active_sigs  in
658
        let body = List.map self#vhdl_sequential_stmt_t body  in
659
        let postponed = false in
660
        let label = None in
661
        { id; declarations; active_sigs; body; postponed; label }
662

    
663
    method vhdl_selected_signal_t :
664
      vhdl_selected_signal_t -> vhdl_selected_signal_t=
665
      fun { postponed; label; lhs; sel; branches; delay }  ->
666
        let postponed = self#bool postponed  in
667
        let label = self#lower_vhdl_name_t label  in
668
        let lhs = self#lower_vhdl_name_t lhs  in
669
        let sel = self#vhdl_expr_t sel  in
670
        let branches = self#list self#vhdl_signal_selection_t branches  in
671
        let delay = self#option self#vhdl_expr_t delay  in
672
        { postponed; label; lhs; sel; branches; delay }
673

    
674
    method vhdl_port_mode_t : vhdl_port_mode_t -> vhdl_port_mode_t=
675
      fun x  -> x
676

    
677
    method vhdl_component_instantiation_t :
678
      vhdl_component_instantiation_t -> mini_vhdl_component_instantiation_t=
679
        fun { name; inst_unit; inst_unit_type; archi_name; generic_map; port_map }  ->
680
        let name = self#lower_vhdl_name_t name  in
681
        let archi_name = self#option self#lower_vhdl_name_t archi_name  in
682
        let inst_unit = self#lower_vhdl_name_t inst_unit in
683
        let db_tuple = match archi_name with
684
          | None -> failwith ("Component [" ^ self#to_string_vhdl_name_t name ^ "] is not an entity")
685
          | Some a -> self#get_tuple_from_archi_and_entity_name (a, inst_unit) in (* Get corresponding tuple in db *)
686
        let archi = db_tuple.architecture in
687
        let entity = db_tuple.entity in
688
        let generic_map = self#list self#vhdl_assoc_element_t generic_map  in
689
        let port_map = self#list self#vhdl_assoc_element_t port_map  in
690
        { name; archi; entity; generic_map; port_map }
691

    
692
    method vhdl_concurrent_stmt_t :
693
      vhdl_concurrent_stmt_t -> mini_vhdl_concurrent_stmt_t=
694
      fun x  ->
695
        match x with
696
        | SigAssign a -> 
697
            Process {
698
              id = self#postfix_flatten_vhdl_name_t a.lhs "__implicit_process";
699
              declarations = [];
700
              active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x [];
701
              body = (SigCondAssign {
702
                label = None;
703
                lhs = a.lhs;
704
                rhs = a.rhs;
705
                delay = match a.delay with | IsNull -> None | _ -> Some a.delay
706
              })::[];
707
              postponed = a.postponed;
708
              label = match a.label with | NoName -> None | _ -> Some a.label
709
            }
710
        | Process a -> let a = self#vhdl_process_t a  in Process a
711
        | SelectedSig a -> 
712
            Process {
713
              id = self#postfix_flatten_vhdl_name_t a.lhs "__implicit_process";
714
              declarations = [];
715
              active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x [];
716
              body = (SigSelectAssign {
717
                label = None;
718
                lhs = a.lhs;
719
                sel = a.sel;
720
                branches = a.branches;
721
                delay = a.delay
722
              })::[];
723
              postponed = a.postponed;
724
              label = match a.label with | NoName -> None | _ -> Some a.label
725
            }
726
        | ComponentInst a -> let a = self#vhdl_component_instantiation_t a  in ComponentInst a
727

    
728
    method vhdl_port_t : vhdl_port_t -> vhdl_port_t=
729
      fun { names; mode; typ; expr }  ->
730
        let names = self#list self#lower_vhdl_name_t names  in
731
        let mode = self#vhdl_port_mode_t mode  in
732
        let typ = self#vhdl_subtype_indication_t typ  in
733
        let expr = self#vhdl_expr_t expr  in { names; mode; typ; expr }
734

    
735
    method vhdl_entity_t : vhdl_entity_t -> unit =
736
      fun { name; generics; ports; declaration; stmts }  -> ()
737

    
738
    method vhdl_package_t : (vhdl_load_t list * vhdl_package_t) -> mini_vhdl_package_t=
739
      fun ( ctxs, {name; shared_defs; shared_decls; shared_uses })  ->
740
        let name = self#lower_vhdl_name_t name  in
741
        let shared_defs = self#list self#vhdl_definition_t shared_defs  in
742
        let shared_decls = List.map self#vhdl_declaration_t shared_decls  in
743
        let shared_uses = self#list self#vhdl_load_t shared_uses @ ctxs in
744
        { name; shared_defs; shared_decls; shared_uses }
745

    
746
    method vhdl_load_t : vhdl_load_t -> vhdl_load_t=
747
      fun x  ->
748
        match x with
749
        | Library a -> let a = self#list self#lower_vhdl_name_t a  in Library a
750
        | Use a -> let a = self#list self#lower_vhdl_name_t a  in Use a
751

    
752
    method vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list *
753
                                  (vhdl_load_t list * vhdl_entity_t) list * 
754
                                  (vhdl_load_t list * vhdl_configuration_t) list *
755
                                  (vhdl_load_t list * vhdl_architecture_t)) -> mini_vhdl_component_t=
756
      fun ( packs_pairs, ents_pairs, confs_pairs, (arch_ctx, arch) ) ->
757
        let names = arch.name::(arch.entity::[])  in
758
        let (ref_ent_ctx,ref_ent) = self#filter_entity (ents_pairs, arch.entity) in
759
        let contexts =
760
          ref_ent_ctx @ (* Referenced entity context elements *)
761
          arch_ctx @ (* Architecture context elements *)
762
          self#declarative_items_uses ref_ent.declaration @ (* Referenced entity inner context elements *)
763
          self#declarative_items_uses arch.declarations in (* Architecture inner context elements *)
764
        let declarations = 
765
          self#declarative_items_declarations ref_ent.declaration @ (* Referenced entity inner declarations *)
766
          self#declarative_items_declarations arch.declarations in (* Architecture inner declarations *)
767
        let definitions =
768
          self#declarative_items_definitions ref_ent.declaration @ (* Referenced entity inner definitions *)
769
          self#declarative_items_definitions arch.declarations in (* Architecture inner definitions *)
770
        let body = 
771
          List.map self#vhdl_concurrent_stmt_t ref_ent.stmts @ (* Referenced entity concurrent statement *)
772
          List.map self#vhdl_concurrent_stmt_t arch.body in (* Architecture concurrent statements *)
773
        let generics = ref_ent.generics in (* Referenced entity generics *)
774
        let ports = ref_ent.ports in (* Referenced entity ports *)
775
        let declarations = List.map self#vhdl_declaration_t declarations in
776
        let signals = 
777
          let rec find_sig_decls declarations = 
778
            match declarations with
779
            | [] -> []
780
            | (SigDecl (s))::tl -> (SigDecl (s))::find_sig_decls tl
781
            | _::tl -> find_sig_decls tl in find_sig_decls declarations in
782
        let assigned_names = List.flatten (List.map self#mini_vhdl_concurrent_stmt_t_assigned_signals_names body) in
783
        (* TODO: Flatten component instantiation from here *)
784
        self#db_add_tuple { entity=ref_ent; 
785
                            architecture=arch; 
786
                            architecture_signals=signals;
787
                            architecture_ports=ports;
788
                            architecture_generics=generics;
789
                            assigned_names=assigned_names;
790
                            contexts=contexts;
791
                          };
792
        { names; 
793
          generics=generics; 
794
          ports=ports; 
795
          contexts=contexts; 
796
          declarations=declarations; 
797
          definitions=definitions; 
798
          body=body
799
        }
800

    
801
    method vhdl_configuration_t :
802
      vhdl_configuration_t -> unit= self#unit
803

    
804
    method vhdl_library_unit_t : vhdl_library_unit_t -> unit=
805
      fun x  -> ()
806

    
807
    method vhdl_design_unit_t : vhdl_design_unit_t -> unit=
808
      fun { contexts; library }  -> ()
809

    
810
    method vhdl_design_file_t : vhdl_design_file_t -> mini_vhdl_design_file_t=
811
      fun { design_units }  ->
812
        let rec inline_df l packs ents archs confs = match l with
813
          | [] -> (List.rev packs, List.rev ents, List.rev archs, List.rev confs)
814
          | {contexts = c; library = lib}::tl -> match lib with
815
            | Package p -> inline_df tl ((c,p)::packs) ents archs confs
816
            | Entities e -> inline_df tl packs ((c,e)::ents) archs confs
817
            | Architecture a -> inline_df tl packs ents ((c,a)::archs) confs
818
            | Configuration conf -> inline_df tl packs ents archs ((c,conf)::confs) in
819
        let (p,e,a,con) = inline_df design_units [] [] [] [] in
820
        let app x = self#vhdl_architecture_t (p,e,con,x) in
821
        let components = List.map app a in
822
        let packages = List.map self#vhdl_package_t p in
823
        { components; packages }
824

    
825
  end