Project

General

Profile

Revision d3f0059e

View differences:

src/tools/importer/main_lustre_importer.ml
14 14
open Vhdl_test
15 15
  *)
16 16
open Yojson.Safe
17
open Vhdl_ast_utils
18
open Vhdl_ast_map
17 19
open Vhdl_ast
20
open Ppxlib_traverse_builtins
18 21
open Printf
19 22

  
20 23
let _ =
......
24 27
  (* Create VHDL values *)
25 28
  let vhdl = vhdl_file_t_of_yojson vhdl_json in
26 29

  
30
  (* Simplify VHDL values *)
27 31
  match vhdl with
28 32
    Ok x ->
29
      Format.printf "Parsed VHDL: \n%s\n" (pretty_to_string (vhdl_file_t_to_yojson x))
33
      Format.printf "Parsed VHDL: \n%s\n" (pretty_to_string (vhdl_file_t_to_yojson x));
34
      let folded = replace_op_expr#vhdl_file_t x in
35
      Format.printf "PP VHDL: \n%s\n" (show_vhdl_file_t folded);
30 36
  | Error e -> Format.printf "Error: %s\n" e;
37

  
src/tools/importer/vhdl_ast.ml
22 22
    CstInt of int 
23 23
  | CstStdLogic of string
24 24
  | CstLiteral of string [@name "CST_LITERAL"]
25
[@@deriving yojson {strict = false}];;
25
[@@deriving show { with_path = false }, yojson {strict = false}];;
26

  
27
(*
28
let pp_cst_val fmt c =
29
  match c with
30
  | CstInt i -> Format.fprintf fmt "%i" i
31
  | CstStdLogic s -> if List.mem s std_logic_cst then Format.fprintf fmt "%s" s else assert false
32
  | CstLiteral s -> Format.fprintf fmt "%s" s
33
*)
26 34

  
27 35
type vhdl_type_t =
28 36
  | Base of string
......
58 66
  | IsNull [@name "IsNull"]
59 67
  | Time of { value: int; phy_unit: string [@default ""]}
60 68
  | Sig of { name: vhdl_name_t; att: vhdl_signal_attributes_t option }
61
  | SuffixMod of { expr : vhdl_expr_t; selection : suffix_selection_t }
69
  | SuffixMod of { expr : vhdl_expr_t; selection : vhdl_suffix_selection_t }
62 70
  | Aggregate of { elems : vhdl_element_assoc_t list } [@name "AGGREGATE"]
63 71
  | Others [@name "OTHERS"]
64 72
and vhdl_name_t =
......
88 96
  | AAttAscending
89 97
and vhdl_signal_attributes_t = SigAtt of string
90 98
and vhdl_string_attributes_t = StringAtt of string
91
and suffix_selection_t = Idx of int | SuffixRange of int * int
92
[@@deriving yojson {strict = false}];;
99
and vhdl_suffix_selection_t = Idx of int | SuffixRange of int * int
100
[@@deriving show { with_path = false }, yojson {strict = false}];;
101

  
102
(*
103
let rec pp_vhdl_type fmt t =
104
  match t with
105
  | Base s -> Format.fprintf fmt "%s" s 
106
  | Range(base, n, m) -> Format.fprintf fmt "%trange %i to %i" (fun fmt -> match base with Some s -> Format.fprintf fmt "%s " s | None -> ()) n m
107
  | Bit_vector (n,m) -> Format.fprintf fmt "bit_vector(%i downto %i)" n m
108
  | Array (n, m, base) -> Format.fprintf fmt "array (%i to %i) of %a" n m pp_vhdl_type base
109
  | Enumerated sl -> Format.fprintf fmt "(%a)" (Utils.fprintf_list ~sep:", " Format.pp_print_string) sl
110
  | Void -> Format.fprintf fmt ""
111
*)
93 112

  
94 113
(************************************************************************************)		   
95 114
(*            Attributes for types, arrays, signals and strings                     *)
......
100 119
  | TAttIntArg of { id: string; arg: int }
101 120
  | TAttValArg of { id: string; arg: 'basetype }
102 121
  | TAttStringArg of { id: string; arg: string }
103
[@@deriving yojson {strict = false}];;
122
[@@deriving show { with_path = false }, yojson {strict = false}];;
104 123

  
105 124
let typ_att_noarg = ["base"; "left"; "right"; "high"; "low"]
106 125
let typ_att_intarg = ["pos"; "val"; "succ"; "pred"; "leftof"; "rightof"]
......
116 135
    typ: vhdl_subtype_indication_t;
117 136
    init_val: cst_val_t option [@default Some (CstInt (0))];
118 137
  }
119
[@@deriving yojson {strict = false}];;
138
[@@deriving show { with_path = false }, yojson {strict = false}];;
120 139

  
121 140
type vhdl_subprogram_spec_t =
122 141
  {
......
125 144
    parameters: vhdl_parameter_t list;
126 145
    isPure: bool [@default false];
127 146
  }
128
[@@deriving yojson {strict = false}];;
147
[@@deriving show { with_path = false }, yojson {strict = false}];;
129 148

  
130 149
(************************************************************************************)		   
131 150
(*                        Expressions  / Statements                                 *)
......
157 176
    when_cond: vhdl_expr_t list;
158 177
    when_stmt: vhdl_sequential_stmt_t list;
159 178
  }
160
[@@deriving yojson {strict = false}];;
179
[@@deriving show { with_path = false }, yojson {strict = false}];;
161 180

  
162 181
type vhdl_declaration_t =
163 182
  | VarDecl of {
......
182 201
      decl_part: vhdl_declaration_t list [@default []]; 
183 202
      stmts: vhdl_sequential_stmt_t list [@default []]
184 203
    } [@name "SUBPROGRAM_BODY"]
