Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / VHDL / vhdl_2_mini_vhdl_map.ml @ 4a92cb37

History | View | Annotate | Download (33.7 KB)

1 5bbf7413 Arnaud Dieumegard
open Vhdl_ast
2
open Mini_vhdl_ast
3
4 76f9de64 Arnaud Dieumegard
type db_tuple_t =
5
  {
6
    mutable entity: vhdl_entity_t;
7
    mutable architecture: vhdl_architecture_t;
8 4a92cb37 Arnaud Dieumegard
    mutable architecture_signals_names: vhdl_name_t list;
9 76f9de64 Arnaud Dieumegard
    mutable contexts: vhdl_load_t list;
10
  }
11
12 5bbf7413 Arnaud Dieumegard
let _ = fun (_ : vhdl_cst_val_t)  -> () 
13
let _ = fun (_ : vhdl_type_t)  -> () 
14
let _ = fun (_ : vhdl_element_declaration_t)  -> () 
15
let _ = fun (_ : vhdl_subtype_indication_t)  -> () 
16
let _ = fun (_ : vhdl_discrete_range_t)  -> () 
17
let _ = fun (_ : vhdl_constraint_t)  -> () 
18
let _ = fun (_ : vhdl_definition_t)  -> () 
19
let _ = fun (_ : vhdl_expr_t)  -> () 
20
let _ = fun (_ : vhdl_name_t)  -> () 
21
let _ = fun (_ : vhdl_assoc_element_t)  -> () 
22
let _ = fun (_ : vhdl_element_assoc_t)  -> () 
23
let _ = fun (_ : vhdl_array_attributes_t)  -> () 
24
let _ = fun (_ : vhdl_signal_attributes_t)  -> () 
25
let _ = fun (_ : vhdl_string_attributes_t)  -> () 
26
let _ = fun (_ : vhdl_suffix_selection_t)  -> () 
27
let _ = fun (_ : 'basetype vhdl_type_attributes_t)  -> () 
28
let _ = fun (_ : vhdl_parameter_t)  -> () 
29
let _ = fun (_ : vhdl_subprogram_spec_t)  -> () 
30
let _ = fun (_ : vhdl_sequential_stmt_t)  -> () 
31
let _ = fun (_ : vhdl_if_case_t)  -> () 
32
let _ = fun (_ : vhdl_case_item_t)  -> () 
33
let _ = fun (_ : vhdl_declaration_t)  -> () 
34
let _ = fun (_ : vhdl_signal_selection_t)  -> () 
35
let _ = fun (_ : vhdl_declarative_item_t)  -> () 
36
let _ = fun (_ : vhdl_waveform_element_t)  -> ()
37
let _ = fun (_ : vhdl_signal_condition_t)  -> () 
38
let _ = fun (_ : vhdl_conditional_signal_t)  -> () 
39
let _ = fun (_ : vhdl_process_t)  -> () 
40
let _ = fun (_ : vhdl_selected_signal_t)  -> () 
41
let _ = fun (_ : vhdl_port_mode_t)  -> () 
42
let _ = fun (_ : vhdl_component_instantiation_t)  -> ()
43
let _ = fun (_ : vhdl_concurrent_stmt_t)  -> () 
44
let _ = fun (_ : vhdl_port_t)  -> () 
45
let _ = fun (_ : vhdl_entity_t)  -> () 
46
let _ = fun (_ : vhdl_package_t)  -> () 
47
let _ = fun (_ : vhdl_load_t)  -> () 
48
let _ = fun (_ : vhdl_architecture_t)  -> () 
49
let _ = fun (_ : vhdl_configuration_t)  -> () 
50
let _ = fun (_ : vhdl_library_unit_t)  -> () 
51
let _ = fun (_ : vhdl_design_unit_t)  -> () 
52
let _ = fun (_ : vhdl_design_file_t)  -> () 
53
54
class virtual vhdl_2_mini_vhdl_map =
55
  object (self)
56
    method virtual  string : string -> string
57
    method virtual  list : 'a . ('a -> 'a) -> 'a list -> 'a list
58
    method virtual  unit : unit -> unit
59
    method virtual  bool : bool -> bool
60
    method virtual  option : 'a . ('a -> 'a) -> 'a option -> 'a option
61
    method virtual  int : int -> int
62
    method virtual  vhdl_name_t : vhdl_name_t -> vhdl_name_t
63
    method virtual  vhdl_definition_t : vhdl_definition_t -> vhdl_definition_t
64
    method virtual  vhdl_port_t : vhdl_port_t -> vhdl_port_t
65
    method virtual  vhdl_expr_t : vhdl_expr_t -> vhdl_expr_t
66
    method virtual  vhdl_port_mode_t : vhdl_port_mode_t -> vhdl_port_mode_t
67
    method virtual  vhdl_element_declaration_t : vhdl_element_declaration_t -> vhdl_element_declaration_t
68
    method virtual  vhdl_subtype_indication_t : vhdl_subtype_indication_t -> vhdl_subtype_indication_t
69
    method virtual  vhdl_conditional_signal_t : vhdl_conditional_signal_t -> vhdl_conditional_signal_t
70
    method virtual  vhdl_process_t : vhdl_process_t -> vhdl_process_t
71
    method virtual  vhdl_selected_signal_t : vhdl_selected_signal_t -> vhdl_selected_signal_t
72
    method virtual  vhdl_signal_selection_t : vhdl_signal_selection_t -> vhdl_signal_selection_t
73
    method virtual  vhdl_suffix_selection_t : vhdl_suffix_selection_t -> vhdl_suffix_selection_t
74
    method virtual  vhdl_declaration_t : vhdl_declaration_t -> vhdl_declaration_t
75
    method virtual  vhdl_sequential_stmt_t : vhdl_sequential_stmt_t -> vhdl_sequential_stmt_t
76
    method virtual  vhdl_declarative_item_t : vhdl_declarative_item_t -> vhdl_declarative_item_t
77
    method virtual  vhdl_waveform_element_t : vhdl_waveform_element_t -> vhdl_waveform_element_t
78
    method virtual  vhdl_signal_condition_t : vhdl_signal_condition_t -> vhdl_signal_condition_t
79
    method virtual  vhdl_cst_val_t : vhdl_cst_val_t -> vhdl_cst_val_t
80
    method virtual  vhdl_subprogram_spec_t : vhdl_subprogram_spec_t -> vhdl_subprogram_spec_t
81
    method virtual  vhdl_discrete_range_t : vhdl_discrete_range_t -> vhdl_discrete_range_t
82
    method virtual  vhdl_parameter_t : vhdl_parameter_t -> vhdl_parameter_t
83 76f9de64 Arnaud Dieumegard
    method virtual  vhdl_concurrent_stmt_t : vhdl_concurrent_stmt_t -> mini_vhdl_concurrent_stmt_t
84 5bbf7413 Arnaud Dieumegard
    method virtual  vhdl_declaration_t : vhdl_declaration_t -> 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
    method virtual  vhdl_design_file_t : vhdl_design_file_t -> mini_vhdl_design_file_t
91
92
    method virtual  vhdl_package_t : (vhdl_load_t list * vhdl_package_t) -> vhdl_package_t
93
    method virtual  vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list *
94
                                  (vhdl_load_t list * vhdl_entity_t) list * 
95
                                  (vhdl_load_t list * vhdl_configuration_t) list *
96
                                  (vhdl_load_t list * vhdl_architecture_t)) -> mini_vhdl_component_t
