Project

General

Profile

« Previous | Next » 

Revision 5bbf7413

Added by Arnaud Dieumegard over 5 years ago

definition of the mini-vhdl types + pp + transformation from vhdl structure

View differences:

src/backends/VHDL/mini_vhdl_ast.ml
1
open Vhdl_ast
2
				       
3
type mini_vhdl_component_t =
4
  {
5
    names: vhdl_name_t list [@default NoName];
6
    generics: vhdl_port_t list [@default []]; (* From related 'entity' *)
7
    ports: vhdl_port_t list [@default []]; (* From related 'entity' *)
8
    contexts: vhdl_load_t list [@default []]; (* Related 'declarations' contexts + relatated entity contexts *)
9
    declarations: vhdl_declaration_t list [@default []]; (* From inlined 'declarations' + entity.declaration *)
10
    definitions: vhdl_definition_t list [@default []]; (* From inlined 'declarations' + entity.declaration *)
11
    body: vhdl_concurrent_stmt_t list [@key "ARCHITECTURE_STATEMENT_PART"] [@default []]; (* + entity.stmts *)
12
  }
13
[@@deriving show { with_path = false }, yojson {strict = false}];;
14

  
15
type mini_vhdl_design_file_t = 
16
  {
17
    components: mini_vhdl_component_t list [@default []];
18
    packages: vhdl_package_t list [@default []];
19
  }
20
[@@deriving show { with_path = false }, yojson];;
src/backends/VHDL/mini_vhdl_ast_pp.ml
1
open Mini_vhdl_ast
2
open Vhdl_ast
3
open Vhdl_ast_pp
4

  
5
let rec pp_mini_vhdl_component_t :
6
  Format.formatter -> mini_vhdl_component_t -> Ppx_deriving_runtime.unit =
7
  let __6 () = pp_vhdl_concurrent_stmt_t
8
  
9
  and __5 () = pp_vhdl_definition_t
10
  
11
  and __4 () = pp_vhdl_declaration_t
12
  
13
  and __3 () = pp_vhdl_load_t
14
  
15
  and __2 () = pp_vhdl_port_t
16
  
17
  and __1 () = pp_vhdl_port_t
18
  
19
  and __0 () = pp_vhdl_name_t
20
   in
21
  ((let open! Ppx_deriving_runtime in
22
      fun fmt  ->
23
        fun x  ->
24
          Format.fprintf fmt "@[<v 2>component ";
25
          (match x.names with
26
          | [] -> ()
27
          | _ ->
28
            ((fun x  ->
29
              ignore
30
              (List.fold_left
31
                (fun sep  ->
32
                  fun x  ->
33
                    if sep then Format.fprintf fmt "__";
34
                      ((__0 ()) fmt) x;
35
                      true) false x))) x.names);
36
          Format.fprintf fmt " is";
37
          (match x.generics with
38
          | [] -> ()
39
          | _ ->
40
              Format.fprintf fmt "@;generics (@[";
41
                ((fun x  ->
42
                    ignore
43
                      (List.fold_left
44
                         (fun sep  ->
45
                            fun x  ->
46
                              if sep then Format.fprintf fmt ",@ ";
47
                              ((__1 ()) fmt) x;
48
                              true) false x))) x.generics;
49
              Format.fprintf fmt "@]);");
50
          (match x.ports with
51
          | [] -> ()
52
          | _ ->
53
              Format.fprintf fmt "@;ports (@[";
54
               ((fun x  ->
55
                   ignore
56
                     (List.fold_left
57
                        (fun sep  ->
58
                           fun x  ->
59
                             if sep then Format.fprintf fmt ",@ ";
60
                             ((__2 ()) fmt) x;
61
                             true) false x))) x.ports;
62
               Format.fprintf fmt "@]);");
63
          (match x.contexts with
64
          | [] -> ()
65
          | _ ->
66
            Format.fprintf fmt "@;";
67
            ((fun x  ->
68
            ignore
69
              (List.fold_left
70
                (fun sep  ->
71
                  fun x  ->
72
                    if sep then Format.fprintf fmt ";@;";
73
                      ((__3 ()) fmt) x;
74
                      true) false x))) x.contexts);
75
          (match x.declarations with
76
          | [] -> ()
77
          | _ ->
78
            Format.fprintf fmt "@;";
79
            ((fun x  ->
80
            ignore
81
              (List.fold_left
82
                (fun sep  ->
83
                  fun x  ->
84
                    if sep then Format.fprintf fmt "@;";
85
                      ((__4 ()) fmt) x;
86
                      Format.fprintf fmt ";";
87
                      true) false x))) x.declarations);
88
          (match x.definitions with
89
          | [] -> ()
90
          | _ ->
91
            Format.fprintf fmt "@;";
92
            ((fun x  ->
93
            ignore
94
              (List.fold_left
95
                (fun sep  ->
96
                  fun x  ->
97
                    if sep then Format.fprintf fmt "@;";
98
                      ((__5 ()) fmt) x;
99
                      Format.fprintf fmt ";";
100
                      true) false x))) x.definitions);
101
          Format.fprintf fmt "@]@;@[<v 2>begin";
102
          (match x.body with
103
          | [] -> ()
104
          | _ ->
105
            Format.fprintf fmt "@;";
106
            ((fun x  ->
107
            ignore
108
              (List.fold_left
109
                (fun sep  ->
110
                  fun x  ->
111
                    if sep then Format.fprintf fmt "@;";
112
                      ((__6 ()) fmt) x;
113
                         true) false x))) x.body);
114
           Format.fprintf fmt "@]@;end;")
115
    [@ocaml.warning "-A"])
