Project

General

Profile

Download (31.3 KB) Statistics
| Branch: | Tag: | Revision:
1
open Vhdl_ast
2
open Mini_vhdl_ast
3

    
4
type db_tuple_t =
5
  {
6
    mutable entity: vhdl_entity_t;
7
    mutable architecture: vhdl_architecture_t;
8
    mutable contexts: vhdl_load_t list;
9
  }
10

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

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

    
91
    method virtual  vhdl_package_t : (vhdl_load_t list * vhdl_package_t) -> vhdl_package_t
92
    method virtual  vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list *
93
                                  (vhdl_load_t list * vhdl_entity_t) list * 
94
                                  (vhdl_load_t list * vhdl_configuration_t) list *
95
                                  (vhdl_load_t list * vhdl_architecture_t)) -> mini_vhdl_component_t
96
    method virtual  vhdl_component_instantiation_t : vhdl_component_instantiation_t -> mini_vhdl_component_instantiation_t
97
    method virtual  declarative_items_declarations : vhdl_declarative_item_t list -> vhdl_declaration_t list
98
    method virtual  declarative_items_definitions : vhdl_declarative_item_t list -> vhdl_definition_t list
99
    method virtual  declarative_items_uses : vhdl_declarative_item_t list -> vhdl_load_t list
100
    method virtual  filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) -> 
101
                           (vhdl_load_t list * vhdl_entity_t)
102

    
103
    val mutable db : db_tuple_t list = []
104

    
105
    method simplify_name_t : vhdl_name_t -> vhdl_name_t=
106
      fun n ->
107
        match n with
108
        | Selected (NoName::tl) -> self#simplify_name_t (Selected tl)
109
        | Selected ((Simple (s))::tl) ->  if (s = "work" || s= "Work") 
110
                                          then self#simplify_name_t (Selected tl)
111
                                          else n
112
        | Selected (a::[]) -> a
113
        | _ -> n
114
    
115
    method db_add_tuple : db_tuple_t -> unit=
116
      fun x -> db <- x::db
117

    
118
    method db_get : vhdl_architecture_t -> (vhdl_entity_t * vhdl_load_t list)=
119
      fun x ->
120
        let rec find a dbl =
121
          match dbl with
122
          | [] -> failwith "No matching tuple in DB"
123
          | e::tl -> if (e.architecture = a) then (e.entity, e.contexts) else find a tl in find x db
124

    
125
    method get_get_from_archi_entity_name : (vhdl_name_t * vhdl_name_t) -> db_tuple_t=
126
      fun (a_name,e_name) ->
127
        let rec find (a_name,e_name) dbl =
128
          match dbl with
129
          | [] -> failwith "No matching tuple in DB"