185
[@@deriving yojson {strict = false}];;
204
[@@deriving show { with_path = false }, yojson {strict = false}];;
186 205

  
187
type signal_condition_t =
206
type vhdl_signal_condition_t =
188 207
  {                            
189 208
    expr: vhdl_expr_t list;              (* when expression *)
190 209
    cond: vhdl_expr_t [@default IsNull];  (* optional else case expression. 
191 210
                                             If None, could be a latch  *)
192 211
  }
193
[@@deriving yojson {strict = false}];;
212
[@@deriving show { with_path = false }, yojson {strict = false}];;
194 213

  
195
type signal_selection_t =
214
type vhdl_signal_selection_t =
196 215
  {
197 216
    expr : vhdl_expr_t;
198 217
    when_sel: vhdl_expr_t list [@default []];
199 218
  }
200
[@@deriving yojson {strict = false}];;
219
[@@deriving show { with_path = false }, yojson {strict = false}];;
201 220

  
202
type conditional_signal_t =
221
type vhdl_conditional_signal_t =
203 222
  {
204 223
    postponed: bool [@default false];
205 224
    label: vhdl_name_t [@default NoName];
206 225
    lhs: vhdl_name_t;        (* assigned signal = target*)
207
    rhs: signal_condition_t list;                   (* expression *)
226
    rhs: vhdl_signal_condition_t list;                   (* expression *)
208 227
    cond: vhdl_expr_t [@default IsNull];
209 228
    delay: vhdl_expr_t [@default IsNull];
210 229
  }
211
[@@deriving yojson {strict = false}];;
230
[@@deriving show { with_path = false }, yojson {strict = false}];;
212 231

  
213
type process_t =
232
type vhdl_process_t =
214 233
  { 
215 234
    id: vhdl_name_t [@default NoName];
216 235
    declarations: vhdl_declaration_t list option [@key "PROCESS_DECLARATIVE_PART"] [@default Some []];
217 236
    active_sigs: vhdl_name_t list [@default []];
218 237
    body: vhdl_sequential_stmt_t list [@key "PROCESS_STATEMENT_PART"] [@default []]
219 238
  }
220
[@@deriving yojson {strict = false}];;
239
[@@deriving show { with_path = false }, yojson {strict = false}];;
221 240

  
222
type selected_signal_t = 
241
type vhdl_selected_signal_t = 
223 242
  { 
224 243
    postponed: bool [@default false];
225 244
    label: vhdl_name_t [@default NoName];
226 245
    lhs: vhdl_name_t;      (* assigned signal = target *)
227 246
    sel: vhdl_expr_t;  
228
    branches: signal_selection_t list [@default []];
247
    branches: vhdl_signal_selection_t list [@default []];
229 248
    delay: vhdl_expr_t option;
230 249
  }
231
[@@deriving yojson {strict = false}];;
250
[@@deriving show { with_path = false }, yojson {strict = false}];;
232 251
			   
233 252
type vhdl_concurrent_stmt_t =
234
  | SigAssign of conditional_signal_t [@name "CONDITIONAL_SIGNAL_ASSIGNMENT"]
235
  | Process of process_t [@name "PROCESS_STATEMENT"]
236
  | SelectedSig of selected_signal_t [@name "SELECTED_SIGNAL_ASSIGNMENT"]
237
[@@deriving yojson {strict = false}];;
253
  | SigAssign of vhdl_conditional_signal_t [@name "CONDITIONAL_SIGNAL_ASSIGNMENT"]
254
  | Process of vhdl_process_t [@name "PROCESS_STATEMENT"]
255
  | SelectedSig of vhdl_selected_signal_t [@name "SELECTED_SIGNAL_ASSIGNMENT"]
256
[@@deriving show { with_path = false }, yojson {strict = false}];;
238 257
  (*
239 258
type vhdl_statement_t =
240 259
  
......
252 271
  | OutPort    [@name "out"]
253 272
  | InoutPort  [@name "inout"]
254 273
  | BufferPort [@name "buffer"]
255
[@@deriving yojson];;
274
[@@deriving show { with_path = false }, yojson];;
256 275
	     
257 276
type vhdl_port_t =
258 277
  {
......
261 280
    typ: vhdl_subtype_indication_t;
262 281
    expr: vhdl_expr_t [@default IsNull];
263 282
  }
264
[@@deriving yojson {strict = false}];;
283
[@@deriving show { with_path = false }, yojson {strict = false}];;
265 284

  
266 285
type vhdl_entity_t =
267 286
  {
......
271 290
    declaration: vhdl_declaration_t list [@key "ENTITY_DECLARATIVE_PART"] [@default []];
272 291
    stmts: vhdl_concurrent_stmt_t list [@key "ENTITY_STATEMENT_PART"] [@default []]; 
273 292
  }
274
[@@deriving yojson {strict = false}];;
293
[@@deriving show { with_path = false }, yojson {strict = false}];;
275 294

  
276 295
(************************************************************************************)		   
277 296
(*                    Packages / Library loading                                    *)
......
283 302
    name: vhdl_name_t [@default NoName];
284 303
    shared_defs: vhdl_definition_t list [@default []];
285 304
  }
286
[@@deriving yojson {strict = false}];;
305
[@@deriving show { with_path = false }, yojson {strict = false}];;
287 306

  
288 307
type vhdl_load_t = 
289 308
    Library of vhdl_name_t list [@name "LIBRARY_CLAUSE"] [@default []]
290 309
  | Use of vhdl_name_t list [@name "USE_CLAUSE"] [@default []]
291
[@@deriving yojson];;
310
[@@deriving show { with_path = false }, yojson];;
292 311

  
293 312
(************************************************************************************)		   
294 313
(*                        Architecture / VHDL Design                                *)
......
301 320
    declarations: vhdl_declaration_t list [@key "ARCHITECTURE_DECLARATIVE_PART"] [@default []];
302 321
    body: vhdl_concurrent_stmt_t list [@key "ARCHITECTURE_STATEMENT_PART"] [@default []]; 
303 322
  }
304
[@@deriving yojson {strict = false}];;
323
[@@deriving show { with_path = false }, yojson {strict = false}];;
305 324
    