116

  
117
and show_mini_vhdl_component_t :
118
  mini_vhdl_component_t -> Ppx_deriving_runtime.string =
119
  fun x  -> Format.asprintf "%a" pp_mini_vhdl_component_t x
120

  
121
let rec pp_mini_vhdl_design_file_t :
122
  Format.formatter -> mini_vhdl_design_file_t -> Ppx_deriving_runtime.unit =
123
  let __1 () = pp_vhdl_package_t
124
  
125
  and __0 () = pp_mini_vhdl_component_t
126
   in
127
  ((let open! Ppx_deriving_runtime in
128
      fun fmt  ->
129
        fun x  ->
130
          Format.fprintf fmt "@[<v>";
131
            ((fun x  ->
132
                ignore
133
                  (List.fold_left
134
                     (fun sep  ->
135
                        fun x  ->
136
                          if sep then Format.fprintf fmt "@;";
137
                          ((__0 ()) fmt) x;
138
                          true) false x))) x.components;
139
           ((fun x  ->
140
               ignore
141
                 (List.fold_left
142
                    (fun sep  ->
143
                       fun x  ->
144
                         if sep then Format.fprintf fmt "@;";
145
                         ((__1 ()) fmt) x;
146
                         true) false x))) x.packages;
147
           Format.fprintf fmt "@]")
148
    [@ocaml.warning "-A"])
149

  
150
and show_mini_vhdl_design_file_t :
151
  mini_vhdl_design_file_t -> Ppx_deriving_runtime.string =
152
  fun x  -> Format.asprintf "%a" pp_mini_vhdl_design_file_t x
src/backends/VHDL/vhdl_2_mini_vhdl_map.ml
1
open Vhdl_ast
2
open Mini_vhdl_ast
3

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

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

  
85
    method virtual  vhdl_package_t : (vhdl_load_t list * vhdl_package_t) -> vhdl_package_t
86
    method virtual  vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list *
87
                                  (vhdl_load_t list * vhdl_entity_t) list * 
88
                                  (vhdl_load_t list * vhdl_configuration_t) list *
89
                                  (vhdl_load_t list * vhdl_architecture_t)) -> mini_vhdl_component_t
90
    method virtual  declarative_items_declarations : vhdl_declarative_item_t list -> vhdl_declaration_t list
91
    method virtual  declarative_items_definitions : vhdl_declarative_item_t list -> vhdl_definition_t list
92
    method virtual  declarative_items_uses : vhdl_declarative_item_t list -> vhdl_load_t list
93
    method virtual  filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) -> 
94
                           (vhdl_load_t list * vhdl_entity_t)
95

  
96
    method vhdl_cst_val_t : vhdl_cst_val_t -> vhdl_cst_val_t=
97
      fun x  ->
98
        match x with
99
        | CstInt a -> let a = self#int a  in CstInt a
100
        | CstStdLogic a -> let a = self#string a  in CstStdLogic a
101
        | CstLiteral a -> let a = self#string a  in CstLiteral a
102

  
103
    method vhdl_type_t : vhdl_type_t -> vhdl_type_t=
104
      fun x  ->
105
        match x with
106
        | Base a -> let a = self#string a  in Base a
107
        | Range (a,b,c) ->
108
            let a = self#option self#string a  in
109
            let b = self#int b  in let c = self#int c  in Range (a, b, c)
110
        | Bit_vector (a,b) ->
111
            let a = self#int a  in let b = self#int b  in Bit_vector (a, b)
112
        | Array { indexes; const; definition } ->
113
            let indexes = self#list self#vhdl_name_t indexes  in
114
            let const = self#option self#vhdl_constraint_t const  in
115
            let definition = self#vhdl_subtype_indication_t definition  in