130
          | e::tl -> if ((self#simplify_name_t e.architecture.name = self#simplify_name_t a_name) && (self#simplify_name_t e.entity.name = self#simplify_name_t e_name)) 
131
                      then e 
132
                      else find (a_name,e_name) tl in 
133
        find (a_name,e_name) db
134

    
135
    method vhdl_cst_val_t : vhdl_cst_val_t -> vhdl_cst_val_t=
136
      fun x  ->
137
        match x with
138
        | CstInt a -> let a = self#int a  in CstInt a
139
        | CstStdLogic a -> let a = self#string a  in CstStdLogic a
140
        | CstLiteral a -> let a = self#string a  in CstLiteral a
141

    
142
    method vhdl_type_t : vhdl_type_t -> vhdl_type_t=
143
      fun x  ->
144
        match x with
145
        | Base a -> let a = self#string a  in Base a
146
        | Range (a,b,c) ->
147
            let a = self#option self#string a  in
148
            let b = self#int b  in let c = self#int c  in Range (a, b, c)
149
        | Bit_vector (a,b) ->
150
            let a = self#int a  in let b = self#int b  in Bit_vector (a, b)
151
        | Array { indexes; const; definition } ->
152
            let indexes = self#list self#vhdl_name_t indexes  in
153
            let const = self#option self#vhdl_constraint_t const  in
154
            let definition = self#vhdl_subtype_indication_t definition  in
155
            Array { indexes; const; definition }
156
        | Record a ->
157
            let a = self#list self#vhdl_element_declaration_t a  in Record a
158
        | Enumerated a ->
159
            let a = self#list self#vhdl_name_t a  in Enumerated a
160
        | Void  -> Void
161
    method vhdl_element_declaration_t :
162
      vhdl_element_declaration_t -> vhdl_element_declaration_t=
163
      fun { names; definition }  ->
164
        let names = self#list self#vhdl_name_t names  in
165
        let definition = self#vhdl_subtype_indication_t definition  in
166
        { names; definition }
167
    method vhdl_subtype_indication_t :
168
      vhdl_subtype_indication_t -> vhdl_subtype_indication_t=
169
      fun { name; functionName; const }  ->
170
        let name = self#vhdl_name_t name  in
171
        let functionName = self#vhdl_name_t functionName  in
172
        let const = self#vhdl_constraint_t const  in
173
        { name; functionName; const }
174
    method vhdl_discrete_range_t :
175
      vhdl_discrete_range_t -> vhdl_discrete_range_t=
176
      fun x  ->
177
        match x with
178
        | SubDiscreteRange a ->
179
            let a = self#vhdl_subtype_indication_t a  in SubDiscreteRange a
180
        | NamedRange a -> let a = self#vhdl_name_t a  in NamedRange a
181
        | DirectedRange { direction; from; _to } ->
182
            let direction = self#string direction  in
183
            let from = self#vhdl_expr_t from  in
184
            let _to = self#vhdl_expr_t _to  in
185
            DirectedRange { direction; from; _to }
186

    
187
    method vhdl_constraint_t : vhdl_constraint_t -> vhdl_constraint_t=
188
      fun x  ->
189
        match x with
190
        | RefConstraint { ref_name } ->
191
            let ref_name = self#vhdl_name_t ref_name  in
192
            RefConstraint { ref_name }
193
        | RangeConstraint { range } ->
194
            let range = self#vhdl_discrete_range_t range  in
195
            RangeConstraint { range }
196
        | IndexConstraint { ranges } ->
197
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
198
            IndexConstraint { ranges }
199
        | ArrayConstraint { ranges; sub } ->
200
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
201
            let sub = self#vhdl_constraint_t sub  in
202
            ArrayConstraint { ranges; sub }
203
        | RecordConstraint  -> RecordConstraint
204
        | NoConstraint  -> NoConstraint
205

    
206
    method vhdl_definition_t : vhdl_definition_t -> vhdl_definition_t=
207
      fun x  ->
208
        match x with
209
        | Type { name; definition } ->
210
            let name = self#vhdl_name_t name  in
211
            let definition = self#vhdl_type_t definition  in
212
            Type { name; definition }
213
        | Subtype { name; typ } ->
214
            let name = self#vhdl_name_t name  in
215
            let typ = self#vhdl_subtype_indication_t typ  in
216
            Subtype { name; typ }
217
    method vhdl_expr_t : vhdl_expr_t -> vhdl_expr_t=
218
      fun x  ->
219
        match x with
220
        | Call a -> let a = self#vhdl_name_t a  in Call a
221
        | Cst { value; unit_name } ->
222
            let value = self#vhdl_cst_val_t value  in
223
            let unit_name = self#option self#vhdl_name_t unit_name  in
224
            Cst { value; unit_name }
225
        | Op { id; args } ->
226
            let id = self#string id  in
227
            let args = self#list self#vhdl_expr_t args  in Op { id; args }
228
        | IsNull  -> IsNull
229
        | Time { value; phy_unit } ->
230
            let value = self#int value  in
231
            let phy_unit = self#string phy_unit  in Time { value; phy_unit }
232
        | Sig { name; att } ->
233
            let name = self#vhdl_name_t name  in
234
            let att = self#option self#vhdl_signal_attributes_t att  in
235
            Sig { name; att }
236
        | SuffixMod { expr; selection } ->
237
            let expr = self#vhdl_expr_t expr  in
238
            let selection = self#vhdl_suffix_selection_t selection  in
239
            SuffixMod { expr; selection }
240
        | Aggregate { elems } ->
241
            let elems = self#list self#vhdl_element_assoc_t elems  in
242
            Aggregate { elems }
243
        | QualifiedExpression { type_mark; aggregate; expression } ->
244
            let type_mark = self#vhdl_name_t type_mark  in
245
            let aggregate = self#list self#vhdl_element_assoc_t aggregate  in
246
            let expression = self#option self#vhdl_expr_t expression  in
247
            QualifiedExpression { type_mark; aggregate; expression }
248
        | Others  -> Others
249
    method vhdl_name_t : vhdl_name_t -> vhdl_name_t=
250
      fun x  ->
251
        match x with
252
        | Simple a -> let a = self#string a  in Simple a
253
        | Identifier a -> let a = self#string a  in Identifier a
254
        | Selected a -> let a = self#list self#vhdl_name_t a  in Selected a
255
        | Index { id; exprs } ->
256
            let id = self#vhdl_name_t id  in
257
            let exprs = self#list self#vhdl_expr_t exprs  in
258
            Index { id; exprs }
259
        | Slice { id; range } ->
260
            let id = self#vhdl_name_t id  in
261
            let range = self#vhdl_discrete_range_t range  in
262
            Slice { id; range }
263
        | Attribute { id; designator; expr } ->
264
            let id = self#vhdl_name_t id  in
265
            let designator = self#vhdl_name_t designator  in
266
            let expr = self#vhdl_expr_t expr  in
267
            Attribute { id; designator; expr }
268
        | Function { id; assoc_list } ->
269
            let id = self#vhdl_name_t id  in
270
            let assoc_list = self#list self#vhdl_assoc_element_t assoc_list
271
               in
272
            Function { id; assoc_list }
273
        | NoName  -> NoName
274
    method vhdl_assoc_element_t :
275
      vhdl_assoc_element_t -> vhdl_assoc_element_t=
276
      fun
277
        { formal_name; formal_arg; actual_name; actual_designator;
278
          actual_expr }
279
         ->
280
        let formal_name = self#option self#vhdl_name_t formal_name  in
281
        let formal_arg = self#option self#vhdl_name_t formal_arg  in
282
        let actual_name = self#option self#vhdl_name_t actual_name  in
283
        let actual_designator =
284
          self#option self#vhdl_name_t actual_designator  in
285
        let actual_expr = self#option self#vhdl_expr_t actual_expr  in
286
        {
287
          formal_name;
288
          formal_arg;
289
          actual_name;
290
          actual_designator;
291
          actual_expr
292
        }
293
    method vhdl_element_assoc_t :
294
      vhdl_element_assoc_t -> vhdl_element_assoc_t=
295
      fun { choices; expr }  ->
296
        let choices = self#list self#vhdl_expr_t choices  in
297
        let expr = self#vhdl_expr_t expr  in { choices; expr }
298
    method vhdl_array_attributes_t :
299
      vhdl_array_attributes_t -> vhdl_array_attributes_t=
300
      fun x  ->
301
        match x with
302
        | AAttInt { id; arg } ->
303
            let id = self#string id  in
304
            let arg = self#int arg  in AAttInt { id; arg }
305
        | AAttAscending  -> AAttAscending
306
    method vhdl_signal_attributes_t :
307
      vhdl_signal_attributes_t -> vhdl_signal_attributes_t=
308
      fun x  -> match x with | SigAtt a -> let a = self#string a  in SigAtt a
309
    method vhdl_string_attributes_t :
310
      vhdl_string_attributes_t -> vhdl_string_attributes_t=
311
      fun x  ->
312
        match x with | StringAtt a -> let a = self#string a  in StringAtt a
313
    method vhdl_suffix_selection_t : vhdl_suffix_selection_t -> vhdl_suffix_selection_t=
314
      fun x  ->
315
        match x with
316
        | Idx a -> let a = self#int a  in Idx a
317
        | SuffixRange (a,b) ->
318
            let a = self#int a  in let b = self#int b  in SuffixRange (a, b)
319

    
320
    method vhdl_type_attributes_t :
321
      'a .
322
        ('a -> 'a) -> 'a vhdl_type_attributes_t -> 'a vhdl_type_attributes_t=
323
      fun _basetype  ->
324
        fun x  ->
325
          match x with
326
          | TAttNoArg { id } -> let id = self#string id  in TAttNoArg { id }
327
          | TAttIntArg { id; arg } ->
328
              let id = self#string id  in
329
              let arg = self#int arg  in TAttIntArg { id; arg }
330
          | TAttValArg { id; arg } ->
331
              let id = self#string id  in
332
              let arg = _basetype arg  in TAttValArg { id; arg }
333
          | TAttStringArg { id; arg } ->
334
              let id = self#string id  in
335
              let arg = self#string arg  in TAttStringArg { id; arg }
336

    
337
    method vhdl_parameter_t : vhdl_parameter_t -> vhdl_parameter_t=
338
      fun { names; mode; typ; init_val }  ->
339
        let names = self#list self#vhdl_name_t names  in
340
        let mode = self#list self#string mode  in
341
        let typ = self#vhdl_subtype_indication_t typ  in
342
        let init_val = self#option self#vhdl_cst_val_t init_val  in
343
        { names; mode; typ; init_val }
344

    
345
    method vhdl_subprogram_spec_t :
346
      vhdl_subprogram_spec_t -> vhdl_subprogram_spec_t=
347
      fun { name; subprogram_type; typeMark; parameters; isPure }  ->
348
        let name = self#string name  in
349
        let subprogram_type = self#string subprogram_type  in
350
        let typeMark = self#vhdl_name_t typeMark  in
351
        let parameters = self#list self#vhdl_parameter_t parameters  in
352
        let isPure = self#bool isPure  in
353
        { name; subprogram_type; typeMark; parameters; isPure }
354

    
355
    method vhdl_sequential_stmt_t :
356
      vhdl_sequential_stmt_t -> vhdl_sequential_stmt_t=
357
      fun x  ->
358
        match x with
359
        | VarAssign { label; lhs; rhs } ->
360
            let label = self#vhdl_name_t label  in
361
            let lhs = self#vhdl_name_t lhs  in
362
            let rhs = self#vhdl_expr_t rhs  in VarAssign { label; lhs; rhs }
363
        | SigSeqAssign { label; lhs; rhs } ->
364
            let label = self#vhdl_name_t label  in
365
            let lhs = self#vhdl_name_t lhs  in
366
            let rhs = self#list self#vhdl_waveform_element_t rhs  in
367
            SigSeqAssign { label; lhs; rhs }
368
        | If { label; if_cases; default } ->
369
            let label = self#vhdl_name_t label  in
370
            let if_cases = self#list self#vhdl_if_case_t if_cases  in
371
            let default = self#list self#vhdl_sequential_stmt_t default  in
372
            If { label; if_cases; default }
373
        | Case { label; guard; branches } ->
374
            let label = self#vhdl_name_t label  in
375
            let guard = self#vhdl_expr_t guard  in
376
            let branches = self#list self#vhdl_case_item_t branches  in
377
            Case { label; guard; branches }
378
        | Exit { label; loop_label; condition } ->
379
            let label = self#vhdl_name_t label  in
380
            let loop_label = self#option self#string loop_label  in
381
            let condition = self#option self#vhdl_expr_t condition  in
382
            Exit { label; loop_label; condition }
383
        | Assert { label; cond; report; severity } ->
384
            let label = self#vhdl_name_t label  in
385
            let cond = self#vhdl_expr_t cond  in
386
            let report = self#vhdl_expr_t report  in
387
            let severity = self#vhdl_expr_t severity  in
388
            Assert { label; cond; report; severity }
389
        | ProcedureCall { label; name; assocs } ->
390
            let label = self#vhdl_name_t label  in
391
            let name = self#vhdl_name_t name  in
392
            let assocs = self#list self#vhdl_assoc_element_t assocs  in
393
            ProcedureCall { label; name; assocs }
394
        | Wait  -> Wait
395
        | Null { label } ->
396
            let label = self#vhdl_name_t label  in Null { label }
397
        | Return { label; expr } ->
398
            let label = self#option self#vhdl_name_t label  in
399
            let expr = self#option self#vhdl_expr_t expr in
400
            Return { label; expr }
401
    method vhdl_if_case_t : vhdl_if_case_t -> vhdl_if_case_t=
402
      fun { if_cond; if_block }  ->
403
        let if_cond = self#vhdl_expr_t if_cond  in
404
        let if_block = self#list self#vhdl_sequential_stmt_t if_block  in
405
        { if_cond; if_block }
406
    method vhdl_case_item_t : vhdl_case_item_t -> vhdl_case_item_t=
407
      fun { when_cond; when_stmt }  ->
408
        let when_cond = self#list self#vhdl_expr_t when_cond  in
409
        let when_stmt = self#list self#vhdl_sequential_stmt_t when_stmt  in
410
        { when_cond; when_stmt }
411

    
412
    method vhdl_declaration_t : vhdl_declaration_t -> vhdl_declaration_t=
413
      fun x  ->
414
        match x with
415
        | VarDecl { names; typ; init_val } ->
416
            let names = self#list self#vhdl_name_t names  in
417
            let typ = self#vhdl_subtype_indication_t typ  in
418
            let init_val = self#vhdl_expr_t init_val  in
419
            VarDecl { names; typ; init_val }
420
        | CstDecl { names; typ; init_val } ->
421
            let names = self#list self#vhdl_name_t names  in
422
            let typ = self#vhdl_subtype_indication_t typ  in
423
            let init_val = self#vhdl_expr_t init_val  in
424
            CstDecl { names; typ; init_val }
425
        | SigDecl { names; typ; init_val } ->
426
            let names = self#list self#vhdl_name_t names  in
427
            let typ = self#vhdl_subtype_indication_t typ  in
428
            let init_val = self#vhdl_expr_t init_val  in
429
            SigDecl { names; typ; init_val }
430
        | ComponentDecl { name; generics; ports } ->
431
            let name = self#vhdl_name_t name  in
432
            let generics = self#list self#vhdl_port_t generics  in
433
            let ports = self#list self#vhdl_port_t ports  in
434
            ComponentDecl { name; generics; ports }
435
        | Subprogram { spec; decl_part; stmts } ->
436
            let spec = self#vhdl_subprogram_spec_t spec  in
437
            let decl_part = self#list self#vhdl_declaration_t decl_part  in
438
            let stmts = self#list self#vhdl_sequential_stmt_t stmts  in
439
            Subprogram { spec; decl_part; stmts }
440

    
441
    method vhdl_declarative_item_t :
442
      vhdl_declarative_item_t -> vhdl_declarative_item_t=
443
      fun { use_clause; declaration; definition }  ->
444
        let use_clause = self#option self#vhdl_load_t use_clause  in
445
        let declaration = self#option self#vhdl_declaration_t declaration  in
446
        let definition = self#option self#vhdl_definition_t definition  in
447
        { use_clause; declaration; definition }
448

    
449
    method vhdl_waveform_element_t :
450
      vhdl_waveform_element_t -> vhdl_waveform_element_t=
451
      fun { value; delay }  ->
452
        let value = self#option self#vhdl_expr_t value  in
453
        let delay = self#option self#vhdl_expr_t delay  in { value; delay }
454

    
455
    method vhdl_signal_condition_t :
456
      vhdl_signal_condition_t -> vhdl_signal_condition_t=
457
      fun { expr; cond }  ->
458
        let expr = self#list self#vhdl_waveform_element_t expr  in
459
        let cond = self#option self#vhdl_expr_t cond  in { expr; cond }
460

    
461
    method vhdl_signal_selection_t :
462
      vhdl_signal_selection_t -> vhdl_signal_selection_t=
463
      fun { expr; when_sel }  ->
464
        let expr = self#list self#vhdl_waveform_element_t expr  in
465
        let when_sel = self#list self#vhdl_expr_t when_sel  in
466
        { expr; when_sel }
467

    
468
    method vhdl_conditional_signal_t :
469
      vhdl_conditional_signal_t -> vhdl_conditional_signal_t=
470
      fun { postponed; label; lhs; rhs; delay }  ->
471
        let postponed = self#bool postponed  in
472
        let label = self#vhdl_name_t label  in
473
        let lhs = self#vhdl_name_t lhs  in
474
        let rhs = self#list self#vhdl_signal_condition_t rhs  in
475
        let delay = self#vhdl_expr_t delay  in
476
        { postponed; label; lhs; rhs; delay }
477

    
478
    method vhdl_process_t : vhdl_process_t -> vhdl_process_t=
479
      fun { id; declarations; active_sigs; body }  ->
480
        let id = self#vhdl_name_t id  in
481
        let declarations = self#list self#vhdl_declarative_item_t declarations  in
482
        let active_sigs = self#list self#vhdl_name_t active_sigs  in
483
        let body = self#list self#vhdl_sequential_stmt_t body  in
484
        { id; declarations; active_sigs; body }
485

    
486
    method vhdl_selected_signal_t :
487
      vhdl_selected_signal_t -> vhdl_selected_signal_t=
488
      fun { postponed; label; lhs; sel; branches; delay }  ->
489
        let postponed = self#bool postponed  in
490
        let label = self#vhdl_name_t label  in
491
        let lhs = self#vhdl_name_t lhs  in
492
        let sel = self#vhdl_expr_t sel  in
493
        let branches = self#list self#vhdl_signal_selection_t branches  in
494
        let delay = self#option self#vhdl_expr_t delay  in
495
        { postponed; label; lhs; sel; branches; delay }
496

    
497
    method vhdl_port_mode_t : vhdl_port_mode_t -> vhdl_port_mode_t=
498
      fun x  -> x
499

    
500
    method vhdl_component_instantiation_t :
501
      vhdl_component_instantiation_t -> mini_vhdl_component_instantiation_t=
502
        fun { name; inst_unit; inst_unit_type; archi_name; generic_map; port_map }  ->
503
        let name = self#vhdl_name_t name  in
504
        let archi_name = self#option self#vhdl_name_t archi_name  in
505
        let db_tuple = match archi_name with
506
          | None -> failwith "Component is not an entity" 
507
          | Some a -> self#get_get_from_archi_entity_name (a,inst_unit) in (* Get corresponding tuple in db *)
508
        let archi = db_tuple.architecture in
509
        let entity = db_tuple.entity in
510
        let generic_map = self#list self#vhdl_assoc_element_t generic_map  in
511
        let port_map = self#list self#vhdl_assoc_element_t port_map  in
512
        { name; archi; entity; generic_map; port_map }
513

    
514
    method vhdl_concurrent_stmt_t :
515
      vhdl_concurrent_stmt_t -> mini_vhdl_concurrent_stmt_t=
516
      fun x  ->
517
        match x with
518
        | SigAssign a -> let a = self#vhdl_conditional_signal_t a  in SigAssign a
519
        | Process a -> let a = self#vhdl_process_t a  in Process a
520
        | SelectedSig a -> let a = self#vhdl_selected_signal_t a  in SelectedSig a
521
        | ComponentInst a -> let a = self#vhdl_component_instantiation_t a  in ComponentInst a
522

    
523
    method vhdl_port_t : vhdl_port_t -> vhdl_port_t=
524
      fun { names; mode; typ; expr }  ->
525
        let names = self#list self#vhdl_name_t names  in
526
        let mode = self#vhdl_port_mode_t mode  in
527
        let typ = self#vhdl_subtype_indication_t typ  in
528
        let expr = self#vhdl_expr_t expr  in { names; mode; typ; expr }
529

    
530
    method vhdl_entity_t : vhdl_entity_t -> unit =
531
      fun { name; generics; ports; declaration; stmts }  -> ()
532
(*        let name = self#vhdl_name_t name  in
533
        let generics = self#list self#vhdl_port_t generics  in
534
        let ports = self#list self#vhdl_port_t ports  in
535
        let declaration = self#list self#vhdl_declarative_item_t declaration
536
           in
537
        let stmts = self#list self#vhdl_concurrent_stmt_t stmts  in () *)
538

    
539
        
540

    
541
    method vhdl_package_t : (vhdl_load_t list * vhdl_package_t) -> vhdl_package_t=
542
      fun ( ctxs, {name; shared_defs; shared_decls; shared_uses })  ->
543
        let name = self#vhdl_name_t name  in
544
        let shared_defs = self#list self#vhdl_definition_t shared_defs  in
545
        let shared_decls = self#list self#vhdl_declaration_t shared_decls  in
546
        let shared_uses = self#list self#vhdl_load_t shared_uses @ ctxs in
547
        { name; shared_defs; shared_decls; shared_uses }
548

    
549
    method vhdl_load_t : vhdl_load_t -> vhdl_load_t=
550
      fun x  ->
551
        match x with
552
        | Library a -> let a = self#list self#vhdl_name_t a  in Library a
553
        | Use a -> let a = self#list self#vhdl_name_t a  in Use a
554

    
555
    method vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list *
556
                                  (vhdl_load_t list * vhdl_entity_t) list * 
557
                                  (vhdl_load_t list * vhdl_configuration_t) list *
558
                                  (vhdl_load_t list * vhdl_architecture_t)) -> mini_vhdl_component_t=
559
        fun ( packs_pairs, ents_pairs, confs_pairs, (arch_ctx, arch) ) ->
560
        let names = arch.name::(arch.entity::[])  in
561
        let (ref_ent_ctx,ref_ent) = self#filter_entity (ents_pairs, arch.entity) in
562
        self#db_add_tuple {entity=ref_ent; architecture=arch; contexts=ref_ent_ctx@arch_ctx};
563
        let contexts =
564
          ref_ent_ctx @ (* Referenced entity context elements *)
565
          arch_ctx @ (* Architecture context elements *)
566
          self#declarative_items_uses ref_ent.declaration @ (* Referenced entity inner context elements *)
567
          self#declarative_items_uses arch.declarations in (* Architecture inner context elements *)
568
        let declarations = 
569
          self#declarative_items_declarations ref_ent.declaration @ (* Referenced entity inner declarations *)
570
          self#declarative_items_declarations arch.declarations in (* Architecture inner declarations *)
571
        let definitions =
572
          self#declarative_items_definitions ref_ent.declaration @ (* Referenced entity inner definitions *)
573
          self#declarative_items_definitions arch.declarations in (* Architecture inner definitions *)
574
        let body = 
575
          List.map self#vhdl_concurrent_stmt_t ref_ent.stmts @ (* Referenced entity concurrent statement *)
576
          List.map self#vhdl_concurrent_stmt_t arch.body in (* Architecture concurrent statements *)
577
        let generics = ref_ent.generics in (* Referenced entity generics *)
578
        let ports = ref_ent.ports in (* Referenced entity ports *)
579
        { names; generics=generics; ports=ports; contexts=contexts; declarations=declarations; definitions=definitions; body=body }
580

    
581
    method declarative_items_declarations : vhdl_declarative_item_t list -> vhdl_declaration_t list =
582
      fun x ->
583
        let rec map_decls l = match l with
584
        | {use_clause=_; declaration=Some a;definition=_}::tl -> a::map_decls tl
585
        | _::tl -> map_decls tl
586
        | [] -> [] in map_decls x
587

    
588
    method declarative_items_definitions : vhdl_declarative_item_t list -> vhdl_definition_t list =
589
      fun x ->
590
        let rec map_decls l = match l with
591
        | {use_clause=_; declaration=_;definition=Some a}::tl -> a::map_decls tl
592
        | _::tl -> map_decls tl
593
        | [] -> [] in map_decls x
594

    
595
    method declarative_items_uses : vhdl_declarative_item_t list -> vhdl_load_t list =
596
      fun x ->
597
        let rec map_decls l = match l with
598
        | {use_clause=Some a; declaration=_;definition=_}::tl -> a::map_decls tl
599
        | _::tl -> map_decls tl
600
        | [] -> [] in map_decls x
601

    
602
    method filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) -> 
603
                           (vhdl_load_t list * vhdl_entity_t) =
604
      fun ( entities_pair, filter_name ) ->
605
      let rec filter ep n = match ep with
606
      | [] -> failwith "Impossible to find a matching entity"
607
      | (c,{name; generics; ports; declaration;stmts})::tl -> 
608
          if (name = n) then 
609
            List.hd ep
610
          else filter (List.tl ep) n in
611
      filter entities_pair filter_name
612

    
613
    method vhdl_configuration_t :
614
      vhdl_configuration_t -> unit= self#unit
615

    
616
    method vhdl_library_unit_t : vhdl_library_unit_t -> unit=
617
      fun x  -> ()
618
(*        match x with
619
        | Package a -> let a = self#vhdl_package_t ([],a)  in ()
620
        | Entities a -> let a = self#vhdl_entity_t a  in ()
621
        | Architecture a ->
622
            let a = self#vhdl_architecture_t ([],[],[],([],a))  in ()
623
        | Configuration a ->
624
            let a = self#vhdl_configuration_t a  in () *)
625

    
626
    method vhdl_design_unit_t : vhdl_design_unit_t -> unit=
627
      fun { contexts; library }  -> ()
628
(*        let contexts = self#list self#vhdl_load_t contexts  in
629
        let library = self#vhdl_library_unit_t library  in () *)
630

    
631
    method vhdl_design_file_t : vhdl_design_file_t -> mini_vhdl_design_file_t=
632
      fun { design_units }  ->
633
        let rec inline_df l packs ents archs confs = match l with
634
          | [] -> (List.rev packs, List.rev ents, List.rev archs, List.rev confs)
635
          | {contexts = c; library = lib}::tl -> match lib with
636
            | Package p -> inline_df tl ((c,p)::packs) ents archs confs
637
            | Entities e -> inline_df tl packs ((c,e)::ents) archs confs
638
            | Architecture a -> inline_df tl packs ents ((c,a)::archs) confs
639
            | Configuration conf -> inline_df tl packs ents archs ((c,conf)::confs) in
640
        let (p,e,a,con) = inline_df design_units [] [] [] [] in
641
        let app x = self#vhdl_architecture_t (p,e,con,x) in
642
        let components = List.map app a in
643
        let packages = List.map self#vhdl_package_t p in
644
        { components; packages }
645

    
646
  end
(3-3/10)