306 325
(* TODO. Configuration is optional *)
307 326
type vhdl_configuration_t = unit
308
[@@deriving yojson {strict = false}];;
327
[@@deriving show { with_path = false }, yojson {strict = false}];;
309 328

  
310 329
type vhdl_library_unit_t = (* TODO: PACKAGE_BODY *)
311 330
    Package of vhdl_package_t [@name "PACKAGE_DECLARATION"]
312 331
  | Entities of vhdl_entity_t [@name "ENTITY_DECLARATION"]
313 332
  | Architecture of vhdl_architecture_t [@name "ARCHITECTURE_BODY"]
314 333
  | Configuration of vhdl_configuration_t [@name "CONFIGURATION_DECLARATION"]
315
[@@deriving yojson {strict = false}];;
334
[@@deriving show { with_path = false }, yojson {strict = false}];;
316 335

  
317 336
type vhdl_design_unit_t =
318 337
  {
319 338
    contexts: vhdl_load_t list [@default []];
320 339
    library: vhdl_library_unit_t;
321 340
  }
322
[@@deriving yojson {strict = false}];;
341
[@@deriving show { with_path = false }, yojson {strict = false}];;
323 342

  
324 343
type vhdl_design_file_t =
325 344
  {
326 345
    design_units: vhdl_design_unit_t list [@default []];
327 346
  }
328
[@@deriving yojson {strict = false}];;
347
[@@deriving show { with_path = false }, yojson {strict = false}];;
329 348

  
330 349
type vhdl_file_t = 
331 350
  {
332 351
    design_file: vhdl_design_file_t [@default {design_units=[]}] [@key "DESIGN_FILE"];
333 352
  }
334
[@@deriving yojson];;
353
[@@deriving show { with_path = false }, yojson];;
src/tools/importer/vhdl_ast_map.ml
1
open Vhdl_ast
2

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

  
42
class virtual vhdl_map =
43
  object (self)
44
    method virtual  string : string -> string
45
    method virtual  list : 'a . ('a -> 'a) -> 'a list -> 'a list
46
    method virtual  unit : unit -> unit
47
    method virtual  bool : bool -> bool
48
    method virtual  option : 'a . ('a -> 'a) -> 'a option -> 'a option
49
    method virtual  int : int -> int
50
    method virtual  vhdl_name_t : vhdl_name_t -> vhdl_name_t
51
    method virtual  vhdl_definition_t : vhdl_definition_t -> vhdl_definition_t
52
    method virtual  vhdl_port_t : vhdl_port_t -> vhdl_port_t
53
    method virtual  vhdl_expr_t : vhdl_expr_t -> vhdl_expr_t
54
    method virtual  vhdl_port_mode_t : vhdl_port_mode_t -> vhdl_port_mode_t
55
    method virtual  vhdl_subtype_indication_t : vhdl_subtype_indication_t -> vhdl_subtype_indication_t
56
    method virtual  vhdl_conditional_signal_t : vhdl_conditional_signal_t -> vhdl_conditional_signal_t
57
    method virtual  vhdl_process_t : vhdl_process_t -> vhdl_process_t
58
    method virtual  vhdl_selected_signal_t : vhdl_selected_signal_t -> vhdl_selected_signal_t
59
    method virtual  vhdl_signal_selection_t : vhdl_signal_selection_t -> vhdl_signal_selection_t
60
    method virtual  vhdl_suffix_selection_t : vhdl_suffix_selection_t -> vhdl_suffix_selection_t
61
    method virtual  vhdl_declaration_t : vhdl_declaration_t -> vhdl_declaration_t
62
    method virtual  vhdl_sequential_stmt_t : vhdl_sequential_stmt_t -> vhdl_sequential_stmt_t
63
    method virtual  vhdl_signal_condition_t : vhdl_signal_condition_t -> vhdl_signal_condition_t
64
    method virtual  cst_val_t : cst_val_t -> cst_val_t
65
    method virtual  vhdl_subprogram_spec_t : vhdl_subprogram_spec_t -> vhdl_subprogram_spec_t
66
    method virtual  vhdl_discrete_range_t : vhdl_discrete_range_t -> vhdl_discrete_range_t
67
    method virtual  vhdl_parameter_t : vhdl_parameter_t -> vhdl_parameter_t
68
    method virtual  vhdl_concurrent_stmt_t : vhdl_concurrent_stmt_t -> vhdl_concurrent_stmt_t
69
    method virtual  vhdl_declaration_t : vhdl_declaration_t -> vhdl_declaration_t
70
    method virtual  vhdl_architecture_t : vhdl_architecture_t -> vhdl_architecture_t
71
    method virtual  vhdl_configuration_t : vhdl_configuration_t -> vhdl_configuration_t
72
    method virtual  vhdl_entity_t : vhdl_entity_t -> vhdl_entity_t
73
    method virtual  vhdl_package_t : vhdl_package_t -> vhdl_package_t
74
    method virtual  vhdl_library_unit_t : vhdl_library_unit_t -> vhdl_library_unit_t
75
    method virtual  vhdl_load_t : vhdl_load_t -> vhdl_load_t
76
    method virtual  vhdl_design_unit_t : vhdl_design_unit_t -> vhdl_design_unit_t
77
    method virtual  vhdl_design_file_t : vhdl_design_file_t -> vhdl_design_file_t
78

  
79
    method cst_val_t : cst_val_t -> cst_val_t=
80
      fun x  ->
81
        match x with
82
        | CstInt a -> let a = self#int a  in CstInt a
83
        | CstStdLogic a -> let a = self#string a  in CstStdLogic a
84
        | CstLiteral a -> let a = self#string a  in CstLiteral a
85

  
86
    method vhdl_type_t : vhdl_type_t -> vhdl_type_t=
87
      fun x  ->
88
        match x with
89
        | Base a -> let a = self#string a  in Base a
90
        | Range (a,b,c) ->
91
            let a = self#option self#string a  in
