Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / tools / importer / mini_vhdl_to_lustre.ml @ 13872a54

History | View | Annotate | Download (18.5 KB)

1 1732ef44 Arnaud Dieumegard
open Vhdl_ast
2
open Vhdl_ast_pp
3
open Mini_vhdl_ast
4
open Vhdl_2_mini_vhdl_map
5
open Lustre_types
6
open Utils
7
8
9
class virtual mini_vhdl_to_lustre_map =
10
  object (self)
11
    inherit vhdl_2_mini_vhdl_map
12 13872a54 Arnaud Dieumegard
13 1732ef44 Arnaud Dieumegard
    method virtual  list : 'a . ('a -> 'a) -> 'a list -> 'a list
14 13872a54 Arnaud Dieumegard
    method virtual  option : 'a . ('a -> 'a) -> 'a option -> 'a option
15
    method virtual  string : string -> string
16
17
    method vhdl_type_t : vhdl_type_t -> vhdl_type_t=
18
      fun x  ->
19
        match x with
20
        | Base a -> let a = self#string a  in Base a
21
        | Range (a,b,c) ->
22
            let a = self#option self#string a  in
23
            let b = self#int b  in let c = self#int c  in Range (a, b, c)
24
        | Bit_vector (a,b) ->
25
            let a = self#int a  in let b = self#int b  in Bit_vector (a, b)
26
        | Array { indexes; const; definition } ->
27
            let indexes = self#list self#vhdl_name_t indexes  in
28
            let const = self#option self#vhdl_constraint_t const  in
29
            let definition = self#vhdl_subtype_indication_t definition  in
30
            Array { indexes; const; definition }
31
        | Record a ->
32
            let a = self#list self#vhdl_element_declaration_t a  in Record a
33
        | Enumerated a ->
34
            let a = self#list self#vhdl_name_t a  in Enumerated a
35
        | Void  -> Void
36
37
    method vhdl_element_declaration_t :
38
      vhdl_element_declaration_t -> vhdl_element_declaration_t=
39
      fun { names; definition }  ->
40
        let names = self#list self#vhdl_name_t names  in
41
        let definition = self#vhdl_subtype_indication_t definition  in
42
        { names; definition }
43
44
    method vhdl_subtype_indication_t :
45
      vhdl_subtype_indication_t -> vhdl_subtype_indication_t=
46
      fun { name; functionName; const }  ->
47
        let name = self#vhdl_name_t name  in
48
        let functionName = self#vhdl_name_t functionName  in
49
        let const = self#vhdl_constraint_t const  in
50
        { name; functionName; const }
51
52
    method vhdl_discrete_range_t :
53
      vhdl_discrete_range_t -> vhdl_discrete_range_t=
54
      fun x  ->
55
        match x with
56
        | SubDiscreteRange a ->
57
            let a = self#vhdl_subtype_indication_t a  in SubDiscreteRange a
58
        | NamedRange a -> let a = self#vhdl_name_t a  in NamedRange a
59
        | DirectedRange { direction; from; _to } ->
60
            let direction = self#string direction  in
61
            let from = self#vhdl_expr_t from  in
62
            let _to = self#vhdl_expr_t _to  in
63
            DirectedRange { direction; from; _to }
64
65
    method vhdl_constraint_t : vhdl_constraint_t -> vhdl_constraint_t=
66
      fun x  ->
67
        match x with
68
        | RefConstraint { ref_name } ->
69
            let ref_name = self#vhdl_name_t ref_name  in
70
            RefConstraint { ref_name }
71
        | RangeConstraint { range } ->
72
            let range = self#vhdl_discrete_range_t range  in
73
            RangeConstraint { range }
74
        | IndexConstraint { ranges } ->
75
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
76
            IndexConstraint { ranges }
77
        | ArrayConstraint { ranges; sub } ->
78
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
79
            let sub = self#vhdl_constraint_t sub  in
80
            ArrayConstraint { ranges; sub }
81
        | RecordConstraint  -> RecordConstraint
82
        | NoConstraint  -> NoConstraint
83
84
    method vhdl_definition_t : vhdl_definition_t -> vhdl_definition_t=
85
      fun x  ->
86
        match x with
87
        | Type { name; definition } ->
88
            let name = self#vhdl_name_t name  in
89
            let definition = self#vhdl_type_t definition  in
90
            Type { name; definition }
91
        | Subtype { name; typ } ->