116
            Array { indexes; const; definition }
117
        | Record a ->
118
            let a = self#list self#vhdl_element_declaration_t a  in Record a
119
        | Enumerated a ->
120
            let a = self#list self#vhdl_name_t a  in Enumerated a
121
        | Void  -> Void
122
    method vhdl_element_declaration_t :
123
      vhdl_element_declaration_t -> vhdl_element_declaration_t=
124
      fun { names; definition }  ->
125
        let names = self#list self#vhdl_name_t names  in
126
        let definition = self#vhdl_subtype_indication_t definition  in
127
        { names; definition }
128
    method vhdl_subtype_indication_t :
129
      vhdl_subtype_indication_t -> vhdl_subtype_indication_t=
130
      fun { name; functionName; const }  ->
131
        let name = self#vhdl_name_t name  in
132
        let functionName = self#vhdl_name_t functionName  in
133
        let const = self#vhdl_constraint_t const  in
134
        { name; functionName; const }
135
    method vhdl_discrete_range_t :
136
      vhdl_discrete_range_t -> vhdl_discrete_range_t=
137
      fun x  ->
138
        match x with
139
        | SubDiscreteRange a ->
140
            let a = self#vhdl_subtype_indication_t a  in SubDiscreteRange a
141
        | NamedRange a -> let a = self#vhdl_name_t a  in NamedRange a
142
        | DirectedRange { direction; from; _to } ->
143
            let direction = self#string direction  in
144
            let from = self#vhdl_expr_t from  in
145
            let _to = self#vhdl_expr_t _to  in
146
            DirectedRange { direction; from; _to }
147

  
148
    method vhdl_constraint_t : vhdl_constraint_t -> vhdl_constraint_t=
149
      fun x  ->
150
        match x with
151
        | RefConstraint { ref_name } ->
152
            let ref_name = self#vhdl_name_t ref_name  in
153
            RefConstraint { ref_name }
154
        | RangeConstraint { range } ->
155
            let range = self#vhdl_discrete_range_t range  in
156
            RangeConstraint { range }
157
        | IndexConstraint { ranges } ->
158
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
159
            IndexConstraint { ranges }
160
        | ArrayConstraint { ranges; sub } ->
161
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
162
            let sub = self#vhdl_constraint_t sub  in
163
            ArrayConstraint { ranges; sub }
164
        | RecordConstraint  -> RecordConstraint
165
        | NoConstraint  -> NoConstraint
166

  
167
    method vhdl_definition_t : vhdl_definition_t -> vhdl_definition_t=
168
      fun x  ->
169
        match x with
170
        | Type { name; definition } ->
171
            let name = self#vhdl_name_t name  in
172
            let definition = self#vhdl_type_t definition  in
173
            Type { name; definition }
174
        | Subtype { name; typ } ->
175
            let name = self#vhdl_name_t name  in
176
            let typ = self#vhdl_subtype_indication_t typ  in
177
            Subtype { name; typ }
178
    method vhdl_expr_t : vhdl_expr_t -> vhdl_expr_t=
179
      fun x  ->
180
        match x with
181
        | Call a -> let a = self#vhdl_name_t a  in Call a
182
        | Cst { value; unit_name } ->
183
            let value = self#vhdl_cst_val_t value  in
184
            let unit_name = self#option self#vhdl_name_t unit_name  in
185
            Cst { value; unit_name }
186
        | Op { id; args } ->
187
            let id = self#string id  in
188
            let args = self#list self#vhdl_expr_t args  in Op { id; args }
189
        | IsNull  -> IsNull
190
        | Time { value; phy_unit } ->
191
            let value = self#int value  in
192
            let phy_unit = self#string phy_unit  in Time { value; phy_unit }
193
        | Sig { name; att } ->
194
            let name = self#vhdl_name_t name  in
195
            let att = self#option self#vhdl_signal_attributes_t att  in
196
            Sig { name; att }
197
        | SuffixMod { expr; selection } ->
198
            let expr = self#vhdl_expr_t expr  in
199
            let selection = self#vhdl_suffix_selection_t selection  in
200
            SuffixMod { expr; selection }
201
        | Aggregate { elems } ->
202
            let elems = self#list self#vhdl_element_assoc_t elems  in
203
            Aggregate { elems }
204
        | QualifiedExpression { type_mark; aggregate; expression } ->
205
            let type_mark = self#vhdl_name_t type_mark  in
206
            let aggregate = self#list self#vhdl_element_assoc_t aggregate  in
207
            let expression = self#option self#vhdl_expr_t expression  in
208
            QualifiedExpression { type_mark; aggregate; expression }
209
        | Others  -> Others
210
    method vhdl_name_t : vhdl_name_t -> vhdl_name_t=