92
            let b = self#int b  in let c = self#int c  in Range (a, b, c)
93
        | Bit_vector (a,b) ->
94
            let a = self#int a  in let b = self#int b  in Bit_vector (a, b)
95
        | Array (a,b,c) ->
96
            let a = self#int a  in
97
            let b = self#int b  in
98
            let c = self#vhdl_type_t c  in Array (a, b, c)
99
        | Enumerated a -> let a = self#list self#string a  in Enumerated a
100
        | Void  -> Void
101
    method vhdl_subtype_indication_t :
102
      vhdl_subtype_indication_t -> vhdl_subtype_indication_t=
103
      fun { name; functionName; const }  ->
104
        let name = self#vhdl_name_t name  in
105
        let functionName = self#vhdl_name_t functionName  in
106
        let const = self#vhdl_constraint_t const  in
107
        { name; functionName; const }
108
    method vhdl_discrete_range_t :
109
      vhdl_discrete_range_t -> vhdl_discrete_range_t=
110
      fun x  ->
111
        match x with
112
        | SubDiscreteRange a ->
113
            let a = self#vhdl_subtype_indication_t a  in SubDiscreteRange a
114
        | NamedRange a -> let a = self#vhdl_name_t a  in NamedRange a
115
        | DirectedRange { direction; from; _to } ->
116
            let direction = self#string direction  in
117
            let from = self#vhdl_expr_t from  in
118
            let _to = self#vhdl_expr_t _to  in
119
            DirectedRange { direction; from; _to }
120

  
121
    method vhdl_constraint_t : vhdl_constraint_t -> vhdl_constraint_t=
122
      fun x  ->
123
        match x with
124
        | RefConstraint { ref_name } ->
125
            let ref_name = self#vhdl_name_t ref_name  in
126
            RefConstraint { ref_name }
127
        | RangeConstraint { range } ->
128
            let range = self#vhdl_discrete_range_t range  in
129
            RangeConstraint { range }
130
        | IndexConstraint { ranges } ->
131
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
132
            IndexConstraint { ranges }
133
        | ArrayConstraint { ranges; sub } ->
134
            let ranges = self#list self#vhdl_discrete_range_t ranges  in
135
            let sub = self#vhdl_constraint_t sub  in
136
            ArrayConstraint { ranges; sub }
137
        | RecordConstraint  -> RecordConstraint
138
        | NoConstraint  -> NoConstraint
139

  
140
    method vhdl_definition_t : vhdl_definition_t -> vhdl_definition_t=
141
      fun x  ->
142
        match x with
143
        | Type { name; definition } ->
144
            let name = self#vhdl_name_t name  in
145
            let definition = self#vhdl_type_t definition  in
146
            Type { name; definition }
147
        | Subtype { name; typ } ->
148
            let name = self#vhdl_name_t name  in
149
            let typ = self#vhdl_subtype_indication_t typ  in
150
            Subtype { name; typ }
151
    method vhdl_expr_t : vhdl_expr_t -> vhdl_expr_t=
152
      fun x  ->
153
        match x with
154
        | Call a -> let a = self#vhdl_name_t a  in Call a
155
        | Cst a -> let a = self#cst_val_t a  in Cst a
156
        | Op { id; args } ->
157
            let id = self#string id  in
158
            let args = self#list self#vhdl_expr_t args  in Op { id; args }
159
        | IsNull  -> IsNull
160
        | Time { value; phy_unit } ->
161
            let value = self#int value  in
162
            let phy_unit = self#string phy_unit  in Time { value; phy_unit }
163
        | Sig { name; att } ->
164
            let name = self#vhdl_name_t name  in
165
            let att = self#option self#vhdl_signal_attributes_t att  in
166
            Sig { name; att }
167
        | SuffixMod { expr; selection } ->
168
            let expr = self#vhdl_expr_t expr  in
169
            let selection = self#vhdl_suffix_selection_t selection  in
170
            SuffixMod { expr; selection }
171
        | Aggregate { elems } ->
172
            let elems = self#list self#vhdl_element_assoc_t elems  in
173
            Aggregate { elems }
174
        | Others  -> Others
175
    method vhdl_name_t : vhdl_name_t -> vhdl_name_t=
176
      fun x  ->
177
        match x with
178
        | Simple a -> let a = self#string a  in Simple a
179
        | Identifier a -> let a = self#string a  in Identifier a
180
        | Selected a -> let a = self#list self#vhdl_name_t a  in Selected a
181
        | Index { id; exprs } ->
182
            let id = self#vhdl_name_t id  in
183
            let exprs = self#list self#vhdl_expr_t exprs  in
184
            Index { id; exprs }
185
        | Slice { id; range } ->
186
            let id = self#vhdl_name_t id  in
187
            let range = self#vhdl_discrete_range_t range  in
188
            Slice { id; range }
189
        | Attribute { id; designator; expr } ->
190
            let id = self#vhdl_name_t id  in
191
            let designator = self#vhdl_name_t designator  in
192
            let expr = self#vhdl_expr_t expr  in
193
            Attribute { id; designator; expr }
194
        | Function { id; assoc_list } ->
195
            let id = self#vhdl_name_t id  in
196
            let assoc_list = self#list self#vhdl_assoc_element_t assoc_list
197
               in
198
            Function { id; assoc_list }
199
        | NoName  -> NoName
200
    method vhdl_assoc_element_t :
201
      vhdl_assoc_element_t -> vhdl_assoc_element_t=
202
      fun
203
        { formal_name; formal_arg; actual_name; actual_designator;
204
          actual_expr }
205
         ->
206
        let formal_name = self#option self#vhdl_name_t formal_name  in
207
        let formal_arg = self#option self#vhdl_name_t formal_arg  in
208
        let actual_name = self#option self#vhdl_name_t actual_name  in
209
        let actual_designator =
210
          self#option self#vhdl_name_t actual_designator  in
211
        let actual_expr = self#option self#vhdl_expr_t actual_expr  in