92
            let name = self#vhdl_name_t name  in
93
            let typ = self#vhdl_subtype_indication_t typ  in
94
            Subtype { name; typ }
95
96
    method vhdl_expr_t : vhdl_expr_t -> vhdl_expr_t=
97
      fun x  ->
98
        match x with
99
        | Call a -> let a = self#vhdl_name_t a  in Call a
100
        | Cst { value; unit_name } ->
101
            let value = self#vhdl_cst_val_t value  in
102
            let unit_name = self#option self#vhdl_name_t unit_name  in
103
            Cst { value; unit_name }
104
        | Op { id; args } ->
105
            let id = self#string id  in
106
            let args = self#list self#vhdl_expr_t args  in Op { id; args }
107
        | IsNull  -> IsNull
108
        | Time { value; phy_unit } ->
109
            let value = self#int value  in
110
            let phy_unit = self#string phy_unit  in Time { value; phy_unit }
111
        | Sig { name; att } ->
112
            let name = self#vhdl_name_t name  in
113
            let att = self#option self#vhdl_signal_attributes_t att  in
114
            Sig { name; att }
115
        | SuffixMod { expr; selection } ->
116
            let expr = self#vhdl_expr_t expr  in
117
            let selection = self#vhdl_suffix_selection_t selection  in
118
            SuffixMod { expr; selection }
119
        | Aggregate { elems } ->
120
            let elems = self#list self#vhdl_element_assoc_t elems  in
121
            Aggregate { elems }
122
        | QualifiedExpression { type_mark; aggregate; expression } ->
123
            let type_mark = self#vhdl_name_t type_mark  in
124
            let aggregate = self#list self#vhdl_element_assoc_t aggregate  in
125
            let expression = self#option self#vhdl_expr_t expression  in
126
            QualifiedExpression { type_mark; aggregate; expression }
127
        | Others  -> Others
128
129
    method vhdl_name_t : vhdl_name_t -> vhdl_name_t=
130
      fun x  ->
131
        match x with
132
        | Simple a -> let a = self#string a  in Simple a
133
        | Identifier a -> let a = self#string a  in Identifier a
134
        | Selected a -> let a = self#list self#vhdl_name_t a  in Selected a
135
        | Index { id; exprs } ->
136
            let id = self#vhdl_name_t id  in
137
            let exprs = self#list self#vhdl_expr_t exprs  in
138
            Index { id; exprs }
139
        | Slice { id; range } ->
140
            let id = self#vhdl_name_t id  in
141
            let range = self#vhdl_discrete_range_t range  in
142
            Slice { id; range }
143
        | Attribute { id; designator; expr } ->
144
            let id = self#vhdl_name_t id  in
145
            let designator = self#vhdl_name_t designator  in
146
            let expr = self#vhdl_expr_t expr  in
147
            Attribute { id; designator; expr }
148
        | Function { id; assoc_list } ->
149
            let id = self#vhdl_name_t id  in
150
            let assoc_list = self#list self#vhdl_assoc_element_t assoc_list
151
               in
152
            Function { id; assoc_list }
153
        | Open  -> Open
154
        | NoName  -> NoName
155
156
    method vhdl_assoc_element_t :
157
      vhdl_assoc_element_t -> vhdl_assoc_element_t=
158
      fun
159
        { formal_name; formal_arg; actual_name; actual_designator;
160
          actual_expr }
161
         ->
162
        let formal_name = self#option self#vhdl_name_t formal_name  in
163
        let formal_arg = self#option self#vhdl_name_t formal_arg  in
164
        let actual_name = self#option self#vhdl_name_t actual_name  in
165
        let actual_designator =
166
          self#option self#vhdl_name_t actual_designator  in
167
        let actual_expr = self#option self#vhdl_expr_t actual_expr  in
168
        {
169
          formal_name;
170
          formal_arg;
171
          actual_name;
172
          actual_designator;
173
          actual_expr
174
        }
175
176
    method vhdl_element_assoc_t :
177
      vhdl_element_assoc_t -> vhdl_element_assoc_t=
178
      fun { choices; expr }  ->
179
        let choices = self#list self#vhdl_expr_t choices  in
180
        let expr = self#vhdl_expr_t expr  in { choices; expr }
181
182
    method vhdl_array_attributes_t :
183
      vhdl_array_attributes_t -> vhdl_array_attributes_t=
184
      fun x  ->
185
        match x with