211
      fun x  ->
212
        match x with
213
        | Simple a -> let a = self#string a  in Simple a
214
        | Identifier a -> let a = self#string a  in Identifier a
215
        | Selected a -> let a = self#list self#vhdl_name_t a  in Selected a
216
        | Index { id; exprs } ->
217
            let id = self#vhdl_name_t id  in
218
            let exprs = self#list self#vhdl_expr_t exprs  in
219
            Index { id; exprs }
220
        | Slice { id; range } ->
221
            let id = self#vhdl_name_t id  in
222
            let range = self#vhdl_discrete_range_t range  in
223
            Slice { id; range }
224
        | Attribute { id; designator; expr } ->
225
            let id = self#vhdl_name_t id  in
226
            let designator = self#vhdl_name_t designator  in
227
            let expr = self#vhdl_expr_t expr  in
228
            Attribute { id; designator; expr }
229
        | Function { id; assoc_list } ->
230
            let id = self#vhdl_name_t id  in
231
            let assoc_list = self#list self#vhdl_assoc_element_t assoc_list
232
               in
233
            Function { id; assoc_list }
234
        | NoName  -> NoName
235
    method vhdl_assoc_element_t :
236
      vhdl_assoc_element_t -> vhdl_assoc_element_t=
237
      fun
238
        { formal_name; formal_arg; actual_name; actual_designator;
239
          actual_expr }
240
         ->
241
        let formal_name = self#option self#vhdl_name_t formal_name  in
242
        let formal_arg = self#option self#vhdl_name_t formal_arg  in
243
        let actual_name = self#option self#vhdl_name_t actual_name  in
244
        let actual_designator =
245
          self#option self#vhdl_name_t actual_designator  in
246
        let actual_expr = self#option self#vhdl_expr_t actual_expr  in
247
        {
248
          formal_name;
249
          formal_arg;
250
          actual_name;
251
          actual_designator;
252
          actual_expr
253
        }
254
    method vhdl_element_assoc_t :
255
      vhdl_element_assoc_t -> vhdl_element_assoc_t=
256
      fun { choices; expr }  ->
257
        let choices = self#list self#vhdl_expr_t choices  in
258
        let expr = self#vhdl_expr_t expr  in { choices; expr }
259
    method vhdl_array_attributes_t :
260
      vhdl_array_attributes_t -> vhdl_array_attributes_t=
261
      fun x  ->
262
        match x with
263
        | AAttInt { id; arg } ->
264
            let id = self#string id  in
265
            let arg = self#int arg  in AAttInt { id; arg }
266
        | AAttAscending  -> AAttAscending
267
    method vhdl_signal_attributes_t :
268
      vhdl_signal_attributes_t -> vhdl_signal_attributes_t=
269
      fun x  -> match x with | SigAtt a -> let a = self#string a  in SigAtt a
270
    method vhdl_string_attributes_t :
271
      vhdl_string_attributes_t -> vhdl_string_attributes_t=
272
      fun x  ->
273
        match x with | StringAtt a -> let a = self#string a  in StringAtt a
274
    method vhdl_suffix_selection_t : vhdl_suffix_selection_t -> vhdl_suffix_selection_t=
275
      fun x  ->
276
        match x with
277
        | Idx a -> let a = self#int a  in Idx a
278
        | SuffixRange (a,b) ->
279
            let a = self#int a  in let b = self#int b  in SuffixRange (a, b)
280

  
281
    method vhdl_type_attributes_t :
282
      'a .
283
        ('a -> 'a) -> 'a vhdl_type_attributes_t -> 'a vhdl_type_attributes_t=
284
      fun _basetype  ->
285
        fun x  ->
286
          match x with
287
          | TAttNoArg { id } -> let id = self#string id  in TAttNoArg { id }
288
          | TAttIntArg { id; arg } ->
289
              let id = self#string id  in
290
              let arg = self#int arg  in TAttIntArg { id; arg }
291
          | TAttValArg { id; arg } ->
292
              let id = self#string id  in
293
              let arg = _basetype arg  in TAttValArg { id; arg }
294
          | TAttStringArg { id; arg } ->
295
              let id = self#string id  in
296
              let arg = self#string arg  in TAttStringArg { id; arg }
297

  
298
    method vhdl_parameter_t : vhdl_parameter_t -> vhdl_parameter_t=
299
      fun { names; mode; typ; init_val }  ->
300
        let names = self#list self#vhdl_name_t names  in
301
        let mode = self#list self#string mode  in
302
        let typ = self#vhdl_subtype_indication_t typ  in
303
        let init_val = self#option self#vhdl_cst_val_t init_val  in