212
        {
213
          formal_name;
214
          formal_arg;
215
          actual_name;
216
          actual_designator;
217
          actual_expr
218
        }
219
    method vhdl_element_assoc_t :
220
      vhdl_element_assoc_t -> vhdl_element_assoc_t=
221
      fun { choices; expr }  ->
222
        let choices = self#list self#vhdl_expr_t choices  in
223
        let expr = self#vhdl_expr_t expr  in { choices; expr }
224
    method vhdl_array_attributes_t :
225
      vhdl_array_attributes_t -> vhdl_array_attributes_t=
226
      fun x  ->
227
        match x with
228
        | AAttInt { id; arg } ->
229
            let id = self#string id  in
230
            let arg = self#int arg  in AAttInt { id; arg }
231
        | AAttAscending  -> AAttAscending
232
    method vhdl_signal_attributes_t :
233
      vhdl_signal_attributes_t -> vhdl_signal_attributes_t=
234
      fun x  -> match x with | SigAtt a -> let a = self#string a  in SigAtt a
235
    method vhdl_string_attributes_t :
236
      vhdl_string_attributes_t -> vhdl_string_attributes_t=
237
      fun x  ->
238
        match x with | StringAtt a -> let a = self#string a  in StringAtt a
239
    method vhdl_suffix_selection_t : vhdl_suffix_selection_t -> vhdl_suffix_selection_t=
240
      fun x  ->
241
        match x with
242
        | Idx a -> let a = self#int a  in Idx a
243
        | SuffixRange (a,b) ->
244
            let a = self#int a  in let b = self#int b  in SuffixRange (a, b)
245

  
246
    method vhdl_type_attributes_t :
247
      'a .
248
        ('a -> 'a) -> 'a vhdl_type_attributes_t -> 'a vhdl_type_attributes_t=
249
      fun _basetype  ->
250
        fun x  ->
251
          match x with
252
          | TAttNoArg { id } -> let id = self#string id  in TAttNoArg { id }
253
          | TAttIntArg { id; arg } ->
254
              let id = self#string id  in
255
              let arg = self#int arg  in TAttIntArg { id; arg }
256
          | TAttValArg { id; arg } ->
257
              let id = self#string id  in
258
              let arg = _basetype arg  in TAttValArg { id; arg }
259
          | TAttStringArg { id; arg } ->
260
              let id = self#string id  in
261
              let arg = self#string arg  in TAttStringArg { id; arg }
262

  
263
    method vhdl_parameter_t : vhdl_parameter_t -> vhdl_parameter_t=
264
      fun { names; mode; typ; init_val }  ->
265
        let names = self#list self#vhdl_name_t names  in
266
        let mode = self#list self#string mode  in
267
        let typ = self#vhdl_subtype_indication_t typ  in
268
        let init_val = self#option self#cst_val_t init_val  in
269
        { names; mode; typ; init_val }
270

  
271
    method vhdl_subprogram_spec_t :
272
      vhdl_subprogram_spec_t -> vhdl_subprogram_spec_t=
273
      fun { name; typeMark; parameters; isPure }  ->
274
        let name = self#string name  in
275
        let typeMark = self#vhdl_name_t typeMark  in
276
        let parameters = self#list self#vhdl_parameter_t parameters  in
277
        let isPure = self#bool isPure  in
278
        { name; typeMark; parameters; isPure }
279

  
280
    method vhdl_sequential_stmt_t :
281
      vhdl_sequential_stmt_t -> vhdl_sequential_stmt_t=
282
      fun x  ->
283
        match x with
284
        | VarAssign { label; lhs; rhs } ->
285
            let label = self#vhdl_name_t label  in
286
            let lhs = self#vhdl_name_t lhs  in
287
            let rhs = self#vhdl_expr_t rhs  in VarAssign { label; lhs; rhs }
288
        | SigSeqAssign { label; lhs; rhs } ->
289
            let label = self#vhdl_name_t label  in
290
            let lhs = self#vhdl_name_t lhs  in
291
            let rhs = self#list self#vhdl_expr_t rhs  in
292
            SigSeqAssign { label; lhs; rhs }
293
        | If { label; if_cases; default } ->
294
            let label = self#vhdl_name_t label  in
295
            let if_cases = self#list self#vhdl_if_case_t if_cases  in
296
            let default = self#list self#vhdl_sequential_stmt_t default  in
297
            If { label; if_cases; default }
298
        | Case { label; guard; branches } ->
299
            let label = self#vhdl_name_t label  in
300
            let guard = self#vhdl_expr_t guard  in
301
            let branches = self#list self#vhdl_case_item_t branches  in
302
            Case { label; guard; branches }
303
        | Exit { label; loop_label; condition } ->
304
            let label = self#vhdl_name_t label  in
305
            let loop_label = self#option self#string loop_label  in
306
            let condition = self#option self#vhdl_expr_t condition  in
307
            Exit { label; loop_label; condition }
308
        | Assert { label; cond; report; severity } ->
309
            let label = self#vhdl_name_t label  in
310
            let cond = self#vhdl_expr_t cond  in
311
            let report = self#vhdl_expr_t report  in
312
            let severity = self#vhdl_expr_t severity  in
313
            Assert { label; cond; report; severity }
314
        | Wait  -> Wait
315
        | Null { label } ->
316
            let label = self#vhdl_name_t label  in Null { label }
317
        | Return { label } ->
318
            let label = self#vhdl_name_t label  in Return { label }
319
    method vhdl_if_case_t : vhdl_if_case_t -> vhdl_if_case_t=
320
      fun { if_cond; if_block }  ->
321
        let if_cond = self#vhdl_expr_t if_cond  in
322
        let if_block = self#list self#vhdl_sequential_stmt_t if_block  in
323
        { if_cond; if_block }
324
    method vhdl_case_item_t : vhdl_case_item_t -> vhdl_case_item_t=
325
      fun { when_cond; when_stmt }  ->
326
        let when_cond = self#list self#vhdl_expr_t when_cond  in