186
        | AAttInt { id; arg } ->
187
            let id = self#string id  in
188
            let arg = self#int arg  in AAttInt { id; arg }
189
        | AAttAscending  -> AAttAscending
190
191
    method vhdl_signal_attributes_t :
192
      vhdl_signal_attributes_t -> vhdl_signal_attributes_t=
193
      fun x  -> match x with | SigAtt a -> let a = self#string a  in SigAtt a
194
195
    method vhdl_string_attributes_t :
196
      vhdl_string_attributes_t -> vhdl_string_attributes_t=
197
      fun x  ->
198
        match x with | StringAtt a -> let a = self#string a  in StringAtt a
199
200
    method vhdl_suffix_selection_t :
201
      vhdl_suffix_selection_t -> vhdl_suffix_selection_t=
202
      fun x  ->
203
        match x with
204
        | Idx a -> let a = self#int a  in Idx a
205
        | SuffixRange (a,b) ->
206
            let a = self#int a  in let b = self#int b  in SuffixRange (a, b)
207
208
    method mini_vhdl_sequential_stmt_t :
209
      mini_vhdl_sequential_stmt_t -> mini_vhdl_sequential_stmt_t=
210
      fun x  ->
211
        match x with
212
        | VarAssign { label; lhs; rhs } ->
213
            let label = self#option self#vhdl_name_t label  in
214
            let lhs = self#vhdl_name_t lhs  in
215
            let rhs = self#vhdl_expr_t rhs  in VarAssign { label; lhs; rhs }
216
        | SigSeqAssign { label; lhs; rhs } ->
217
            let label = self#option self#vhdl_name_t label  in
218
            let lhs = self#vhdl_name_t lhs  in
219
            let rhs = self#list self#vhdl_waveform_element_t rhs  in
220
            SigSeqAssign { label; lhs; rhs }
221
        | SigCondAssign { label; lhs; rhs; delay } ->
222
            let label = self#option self#vhdl_name_t label  in
223
            let lhs = self#vhdl_name_t lhs  in
224
            let rhs = self#list self#vhdl_signal_condition_t rhs  in
225
            let delay = self#option self#vhdl_expr_t delay  in
226
            SigCondAssign { label; lhs; rhs; delay }
227
        | SigSelectAssign { label; lhs; sel; branches; delay } ->
228
            let label = self#option self#vhdl_name_t label  in
229
            let lhs = self#vhdl_name_t lhs  in
230
            let sel = self#vhdl_expr_t sel  in
231
            let branches = self#list self#vhdl_signal_selection_t branches
232
               in
233
            let delay = self#option self#vhdl_expr_t delay  in
234
            SigSelectAssign { label; lhs; sel; branches; delay }
235
        | If { label; if_cases; default } ->
236
            let label = self#option self#vhdl_name_t label  in
237
            let if_cases = self#list self#mini_vhdl_if_case_t if_cases  in
238
            let default = self#list self#mini_vhdl_sequential_stmt_t default
239
               in
240
            If { label; if_cases; default }
241
        | Case { label; guard; branches } ->
242
            let label = self#option self#vhdl_name_t label  in
243
            let guard = self#vhdl_expr_t guard  in
244
            let branches = self#list self#mini_vhdl_case_item_t branches  in
245
            Case { label; guard; branches }
246
        | Exit { label; loop_label; condition } ->
247
            let label = self#option self#vhdl_name_t label  in
248
            let loop_label = self#option self#string loop_label  in
249
            let condition = self#option self#vhdl_expr_t condition  in
250
            Exit { label; loop_label; condition }
251
        | Assert { label; cond; report; severity } ->
252
            let label = self#option self#vhdl_name_t label  in
253
            let cond = self#vhdl_expr_t cond  in
254
            let report = self#vhdl_expr_t report  in
255
            let severity = self#vhdl_expr_t severity  in
256
            Assert { label; cond; report; severity }
257
        | ProcedureCall { label; name; assocs } ->
258
            let label = self#option self#vhdl_name_t label  in
259
            let name = self#vhdl_name_t name  in
260
            let assocs = self#list self#vhdl_assoc_element_t assocs  in
261
            ProcedureCall { label; name; assocs }
262
        | Wait  -> Wait
263
        | Null { label } ->
264
            let label = self#option self#vhdl_name_t label  in Null { label }
265
        | Return { label; expr } ->
266
            let label = self#option self#vhdl_name_t label  in
