Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / tools / importer / mini_vhdl_to_lustre.ml @ a0721293

History | View | Annotate | Download (21.1 KB)

1
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
class virtual mini_vhdl_to_lustre_map =
9
  object (self)
10

    
11
    method virtual  list : 'a . ('a -> 'a) -> 'a list -> 'a list
12
    method virtual  option : 'a . ('a -> 'a) -> 'a option -> 'a option
13
    method virtual  string : string -> string
14
    method virtual  int : int -> int
15

    
16
    (*
17
     * Lustre structure constructors
18
     *)
19
    method lustre_mk_var_decl : vhdl_port_mode_t -> vhdl_name_t list -> vhdl_subtype_indication_t -> var_decl list=
20
      fun mode -> fun names -> fun typ ->
21
        let var_id_list = List.map show_vhdl_name_t names in
22
        let var_orig = match mode with InPort -> true | _ -> false in
23
        let var_dec_type = self#vhdl_subtype_indication_t_type_dec typ in
24
        let var_dec_clock = {ck_dec_desc = Ckdec_any; ck_dec_loc = Location.dummy_loc } in
25
        let var_dec_const = false in
26
        let var_dec_value = None in
27
        let var_parent_nodeid = None in
28
        let var_type = self#vhdl_subtype_indication_t typ in
29
        let var_clock = Clocks.new_ck Cvar false in
30
        let var_loc = Location.dummy_loc in
31
        List.map (fun var_id -> {var_id;var_orig;var_dec_type;var_dec_clock;var_dec_const;
32
                                 var_dec_value;var_parent_nodeid;var_type;var_clock;var_loc}) var_id_list
33

    
34
    method lustre_mk_node : vhdl_name_t list -> var_decl list -> vhdl_port_t list -> mini_vhdl_concurrent_stmt_t list -> top_decl_desc=
35
      fun names -> fun node_locals -> fun ports -> fun c_stmts ->
36
        let node_id = String.concat "__" (List.map show_vhdl_name_t names) in
37
        let node_type = Types.new_var () in
38
        let node_clock = Clocks.new_ck Cvar false in
39
        let in_ports = Mini_vhdl_utils.get_ports ports InPort in
40
        let inports_names = List.map Mini_vhdl_utils.get_names in_ports in
41
        let inports_types = List.map (fun x -> x.typ) in_ports in