304
        { names; mode; typ; init_val }
305

  
306
    method vhdl_subprogram_spec_t :
307
      vhdl_subprogram_spec_t -> vhdl_subprogram_spec_t=
308
      fun { name; subprogram_type; typeMark; parameters; isPure }  ->
309
        let name = self#string name  in
310
        let subprogram_type = self#string subprogram_type  in
311
        let typeMark = self#vhdl_name_t typeMark  in
312
        let parameters = self#list self#vhdl_parameter_t parameters  in
313
        let isPure = self#bool isPure  in
314
        { name; subprogram_type; typeMark; parameters; isPure }
315

  
316
    method vhdl_sequential_stmt_t :
317
      vhdl_sequential_stmt_t -> vhdl_sequential_stmt_t=
318
      fun x  ->
319
        match x with
320
        | VarAssign { label; lhs; rhs } ->
321
            let label = self#vhdl_name_t label  in
322
            let lhs = self#vhdl_name_t lhs  in
323
            let rhs = self#vhdl_expr_t rhs  in VarAssign { label; lhs; rhs }
324
        | SigSeqAssign { label; lhs; rhs } ->
325
            let label = self#vhdl_name_t label  in
326
            let lhs = self#vhdl_name_t lhs  in
327
            let rhs = self#list self#vhdl_waveform_element_t rhs  in
328
            SigSeqAssign { label; lhs; rhs }
329
        | If { label; if_cases; default } ->
330
            let label = self#vhdl_name_t label  in
331
            let if_cases = self#list self#vhdl_if_case_t if_cases  in
332
            let default = self#list self#vhdl_sequential_stmt_t default  in
333
            If { label; if_cases; default }
334
        | Case { label; guard; branches } ->
335
            let label = self#vhdl_name_t label  in
336
            let guard = self#vhdl_expr_t guard  in
337
            let branches = self#list self#vhdl_case_item_t branches  in
338
            Case { label; guard; branches }
339
        | Exit { label; loop_label; condition } ->
340
            let label = self#vhdl_name_t label  in
341
            let loop_label = self#option self#string loop_label  in
342
            let condition = self#option self#vhdl_expr_t condition  in
343
            Exit { label; loop_label; condition }
344
        | Assert { label; cond; report; severity } ->
345
            let label = self#vhdl_name_t label  in
346
            let cond = self#vhdl_expr_t cond  in
347
            let report = self#vhdl_expr_t report  in
348
            let severity = self#vhdl_expr_t severity  in
349
            Assert { label; cond; report; severity }
350
        | ProcedureCall { label; name; assocs } ->
351
            let label = self#vhdl_name_t label  in
352
            let name = self#vhdl_name_t name  in
353
            let assocs = self#list self#vhdl_assoc_element_t assocs  in
354
            ProcedureCall { label; name; assocs }
355
        | Wait  -> Wait
356
        | Null { label } ->
357
            let label = self#vhdl_name_t label  in Null { label }
358
        | Return { label; expr } ->
359
            let label = self#option self#vhdl_name_t label  in
360
            let expr = self#option self#vhdl_expr_t expr in
361
            Return { label; expr }
362
    method vhdl_if_case_t : vhdl_if_case_t -> vhdl_if_case_t=
363
      fun { if_cond; if_block }  ->
364
        let if_cond = self#vhdl_expr_t if_cond  in
365
        let if_block = self#list self#vhdl_sequential_stmt_t if_block  in
366
        { if_cond; if_block }
367
    method vhdl_case_item_t : vhdl_case_item_t -> vhdl_case_item_t=
368
      fun { when_cond; when_stmt }  ->
369
        let when_cond = self#list self#vhdl_expr_t when_cond  in
370
        let when_stmt = self#list self#vhdl_sequential_stmt_t when_stmt  in
371
        { when_cond; when_stmt }
372

  
373
    method vhdl_declaration_t : vhdl_declaration_t -> vhdl_declaration_t=
374
      fun x  ->
375
        match x with
376
        | VarDecl { names; typ; init_val } ->
377
            let names = self#list self#vhdl_name_t names  in
378
            let typ = self#vhdl_subtype_indication_t typ  in
379
            let init_val = self#vhdl_expr_t init_val  in
380
            VarDecl { names; typ; init_val }
381
        | CstDecl { names; typ; init_val } ->
382
            let names = self#list self#vhdl_name_t names  in
383
            let typ = self#vhdl_subtype_indication_t typ  in
384
            let init_val = self#vhdl_expr_t init_val  in
385
            CstDecl { names; typ; init_val }
386
        | SigDecl { names; typ; init_val } ->
387
            let names = self#list self#vhdl_name_t names  in