267
            let expr = self#option self#vhdl_expr_t expr  in
268
            Return { label; expr }
269
270
    method mini_vhdl_if_case_t : mini_vhdl_if_case_t -> mini_vhdl_if_case_t=
271
      fun { if_cond; if_block }  ->
272
        let if_cond = self#vhdl_expr_t if_cond  in
273
        let if_block = self#list self#mini_vhdl_sequential_stmt_t if_block
274
           in
275
        { if_cond; if_block }
276
277
    method mini_vhdl_case_item_t :
278
      mini_vhdl_case_item_t -> mini_vhdl_case_item_t=
279
      fun { when_cond; when_stmt }  ->
280
        let when_cond = self#list self#vhdl_expr_t when_cond  in
281
        let when_stmt = self#list self#mini_vhdl_sequential_stmt_t when_stmt
282
           in
283
        { when_cond; when_stmt }
284
285
    method mini_vhdl_declaration_t :
286
      mini_vhdl_declaration_t -> mini_vhdl_declaration_t=
287
      fun x  ->
288
        match x with
289
        | VarDecl { names; typ; init_val } ->
290
            let names = self#list self#vhdl_name_t names  in
291
            let typ = self#vhdl_subtype_indication_t typ  in
292
            let init_val = self#vhdl_expr_t init_val  in
293
            VarDecl { names; typ; init_val }
294
        | CstDecl { names; typ; init_val } ->
295
            let names = self#list self#vhdl_name_t names  in
296
            let typ = self#vhdl_subtype_indication_t typ  in
297
            let init_val = self#vhdl_expr_t init_val  in
298
            CstDecl { names; typ; init_val }
299
        | SigDecl { names; typ; init_val } ->
300
            let names = self#list self#vhdl_name_t names  in
301
            let typ = self#vhdl_subtype_indication_t typ  in
302
            let init_val = self#vhdl_expr_t init_val  in
303
            SigDecl { names; typ; init_val }
304
        | ComponentDecl { name; generics; ports } ->
305
            let name = self#vhdl_name_t name  in
306
            let generics = self#list self#vhdl_port_t generics  in
307
            let ports = self#list self#vhdl_port_t ports  in
308
            ComponentDecl { name; generics; ports }
309
        | Subprogram { spec; decl_part; stmts } ->
310
            let spec = self#vhdl_subprogram_spec_t spec  in
311
            let decl_part = self#list self#mini_vhdl_declaration_t decl_part
312
               in
313
            let stmts = self#list self#mini_vhdl_sequential_stmt_t stmts  in
314
            Subprogram { spec; decl_part; stmts }
315
316
    method mini_vhdl_declarative_item_t :
317
      mini_vhdl_declarative_item_t -> mini_vhdl_declarative_item_t=
318
      fun { use_clause; declaration; definition }  ->
319
        let use_clause = self#option self#vhdl_load_t use_clause  in
320
        let declaration =
321
          self#option self#mini_vhdl_declaration_t declaration  in
322
        let definition = self#option self#vhdl_definition_t definition  in
323
        { use_clause; declaration; definition }
324 304640aa Arnaud Dieumegard
325
    method mini_vhdl_process_t : mini_vhdl_process_t -> mini_vhdl_process_t=
326 13872a54 Arnaud Dieumegard
      fun { id; declarations; active_sigs; body; postponed; label }  ->
327
        let id = self#vhdl_name_t id  in
328
        let declarations =
329
          self#list self#mini_vhdl_declarative_item_t declarations  in
330
        let active_sigs = self#list self#vhdl_name_t active_sigs  in
331
        let body = self#list self#mini_vhdl_sequential_stmt_t body  in
332
        let postponed = self#bool postponed  in
333
        let label = self#option self#vhdl_name_t label  in
334
        { id; declarations; active_sigs; body; postponed; label }
335 304640aa Arnaud Dieumegard
336 1732ef44 Arnaud Dieumegard
    method mini_vhdl_component_instantiation_t :
337
      mini_vhdl_component_instantiation_t -> statement=
338
      fun { name; archi; entity; generic_map; port_map }  ->
339
        let name = self#vhdl_name_t name  in
340
        let archi = archi  in
341
        let entity = entity  in
342
        let generic_map = self#list self#vhdl_assoc_element_t generic_map  in
343
        let port_map = self#list self#vhdl_assoc_element_t port_map  in