42
        let node_inputs = List.flatten (List.map2 (self#lustre_mk_var_decl InPort) inports_names inports_types) in
43
        let out_ports = Mini_vhdl_utils.get_ports ports OutPort in
44
        let outports_names = List.map Mini_vhdl_utils.get_names out_ports in
45
        let outports_types = List.map (fun x -> x.typ) out_ports in
46
        let node_outputs = List.flatten (List.map2 (self#lustre_mk_var_decl OutPort) outports_names outports_types) in
47
        (* TODO: deal with inout ports *)
48
        let body = List.map self#mini_vhdl_concurrent_stmt_t c_stmts in
49
        Node { node_id; node_type; node_clock; 
50
               node_inputs; node_outputs; node_locals;
51
               node_gencalls = []; node_checks = []; node_asserts = [];
52
               node_stmts = body; node_dec_stateless = false; node_stateless = None; 
53
               node_spec = None; node_annot = [] }
54

    
55
    (*
56
     * Mini_vhdl to lustre tranformation
57
     *)
58
    method vhdl_port_t : vhdl_port_t -> vhdl_port_t= fun x -> x
59

    
60
    method vhdl_type_t : vhdl_type_t -> vhdl_type_t=
61
      fun x  ->
62
        match x with
63
        | Base a -> let a = self#string a  in Base a
64
        | Range (a,b,c) ->
65
            let a = self#option self#string a  in
66
            let b = self#int b  in let c = self#int c  in Range (a, b, c)
67
        | Bit_vector (a,b) ->
68
            let a = self#int a  in let b = self#int b  in Bit_vector (a, b)
69
        | Array { indexes; const; definition } ->
70
            let indexes = indexes  in
71
            let const = self#option self#vhdl_constraint_t const  in
72
            (*let definition = self#vhdl_subtype_indication_t definition  in*)
73
            Array { indexes; const; definition }
74
        | Record a ->
75
            let a = self#list self#vhdl_element_declaration_t a  in Record a
76
        | Enumerated a ->
77
            (*let a = self#list self#vhdl_name_t a  in *)
78
            Enumerated a
79
        | Void  -> Void
80

    
81
    method vhdl_element_declaration_t :
82
      vhdl_element_declaration_t -> vhdl_element_declaration_t=
83
      fun { names; definition }  ->
84
        (*let names = self#list self#vhdl_name_t names  in
85
        let definition = self#vhdl_subtype_indication_t definition  in*)
86
        { names; definition }
87

    
88
    method vhdl_subtype_indication_t :
89
      vhdl_subtype_indication_t -> Types.type_expr=
90
      fun { name; functionName; const }  ->
91
        let name = self#vhdl_name_t name  in
92
        let functionName = self#vhdl_name_t functionName  in
93
        let const = self#vhdl_constraint_t const  in
94
        let desc = match name with
95
                  | "integer" -> Types.Tbasic (Tint)
96
                  | "boolean" -> Types.Tbasic (Tbool)
97
                  | _ -> Tconst (name) in
98
        Types.new_ty desc;
99

    
100
    method vhdl_subtype_indication_t_type_dec :
101
      vhdl_subtype_indication_t -> type_dec=
102
      fun { name; functionName; const }  ->
103
        let name = self#vhdl_name_t name  in
104
        let functionName = self#vhdl_name_t functionName  in
105
        let const = self#vhdl_constraint_t const  in
106
        {ty_dec_desc = Tydec_const name;
107
         ty_dec_loc = Location.dummy_loc }
108

    
109
    method vhdl_discrete_range_t :
110
      vhdl_discrete_range_t -> vhdl_discrete_range_t=
111
      fun x  ->
112
        match x with
113
        | SubDiscreteRange a ->
114
            (*let a = self#vhdl_subtype_indication_t a  in *)
115
            SubDiscreteRange a
116
        | NamedRange a -> 
117
            (*let a = self#vhdl_name_t a  in *)
118
            NamedRange a
119
        | DirectedRange { direction; from; _to } ->
120
            let direction = self#string direction  in
121
            let from = self#vhdl_expr_t from  in
122
            let _to = self#vhdl_expr_t _to  in
123
            DirectedRange { direction; from; _to }
124

    
125
    method vhdl_constraint_t : vhdl_constraint_t -> vhdl_constraint_t=
126
      fun x  ->
127
        x
128
(*        match x with
129
        | RefConstraint { ref_name } ->
130
            let ref_name = self#vhdl_name_t ref_name  in
131
            RefConstraint { ref_name }
132
        | RangeConstraint { range } ->
133
            let range = self#vhdl_discrete_range_t range  in
134
            RangeConstraint { range }
135
        | IndexConstraint { ranges } ->
136
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
137
            IndexConstraint { ranges }
138
        | ArrayConstraint { ranges; sub } ->
139
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
140
            let sub = self#vhdl_constraint_t sub  in
141
            ArrayConstraint { ranges; sub }
142
        | RecordConstraint  -> RecordConstraint
143
        | NoConstraint  -> NoConstraint*)
144

    
145
    method vhdl_definition_t : vhdl_definition_t -> vhdl_definition_t=
146
      fun x  ->
147
        x
148
(*        match x with
149
        | Type { name; definition } ->
150
            let name = self#vhdl_name_t name  in
151
            let definition = self#vhdl_type_t definition  in
152
            Type { name; definition }
153
        | Subtype { name; typ } ->
154
            let name = self#vhdl_name_t name  in
155
            let typ = self#vhdl_subtype_indication_t typ  in
156
            Subtype { name; typ }*)
157

    
158
    method vhdl_expr_t : vhdl_expr_t -> vhdl_expr_t=
159
      fun x  ->
160
        x
161
(*        match x with
162
        | Call a -> let a = self#vhdl_name_t a  in Call a
163
        | Cst { value; unit_name } ->
164
            let value = self#vhdl_cst_val_t value  in
165
            let unit_name = self#option self#vhdl_name_t unit_name  in
166
            Cst { value; unit_name }
167
        | Op { id; args } ->
168
            let id = self#string id  in
169
            let args = self#list self#vhdl_expr_t args  in Op { id; args }
170
        | IsNull  -> IsNull
171
        | Time { value; phy_unit } ->
172
            let value = self#int value  in
173
            let phy_unit = self#string phy_unit  in Time { value; phy_unit }
174
        | Sig { name; att } ->
175
            let name = self#vhdl_name_t name  in
176
            let att = self#option self#vhdl_signal_attributes_t att  in
177
            Sig { name; att }
178
        | SuffixMod { expr; selection } ->
179
            let expr = self#vhdl_expr_t expr  in
180
            let selection = self#vhdl_suffix_selection_t selection  in
181
            SuffixMod { expr; selection }
182
        | Aggregate { elems } ->
183
            let elems = self#list self#vhdl_element_assoc_t elems  in
184
            Aggregate { elems }
185
        | QualifiedExpression { type_mark; aggregate; expression } ->
186
            let type_mark = self#vhdl_name_t type_mark  in
187
            let aggregate = self#list self#vhdl_element_assoc_t aggregate  in
188
            let expression = self#option self#vhdl_expr_t expression  in
189
            QualifiedExpression { type_mark; aggregate; expression }
190
        | Others  -> Others*)
191

    
192
    method vhdl_name_t : vhdl_name_t -> string=
193
      fun x  ->
194
        show_vhdl_name_t x
195

    
196
    method vhdl_assoc_element_t :
197
      vhdl_assoc_element_t -> vhdl_assoc_element_t=
198
      fun
199
        { formal_name; formal_arg; actual_name; actual_designator;
200
          actual_expr }
201
        (* At this point of the transformation, association elements have been resolved. 
202
         * formal_[name|arg] are empty
203
         * A simple variable name is of the form: actual_designator
204
         * A function call is of the form: actual_name ( [actual_designator | actual_expr] )
205
         * A conversion function is of the form: actual_name ( [actual_designator | actual_expr] )
206
         *)
207
         ->
208
(*        let formal_name = self#option self#vhdl_name_t formal_name  in
209
        let formal_arg = self#option self#vhdl_name_t formal_arg  in
210
        let actual_name = self#option self#vhdl_name_t actual_name  in
211
        let actual_designator =
212
          self#option self#vhdl_name_t actual_designator  in
213
        let actual_expr = self#option self#vhdl_expr_t actual_expr  in*)
214
        {
215
          formal_name;
216
          formal_arg;
217
          actual_name;
218
          actual_designator;
219
          actual_expr
220
        }
221

    
222
    method vhdl_element_assoc_t :
223
      vhdl_element_assoc_t -> vhdl_element_assoc_t=
224
      fun { choices; expr }  ->
225
        let choices = self#list self#vhdl_expr_t choices  in
226
        let expr = self#vhdl_expr_t expr  in { choices; expr }
227

    
228
    method vhdl_array_attributes_t :
229
      vhdl_array_attributes_t -> vhdl_array_attributes_t=
230
      fun x  ->
231
        match x with
232
        | AAttInt { id; arg } ->
233
            let id = self#string id  in
234
            let arg = self#int arg  in AAttInt { id; arg }
235
        | AAttAscending  -> AAttAscending
236

    
237
    method vhdl_signal_attributes_t :
238
      vhdl_signal_attributes_t -> vhdl_signal_attributes_t=
239
      fun x  -> match x with | SigAtt a -> let a = self#string a  in SigAtt a
240

    
241
    method vhdl_string_attributes_t :
242
      vhdl_string_attributes_t -> vhdl_string_attributes_t=
243
      fun x  ->
244
        match x with | StringAtt a -> let a = self#string a  in StringAtt a
245

    
246
    method vhdl_suffix_selection_t :
247
      vhdl_suffix_selection_t -> vhdl_suffix_selection_t=
248
      fun x  ->
249
        match x with
250
        | Idx a -> let a = self#int a  in Idx a
251
        | SuffixRange (a,b) ->
252
            let a = self#int a  in let b = self#int b  in SuffixRange (a, b)
253

    
254
    (* TODO *)
255
    method mini_vhdl_sequential_stmt_t :
256
      mini_vhdl_sequential_stmt_t -> mini_vhdl_sequential_stmt_t=
257
      fun x  ->
258
        x
259
(*        match x with
260
        | VarAssign { label; lhs; rhs } ->
261
            let label = self#option self#vhdl_name_t label  in 
262
            let lhs = self#vhdl_name_t lhs  in
263
            let rhs = self#vhdl_expr_t rhs  in VarAssign { label; lhs; rhs }
264
        | SigSeqAssign { label; lhs; rhs } ->
265
            let label = self#option self#vhdl_name_t label  in
266
            let lhs = self#vhdl_name_t lhs  in
267
            let rhs = self#list self#vhdl_waveform_element_t rhs  in
268
            SigSeqAssign { label; lhs; rhs }
269
        | SigCondAssign { label; lhs; rhs; delay } ->
270
            let label = self#option self#vhdl_name_t label  in
271
            let lhs = self#vhdl_name_t lhs  in
272
            let rhs = self#list self#vhdl_signal_condition_t rhs  in
273
            let delay = self#option self#vhdl_expr_t delay  in
274
            SigCondAssign { label; lhs; rhs; delay }
275
        | SigSelectAssign { label; lhs; sel; branches; delay } ->
276
            let label = self#option self#vhdl_name_t label  in
277
            let lhs = self#vhdl_name_t lhs  in
278
            let sel = self#vhdl_expr_t sel  in
279
            let branches = self#list self#vhdl_signal_selection_t branches
280
               in
281
            let delay = self#option self#vhdl_expr_t delay  in
282
            SigSelectAssign { label; lhs; sel; branches; delay }
283
        | If { label; if_cases; default } ->
284
            let label = self#option self#vhdl_name_t label  in
285
            let if_cases = self#list self#mini_vhdl_if_case_t if_cases  in
286
            let default = self#list self#mini_vhdl_sequential_stmt_t default
287
               in
288
            If { label; if_cases; default }
289
        | Case { label; guard; branches } ->
290
            let label = self#option self#vhdl_name_t label  in
291
            let guard = self#vhdl_expr_t guard  in
292
            let branches = self#list self#mini_vhdl_case_item_t branches  in
293
            Case { label; guard; branches }
294
        | Exit { label; loop_label; condition } ->
295
            let label = self#option self#vhdl_name_t label  in
296
            let loop_label = self#option self#string loop_label  in
297
            let condition = self#option self#vhdl_expr_t condition  in
298
            Exit { label; loop_label; condition }
299
        | Assert { label; cond; report; severity } ->
300
            let label = self#option self#vhdl_name_t label  in
301
            let cond = self#vhdl_expr_t cond  in
302
            let report = self#vhdl_expr_t report  in
303
            let severity = self#vhdl_expr_t severity  in
304
            Assert { label; cond; report; severity }
305
        | ProcedureCall { label; name; assocs } ->
306
            let label = self#option self#vhdl_name_t label  in
307
            let name = self#vhdl_name_t name  in
308
            let assocs = self#list self#vhdl_assoc_element_t assocs  in
309
            ProcedureCall { label; name; assocs }
310
        | Wait  -> Wait
311
        | Null { label } ->
312
            let label = self#option self#vhdl_name_t label  in Null { label }
313
        | Return { label; expr } ->
314
            let label = self#option self#vhdl_name_t label  in
315
            let expr = self#option self#vhdl_expr_t expr  in
316
            Return { label; expr }*)
317

    
318
    method mini_vhdl_if_case_t : mini_vhdl_if_case_t -> mini_vhdl_if_case_t=
319
      fun { if_cond; if_block }  ->
320
        let if_cond = self#vhdl_expr_t if_cond  in
321
        let if_block = self#list self#mini_vhdl_sequential_stmt_t if_block
322
           in
323
        { if_cond; if_block }
324

    
325
    method mini_vhdl_case_item_t :
326
      mini_vhdl_case_item_t -> mini_vhdl_case_item_t=
327
      fun { when_cond; when_stmt }  ->
328
        let when_cond = self#list self#vhdl_expr_t when_cond  in
329
        let when_stmt = self#list self#mini_vhdl_sequential_stmt_t when_stmt
330
           in
331
        { when_cond; when_stmt }
332

    
333
    method mini_vhdl_declaration_t :
334
      mini_vhdl_declaration_t -> var_decl list=
335
      fun x  ->
336
        match x with
337
        | VarDecl { names; typ; init_val } ->
338
            self#lustre_mk_var_decl InPort names typ
339
(*            let names = self#list self#vhdl_name_t names  in
340
            let typ = self#vhdl_subtype_indication_t typ  in
341
            let init_val = self#vhdl_expr_t init_val  in
342
            VarDecl { names; typ; init_val }*)
343
        | CstDecl { names; typ; init_val } ->
344
            self#lustre_mk_var_decl InPort names typ
345
(*            let names = self#list self#vhdl_name_t names  in
346
            let typ = self#vhdl_subtype_indication_t typ  in
347
            let init_val = self#vhdl_expr_t init_val  in
348
            CstDecl { names; typ; init_val }*)
349
        | SigDecl { names; typ; init_val } ->
350
            self#lustre_mk_var_decl InPort names typ
351
(*            let names = self#list self#vhdl_name_t names  in
352
            let typ = self#vhdl_subtype_indication_t typ  in
353
            let init_val = self#vhdl_expr_t init_val  in
354
            SigDecl { names; typ; init_val }*)
355
        | ComponentDecl { name; generics; ports } ->
356
            []
357
(*            let name = self#vhdl_name_t name  in
358
            let generics = self#list self#vhdl_port_t generics  in
359
            let ports = self#list self#vhdl_port_t ports  in
360
            ComponentDecl { name; generics; ports }*)
361
        | Subprogram { spec; decl_part; stmts } ->
362
            []
363
(*            let spec = self#vhdl_subprogram_spec_t spec  in
364
            let decl_part = self#list self#mini_vhdl_declaration_t decl_part
365
               in
366
            let stmts = self#list self#mini_vhdl_sequential_stmt_t stmts  in
367
            Subprogram { spec; decl_part; stmts }*)
368

    
369
    method vhdl_load_t : vhdl_load_t -> vhdl_load_t=
370
      fun x -> x
371

    
372
    method mini_vhdl_declarative_item_t :
373
      mini_vhdl_declarative_item_t -> mini_vhdl_declarative_item_t=
374
      fun { use_clause; declaration; definition }  ->
375
        let use_clause = self#option self#vhdl_load_t use_clause  in
376
(*        let declaration = self#option self#mini_vhdl_declaration_t declaration  in *)
377
        let definition = self#option self#vhdl_definition_t definition  in
378
        { use_clause; declaration; definition }
379

    
380
    (* TODO : transform this as a new node *)
381
    method mini_vhdl_process_t : mini_vhdl_process_t -> mini_vhdl_process_t=
382
      fun { id; declarations; active_sigs; body; postponed; label }  ->
383
(*        let id = self#vhdl_name_t id  in
384
        let declarations =
385
          self#list self#mini_vhdl_declarative_item_t declarations  in
386
        let active_sigs = self#list self#vhdl_name_t active_sigs  in
387
        let body = self#list self#mini_vhdl_sequential_stmt_t body  in
388
        let postponed = self#bool postponed  in
389
        let label = self#option self#vhdl_name_t label  in *)
390
        { id; declarations; active_sigs; body; postponed; label }
391

    
392
    (* TODO : transform this as a node call *)
393
    method mini_vhdl_component_instantiation_t :
394
      mini_vhdl_component_instantiation_t -> statement=
395
      fun { name; archi; entity; generic_map; port_map }  ->
396
        let name = self#vhdl_name_t name  in
397
        let archi = archi  in
398
        let entity = entity  in
399
        let generic_map = self#list self#vhdl_assoc_element_t generic_map  in
400
        let port_map = self#list self#vhdl_assoc_element_t port_map  in
401
        Eq {eq_lhs=[name];
402
            eq_rhs={expr_tag=Utils.new_tag (); expr_desc=Expr_ident "toto";
403
                    expr_type={tdesc=Tconst "cst"; tid=0}; expr_clock={cdesc=Cvar;cscoped=false;cid=0};
404
                    expr_delay={ddesc=Dundef;did=0}; expr_annot=None; expr_loc=Location.dummy_loc};
405
            eq_loc=Location.dummy_loc}
406

    
407
        (* TODO : Process is a new node; ComponentInst is a node call *)
408
    method mini_vhdl_concurrent_stmt_t :
409
      mini_vhdl_concurrent_stmt_t -> statement=
410
      fun x  ->
411
        match x with
412
        | Process a -> let a = self#mini_vhdl_process_t a  in
413
            Eq {eq_lhs=["Process"];
414
                eq_rhs={expr_tag=Utils.new_tag (); expr_desc=Expr_ident "toto";
415
                        expr_type={tdesc=Tconst "cst"; tid=0}; expr_clock={cdesc=Cvar;cscoped=false;cid=0};
416
                        expr_delay={ddesc=Dundef;did=0}; expr_annot=None; expr_loc=Location.dummy_loc};
417
                eq_loc=Location.dummy_loc}
418
        | ComponentInst a ->
419
            let a = self#mini_vhdl_component_instantiation_t a  in a
420

    
421
    method mini_vhdl_package_t : mini_vhdl_package_t -> top_decl_desc=
422
      fun { name; shared_defs; shared_decls; shared_uses }  ->
423
        let node_id = self#vhdl_name_t name  in
424
        let shared_defs = self#list self#vhdl_definition_t shared_defs  in
425
        let shared_decls = List.map self#mini_vhdl_declaration_t shared_decls  in
426
        let shared_uses = self#list self#vhdl_load_t shared_uses in
427
        let node_type = Types.new_var () in
428
        let node_clock = Clocks.new_ck Cvar false in
429
        Node { node_id; node_type; node_clock; 
430
               node_inputs=[]; node_outputs = []; node_locals = [];
431
               node_gencalls = []; node_checks = []; node_asserts = [];
432
               node_stmts = []; node_dec_stateless = false; node_stateless = None; 
433
               node_spec = None; node_annot = [] }
434

    
435
    method mini_vhdl_component_t :
436
      mini_vhdl_component_t -> top_decl_desc =
437
      fun
438
        { names; generics; ports; contexts; declarations; definitions; body }
439
         ->
440
        let generics = self#list self#vhdl_port_t generics  in
441
        let ports = self#list self#vhdl_port_t ports  in
442
        let contexts = self#list self#vhdl_load_t contexts  in
443
        let declarations = List.flatten (List.map self#mini_vhdl_declaration_t declarations) in
444
        let definitions = List.map self#vhdl_definition_t definitions  in (* TODO: add the result of this transformation to mk_node call *)
445
        let node_id = String.concat "__" (List.map show_vhdl_name_t names) in
446
        let node_type = Types.new_var () in
447
        let node_clock = Clocks.new_ck Cvar false in
448
        self#lustre_mk_node names declarations ports body
449

    
450
    method mini_vhdl_design_file_t :
451
      mini_vhdl_design_file_t -> program_t =
452
      fun { components; packages }  ->
453
        let components = List.map self#mini_vhdl_component_t components  in
454
        let packages = List.map self#mini_vhdl_package_t packages  in
455
        let desc x = { top_decl_desc = x;
456
		       top_decl_owner = "";
457
		       top_decl_itf = false;
458
		       top_decl_loc = Location.dummy_loc } in
459
        let desc1 = List.map desc components in
460
        let desc2 = List.map desc packages in
461
        desc1 @ desc2
462
  end