388
            let typ = self#vhdl_subtype_indication_t typ  in
389
            let init_val = self#vhdl_expr_t init_val  in
390
            SigDecl { names; typ; init_val }
391
        | ComponentDecl { name; generics; ports } ->
392
            let name = self#vhdl_name_t name  in
393
            let generics = self#list self#vhdl_port_t generics  in
394
            let ports = self#list self#vhdl_port_t ports  in
395
            ComponentDecl { name; generics; ports }
396
        | Subprogram { spec; decl_part; stmts } ->
397
            let spec = self#vhdl_subprogram_spec_t spec  in
398
            let decl_part = self#list self#vhdl_declaration_t decl_part  in
399
            let stmts = self#list self#vhdl_sequential_stmt_t stmts  in
400
            Subprogram { spec; decl_part; stmts }
401

  
402
    method vhdl_declarative_item_t :
403
      vhdl_declarative_item_t -> vhdl_declarative_item_t=
404
      fun { use_clause; declaration; definition }  ->
405
        let use_clause = self#option self#vhdl_load_t use_clause  in
406
        let declaration = self#option self#vhdl_declaration_t declaration  in
407
        let definition = self#option self#vhdl_definition_t definition  in
408
        { use_clause; declaration; definition }
409

  
410
    method vhdl_waveform_element_t :
411
      vhdl_waveform_element_t -> vhdl_waveform_element_t=
412
      fun { value; delay }  ->
413
        let value = self#option self#vhdl_expr_t value  in
414
        let delay = self#option self#vhdl_expr_t delay  in { value; delay }
415

  
416
    method vhdl_signal_condition_t :
417
      vhdl_signal_condition_t -> vhdl_signal_condition_t=
418
      fun { expr; cond }  ->
419
        let expr = self#list self#vhdl_waveform_element_t expr  in
420
        let cond = self#option self#vhdl_expr_t cond  in { expr; cond }
421

  
422
    method vhdl_signal_selection_t :
423
      vhdl_signal_selection_t -> vhdl_signal_selection_t=
424
      fun { expr; when_sel }  ->
425
        let expr = self#list self#vhdl_waveform_element_t expr  in
426
        let when_sel = self#list self#vhdl_expr_t when_sel  in
427
        { expr; when_sel }
428

  
429
    method vhdl_conditional_signal_t :
430
      vhdl_conditional_signal_t -> vhdl_conditional_signal_t=
431
      fun { postponed; label; lhs; rhs; delay }  ->
432
        let postponed = self#bool postponed  in
433
        let label = self#vhdl_name_t label  in
434
        let lhs = self#vhdl_name_t lhs  in
435
        let rhs = self#list self#vhdl_signal_condition_t rhs  in
436
        let delay = self#vhdl_expr_t delay  in
437
        { postponed; label; lhs; rhs; delay }
438

  
439
    method vhdl_process_t : vhdl_process_t -> vhdl_process_t=
440
      fun { id; declarations; active_sigs; body }  ->
441
        let id = self#vhdl_name_t id  in
442
        let declarations = self#list self#vhdl_declarative_item_t declarations  in
443
        let active_sigs = self#list self#vhdl_name_t active_sigs  in
444
        let body = self#list self#vhdl_sequential_stmt_t body  in
445
        { id; declarations; active_sigs; body }
446

  
447
    method vhdl_selected_signal_t :
448
      vhdl_selected_signal_t -> vhdl_selected_signal_t=
449
      fun { postponed; label; lhs; sel; branches; delay }  ->
450
        let postponed = self#bool postponed  in
451
        let label = self#vhdl_name_t label  in
452
        let lhs = self#vhdl_name_t lhs  in
453
        let sel = self#vhdl_expr_t sel  in
454
        let branches = self#list self#vhdl_signal_selection_t branches  in
455
        let delay = self#option self#vhdl_expr_t delay  in
456
        { postponed; label; lhs; sel; branches; delay }
457

  
458
    method vhdl_port_mode_t : vhdl_port_mode_t -> vhdl_port_mode_t=
459
      fun x  -> x
460

  
461
    method vhdl_component_instantiation_t :
462
      vhdl_component_instantiation_t -> vhdl_component_instantiation_t=
463
        fun { name; inst_unit; inst_unit_type; archi_name; generic_map; port_map }  ->
464
        let name = self#vhdl_name_t name  in
465
        let inst_unit = self#vhdl_name_t inst_unit  in
466
        let inst_unit_type = self#string inst_unit_type  in
467
        let archi_name = self#option self#vhdl_name_t archi_name  in
468
        let generic_map = self#list self#vhdl_assoc_element_t generic_map  in
469
        let port_map = self#list self#vhdl_assoc_element_t port_map  in