97 76f9de64 Arnaud Dieumegard
    method virtual  vhdl_component_instantiation_t : vhdl_component_instantiation_t -> mini_vhdl_component_instantiation_t
98 5bbf7413 Arnaud Dieumegard
    method virtual  declarative_items_declarations : vhdl_declarative_item_t list -> vhdl_declaration_t list
99
    method virtual  declarative_items_definitions : vhdl_declarative_item_t list -> vhdl_definition_t list
100
    method virtual  declarative_items_uses : vhdl_declarative_item_t list -> vhdl_load_t list
101
    method virtual  filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) -> 
102
                           (vhdl_load_t list * vhdl_entity_t)
103
104 4a92cb37 Arnaud Dieumegard
(*************************
105
 * Begin vhdl_name_t helpers
106
 *)
107 76f9de64 Arnaud Dieumegard
    method simplify_name_t : vhdl_name_t -> vhdl_name_t=
108
      fun n ->
109 4a92cb37 Arnaud Dieumegard
        let lower a = String.lowercase_ascii a in
110
        let n = self#lower_vhdl_name_t n in
111 76f9de64 Arnaud Dieumegard
        match n with
112 4a92cb37 Arnaud Dieumegard
        | Selected (a::[]) -> self#simplify_name_t a
113 76f9de64 Arnaud Dieumegard
        | Selected (NoName::tl) -> self#simplify_name_t (Selected tl)
114 4a92cb37 Arnaud Dieumegard
        | Selected ((Simple (s))::tl) ->  if (lower s = "work")
115 76f9de64 Arnaud Dieumegard
                                          then self#simplify_name_t (Selected tl)
116
                                          else n
117 4a92cb37 Arnaud Dieumegard
        | Selected ((Identifier (s))::tl) -> if (lower s = "work")
118
                                             then self#simplify_name_t (Selected tl)
119
                                             else n
120 76f9de64 Arnaud Dieumegard
        | _ -> n
121 4a92cb37 Arnaud Dieumegard
122
    method lower_vhdl_name_t : vhdl_name_t -> vhdl_name_t=
123
      fun x  ->
124
        let lower a = String.lowercase_ascii a in
125
        match x with
126
        | Simple a -> Simple (lower a)
127
        | Identifier a -> Identifier (lower a)