327
        let when_stmt = self#list self#vhdl_sequential_stmt_t when_stmt  in
328
        { when_cond; when_stmt }
329

  
330
    method vhdl_declaration_t : vhdl_declaration_t -> vhdl_declaration_t=
331
      fun x  ->
332
        match x with
333
        | VarDecl { names; typ; init_val } ->
334
            let names = self#list self#vhdl_name_t names  in
335
            let typ = self#vhdl_subtype_indication_t typ  in
336
            let init_val = self#option self#cst_val_t init_val  in
337
            VarDecl { names; typ; init_val }
338
        | CstDecl { names; typ; init_val } ->
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#cst_val_t init_val  in
342
            CstDecl { names; typ; init_val }
343
        | SigDecl { names; typ; init_val } ->
344
            let names = self#list self#vhdl_name_t names  in
345
            let typ = self#vhdl_subtype_indication_t typ  in
346
            let init_val = self#option self#cst_val_t init_val  in
347
            SigDecl { names; typ; init_val }
348
        | Subprogram { name; kind; spec; decl_part; stmts } ->
349
            let name = self#vhdl_name_t name  in
350
            let kind = self#string kind  in
351
            let spec = self#vhdl_subprogram_spec_t spec  in
352
            let decl_part = self#list self#vhdl_declaration_t decl_part  in
353
            let stmts = self#list self#vhdl_sequential_stmt_t stmts  in
354
            Subprogram { name; kind; spec; decl_part; stmts }
355

  
356
    method vhdl_signal_condition_t : vhdl_signal_condition_t -> vhdl_signal_condition_t=
357
      fun { expr; cond }  ->
358
        let expr = self#list self#vhdl_expr_t expr  in
359
        let cond = self#vhdl_expr_t cond  in { expr; cond }
360

  
361
    method vhdl_signal_selection_t : vhdl_signal_selection_t -> vhdl_signal_selection_t=
362
      fun { expr; when_sel }  ->
363
        let expr = self#vhdl_expr_t expr  in
364
        let when_sel = self#list self#vhdl_expr_t when_sel  in
365
        { expr; when_sel }
366

  
367
    method vhdl_conditional_signal_t :
368
      vhdl_conditional_signal_t -> vhdl_conditional_signal_t=
369
      fun { postponed; label; lhs; rhs; cond; delay }  ->
370
        let postponed = self#bool postponed  in
371
        let label = self#vhdl_name_t label  in
372
        let lhs = self#vhdl_name_t lhs  in
373
        let rhs = self#list self#vhdl_signal_condition_t rhs  in
374
        let cond = self#vhdl_expr_t cond  in
375
        let delay = self#vhdl_expr_t delay  in
376
        { postponed; label; lhs; rhs; cond; delay }
377

  
378

  
379
    method vhdl_process_t : vhdl_process_t -> vhdl_process_t=
380
      fun { id; declarations; active_sigs; body }  ->
381
        let id = self#vhdl_name_t id  in
382
        let declarations =
383
          self#option (self#list self#vhdl_declaration_t) declarations  in
384
        let active_sigs = self#list self#vhdl_name_t active_sigs  in
385
        let body = self#list self#vhdl_sequential_stmt_t body  in
386
        { id; declarations; active_sigs; body }
387

  
388
    method vhdl_selected_signal_t : vhdl_selected_signal_t -> vhdl_selected_signal_t=
389
      fun { postponed; label; lhs; sel; branches; delay }  ->
390
        let postponed = self#bool postponed  in
391
        let label = self#vhdl_name_t label  in
392
        let lhs = self#vhdl_name_t lhs  in
393
        let sel = self#vhdl_expr_t sel  in
394
        let branches = self#list self#vhdl_signal_selection_t branches  in
395
        let delay = self#option self#vhdl_expr_t delay  in
396
        { postponed; label; lhs; sel; branches; delay }
397

  
398
    method vhdl_port_mode_t : vhdl_port_mode_t -> vhdl_port_mode_t=
399
      fun x  -> x
400

  
401
    method vhdl_concurrent_stmt_t :
402
      vhdl_concurrent_stmt_t -> vhdl_concurrent_stmt_t=
403
      fun x  ->
404
        match x with
405
        | SigAssign a -> let a = self#vhdl_conditional_signal_t a  in SigAssign a
406
        | Process a -> let a = self#vhdl_process_t a  in Process a
407
        | SelectedSig a -> let a = self#vhdl_selected_signal_t a  in SelectedSig a
408

  
409
    method vhdl_port_t : vhdl_port_t -> vhdl_port_t=
410
      fun { names; mode; typ; expr }  ->
411
        let names = self#list self#vhdl_name_t names  in
412
        let mode = self#vhdl_port_mode_t mode  in
413
        let typ = self#vhdl_subtype_indication_t typ  in
414
        let expr = self#vhdl_expr_t expr  in { names; mode; typ; expr }
415

  
416
    method vhdl_entity_t : vhdl_entity_t -> vhdl_entity_t=
417
      fun { name; generics; ports; declaration; stmts }  ->
418
        let name = self#vhdl_name_t name  in
419
        let generics = self#list self#vhdl_port_t generics  in
420
        let ports = self#list self#vhdl_port_t ports  in
421
        let declaration = self#list self#vhdl_declaration_t declaration  in
422
        let stmts = self#list self#vhdl_concurrent_stmt_t stmts  in
423
        { name; generics; ports; declaration; stmts }
424

  
425
    method vhdl_package_t : vhdl_package_t -> vhdl_package_t=
426
      fun { name; shared_defs }  ->
427
        let name = self#vhdl_name_t name  in
428
        let shared_defs = self#list self#vhdl_definition_t shared_defs  in
429
        { name; shared_defs }
430

  
431
    method vhdl_load_t : vhdl_load_t -> vhdl_load_t=
432
      fun x  ->
433
        match x with
434
        | Library a -> let a = self#list self#vhdl_name_t a  in Library a