470
        { name; inst_unit; inst_unit_type; archi_name; generic_map; port_map }
471

  
472
    method vhdl_concurrent_stmt_t :
473
      vhdl_concurrent_stmt_t -> vhdl_concurrent_stmt_t=
474
      fun x  ->
475
        match x with
476
        | SigAssign a -> let a = self#vhdl_conditional_signal_t a  in SigAssign a
477
        | Process a -> let a = self#vhdl_process_t a  in Process a
478
        | SelectedSig a -> let a = self#vhdl_selected_signal_t a  in SelectedSig a
479
        | ComponentInst a -> let a = self#vhdl_component_instantiation_t a  in ComponentInst a 
480

  
481
    method vhdl_port_t : vhdl_port_t -> vhdl_port_t=
482
      fun { names; mode; typ; expr }  ->
483
        let names = self#list self#vhdl_name_t names  in
484
        let mode = self#vhdl_port_mode_t mode  in
485
        let typ = self#vhdl_subtype_indication_t typ  in
486
        let expr = self#vhdl_expr_t expr  in { names; mode; typ; expr }
487

  
488
    method vhdl_entity_t : vhdl_entity_t -> unit =
489
      fun { name; generics; ports; declaration; stmts }  ->
490
        let name = self#vhdl_name_t name  in
491
        let generics = self#list self#vhdl_port_t generics  in
492
        let ports = self#list self#vhdl_port_t ports  in
493
        let declaration = self#list self#vhdl_declarative_item_t declaration
494
           in
495
        let stmts = self#list self#vhdl_concurrent_stmt_t stmts  in ()
496

  
497
        
498

  
499
    method vhdl_package_t : (vhdl_load_t list * vhdl_package_t) -> vhdl_package_t=
500
      fun ( ctxs, {name; shared_defs; shared_decls; shared_uses })  ->
501
        let name = self#vhdl_name_t name  in
502
        let shared_defs = self#list self#vhdl_definition_t shared_defs  in
503
        let shared_decls = self#list self#vhdl_declaration_t shared_decls  in
504
        let shared_uses = self#list self#vhdl_load_t shared_uses @ ctxs in
505
        { name; shared_defs; shared_decls; shared_uses }
506

  
507
    method vhdl_load_t : vhdl_load_t -> vhdl_load_t=
508
      fun x  ->
509
        match x with
510
        | Library a -> let a = self#list self#vhdl_name_t a  in Library a
511
        | Use a -> let a = self#list self#vhdl_name_t a  in Use a
512

  
513
    method vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list *
514
                                  (vhdl_load_t list * vhdl_entity_t) list * 
515
                                  (vhdl_load_t list * vhdl_configuration_t) list *
516
                                  (vhdl_load_t list * vhdl_architecture_t)) -> mini_vhdl_component_t=
517
        fun ( packs_pairs, ents_pairs, confs_pairs, (arch_ctx, arch) ) ->
518
        let names = arch.name::(arch.entity::[])  in
519
        let (ref_ent_ctx,ref_ent) = self#filter_entity (ents_pairs, arch.entity) in
520
        let contexts =
521
          arch_ctx @
522
          ref_ent_ctx @
523
          self#declarative_items_uses arch.declarations @
524
          self#declarative_items_uses ref_ent.declaration in
525
        let declarations = 
526
          self#declarative_items_declarations arch.declarations @
527
          self#declarative_items_declarations ref_ent.declaration in
528
        let definitions =
529
          self#declarative_items_definitions arch.declarations @
530
          self#declarative_items_definitions ref_ent.declaration in
531
        let body = 
532
          arch.body @ 
533
          ref_ent.stmts in
534
        { names; generics=ref_ent.generics; ports=ref_ent.ports; contexts=contexts; declarations=declarations; definitions=definitions; body=body }
535

  
536
    method declarative_items_declarations : vhdl_declarative_item_t list -> vhdl_declaration_t list =
537
      fun x ->
538
        let rec map_decls l = match l with
539
        | {use_clause=_; declaration=Some a;definition=_}::tl -> a::map_decls tl
540
        | _::tl -> map_decls tl
541
        | [] -> [] in map_decls x
542

  
543
    method declarative_items_definitions : vhdl_declarative_item_t list -> vhdl_definition_t list =
544
      fun x ->
545
        let rec map_decls l = match l with
546
        | {use_clause=_; declaration=_;definition=Some a}::tl -> a::map_decls tl
547
        | _::tl -> map_decls tl
548
        | [] -> [] in map_decls x
549

  
550
    method declarative_items_uses : vhdl_declarative_item_t list -> vhdl_load_t list =
551
      fun x ->
552
        let rec map_decls l = match l with