128
        | Selected a -> Selected (self#list self#lower_vhdl_name_t a)
129
        | Index { id; exprs } ->
130
            let id = self#lower_vhdl_name_t id  in
131
            let exprs = self#list self#vhdl_expr_t exprs  in
132
            Index { id; exprs }
133
        | Slice { id; range } ->
134
            let id = self#lower_vhdl_name_t id  in
135
            let range = self#vhdl_discrete_range_t range  in
136
            Slice { id; range }
137
        | Attribute { id; designator; expr } ->
138
            let id = self#lower_vhdl_name_t id  in
139
            let designator = self#lower_vhdl_name_t designator  in
140
            let expr = self#vhdl_expr_t expr  in
141
            Attribute { id; designator; expr }
142
        | Function { id; assoc_list } ->
143
            let id = self#lower_vhdl_name_t id  in
144
            let assoc_list = self#list self#vhdl_assoc_element_t assoc_list in
145
            Function { id; assoc_list }
146
        | NoName  -> NoName
147
 
148
    method to_string_vhdl_name_t : vhdl_name_t -> string=
149
      fun x  ->
150
        match x with
151
        | Simple a -> a
152
        | Identifier a -> a
153
        | Selected a -> String.concat "." (List.map self#to_string_vhdl_name_t a)
154
        | Index { id; exprs } -> self#to_string_vhdl_name_t id
155
        | Slice { id; range } -> self#to_string_vhdl_name_t id
156
        | Attribute { id; designator; expr } -> self#to_string_vhdl_name_t id
157
        | Function { id; assoc_list } -> self#to_string_vhdl_name_t id
158
        | NoName  -> "NoName"
159
(*************************
160
 * End vhdl_name_t helpers
161
 *)
162
163
(*************************
164
 * Begin DB helpers
165
 *)
166
    val mutable db : db_tuple_t list = []
167
168 76f9de64 Arnaud Dieumegard
    method db_add_tuple : db_tuple_t -> unit=
169
      fun x -> db <- x::db
170
171
    method db_get : vhdl_architecture_t -> (vhdl_entity_t * vhdl_load_t list)=
172
      fun x ->
173
        let rec find a dbl =
174
          match dbl with
175 4a92cb37 Arnaud Dieumegard
          | [] -> failwith ("No matching tuple in DB for architecture [" ^ self#to_string_vhdl_name_t x.name ^ "]")
176 76f9de64 Arnaud Dieumegard
          | e::tl -> if (e.architecture = a) then (e.entity, e.contexts) else find a tl in find x db
177
178 4a92cb37 Arnaud Dieumegard
    method get_tuple_from_archi_and_entity_name : (vhdl_name_t * vhdl_name_t) -> db_tuple_t=
179 76f9de64 Arnaud Dieumegard
      fun (a_name,e_name) ->
180 4a92cb37 Arnaud Dieumegard
        let a_name = self#simplify_name_t a_name in
181
        let e_name = self#simplify_name_t e_name in
182 76f9de64 Arnaud Dieumegard
        let rec find (a_name,e_name) dbl =
183
          match dbl with
184 4a92cb37 Arnaud Dieumegard
          | [] -> failwith ("No matching tuple in DB for architecture [" ^ self#to_string_vhdl_name_t a_name ^
185
                           "] and entity [" ^ self#to_string_vhdl_name_t e_name ^ "]")
186
          | e::tl -> 
187
              let inner_e_arch_name = self#simplify_name_t e.architecture.name in
188
              let inner_e_ent_name = self#simplify_name_t e.entity.name in
189
              if ((inner_e_arch_name = a_name) && (inner_e_ent_name = e_name)) 
190
              then e 
191
              else find (a_name,e_name) tl in 
192 76f9de64 Arnaud Dieumegard
        find (a_name,e_name) db
193 4a92cb37 Arnaud Dieumegard
(*******************
194
 * End DB helpers
195
 *)
196 76f9de64 Arnaud Dieumegard
197 5bbf7413 Arnaud Dieumegard
    method vhdl_cst_val_t : vhdl_cst_val_t -> vhdl_cst_val_t=
198
      fun x  ->
199
        match x with
200
        | CstInt a -> let a = self#int a  in CstInt a
201
        | CstStdLogic a -> let a = self#string a  in CstStdLogic a
202
        | CstLiteral a -> let a = self#string a  in CstLiteral a
203
204
    method vhdl_type_t : vhdl_type_t -> vhdl_type_t=
205
      fun x  ->
206
        match x with
207
        | Base a -> let a = self#string a  in Base a
208
        | Range (a,b,c) ->
209
            let a = self#option self#string a  in
210
            let b = self#int b  in let c = self#int c  in Range (a, b, c)
211
        | Bit_vector (a,b) ->
212
            let a = self#int a  in let b = self#int b  in Bit_vector (a, b)
213
        | Array { indexes; const; definition } ->
214 4a92cb37 Arnaud Dieumegard
            let indexes = self#list self#lower_vhdl_name_t indexes  in
215 5bbf7413 Arnaud Dieumegard
            let const = self#option self#vhdl_constraint_t const  in
216
            let definition = self#vhdl_subtype_indication_t definition  in
217
            Array { indexes; const; definition }
218
        | Record a ->
219
            let a = self#list self#vhdl_element_declaration_t a  in Record a
220
        | Enumerated a ->
221 4a92cb37 Arnaud Dieumegard
            let a = self#list self#lower_vhdl_name_t a  in Enumerated a
222 5bbf7413 Arnaud Dieumegard
        | Void  -> Void
223 4a92cb37 Arnaud Dieumegard
224 5bbf7413 Arnaud Dieumegard
    method vhdl_element_declaration_t :
225
      vhdl_element_declaration_t -> vhdl_element_declaration_t=
226
      fun { names; definition }  ->
227 4a92cb37 Arnaud Dieumegard
        let names = self#list self#lower_vhdl_name_t names  in
228 5bbf7413 Arnaud Dieumegard
        let definition = self#vhdl_subtype_indication_t definition  in
229
        { names; definition }
230 4a92cb37 Arnaud Dieumegard
231 5bbf7413 Arnaud Dieumegard
    method vhdl_subtype_indication_t :
232
      vhdl_subtype_indication_t -> vhdl_subtype_indication_t=
233
      fun { name; functionName; const }  ->
234 4a92cb37 Arnaud Dieumegard
        let name = self#lower_vhdl_name_t name  in
235
        let functionName = self#lower_vhdl_name_t functionName  in
236 5bbf7413 Arnaud Dieumegard
        let const = self#vhdl_constraint_t const  in
237
        { name; functionName; const }
238 4a92cb37 Arnaud Dieumegard
239 5bbf7413 Arnaud Dieumegard
    method vhdl_discrete_range_t :
240
      vhdl_discrete_range_t -> vhdl_discrete_range_t=
241
      fun x  ->
242
        match x with
243
        | SubDiscreteRange a ->
244
            let a = self#vhdl_subtype_indication_t a  in SubDiscreteRange a
245 4a92cb37 Arnaud Dieumegard
        | NamedRange a -> let a = self#lower_vhdl_name_t a  in NamedRange a
246 5bbf7413 Arnaud Dieumegard
        | DirectedRange { direction; from; _to } ->
247
            let direction = self#string direction  in
248
            let from = self#vhdl_expr_t from  in
249
            let _to = self#vhdl_expr_t _to  in
250
            DirectedRange { direction; from; _to }
251
252
    method vhdl_constraint_t : vhdl_constraint_t -> vhdl_constraint_t=
253
      fun x  ->
254
        match x with
255
        | RefConstraint { ref_name } ->
256 4a92cb37 Arnaud Dieumegard
            let ref_name = self#lower_vhdl_name_t ref_name  in
257 5bbf7413 Arnaud Dieumegard
            RefConstraint { ref_name }
258
        | RangeConstraint { range } ->
259
            let range = self#vhdl_discrete_range_t range  in
260
            RangeConstraint { range }
261
        | IndexConstraint { ranges } ->
262
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
263
            IndexConstraint { ranges }
264
        | ArrayConstraint { ranges; sub } ->
265
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
266
            let sub = self#vhdl_constraint_t sub  in
267
            ArrayConstraint { ranges; sub }
268
        | RecordConstraint  -> RecordConstraint
269
        | NoConstraint  -> NoConstraint
270
271
    method vhdl_definition_t : vhdl_definition_t -> vhdl_definition_t=
272
      fun x  ->
273
        match x with
274
        | Type { name; definition } ->
275 4a92cb37 Arnaud Dieumegard
            let name = self#lower_vhdl_name_t name  in
276 5bbf7413 Arnaud Dieumegard
            let definition = self#vhdl_type_t definition  in
277
            Type { name; definition }
278
        | Subtype { name; typ } ->
279 4a92cb37 Arnaud Dieumegard
            let name = self#lower_vhdl_name_t name  in
280 5bbf7413 Arnaud Dieumegard
            let typ = self#vhdl_subtype_indication_t typ  in
281
            Subtype { name; typ }
282 4a92cb37 Arnaud Dieumegard
283 5bbf7413 Arnaud Dieumegard
    method vhdl_expr_t : vhdl_expr_t -> vhdl_expr_t=
284
      fun x  ->
285
        match x with
286 4a92cb37 Arnaud Dieumegard
        | Call a -> let a = self#lower_vhdl_name_t a  in Call a
287 5bbf7413 Arnaud Dieumegard
        | Cst { value; unit_name } ->
288
            let value = self#vhdl_cst_val_t value  in
289 4a92cb37 Arnaud Dieumegard
            let unit_name = self#option self#lower_vhdl_name_t unit_name  in
290 5bbf7413 Arnaud Dieumegard
            Cst { value; unit_name }
291
        | Op { id; args } ->
292
            let id = self#string id  in
293
            let args = self#list self#vhdl_expr_t args  in Op { id; args }
294
        | IsNull  -> IsNull
295
        | Time { value; phy_unit } ->
296
            let value = self#int value  in
297
            let phy_unit = self#string phy_unit  in Time { value; phy_unit }
298
        | Sig { name; att } ->
299 4a92cb37 Arnaud Dieumegard
            let name = self#lower_vhdl_name_t name  in
300 5bbf7413 Arnaud Dieumegard
            let att = self#option self#vhdl_signal_attributes_t att  in
301
            Sig { name; att }
302
        | SuffixMod { expr; selection } ->
303
            let expr = self#vhdl_expr_t expr  in
304
            let selection = self#vhdl_suffix_selection_t selection  in
305
            SuffixMod { expr; selection }
306
        | Aggregate { elems } ->
307
            let elems = self#list self#vhdl_element_assoc_t elems  in
308
            Aggregate { elems }
309
        | QualifiedExpression { type_mark; aggregate; expression } ->
310 4a92cb37 Arnaud Dieumegard
            let type_mark = self#lower_vhdl_name_t type_mark  in
311 5bbf7413 Arnaud Dieumegard
            let aggregate = self#list self#vhdl_element_assoc_t aggregate  in
312
            let expression = self#option self#vhdl_expr_t expression  in
313
            QualifiedExpression { type_mark; aggregate; expression }
314
        | Others  -> Others
315 4a92cb37 Arnaud Dieumegard
316 5bbf7413 Arnaud Dieumegard
    method vhdl_name_t : vhdl_name_t -> vhdl_name_t=
317
      fun x  ->
318
        match x with
319
        | Simple a -> let a = self#string a  in Simple a
320
        | Identifier a -> let a = self#string a  in Identifier a
321 4a92cb37 Arnaud Dieumegard
        | Selected a -> let a = self#list self#lower_vhdl_name_t a  in Selected a
322 5bbf7413 Arnaud Dieumegard
        | Index { id; exprs } ->
323 4a92cb37 Arnaud Dieumegard
            let id = self#lower_vhdl_name_t id  in
324 5bbf7413 Arnaud Dieumegard
            let exprs = self#list self#vhdl_expr_t exprs  in
325
            Index { id; exprs }
326
        | Slice { id; range } ->
327 4a92cb37 Arnaud Dieumegard
            let id = self#lower_vhdl_name_t id  in
328 5bbf7413 Arnaud Dieumegard
            let range = self#vhdl_discrete_range_t range  in
329
            Slice { id; range }
330
        | Attribute { id; designator; expr } ->
331 4a92cb37 Arnaud Dieumegard
            let id = self#lower_vhdl_name_t id  in
332
            let designator = self#lower_vhdl_name_t designator  in
333 5bbf7413 Arnaud Dieumegard
            let expr = self#vhdl_expr_t expr  in
334
            Attribute { id; designator; expr }
335
        | Function { id; assoc_list } ->
336 4a92cb37 Arnaud Dieumegard
            let id = self#lower_vhdl_name_t id  in
337 5bbf7413 Arnaud Dieumegard
            let assoc_list = self#list self#vhdl_assoc_element_t assoc_list
338
               in
339
            Function { id; assoc_list }
340
        | NoName  -> NoName
341 4a92cb37 Arnaud Dieumegard
342 5bbf7413 Arnaud Dieumegard
    method vhdl_assoc_element_t :
343
      vhdl_assoc_element_t -> vhdl_assoc_element_t=
344
      fun
345
        { formal_name; formal_arg; actual_name; actual_designator;
346
          actual_expr }
347
         ->
348 4a92cb37 Arnaud Dieumegard
        let formal_name = self#option self#lower_vhdl_name_t formal_name  in
349
        let formal_arg = self#option self#lower_vhdl_name_t formal_arg  in
350
        let actual_name = self#option self#lower_vhdl_name_t actual_name  in
351 5bbf7413 Arnaud Dieumegard
        let actual_designator =
352 4a92cb37 Arnaud Dieumegard
          self#option self#lower_vhdl_name_t actual_designator  in
353 5bbf7413 Arnaud Dieumegard
        let actual_expr = self#option self#vhdl_expr_t actual_expr  in
354
        {
355
          formal_name;
356
          formal_arg;
357
          actual_name;
358
          actual_designator;
359
          actual_expr
360
        }
361 4a92cb37 Arnaud Dieumegard
362 5bbf7413 Arnaud Dieumegard
    method vhdl_element_assoc_t :
363
      vhdl_element_assoc_t -> vhdl_element_assoc_t=
364
      fun { choices; expr }  ->
365
        let choices = self#list self#vhdl_expr_t choices  in
366
        let expr = self#vhdl_expr_t expr  in { choices; expr }
367 4a92cb37 Arnaud Dieumegard
368 5bbf7413 Arnaud Dieumegard
    method vhdl_array_attributes_t :
369
      vhdl_array_attributes_t -> vhdl_array_attributes_t=
370
      fun x  ->
371
        match x with
372
        | AAttInt { id; arg } ->
373
            let id = self#string id  in
374
            let arg = self#int arg  in AAttInt { id; arg }
375
        | AAttAscending  -> AAttAscending
376 4a92cb37 Arnaud Dieumegard
377 5bbf7413 Arnaud Dieumegard
    method vhdl_signal_attributes_t :
378
      vhdl_signal_attributes_t -> vhdl_signal_attributes_t=
379
      fun x  -> match x with | SigAtt a -> let a = self#string a  in SigAtt a
380 4a92cb37 Arnaud Dieumegard
381 5bbf7413 Arnaud Dieumegard
    method vhdl_string_attributes_t :
382
      vhdl_string_attributes_t -> vhdl_string_attributes_t=
383
      fun x  ->
384
        match x with | StringAtt a -> let a = self#string a  in StringAtt a
385 4a92cb37 Arnaud Dieumegard
386 5bbf7413 Arnaud Dieumegard
    method vhdl_suffix_selection_t : vhdl_suffix_selection_t -> vhdl_suffix_selection_t=
387
      fun x  ->
388
        match x with
389
        | Idx a -> let a = self#int a  in Idx a
390
        | SuffixRange (a,b) ->
391
            let a = self#int a  in let b = self#int b  in SuffixRange (a, b)
392
393
    method vhdl_type_attributes_t :
394
      'a .
395
        ('a -> 'a) -> 'a vhdl_type_attributes_t -> 'a vhdl_type_attributes_t=
396
      fun _basetype  ->
397
        fun x  ->
398
          match x with
399
          | TAttNoArg { id } -> let id = self#string id  in TAttNoArg { id }
400
          | TAttIntArg { id; arg } ->
401
              let id = self#string id  in
402
              let arg = self#int arg  in TAttIntArg { id; arg }
403
          | TAttValArg { id; arg } ->
404
              let id = self#string id  in
405
              let arg = _basetype arg  in TAttValArg { id; arg }
406
          | TAttStringArg { id; arg } ->
407
              let id = self#string id  in
408
              let arg = self#string arg  in TAttStringArg { id; arg }
409
410
    method vhdl_parameter_t : vhdl_parameter_t -> vhdl_parameter_t=
411
      fun { names; mode; typ; init_val }  ->
412 4a92cb37 Arnaud Dieumegard
        let names = self#list self#lower_vhdl_name_t names  in
413 5bbf7413 Arnaud Dieumegard
        let mode = self#list self#string mode  in
414
        let typ = self#vhdl_subtype_indication_t typ  in
415
        let init_val = self#option self#vhdl_cst_val_t init_val  in
416
        { names; mode; typ; init_val }
417
418
    method vhdl_subprogram_spec_t :
419
      vhdl_subprogram_spec_t -> vhdl_subprogram_spec_t=
420
      fun { name; subprogram_type; typeMark; parameters; isPure }  ->
421
        let name = self#string name  in
422
        let subprogram_type = self#string subprogram_type  in
423 4a92cb37 Arnaud Dieumegard
        let typeMark = self#lower_vhdl_name_t typeMark  in
424 5bbf7413 Arnaud Dieumegard
        let parameters = self#list self#vhdl_parameter_t parameters  in
425
        let isPure = self#bool isPure  in
426
        { name; subprogram_type; typeMark; parameters; isPure }
427
428
    method vhdl_sequential_stmt_t :
429
      vhdl_sequential_stmt_t -> vhdl_sequential_stmt_t=
430
      fun x  ->
431
        match x with
432
        | VarAssign { label; lhs; rhs } ->
433 4a92cb37 Arnaud Dieumegard
            let label = self#lower_vhdl_name_t label  in
434
            let lhs = self#lower_vhdl_name_t lhs  in
435 5bbf7413 Arnaud Dieumegard
            let rhs = self#vhdl_expr_t rhs  in VarAssign { label; lhs; rhs }
436
        | SigSeqAssign { label; lhs; rhs } ->
437 4a92cb37 Arnaud Dieumegard
            let label = self#lower_vhdl_name_t label  in
438
            let lhs = self#lower_vhdl_name_t lhs  in
439 5bbf7413 Arnaud Dieumegard
            let rhs = self#list self#vhdl_waveform_element_t rhs  in
440
            SigSeqAssign { label; lhs; rhs }
441
        | If { label; if_cases; default } ->
442 4a92cb37 Arnaud Dieumegard
            let label = self#lower_vhdl_name_t label  in
443 5bbf7413 Arnaud Dieumegard
            let if_cases = self#list self#vhdl_if_case_t if_cases  in
444
            let default = self#list self#vhdl_sequential_stmt_t default  in
445
            If { label; if_cases; default }
446
        | Case { label; guard; branches } ->
447 4a92cb37 Arnaud Dieumegard
            let label = self#lower_vhdl_name_t label  in
448 5bbf7413 Arnaud Dieumegard
            let guard = self#vhdl_expr_t guard  in
449
            let branches = self#list self#vhdl_case_item_t branches  in
450
            Case { label; guard; branches }
451
        | Exit { label; loop_label; condition } ->
452 4a92cb37 Arnaud Dieumegard
            let label = self#lower_vhdl_name_t label  in
453 5bbf7413 Arnaud Dieumegard
            let loop_label = self#option self#string loop_label  in
454
            let condition = self#option self#vhdl_expr_t condition  in
455
            Exit { label; loop_label; condition }
456
        | Assert { label; cond; report; severity } ->
457 4a92cb37 Arnaud Dieumegard
            let label = self#lower_vhdl_name_t label  in
458 5bbf7413 Arnaud Dieumegard
            let cond = self#vhdl_expr_t cond  in
459
            let report = self#vhdl_expr_t report  in
460
            let severity = self#vhdl_expr_t severity  in
461
            Assert { label; cond; report; severity }
462
        | ProcedureCall { label; name; assocs } ->
463 4a92cb37 Arnaud Dieumegard
            let label = self#lower_vhdl_name_t label  in
464
            let name = self#lower_vhdl_name_t name  in
465 5bbf7413 Arnaud Dieumegard
            let assocs = self#list self#vhdl_assoc_element_t assocs  in
466
            ProcedureCall { label; name; assocs }
467
        | Wait  -> Wait
468
        | Null { label } ->
469 4a92cb37 Arnaud Dieumegard
            let label = self#lower_vhdl_name_t label  in Null { label }
470 5bbf7413 Arnaud Dieumegard
        | Return { label; expr } ->
471 4a92cb37 Arnaud Dieumegard
            let label = self#option self#lower_vhdl_name_t label  in
472 5bbf7413 Arnaud Dieumegard
            let expr = self#option self#vhdl_expr_t expr in
473
            Return { label; expr }
474 4a92cb37 Arnaud Dieumegard
475 5bbf7413 Arnaud Dieumegard
    method vhdl_if_case_t : vhdl_if_case_t -> vhdl_if_case_t=
476
      fun { if_cond; if_block }  ->
477
        let if_cond = self#vhdl_expr_t if_cond  in
478
        let if_block = self#list self#vhdl_sequential_stmt_t if_block  in
479
        { if_cond; if_block }
480 4a92cb37 Arnaud Dieumegard
481 5bbf7413 Arnaud Dieumegard
    method vhdl_case_item_t : vhdl_case_item_t -> vhdl_case_item_t=
482
      fun { when_cond; when_stmt }  ->
483
        let when_cond = self#list self#vhdl_expr_t when_cond  in
484
        let when_stmt = self#list self#vhdl_sequential_stmt_t when_stmt  in
485
        { when_cond; when_stmt }
486
487
    method vhdl_declaration_t : vhdl_declaration_t -> vhdl_declaration_t=
488
      fun x  ->
489
        match x with
490
        | VarDecl { names; typ; init_val } ->
491 4a92cb37 Arnaud Dieumegard
            let names = self#list self#lower_vhdl_name_t names  in
492 5bbf7413 Arnaud Dieumegard
            let typ = self#vhdl_subtype_indication_t typ  in
493
            let init_val = self#vhdl_expr_t init_val  in
494
            VarDecl { names; typ; init_val }
495
        | CstDecl { names; typ; init_val } ->
496 4a92cb37 Arnaud Dieumegard
            let names = self#list self#lower_vhdl_name_t names  in
497 5bbf7413 Arnaud Dieumegard
            let typ = self#vhdl_subtype_indication_t typ  in
498
            let init_val = self#vhdl_expr_t init_val  in
499
            CstDecl { names; typ; init_val }
500
        | SigDecl { names; typ; init_val } ->
501 4a92cb37 Arnaud Dieumegard
            let names = self#list self#lower_vhdl_name_t names  in
502 5bbf7413 Arnaud Dieumegard
            let typ = self#vhdl_subtype_indication_t typ  in
503
            let init_val = self#vhdl_expr_t init_val  in
504
            SigDecl { names; typ; init_val }
505
        | ComponentDecl { name; generics; ports } ->
506 4a92cb37 Arnaud Dieumegard
            let name = self#lower_vhdl_name_t name  in
507 5bbf7413 Arnaud Dieumegard
            let generics = self#list self#vhdl_port_t generics  in
508
            let ports = self#list self#vhdl_port_t ports  in
509
            ComponentDecl { name; generics; ports }
510
        | Subprogram { spec; decl_part; stmts } ->
511
            let spec = self#vhdl_subprogram_spec_t spec  in
512
            let decl_part = self#list self#vhdl_declaration_t decl_part  in
513
            let stmts = self#list self#vhdl_sequential_stmt_t stmts  in
514
            Subprogram { spec; decl_part; stmts }
515
516
    method vhdl_declarative_item_t :
517
      vhdl_declarative_item_t -> vhdl_declarative_item_t=
518
      fun { use_clause; declaration; definition }  ->
519
        let use_clause = self#option self#vhdl_load_t use_clause  in
520
        let declaration = self#option self#vhdl_declaration_t declaration  in
521
        let definition = self#option self#vhdl_definition_t definition  in
522
        { use_clause; declaration; definition }
523
524
    method vhdl_waveform_element_t :
525
      vhdl_waveform_element_t -> vhdl_waveform_element_t=
526
      fun { value; delay }  ->
527
        let value = self#option self#vhdl_expr_t value  in
528
        let delay = self#option self#vhdl_expr_t delay  in { value; delay }
529
530
    method vhdl_signal_condition_t :
531
      vhdl_signal_condition_t -> vhdl_signal_condition_t=
532
      fun { expr; cond }  ->
533
        let expr = self#list self#vhdl_waveform_element_t expr  in
534
        let cond = self#option self#vhdl_expr_t cond  in { expr; cond }
535
536
    method vhdl_signal_selection_t :
537
      vhdl_signal_selection_t -> vhdl_signal_selection_t=
538
      fun { expr; when_sel }  ->
539
        let expr = self#list self#vhdl_waveform_element_t expr  in
540
        let when_sel = self#list self#vhdl_expr_t when_sel  in
541
        { expr; when_sel }
542
543
    method vhdl_conditional_signal_t :
544
      vhdl_conditional_signal_t -> vhdl_conditional_signal_t=
545
      fun { postponed; label; lhs; rhs; delay }  ->
546
        let postponed = self#bool postponed  in
547 4a92cb37 Arnaud Dieumegard
        let label = self#lower_vhdl_name_t label  in
548
        let lhs = self#lower_vhdl_name_t lhs  in
549 5bbf7413 Arnaud Dieumegard
        let rhs = self#list self#vhdl_signal_condition_t rhs  in
550
        let delay = self#vhdl_expr_t delay  in
551
        { postponed; label; lhs; rhs; delay }
552
553
    method vhdl_process_t : vhdl_process_t -> vhdl_process_t=
554
      fun { id; declarations; active_sigs; body }  ->
555 4a92cb37 Arnaud Dieumegard
        let id = self#lower_vhdl_name_t id  in
556 5bbf7413 Arnaud Dieumegard
        let declarations = self#list self#vhdl_declarative_item_t declarations  in
557 4a92cb37 Arnaud Dieumegard
        let active_sigs = self#list self#lower_vhdl_name_t active_sigs  in
558 5bbf7413 Arnaud Dieumegard
        let body = self#list self#vhdl_sequential_stmt_t body  in
559
        { id; declarations; active_sigs; body }
560
561
    method vhdl_selected_signal_t :
562
      vhdl_selected_signal_t -> vhdl_selected_signal_t=
563
      fun { postponed; label; lhs; sel; branches; delay }  ->
564
        let postponed = self#bool postponed  in
565 4a92cb37 Arnaud Dieumegard
        let label = self#lower_vhdl_name_t label  in
566
        let lhs = self#lower_vhdl_name_t lhs  in
567 5bbf7413 Arnaud Dieumegard
        let sel = self#vhdl_expr_t sel  in
568
        let branches = self#list self#vhdl_signal_selection_t branches  in
569
        let delay = self#option self#vhdl_expr_t delay  in
570
        { postponed; label; lhs; sel; branches; delay }
571
572
    method vhdl_port_mode_t : vhdl_port_mode_t -> vhdl_port_mode_t=
573
      fun x  -> x
574
575
    method vhdl_component_instantiation_t :
576 76f9de64 Arnaud Dieumegard
      vhdl_component_instantiation_t -> mini_vhdl_component_instantiation_t=
577 5bbf7413 Arnaud Dieumegard
        fun { name; inst_unit; inst_unit_type; archi_name; generic_map; port_map }  ->
578 4a92cb37 Arnaud Dieumegard
        let name = self#lower_vhdl_name_t name  in
579
        let archi_name = self#option self#lower_vhdl_name_t archi_name  in
580
        let inst_unit = self#lower_vhdl_name_t inst_unit in
581 76f9de64 Arnaud Dieumegard
        let db_tuple = match archi_name with
582 4a92cb37 Arnaud Dieumegard
          | None -> failwith ("Component [" ^ self#to_string_vhdl_name_t name ^ "] is not an entity")
583
          | Some a -> self#get_tuple_from_archi_and_entity_name (a, inst_unit) in (* Get corresponding tuple in db *)
584 76f9de64 Arnaud Dieumegard
        let archi = db_tuple.architecture in
585
        let entity = db_tuple.entity in
586 5bbf7413 Arnaud Dieumegard
        let generic_map = self#list self#vhdl_assoc_element_t generic_map  in
587
        let port_map = self#list self#vhdl_assoc_element_t port_map  in
588 76f9de64 Arnaud Dieumegard
        { name; archi; entity; generic_map; port_map }
589 5bbf7413 Arnaud Dieumegard
590
    method vhdl_concurrent_stmt_t :
591 76f9de64 Arnaud Dieumegard
      vhdl_concurrent_stmt_t -> mini_vhdl_concurrent_stmt_t=
592 5bbf7413 Arnaud Dieumegard
      fun x  ->
593
        match x with
594
        | SigAssign a -> let a = self#vhdl_conditional_signal_t a  in SigAssign a
595
        | Process a -> let a = self#vhdl_process_t a  in Process a
596
        | SelectedSig a -> let a = self#vhdl_selected_signal_t a  in SelectedSig a
597 76f9de64 Arnaud Dieumegard
        | ComponentInst a -> let a = self#vhdl_component_instantiation_t a  in ComponentInst a
598 5bbf7413 Arnaud Dieumegard
599
    method vhdl_port_t : vhdl_port_t -> vhdl_port_t=
600
      fun { names; mode; typ; expr }  ->
601 4a92cb37 Arnaud Dieumegard
        let names = self#list self#lower_vhdl_name_t names  in
602 5bbf7413 Arnaud Dieumegard
        let mode = self#vhdl_port_mode_t mode  in
603
        let typ = self#vhdl_subtype_indication_t typ  in
604
        let expr = self#vhdl_expr_t expr  in { names; mode; typ; expr }
605
606
    method vhdl_entity_t : vhdl_entity_t -> unit =
607 76f9de64 Arnaud Dieumegard
      fun { name; generics; ports; declaration; stmts }  -> ()
608 5bbf7413 Arnaud Dieumegard
609
    method vhdl_package_t : (vhdl_load_t list * vhdl_package_t) -> vhdl_package_t=
610
      fun ( ctxs, {name; shared_defs; shared_decls; shared_uses })  ->
611 4a92cb37 Arnaud Dieumegard
        let name = self#lower_vhdl_name_t name  in
612 5bbf7413 Arnaud Dieumegard
        let shared_defs = self#list self#vhdl_definition_t shared_defs  in
613
        let shared_decls = self#list self#vhdl_declaration_t shared_decls  in
614
        let shared_uses = self#list self#vhdl_load_t shared_uses @ ctxs in
615
        { name; shared_defs; shared_decls; shared_uses }
616
617
    method vhdl_load_t : vhdl_load_t -> vhdl_load_t=
618
      fun x  ->
619
        match x with
620 4a92cb37 Arnaud Dieumegard
        | Library a -> let a = self#list self#lower_vhdl_name_t a  in Library a
621
        | Use a -> let a = self#list self#lower_vhdl_name_t a  in Use a
622 5bbf7413 Arnaud Dieumegard
623
    method vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list *
624
                                  (vhdl_load_t list * vhdl_entity_t) list * 
625
                                  (vhdl_load_t list * vhdl_configuration_t) list *
626
                                  (vhdl_load_t list * vhdl_architecture_t)) -> mini_vhdl_component_t=
627
        fun ( packs_pairs, ents_pairs, confs_pairs, (arch_ctx, arch) ) ->
628
        let names = arch.name::(arch.entity::[])  in
629
        let (ref_ent_ctx,ref_ent) = self#filter_entity (ents_pairs, arch.entity) in
630 4a92cb37 Arnaud Dieumegard
        self#db_add_tuple {entity=ref_ent; architecture=arch; architecture_signals_names=[]; contexts=ref_ent_ctx@arch_ctx};
631 5bbf7413 Arnaud Dieumegard
        let contexts =
632 3340aff0 Arnaud Dieumegard
          ref_ent_ctx @ (* Referenced entity context elements *)
633 76f9de64 Arnaud Dieumegard
          arch_ctx @ (* Architecture context elements *)
634
          self#declarative_items_uses ref_ent.declaration @ (* Referenced entity inner context elements *)
635
          self#declarative_items_uses arch.declarations in (* Architecture inner context elements *)
636 5bbf7413 Arnaud Dieumegard
        let declarations = 
637 76f9de64 Arnaud Dieumegard
          self#declarative_items_declarations ref_ent.declaration @ (* Referenced entity inner declarations *)
638
          self#declarative_items_declarations arch.declarations in (* Architecture inner declarations *)
639 5bbf7413 Arnaud Dieumegard
        let definitions =
640 76f9de64 Arnaud Dieumegard
          self#declarative_items_definitions ref_ent.declaration @ (* Referenced entity inner definitions *)
641
          self#declarative_items_definitions arch.declarations in (* Architecture inner definitions *)
642 5bbf7413 Arnaud Dieumegard
        let body = 
643 76f9de64 Arnaud Dieumegard
          List.map self#vhdl_concurrent_stmt_t ref_ent.stmts @ (* Referenced entity concurrent statement *)
644
          List.map self#vhdl_concurrent_stmt_t arch.body in (* Architecture concurrent statements *)
645 3340aff0 Arnaud Dieumegard
        let generics = ref_ent.generics in (* Referenced entity generics *)
646 4a37b02a Arnaud Dieumegard
        let ports = ref_ent.ports in (* Referenced entity ports *)
647 4a92cb37 Arnaud Dieumegard
        (* Add declarations names in db *)
648 3340aff0 Arnaud Dieumegard
        { names; generics=generics; ports=ports; contexts=contexts; declarations=declarations; definitions=definitions; body=body }
649 5bbf7413 Arnaud Dieumegard
650
    method declarative_items_declarations : vhdl_declarative_item_t list -> vhdl_declaration_t list =
651
      fun x ->
652
        let rec map_decls l = match l with
653
        | {use_clause=_; declaration=Some a;definition=_}::tl -> a::map_decls tl
654
        | _::tl -> map_decls tl
655
        | [] -> [] in map_decls x
656
657
    method declarative_items_definitions : vhdl_declarative_item_t list -> vhdl_definition_t list =
658
      fun x ->
659
        let rec map_decls l = match l with
660
        | {use_clause=_; declaration=_;definition=Some a}::tl -> a::map_decls tl
661
        | _::tl -> map_decls tl
662
        | [] -> [] in map_decls x
663
664
    method declarative_items_uses : vhdl_declarative_item_t list -> vhdl_load_t list =
665
      fun x ->
666
        let rec map_decls l = match l with
667
        | {use_clause=Some a; declaration=_;definition=_}::tl -> a::map_decls tl
668
        | _::tl -> map_decls tl
669
        | [] -> [] in map_decls x
670
671
    method filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) -> 
672
                           (vhdl_load_t list * vhdl_entity_t) =
673
      fun ( entities_pair, filter_name ) ->
674
      let rec filter ep n = match ep with
675 4a92cb37 Arnaud Dieumegard
      | [] -> failwith ("Impossible to find an entity with name [" ^ self#to_string_vhdl_name_t filter_name ^ "]")
676 5bbf7413 Arnaud Dieumegard
      | (c,{name; generics; ports; declaration;stmts})::tl -> 
677
          if (name = n) then 
678
            List.hd ep
679
          else filter (List.tl ep) n in
680
      filter entities_pair filter_name
681
682
    method vhdl_configuration_t :
683
      vhdl_configuration_t -> unit= self#unit
684
685
    method vhdl_library_unit_t : vhdl_library_unit_t -> unit=
686 76f9de64 Arnaud Dieumegard
      fun x  -> ()
687 5bbf7413 Arnaud Dieumegard
688
    method vhdl_design_unit_t : vhdl_design_unit_t -> unit=
689 76f9de64 Arnaud Dieumegard
      fun { contexts; library }  -> ()
690 5bbf7413 Arnaud Dieumegard
691
    method vhdl_design_file_t : vhdl_design_file_t -> mini_vhdl_design_file_t=
692
      fun { design_units }  ->
693
        let rec inline_df l packs ents archs confs = match l with
694
          | [] -> (List.rev packs, List.rev ents, List.rev archs, List.rev confs)
695
          | {contexts = c; library = lib}::tl -> match lib with
696
            | Package p -> inline_df tl ((c,p)::packs) ents archs confs
697
            | Entities e -> inline_df tl packs ((c,e)::ents) archs confs
698
            | Architecture a -> inline_df tl packs ents ((c,a)::archs) confs
699
            | Configuration conf -> inline_df tl packs ents archs ((c,conf)::confs) in
700
        let (p,e,a,con) = inline_df design_units [] [] [] [] in
701
        let app x = self#vhdl_architecture_t (p,e,con,x) in
702
        let components = List.map app a in
703
        let packages = List.map self#vhdl_package_t p in
704
        { components; packages }
705
706
  end