435
        | Use a -> let a = self#list self#vhdl_name_t a  in Use a
436

  
437
    method vhdl_architecture_t : vhdl_architecture_t -> vhdl_architecture_t=
438
      fun { name; entity; declarations; body }  ->
439
        let name = self#vhdl_name_t name  in
440
        let entity = self#vhdl_name_t entity  in
441
        let declarations = self#list self#vhdl_declaration_t declarations  in
442
        let body = self#list self#vhdl_concurrent_stmt_t body  in
443
        { name; entity; declarations; body }
444

  
445
    method vhdl_configuration_t :
446
      vhdl_configuration_t -> vhdl_configuration_t= self#unit
447

  
448
    method vhdl_library_unit_t : vhdl_library_unit_t -> vhdl_library_unit_t=
449
      fun x  ->
450
        match x with
451
        | Package a -> let a = self#vhdl_package_t a  in Package a
452
        | Entities a -> let a = self#vhdl_entity_t a  in Entities a
453
        | Architecture a ->
454
            let a = self#vhdl_architecture_t a  in Architecture a
455
        | Configuration a ->
456
            let a = self#vhdl_configuration_t a  in Configuration a
457

  
458
    method vhdl_design_unit_t : vhdl_design_unit_t -> vhdl_design_unit_t=
459
      fun { contexts; library }  ->
460
        let contexts = self#list self#vhdl_load_t contexts  in
461
        let library = self#vhdl_library_unit_t library  in
462
        { contexts; library }
463

  
464
    method vhdl_design_file_t : vhdl_design_file_t -> vhdl_design_file_t=
465
      fun { design_units }  ->
466
        let design_units = self#list self#vhdl_design_unit_t design_units  in
467
        { design_units }
468

  
469
    method vhdl_file_t : vhdl_file_t -> vhdl_file_t=
470
      fun { design_file }  ->
471
        let design_file = self#vhdl_design_file_t design_file  in
472
        { design_file }
473
  end
src/tools/importer/vhdl_ast_utils.ml
1
open Vhdl_ast_map
2
open Vhdl_ast
3
open Ppxlib_traverse_builtins
4

  
5
let any x = x
6

  
7
let replace_op_expr = object (self)
8
  inherit Ppxlib_traverse_builtins.map
9
  inherit vhdl_map as super
10

  
11
  method unit: unit T.map = any
12

  
13
  method vhdl_expr_t = function
14
    | Op ({id=""; args=hd::[]}) -> self#vhdl_expr_t hd
15
    | x -> super#vhdl_expr_t x
16
end
17

  
src/tools/importer/vhdl_json_lib.ml
1
open Yojson.Safe
2
open Yojson.Safe.Util
3

  
4
let rec assoc_map_except_str l f str =
5
  match l with
6
  | (s,x)::y -> 
7
    if (String.equal s str) then 
8
      assoc_map_except_str y f str
9
    else
10
      (s,f str x)::assoc_map_except_str y f str
11
  | [] -> []
12

  
13
let rec map_2_args f l arg1 =
14
  match l with
15
  | hd::tl -> (f arg1 hd)::(map_2_args f tl arg1)
16
  | [] -> []
17

  
18
(*
19
Remove `Assoc nodes with tag 'str' in json j
20
*)
21
let rec prune_str str json =
22
  match json with
23
    | `Assoc ((t,hd)::tl) -> 
24
      if (String.equal str t) then
25
        `Assoc (assoc_map_except_str tl prune_str str)
26
      else
27
        `Assoc ((t, prune_str str hd)::(assoc_map_except_str tl prune_str str))
28
    | `List (hd::tl) -> `List ((prune_str str hd)::(map_2_args prune_str tl str))
29
    | `String (s) -> if (String.equal str s) then `String ("") else `String (s)
30
    | x -> x
31

  
32
(*******************)
33

  
34
let rec name_pair_list_to_string l =
35
  match l with
36
  | (t, `String(x))::tl -> 
37
    if (String.equal t "name") then 
38
      (x::name_pair_list_to_string tl) 
39
    else 
40
      (name_pair_list_to_string tl)
41
  | _ -> []
42

  
43
let rec assoc_filter_string l str =
44
  match l with
45
  | `Assoc (x) -> name_pair_list_to_string x
46
  | _ -> []
47

  
48
(********************)
49

  
50
let rec pairlist_remove str l f =
51
  match l with
52
  | (t,j)::tl ->
53
    if (String.equal t str) then
54
      (f j)::(pairlist_remove str tl f)
55
    else
56
      `Assoc ((t, f j)::[])::(pairlist_remove str tl f)
57
  | [] -> []
58

  
59
(******************)
60
let rec assoc_elem_fst pair_list = 
61
  match pair_list with 
62
  | (t,j)::tl -> t::(assoc_elem_fst tl)
63
  | [] -> []
64

  
65
let rec assoc_elem_snd pair_list = 
66
  match pair_list with 
67
  | (t,j)::tl -> j::(assoc_elem_snd tl) 
68
  | [] -> []
69

  
70
let rec assoc_elem_filter pair_list str = 
71
  match pair_list with 
72
  | (t,j)::tl -> if (String.equal t str) then 
73
                    (t,j)::(assoc_elem_filter tl str) 
74
                  else assoc_elem_filter tl str
75
  | [] -> []
76

  
77
let rec assoc_elem_filternot pair_list str = 
78
  match pair_list with 
79
  | (t,j)::tl -> if (not (String.equal t str)) then 
80
                    (t,j)::(assoc_elem_filternot tl str) 
81
                  else assoc_elem_filternot tl str
82
  | [] -> []
83

  
84
let rec assoc_elem_filter_snd pair_list str = 
85
  match pair_list with 
86
  | (t,j)::tl -> if (String.equal t str) then 
87
                    j::(assoc_elem_filter_snd tl str) 
88
                  else assoc_elem_filter_snd tl str
89
  | [] -> []
90

  
91
let rec assoc_elem_filternot_snd pair_list str = 
92
  match pair_list with 