553
        | {use_clause=Some a; declaration=_;definition=_}::tl -> a::map_decls tl
554
        | _::tl -> map_decls tl
555
        | [] -> [] in map_decls x
556

  
557
    method filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) -> 
558
                           (vhdl_load_t list * vhdl_entity_t) =
559
      fun ( entities_pair, filter_name ) ->
560
      let rec filter ep n = match ep with
561
      | [] -> failwith "Impossible to find a matching entity"
562
      | (c,{name; generics; ports; declaration;stmts})::tl -> 
563
          if (name = n) then 
564
            List.hd ep
565
          else filter (List.tl ep) n in
566
      filter entities_pair filter_name
567

  
568
    method vhdl_configuration_t :
569
      vhdl_configuration_t -> unit= self#unit
570

  
571
    method vhdl_library_unit_t : vhdl_library_unit_t -> unit=
572
      fun x  ->
573
        match x with
574
        | Package a -> let a = self#vhdl_package_t ([],a)  in ()
575
        | Entities a -> let a = self#vhdl_entity_t a  in ()
576
        | Architecture a ->
577
            let a = self#vhdl_architecture_t ([],[],[],([],a))  in ()
578
        | Configuration a ->
579
            let a = self#vhdl_configuration_t a  in ()
580

  
581
    method vhdl_design_unit_t : vhdl_design_unit_t -> unit=
582
      fun { contexts; library }  ->
583
        let contexts = self#list self#vhdl_load_t contexts  in
584
        let library = self#vhdl_library_unit_t library  in ()
585

  
586
    method vhdl_design_file_t : vhdl_design_file_t -> mini_vhdl_design_file_t=
587
      fun { design_units }  ->
588
        let rec inline_df l packs ents archs confs = match l with
589
          | [] -> (List.rev packs, List.rev ents, List.rev archs, List.rev confs)
590
          | {contexts = c; library = lib}::tl -> match lib with
591
            | Package p -> inline_df tl ((c,p)::packs) ents archs confs
592
            | Entities e -> inline_df tl packs ((c,e)::ents) archs confs
593
            | Architecture a -> inline_df tl packs ents ((c,a)::archs) confs
594
            | Configuration conf -> inline_df tl packs ents archs ((c,conf)::confs) in
595
        let (p,e,a,con) = inline_df design_units [] [] [] [] in
596
        let app x = self#vhdl_architecture_t (p,e,con,x) in
597
        let components = List.map app a in
598
        let packages = List.map self#vhdl_package_t p in
599
        { components; packages }
600

  
601
  end
src/backends/VHDL/vhdl_ast_utils.ml
1 1
open Vhdl_ast_map
2 2
open Vhdl_to_lustre
3
open Vhdl_2_mini_vhdl_map
3 4
open Vhdl_ast
5
open Mini_vhdl_ast
4 6
open Ppxlib_traverse_builtins
5 7

  
6 8
let any x = x
......
22 24

  
23 25
  method unit: unit T.map = any
24 26
end
27

  
28
let to_mini_vhdl = object (self)
29
  inherit Ppxlib_traverse_builtins.map
30
  inherit vhdl_2_mini_vhdl_map as super
31

  
32
  method unit: unit T.map = any
33
end
src/tools/importer/main_lustre_importer.ml
18 18
open Vhdl_ast_utils
19 19
open Vhdl_ast_map
20 20
open Vhdl_ast
21
open Mini_vhdl_ast
22
open Mini_vhdl_ast_pp
21 23
open Vhdl_ast_pp
22 24
open Vhdl_ast_yojson
23 25
open Printf
......
38 40
      (* Format.printf "Parsed VHDL: \n%s\n" (pretty_to_string (vhdl_file_t_to_yojson x)); *)
39 41
      (* Fold Op vhdl_expr_t values *)
40 42
      let folded = replace_op_expr#vhdl_file_t x in
41
      (* Translate vhdl_file_t value as lustre value *)
42
      let program = to_lustre#vhdl_file_t folded in
43
      Format.printf "%s\n" (show_vhdl_file_t program);
43
      (* Pretty-print vhdl *)
44
      Format.printf "============ Parsed VHDL ============\n%s\n" (show_vhdl_file_t folded);
45

  
46
      (* Translate vhdl_file_t value as mini_vhdl value *)
47
      let mini_vhdl = to_mini_vhdl#vhdl_design_file_t folded.design_file in
48
      Format.printf "============ Mini-VHDL ============\n%s\n" (show_mini_vhdl_design_file_t mini_vhdl);
44 49
      (* Pretty print lustre value *)
45 50
 (*     Printers.pp_prog std_formatter program; *)
46 51
      

Also available in: Unified diff