344
        Eq {eq_lhs=[show_vhdl_name_t name];
345
            eq_rhs={expr_tag=Utils.new_tag (); expr_desc=Expr_ident "toto";
346
                    expr_type={tdesc=Tconst "cst"; tid=0}; expr_clock={cdesc=Cvar;cscoped=false;cid=0};
347
                    expr_delay={ddesc=Dundef;did=0}; expr_annot=None; expr_loc=Location.dummy_loc};
348
            eq_loc=Location.dummy_loc}
349
350
    method mini_vhdl_concurrent_stmt_t :
351
      mini_vhdl_concurrent_stmt_t -> statement=
352
      fun x  ->
353
        match x with
354 304640aa Arnaud Dieumegard
        | Process a -> let a = self#mini_vhdl_process_t a  in
355 1732ef44 Arnaud Dieumegard
            Eq {eq_lhs=["Process"];
356
                eq_rhs={expr_tag=Utils.new_tag (); expr_desc=Expr_ident "toto";
357
                        expr_type={tdesc=Tconst "cst"; tid=0}; expr_clock={cdesc=Cvar;cscoped=false;cid=0};
358
                        expr_delay={ddesc=Dundef;did=0}; expr_annot=None; expr_loc=Location.dummy_loc};
359
                eq_loc=Location.dummy_loc}
360
        | ComponentInst a ->
361
            let a = self#mini_vhdl_component_instantiation_t a  in a
362
363 304640aa Arnaud Dieumegard
    method mini_vhdl_package_t : mini_vhdl_package_t -> top_decl_desc=
364 1732ef44 Arnaud Dieumegard
      fun { name; shared_defs; shared_decls; shared_uses }  ->
365
        let name = self#vhdl_name_t name  in
366
        let shared_defs = self#list self#vhdl_definition_t shared_defs  in
367 304640aa Arnaud Dieumegard
        let shared_decls = List.map self#mini_vhdl_declaration_t shared_decls  in
368 1732ef44 Arnaud Dieumegard
        let shared_uses = self#list self#vhdl_load_t shared_uses in
369
        let node_id = show_vhdl_name_t name in
370
        let node_type = Types.new_var () in
371
        let node_clock = Clocks.new_ck Cvar false in
372
        Node { node_id; node_type; node_clock; 
373
               node_inputs=[]; node_outputs = []; node_locals = [];
374
               node_gencalls = []; node_checks = []; node_asserts = [];
375
               node_stmts = []; node_dec_stateless = false; node_stateless = None; 
376
               node_spec = None; node_annot = [] }
377
378
    method mini_vhdl_component_t :
379
      mini_vhdl_component_t -> top_decl_desc=
380
      fun
381
        { names; generics; ports; contexts; declarations; definitions; body }
382
         ->
383
        let names = self#list self#vhdl_name_t names  in
384
        let generics = self#list self#vhdl_port_t generics  in
385
        let ports = self#list self#vhdl_port_t ports  in
386
        let contexts = self#list self#vhdl_load_t contexts  in
387 304640aa Arnaud Dieumegard
        let declarations = List.map self#mini_vhdl_declaration_t declarations  in
388 1732ef44 Arnaud Dieumegard
        let definitions = self#list self#vhdl_definition_t definitions  in
389
        let body = List.map self#mini_vhdl_concurrent_stmt_t body  in
390
        let node_id = String.concat "__" (List.map show_vhdl_name_t names) in
391
        let node_type = Types.new_var () in
392
        let node_clock = Clocks.new_ck Cvar false in
393
        Node { node_id; node_type; node_clock; 
394
               node_inputs=[]; node_outputs = []; node_locals = [];
395
               node_gencalls = []; node_checks = []; node_asserts = [];
396
               node_stmts = body; node_dec_stateless = false; node_stateless = None; 
397
               node_spec = None; node_annot = [] }
398
399
    method mini_vhdl_design_file_t :
400
      mini_vhdl_design_file_t -> program =
401
      fun { components; packages }  ->
402
        let components = List.map self#mini_vhdl_component_t components  in
403
        let packages = List.map self#mini_vhdl_package_t packages  in
404
        let desc x = { top_decl_desc = x; top_decl_owner = ""; top_decl_itf = false; top_decl_loc = Location.dummy_loc } in
405
        let desc1 = List.map desc components in
406
        let desc2 = List.map desc packages in
407
        desc1 @ desc2
408
  end