93
  | (t,j)::tl -> if (not (String.equal t str)) then 
94
                    j::(assoc_elem_filter_snd tl str) 
95
                  else assoc_elem_filter_snd tl str
96
  | [] -> []
97

  
98
let rec pairlist_snd_as_list pair_list str = 
99
  match pair_list with 
100
  | (t,j)::tl -> if (String.equal t str) then 
101
                    (t,`List (j::[]))::(pairlist_snd_as_list tl str)
102
                  else (t,j)::(pairlist_snd_as_list tl str)
103
  | [] -> []
104

  
105
let all_members str json =
106
  match json with
107
  | `Assoc (l) -> assoc_elem_filter_snd l str
108
  | _ -> []
109

  
110
let retain_other_members str json =
111
  match json with
112
  | `Assoc (l) -> `Assoc (assoc_elem_filter l str)
113
  | _ -> `Null
114

  
115
(*
116
DESIGN_UNIT as lists
117
*)
118
let vhdl_json_designunits_content_as_list json =
119
  let designunits_contents = json |> member "DESIGN_FILE" |> all_members "DESIGN_UNIT" in
120
  `List designunits_contents
121

  
122
let vhdl_json_designfile_content_excluding json str =
123
  json |> member "DESIGN_FILE" |> retain_other_members "DESIGN_UNIT" 
124

  
125
let vhdl_json_list_designunits json =
126
  let designunits_list = vhdl_json_designunits_content_as_list json in
127
  `Assoc (("DESIGN_FILE", (`Assoc (("DESIGN_UNIT", designunits_list)::[])))::[])
128

  
129
let rec pairlist_contains_str str l =
130
  match l with
131
  | (t,j)::tl -> if (String.equal t str) then true else pairlist_contains_str str tl
132
  | [] -> false
133

  
134
(*
135
ITEM element content as list
136
*)
137
let assoc_elem_as_list str json =
138
  match json with
139
  | `Assoc (l) -> `Assoc (pairlist_snd_as_list l str)
140
  | x -> x
141

  
142
let rec map_list map_f l f =
143
  match l with
144
  | hd::tl -> (map_f (f hd) f)::(map_list map_f tl f)
145
  | [] -> []
146

  
147
let rec map_pairlist map_f l f =
148
  match l with
149
  | (t,j)::tl -> (t, map_f (f j) f)::(map_pairlist map_f tl f)
150
  | [] -> []
151

  
152
let rec map_snd f l =
153
  match l with
154
  | (t,j)::tl -> (t,f j)::(map_snd f tl)
155
  | [] -> []
156

  
157
let rec map_all json f =
158
  match json with
159
  | `Assoc ((t,j)::tl) -> 
160
    `Assoc ((t,(map_all (f j) f))::(map_pairlist map_all tl f))
161
  | `List (hd::tl) -> 
162
    `List ((map_all (f hd) f)::(map_list map_all tl f))
163
  | x -> x
164

  
165
let numeric_literal_simpl json =
166
  match json with
167
  | `Assoc (("NUMERIC_LITERAL", `Assoc (("TOKEN", `Assoc (("text", `String(x))::[]))::[]))::[]) -> `String (x)
168
  | x -> x
169

  
170
let flatten_numeric_literal json =
171
  map_all json (numeric_literal_simpl)
172

  
173
let to_list_str str json =
174
  map_all json (assoc_elem_as_list str)
175

  
176
let rec to_list_content_str str json =
177
  match json with
178
  | `Assoc (l) -> if (pairlist_contains_str str l) then
179
      `Assoc (
180
         (str, to_list_content_str str (`List (assoc_elem_filter_snd l str)))
181
         ::(assoc_elem_filternot (map_snd (to_list_content_str str) l) str)
182
      )
183
    else 
184
      `Assoc (map_snd (to_list_content_str str) l)
185
  | `List (hd::tl) -> `List ((to_list_content_str str hd)::(List.map (to_list_content_str str) tl))
186
  | x -> x
187

  
188
let rec prune_null_assoc json =
189
  match json with
190
  | `Assoc ((t, `Assoc([]))::tl) -> prune_null_assoc (`Assoc tl)
191
  | `Assoc ((t, `Null)::tl) -> prune_null_assoc (`Assoc tl)
192
  | `Assoc ((t, j)::tl) -> `Assoc ((t, (prune_null_assoc j))::(map_snd prune_null_assoc tl))
193
  | `List (`Null::[]) -> `Null
194
  | `List (l) -> `List (List.map prune_null_assoc l)
195
  | x -> x
196

  
197
(*
198
Value printers
199
*)
200
let rec print_depth json depth indent =
201
  if (depth > 0) then
202
    match json with
203
    | `Assoc ((t,j)::tl) -> 
204
      (indent^t)::(List.append (print_depth j (depth-1) (indent^"  "))
205
                               (print_depth (`Assoc (tl)) depth indent))
206
    | `List (hd::tl) ->
207
      List.append (print_depth hd depth indent)
208
                  (print_depth (`List (tl)) depth indent)
209
    | `String (s) -> (indent^s)::[]
210
    | _ -> []
211
  else
212
    []
213

  
214
let rec flatten_ivd json =
215
  match json with
216
  | `Assoc ((t, `List (l))::[]) -> if (String.equal t "INTERFACE_VARIABLE_DECLARATION") then
217
      `List (List.map flatten_ivd l) else `Assoc ((t, flatten_ivd (`List(l)))::[])
218
  | `Assoc (l) -> `Assoc (map_snd flatten_ivd l)
219
  | `List (hd::tl) -> `List((flatten_ivd hd)::(List.map flatten_ivd tl))
220
  | x -> x
221

  
222
(*
223
let do_stuff json =
224
  match json with
225
  | `Assoc ((t,j)::tl) -> 
226
  | `List (hd::tl) ->
227
  | `String (s) ->
228
  | _ -> x
229
*)

Also available in: Unified diff