Project

General

Profile

Download (36.8 KB) Statistics
| Branch: | Tag: | Revision:
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 contexts: vhdl_load_t list;
11
  }
12

    
13
let get_sensitivity_list = object (self)
14
  inherit ['acc] fold_sensitivity as super
15
end
16

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

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

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

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

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

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

    
165
    method flatten_vhdl_name_t : vhdl_name_t -> vhdl_name_t=
166
      fun x  ->
167
        match x with
168
        | Simple a -> Simple (a)
169
        | Identifier a -> Simple (a)
170
        | 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)))]))
171
        | _ -> failwith ("Impossible to flatten name value [" ^ self#to_string_vhdl_name_t x ^ "]")
172

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

    
183
(*************************
184
 * End vhdl_name_t helpers
185
 *)
186

    
187
(*************************
188
 * Begin DB helpers
189
 *)
190
    val mutable db : db_tuple_t list = []
191

    
192
    method db_add_tuple : db_tuple_t -> unit=
193
      fun x -> db <- x::db
194

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

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

    
221
    method vhdl_cst_val_t : vhdl_cst_val_t -> vhdl_cst_val_t=
222
      fun x  ->
223
        match x with
224
        | CstInt a -> let a = self#int a  in CstInt a
225
        | CstStdLogic a -> let a = self#string a  in CstStdLogic a
226
        | CstLiteral a -> let a = self#string a  in CstLiteral a
227

    
228
    method vhdl_type_t : vhdl_type_t -> vhdl_type_t=
229
      fun x  ->
230
        match x with
231
        | Base a -> let a = self#string a  in Base a
232
        | Range (a,b,c) ->
233
            let a = self#option self#string a  in
234
            let b = self#int b  in let c = self#int c  in Range (a, b, c)
235
        | Bit_vector (a,b) ->
236
            let a = self#int a  in let b = self#int b  in Bit_vector (a, b)
237
        | Array { indexes; const; definition } ->
238
            let indexes = self#list self#lower_vhdl_name_t indexes  in
239
            let const = self#option self#vhdl_constraint_t const  in
240
            let definition = self#vhdl_subtype_indication_t definition  in
241
            Array { indexes; const; definition }
242
        | Record a ->
243
            let a = self#list self#vhdl_element_declaration_t a  in Record a
244
        | Enumerated a ->
245
            let a = self#list self#lower_vhdl_name_t a  in Enumerated a
246
        | Void  -> Void
247

    
248
    method vhdl_element_declaration_t :
249
      vhdl_element_declaration_t -> vhdl_element_declaration_t=
250
      fun { names; definition }  ->
251
        let names = self#list self#lower_vhdl_name_t names  in
252
        let definition = self#vhdl_subtype_indication_t definition  in
253
        { names; definition }
254

    
255
    method vhdl_subtype_indication_t :
256
      vhdl_subtype_indication_t -> vhdl_subtype_indication_t=
257
      fun { name; functionName; const }  ->
258
        let name = self#lower_vhdl_name_t name  in
259
        let functionName = self#lower_vhdl_name_t functionName  in
260
        let const = self#vhdl_constraint_t const  in
261
        { name; functionName; const }
262

    
263
    method vhdl_discrete_range_t :
264
      vhdl_discrete_range_t -> vhdl_discrete_range_t=
265
      fun x  ->
266
        match x with
267
        | SubDiscreteRange a ->
268
            let a = self#vhdl_subtype_indication_t a  in SubDiscreteRange a
269
        | NamedRange a -> let a = self#lower_vhdl_name_t a  in NamedRange a
270
        | DirectedRange { direction; from; _to } ->
271
            let direction = self#string direction  in
272
            let from = self#vhdl_expr_t from  in
273
            let _to = self#vhdl_expr_t _to  in
274
            DirectedRange { direction; from; _to }
275

    
276
    method vhdl_constraint_t : vhdl_constraint_t -> vhdl_constraint_t=
277
      fun x  ->
278
        match x with
279
        | RefConstraint { ref_name } ->
280
            let ref_name = self#lower_vhdl_name_t ref_name  in
281
            RefConstraint { ref_name }
282
        | RangeConstraint { range } ->
283
            let range = self#vhdl_discrete_range_t range  in
284
            RangeConstraint { range }
285
        | IndexConstraint { ranges } ->
286
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
287
            IndexConstraint { ranges }
288
        | ArrayConstraint { ranges; sub } ->
289
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
290
            let sub = self#vhdl_constraint_t sub  in
291
            ArrayConstraint { ranges; sub }
292
        | RecordConstraint  -> RecordConstraint
293
        | NoConstraint  -> NoConstraint
294

    
295
    method vhdl_definition_t : vhdl_definition_t -> vhdl_definition_t=
296
      fun x  ->
297
        match x with
298
        | Type { name; definition } ->
299
            let name = self#lower_vhdl_name_t name  in
300
            let definition = self#vhdl_type_t definition  in
301
            Type { name; definition }
302
        | Subtype { name; typ } ->
303
            let name = self#lower_vhdl_name_t name  in
304
            let typ = self#vhdl_subtype_indication_t typ  in
305
            Subtype { name; typ }
306

    
307
    method vhdl_expr_t : vhdl_expr_t -> vhdl_expr_t=
308
      fun x  ->
309
        match x with
310
        | Call a -> let a = self#lower_vhdl_name_t a  in Call a
311
        | Cst { value; unit_name } ->
312
            let value = self#vhdl_cst_val_t value  in
313
            let unit_name = self#option self#lower_vhdl_name_t unit_name  in
314
            Cst { value; unit_name }
315
        | Op { id; args } ->
316
            let id = self#string id  in
317
            let args = self#list self#vhdl_expr_t args  in Op { id; args }
318
        | IsNull  -> IsNull
319
        | Time { value; phy_unit } ->
320
            let value = self#int value  in
321
            let phy_unit = self#string phy_unit  in Time { value; phy_unit }
322
        | Sig { name; att } ->
323
            let name = self#lower_vhdl_name_t name  in
324
            let att = self#option self#vhdl_signal_attributes_t att  in
325
            Sig { name; att }
326
        | SuffixMod { expr; selection } ->
327
            let expr = self#vhdl_expr_t expr  in
328
            let selection = self#vhdl_suffix_selection_t selection  in
329
            SuffixMod { expr; selection }
330
        | Aggregate { elems } ->
331
            let elems = self#list self#vhdl_element_assoc_t elems  in
332
            Aggregate { elems }
333
        | QualifiedExpression { type_mark; aggregate; expression } ->
334
            let type_mark = self#lower_vhdl_name_t type_mark  in
335
            let aggregate = self#list self#vhdl_element_assoc_t aggregate  in
336
            let expression = self#option self#vhdl_expr_t expression  in
337
            QualifiedExpression { type_mark; aggregate; expression }
338
        | Others  -> Others
339

    
340
    method vhdl_name_t : vhdl_name_t -> vhdl_name_t=
341
      fun x  ->
342
        match x with
343
        | Simple a -> let a = self#string a  in Simple a
344
        | Identifier a -> let a = self#string a  in Identifier a
345
        | Selected a -> let a = self#list self#lower_vhdl_name_t a  in Selected a
346
        | Index { id; exprs } ->
347
            let id = self#lower_vhdl_name_t id  in
348
            let exprs = self#list self#vhdl_expr_t exprs  in
349
            Index { id; exprs }
350
        | Slice { id; range } ->
351
            let id = self#lower_vhdl_name_t id  in
352
            let range = self#vhdl_discrete_range_t range  in
353
            Slice { id; range }
354
        | Attribute { id; designator; expr } ->
355
            let id = self#lower_vhdl_name_t id  in
356
            let designator = self#lower_vhdl_name_t designator  in
357
            let expr = self#vhdl_expr_t expr  in
358
            Attribute { id; designator; expr }
359
        | Function { id; assoc_list } ->
360
            let id = self#lower_vhdl_name_t id  in
361
            let assoc_list = self#list self#vhdl_assoc_element_t assoc_list
362
               in
363
            Function { id; assoc_list }
364
        | NoName  -> NoName
365

    
366
    method vhdl_assoc_element_t :
367
      vhdl_assoc_element_t -> vhdl_assoc_element_t=
368
      fun
369
        { formal_name; formal_arg; actual_name; actual_designator;
370
          actual_expr }
371
         ->
372
        let formal_name = self#option self#lower_vhdl_name_t formal_name  in
373
        let formal_arg = self#option self#lower_vhdl_name_t formal_arg  in
374
        let actual_name = self#option self#lower_vhdl_name_t actual_name  in
375
        let actual_designator =
376
          self#option self#lower_vhdl_name_t actual_designator  in
377
        let actual_expr = self#option self#vhdl_expr_t actual_expr  in
378
        {
379
          formal_name;
380
          formal_arg;
381
          actual_name;
382
          actual_designator;
383
          actual_expr
384
        }
385

    
386
    method vhdl_element_assoc_t :
387
      vhdl_element_assoc_t -> vhdl_element_assoc_t=
388
      fun { choices; expr }  ->
389
        let choices = self#list self#vhdl_expr_t choices  in
390
        let expr = self#vhdl_expr_t expr  in { choices; expr }
391

    
392
    method vhdl_array_attributes_t :
393
      vhdl_array_attributes_t -> vhdl_array_attributes_t=
394
      fun x  ->
395
        match x with
396
        | AAttInt { id; arg } ->
397
            let id = self#string id  in
398
            let arg = self#int arg  in AAttInt { id; arg }
399
        | AAttAscending  -> AAttAscending
400

    
401
    method vhdl_signal_attributes_t :
402
      vhdl_signal_attributes_t -> vhdl_signal_attributes_t=
403
      fun x  -> match x with | SigAtt a -> let a = self#string a  in SigAtt a
404

    
405
    method vhdl_string_attributes_t :
406
      vhdl_string_attributes_t -> vhdl_string_attributes_t=
407
      fun x  ->
408
        match x with | StringAtt a -> let a = self#string a  in StringAtt a
409

    
410
    method vhdl_suffix_selection_t : vhdl_suffix_selection_t -> vhdl_suffix_selection_t=
411
      fun x  ->
412
        match x with
413
        | Idx a -> let a = self#int a  in Idx a
414
        | SuffixRange (a,b) ->
415
            let a = self#int a  in let b = self#int b  in SuffixRange (a, b)
416

    
417
    method vhdl_type_attributes_t :
418
      'a .
419
        ('a -> 'a) -> 'a vhdl_type_attributes_t -> 'a vhdl_type_attributes_t=
420
      fun _basetype  ->
421
        fun x  ->
422
          match x with
423
          | TAttNoArg { id } -> let id = self#string id  in TAttNoArg { id }
424
          | TAttIntArg { id; arg } ->
425
              let id = self#string id  in
426
              let arg = self#int arg  in TAttIntArg { id; arg }
427
          | TAttValArg { id; arg } ->
428
              let id = self#string id  in
429
              let arg = _basetype arg  in TAttValArg { id; arg }
430
          | TAttStringArg { id; arg } ->
431
              let id = self#string id  in
432
              let arg = self#string arg  in TAttStringArg { id; arg }
433

    
434
    method vhdl_parameter_t : vhdl_parameter_t -> vhdl_parameter_t=
435
      fun { names; mode; typ; init_val }  ->
436
        let names = self#list self#lower_vhdl_name_t names  in
437
        let mode = self#list self#string mode  in
438
        let typ = self#vhdl_subtype_indication_t typ  in
439
        let init_val = self#option self#vhdl_cst_val_t init_val  in
440
        { names; mode; typ; init_val }
441

    
442
    method vhdl_subprogram_spec_t :
443
      vhdl_subprogram_spec_t -> vhdl_subprogram_spec_t=
444
      fun { name; subprogram_type; typeMark; parameters; isPure }  ->
445
        let name = self#string name  in
446
        let subprogram_type = self#string subprogram_type  in
447
        let typeMark = self#lower_vhdl_name_t typeMark  in
448
        let parameters = self#list self#vhdl_parameter_t parameters  in
449
        let isPure = self#bool isPure  in
450
        { name; subprogram_type; typeMark; parameters; isPure }
451

    
452
    method vhdl_sequential_stmt_t :
453
      vhdl_sequential_stmt_t -> mini_vhdl_sequential_stmt_t=
454
      fun x  ->
455
        match x with
456
        | VarAssign { label; lhs; rhs } ->
457
            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in
458
            let lhs = self#lower_vhdl_name_t lhs  in
459
            let rhs = self#vhdl_expr_t rhs  in VarAssign { label; lhs; rhs }
460
        | SigSeqAssign { label; lhs; rhs } ->
461
            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in
462
            let lhs = self#lower_vhdl_name_t lhs  in
463
            let rhs = self#list self#vhdl_waveform_element_t rhs in
464
            SigSeqAssign { label; lhs; rhs }
465
        | If { label; if_cases; default } ->
466
            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in
467
            let if_cases = List.map self#vhdl_if_case_t if_cases  in
468
            let default = List.map self#vhdl_sequential_stmt_t default  in
469
            If { label; if_cases; default }
470
        | Case { label; guard; branches } ->
471
            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in
472
            let guard = self#vhdl_expr_t guard  in
473
            let branches = List.map self#vhdl_case_item_t branches  in
474
            Case { label; guard; branches }
475
        | Exit { label; loop_label; condition } ->
476
            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in
477
            let loop_label = self#option self#string loop_label  in
478
            let condition = self#option self#vhdl_expr_t condition  in
479
            Exit { label; loop_label; condition }
480
        | Assert { label; cond; report; severity } ->
481
            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in
482
            let cond = self#vhdl_expr_t cond  in
483
            let report = self#vhdl_expr_t report  in
484
            let severity = self#vhdl_expr_t severity  in
485
            Assert { label; cond; report; severity }
486
        | ProcedureCall { label; name; assocs } ->
487
            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in
488
            let name = self#lower_vhdl_name_t name  in
489
            let assocs = self#list self#vhdl_assoc_element_t assocs  in
490
            ProcedureCall { label; name; assocs }
491
        | Wait  -> Wait
492
        | Null { label } ->
493
            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in
494
            Null { label }
495
        | Return { label; expr } ->
496
            let label = self#option self#lower_vhdl_name_t label  in
497
            let expr = self#option self#vhdl_expr_t expr in
498
            Return { label; expr }
499

    
500
    method vhdl_if_case_t : vhdl_if_case_t -> mini_vhdl_if_case_t=
501
      fun { if_cond; if_block }  ->
502
        let if_cond = self#vhdl_expr_t if_cond  in
503
        let if_block = List.map self#vhdl_sequential_stmt_t if_block  in
504
        { if_cond; if_block }
505

    
506
    method vhdl_case_item_t : vhdl_case_item_t -> mini_vhdl_case_item_t=
507
      fun { when_cond; when_stmt }  ->
508
        let when_cond = self#list self#vhdl_expr_t when_cond  in
509
        let when_stmt = List.map self#vhdl_sequential_stmt_t when_stmt  in
510
        { when_cond; when_stmt }
511

    
512
    method vhdl_declaration_t : vhdl_declaration_t -> mini_vhdl_declaration_t=
513
      fun x  ->
514
        match x with
515
        | VarDecl { names; typ; init_val } ->
516
            let names = self#list self#lower_vhdl_name_t names  in
517
            let typ = self#vhdl_subtype_indication_t typ  in
518
            let init_val = self#vhdl_expr_t init_val  in
519
            VarDecl { names; typ; init_val }
520
        | CstDecl { names; typ; init_val } ->
521
            let names = self#list self#lower_vhdl_name_t names  in
522
            let typ = self#vhdl_subtype_indication_t typ  in
523
            let init_val = self#vhdl_expr_t init_val  in
524
            CstDecl { names; typ; init_val }
525
        | SigDecl { names; typ; init_val } ->
526
            let names = self#list self#lower_vhdl_name_t names  in
527
            let typ = self#vhdl_subtype_indication_t typ  in
528
            let init_val = self#vhdl_expr_t init_val  in
529
            SigDecl { names; typ; init_val }
530
        | ComponentDecl { name; generics; ports } ->
531
            let name = self#lower_vhdl_name_t name  in
532
            let generics = self#list self#vhdl_port_t generics  in
533
            let ports = self#list self#vhdl_port_t ports  in
534
            ComponentDecl { name; generics; ports }
535
        | Subprogram { spec; decl_part; stmts } ->
536
            let spec = self#vhdl_subprogram_spec_t spec  in
537
            let decl_part = List.map self#vhdl_declaration_t decl_part  in
538
            let stmts = List.map self#vhdl_sequential_stmt_t stmts  in
539
            Subprogram { spec; decl_part; stmts }
540

    
541
    method vhdl_declarative_item_t :
542
      vhdl_declarative_item_t -> mini_vhdl_declarative_item_t=
543
      fun { use_clause; declaration; definition }  ->
544
        let use_clause = self#option self#vhdl_load_t use_clause  in
545
        let declaration = 
546
          match declaration with
547
          | None -> None
548
          | Some a -> Some (self#vhdl_declaration_t a) in
549
        let definition = self#option self#vhdl_definition_t definition  in
550
        { use_clause; declaration; definition }
551

    
552
    method vhdl_waveform_element_t :
553
      vhdl_waveform_element_t -> vhdl_waveform_element_t=
554
      fun { value; delay }  ->
555
        let value = self#option self#vhdl_expr_t value  in
556
        let delay = self#option self#vhdl_expr_t delay  in { value; delay }
557

    
558
    method vhdl_signal_condition_t :
559
      vhdl_signal_condition_t -> vhdl_signal_condition_t=
560
      fun { expr; cond }  ->
561
        let expr = self#list self#vhdl_waveform_element_t expr  in
562
        let cond = self#option self#vhdl_expr_t cond  in { expr; cond }
563

    
564
    method vhdl_signal_selection_t :
565
      vhdl_signal_selection_t -> vhdl_signal_selection_t=
566
      fun { expr; when_sel }  ->
567
        let expr = self#list self#vhdl_waveform_element_t expr  in
568
        let when_sel = self#list self#vhdl_expr_t when_sel  in
569
        { expr; when_sel }
570

    
571
    method vhdl_conditional_signal_t :
572
      vhdl_conditional_signal_t -> vhdl_conditional_signal_t=
573
      fun { postponed; label; lhs; rhs; delay }  ->
574
        let postponed = self#bool postponed  in
575
        let label = self#lower_vhdl_name_t label  in
576
        let lhs = self#lower_vhdl_name_t lhs  in
577
        let rhs = self#list self#vhdl_signal_condition_t rhs  in
578
        let delay = self#vhdl_expr_t delay  in
579
        { postponed; label; lhs; rhs; delay }
580

    
581
    method vhdl_process_t : vhdl_process_t -> mini_vhdl_process_t=
582
      fun { id; declarations; active_sigs; body }  ->
583
        let id = self#lower_vhdl_name_t id  in
584
        let declarations = List.map self#vhdl_declarative_item_t declarations  in
585
        let active_sigs = self#list self#lower_vhdl_name_t active_sigs  in
586
        let body = List.map self#vhdl_sequential_stmt_t body  in
587
        let postponed = false in
588
        let label = None in
589
        { id; declarations; active_sigs; body; postponed; label }
590

    
591
    method vhdl_selected_signal_t :
592
      vhdl_selected_signal_t -> vhdl_selected_signal_t=
593
      fun { postponed; label; lhs; sel; branches; delay }  ->
594
        let postponed = self#bool postponed  in
595
        let label = self#lower_vhdl_name_t label  in
596
        let lhs = self#lower_vhdl_name_t lhs  in
597
        let sel = self#vhdl_expr_t sel  in
598
        let branches = self#list self#vhdl_signal_selection_t branches  in
599
        let delay = self#option self#vhdl_expr_t delay  in
600
        { postponed; label; lhs; sel; branches; delay }
601

    
602
    method vhdl_port_mode_t : vhdl_port_mode_t -> vhdl_port_mode_t=
603
      fun x  -> x
604

    
605
    method vhdl_component_instantiation_t :
606
      vhdl_component_instantiation_t -> mini_vhdl_component_instantiation_t=
607
        fun { name; inst_unit; inst_unit_type; archi_name; generic_map; port_map }  ->
608
        let name = self#lower_vhdl_name_t name  in
609
        let archi_name = self#option self#lower_vhdl_name_t archi_name  in
610
        let inst_unit = self#lower_vhdl_name_t inst_unit in
611
        let db_tuple = match archi_name with
612
          | None -> failwith ("Component [" ^ self#to_string_vhdl_name_t name ^ "] is not an entity")
613
          | Some a -> self#get_tuple_from_archi_and_entity_name (a, inst_unit) in (* Get corresponding tuple in db *)
614
        let archi = db_tuple.architecture in
615
        let entity = db_tuple.entity in
616
        let generic_map = self#list self#vhdl_assoc_element_t generic_map  in
617
        let port_map = self#list self#vhdl_assoc_element_t port_map  in
618
        { name; archi; entity; generic_map; port_map }
619

    
620
    method vhdl_concurrent_stmt_t :
621
      vhdl_concurrent_stmt_t -> mini_vhdl_concurrent_stmt_t=
622
      fun x  ->
623
        match x with
624
        | SigAssign a -> 
625
            Process {
626
              id = self#postfix_flatten_vhdl_name_t a.lhs "__implicit_process";
627
              declarations = [];
628
              active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x []; (* TODO: Resolve sensitivity list from here *)
629
              body = (SigCondAssign {
630
                label = None;
631
                lhs = a.lhs;
632
                rhs = a.rhs;
633
                delay = match a.delay with | IsNull -> None | _ -> Some a.delay
634
              })::[];
635
              postponed = a.postponed;
636
              label = match a.label with | NoName -> None | _ -> Some a.label
637
            }
638
        | Process a -> let a = self#vhdl_process_t a  in Process a
639
        | SelectedSig a -> 
640
            Process {
641
              id = self#postfix_flatten_vhdl_name_t a.lhs "__implicit_process";
642
              declarations = [];
643
              active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x []; (* TODO: Resolve sensitivity list from here *)
644
              body = (SigSelectAssign {
645
                label = None;
646
                lhs = a.lhs;
647
                sel = a.sel;
648
                branches = a.branches;
649
                delay = a.delay
650
              })::[];
651
              postponed = a.postponed;
652
              label = match a.label with | NoName -> None | _ -> Some a.label
653
            }
654
        | ComponentInst a -> let a = self#vhdl_component_instantiation_t a  in ComponentInst a (* TODO: instantiate *)
655

    
656
    method vhdl_port_t : vhdl_port_t -> vhdl_port_t=
657
      fun { names; mode; typ; expr }  ->
658
        let names = self#list self#lower_vhdl_name_t names  in
659
        let mode = self#vhdl_port_mode_t mode  in
660
        let typ = self#vhdl_subtype_indication_t typ  in
661
        let expr = self#vhdl_expr_t expr  in { names; mode; typ; expr }
662

    
663
    method vhdl_entity_t : vhdl_entity_t -> unit =
664
      fun { name; generics; ports; declaration; stmts }  -> ()
665

    
666
    method vhdl_package_t : (vhdl_load_t list * vhdl_package_t) -> mini_vhdl_package_t=
667
      fun ( ctxs, {name; shared_defs; shared_decls; shared_uses })  ->
668
        let name = self#lower_vhdl_name_t name  in
669
        let shared_defs = self#list self#vhdl_definition_t shared_defs  in
670
        let shared_decls = List.map self#vhdl_declaration_t shared_decls  in
671
        let shared_uses = self#list self#vhdl_load_t shared_uses @ ctxs in
672
        { name; shared_defs; shared_decls; shared_uses }
673

    
674
    method vhdl_load_t : vhdl_load_t -> vhdl_load_t=
675
      fun x  ->
676
        match x with
677
        | Library a -> let a = self#list self#lower_vhdl_name_t a  in Library a
678
        | Use a -> let a = self#list self#lower_vhdl_name_t a  in Use a
679

    
680
    method vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list *
681
                                  (vhdl_load_t list * vhdl_entity_t) list * 
682
                                  (vhdl_load_t list * vhdl_configuration_t) list *
683
                                  (vhdl_load_t list * vhdl_architecture_t)) -> mini_vhdl_component_t=
684
        fun ( packs_pairs, ents_pairs, confs_pairs, (arch_ctx, arch) ) ->
685
        let names = arch.name::(arch.entity::[])  in
686
        let (ref_ent_ctx,ref_ent) = self#filter_entity (ents_pairs, arch.entity) in
687
        let contexts =
688
          ref_ent_ctx @ (* Referenced entity context elements *)
689
          arch_ctx @ (* Architecture context elements *)
690
          self#declarative_items_uses ref_ent.declaration @ (* Referenced entity inner context elements *)
691
          self#declarative_items_uses arch.declarations in (* Architecture inner context elements *)
692
        let declarations = 
693
          self#declarative_items_declarations ref_ent.declaration @ (* Referenced entity inner declarations *)
694
          self#declarative_items_declarations arch.declarations in (* Architecture inner declarations *)
695
        let definitions =
696
          self#declarative_items_definitions ref_ent.declaration @ (* Referenced entity inner definitions *)
697
          self#declarative_items_definitions arch.declarations in (* Architecture inner definitions *)
698
        let body = 
699
          List.map self#vhdl_concurrent_stmt_t ref_ent.stmts @ (* Referenced entity concurrent statement *)
700
          List.map self#vhdl_concurrent_stmt_t arch.body in (* Architecture concurrent statements *)
701
        let generics = ref_ent.generics in (* Referenced entity generics *)
702
        let ports = ref_ent.ports in (* Referenced entity ports *)
703
        let declarations = List.map self#vhdl_declaration_t declarations in
704
        let signals = 
705
          let rec find_sig_decls declarations = 
706
            match declarations with
707
            | [] -> []
708
            | (SigDecl (s))::tl -> (SigDecl (s))::find_sig_decls tl
709
            | _::tl -> find_sig_decls tl in find_sig_decls declarations in
710
        self#db_add_tuple { entity=ref_ent; 
711
                            architecture=arch; 
712
                            architecture_signals=signals; 
713
                            contexts=ref_ent_ctx@arch_ctx
714
                          };
715
        { names; 
716
          generics=generics; 
717
          ports=ports; 
718
          contexts=contexts; 
719
          declarations=declarations; 
720
          definitions=definitions; 
721
          body=body (* TODO: Flatten component instantiation from here *)
722
        }
723

    
724
    method declarative_items_declarations : vhdl_declarative_item_t list -> vhdl_declaration_t list =
725
      fun x ->
726
        match x with
727
        | {use_clause=_; declaration=Some a;definition=_}::tl -> a::(self#declarative_items_declarations tl)
728
        | _::tl -> self#declarative_items_declarations tl
729
        | [] -> []
730

    
731
    method declarative_items_definitions : vhdl_declarative_item_t list -> vhdl_definition_t list =
732
      fun x ->
733
        match x with
734
        | {use_clause=_; declaration=_;definition=Some a}::tl -> a::(self#declarative_items_definitions tl)
735
        | _::tl -> self#declarative_items_definitions tl
736
        | [] -> []
737

    
738
    method declarative_items_uses : vhdl_declarative_item_t list -> vhdl_load_t list =
739
      fun x ->
740
        match x with
741
        | {use_clause=Some a; declaration=_;definition=_}::tl -> a::(self#declarative_items_uses tl)
742
        | _::tl -> self#declarative_items_uses tl
743
        | [] -> []
744

    
745
    method filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) -> 
746
                           (vhdl_load_t list * vhdl_entity_t) =
747
      fun ( entities_pair, filter_name ) ->
748
      let rec filter ep n = match ep with
749
      | [] -> failwith ("Impossible to find an entity with name [" ^ self#to_string_vhdl_name_t filter_name ^ "]")
750
      | (c,{name; generics; ports; declaration; stmts})::tl -> 
751
          if (name = n) then 
752
            List.hd ep
753
          else filter (List.tl ep) n in
754
      filter entities_pair filter_name
755

    
756
    method vhdl_configuration_t :
757
      vhdl_configuration_t -> unit= self#unit
758

    
759
    method vhdl_library_unit_t : vhdl_library_unit_t -> unit=
760
      fun x  -> ()
761

    
762
    method vhdl_design_unit_t : vhdl_design_unit_t -> unit=
763
      fun { contexts; library }  -> ()
764

    
765
    method vhdl_design_file_t : vhdl_design_file_t -> mini_vhdl_design_file_t=
766
      fun { design_units }  ->
767
        let rec inline_df l packs ents archs confs = match l with
768
          | [] -> (List.rev packs, List.rev ents, List.rev archs, List.rev confs)
769
          | {contexts = c; library = lib}::tl -> match lib with
770
            | Package p -> inline_df tl ((c,p)::packs) ents archs confs
771
            | Entities e -> inline_df tl packs ((c,e)::ents) archs confs
772
            | Architecture a -> inline_df tl packs ents ((c,a)::archs) confs
773
            | Configuration conf -> inline_df tl packs ents archs ((c,conf)::confs) in
774
        let (p,e,a,con) = inline_df design_units [] [] [] [] in
775
        let app x = self#vhdl_architecture_t (p,e,con,x) in
776
        let components = List.map app a in
777
        let packages = List.map self#vhdl_package_t p in
778
        { components; packages }
779

    
780
  end
(3-3/10)