Project

General

Profile

Revision 55963629

View differences:

src/tools/importer/main_lustre_importer.ml
9 9
In a first step, lustrei -vhdl -print myvhdl.json shall print the VHDL model in stdout
10 10

  
11 11
 *)
12

  
12
(*
13 13
open Vhdl_ast
14 14
open Vhdl_test
15
       
15
  *)
16
open Yojson.Safe
17
open Vhdl_deriving_yojson
18
open Vhdl_json_lib
19
open Printf
20

  
16 21
let _ =
17 22
(*
18 23
  (* Load model with Yojson *)
......
25 30
  Format.printf "Loaded VHDL:@.%a@." pp_vhdl_design vhdl
26 31
 *)
27 32

  
28
  let vhdl = design1 in
29
  Format.printf "Loaded VHDL:@.%a@." pp_vhdl_design vhdl;
30
  ()
33
  let vhdl_json = from_file Sys.argv.(1) in
34
  Format.printf "Original file:\n%s\n\n" (pretty_to_string vhdl_json);
35

  
36
  (*let vhdl = design1 in
37
  Format.printf "Loaded VHDL:@.%a@." pp_vhdl_design vhdl;*)
38

  
39
  let vhdl1_json = vhdl_json |> 
40
                   prune_str "TOKEN" |>
41
                   prune_str "IDENTIFIER" |>
42
                   prune_str "SUBTYPE_INDICATION" |>
43
                   prune_null_assoc |>
44
                   to_list_content_str "DESIGN_UNIT" |>
45
                   to_list_content_str "INTERFACE_VARIABLE_DECLARATION" |>
46
                   flatten_ivd |>
47
                   to_list_str "ARCHITECTURE_BODY" |>
48
                   to_list_str "ARCHITECTURE_DECLARATIVE_PART" |>
49
                   to_list_str "ARCHITECTURE_STATEMENT_PART" |>
50
                   to_list_str "ENTITY_DECLARATION" |>
51
                   to_list_str "PACKAGE_DECLARATION" in
52
  Format.printf "Preprocessed json:\n";
53
  Format.printf "%s\n\n" (pretty_to_string vhdl1_json);
54
  List.iter (Format.printf "%s\n") (print_depth vhdl1_json 5 "");
55

  
56
  to_file (Sys.argv.(1)^".out.json") vhdl1_json;
57

  
58
  match vhdl_file_t_of_yojson vhdl1_json with
59
    Ok x -> Format.printf "Parsed VHDL: \n%s\n" (pretty_to_string (vhdl_file_t_to_yojson x))
60
  | Error e -> failwith e;
src/tools/importer/vhdl_deriving_yojson.ml
1
let base_types = ["integer"; "character"; "bit"; "real"; "natural"; "positive"; "std_logic"; "std_logic_vector" ]
2

  
3
type vhdl_type_t =
4
  | Base of string
5
  | Range of string option * int * int
6
  | Bit_vector of int * int
7
  | Array of int * int * vhdl_type_t
8
  | Enumerated of string list
9
[@@deriving yojson {strict = false}];;
10
  
11
(************************************************************************************)		   
12
(*                     Constants                                                    *)
13
(************************************************************************************)		   
14

  
15
(* Std_logic values :
16
    'U': uninitialized. This signal hasn't been set yet.
17
    'X': unknown. Impossible to determine this value/result.
18
    '0': logic 0
19
    '1': logic 1
20
    'Z': High Impedance
21
    'W': Weak signal, can't tell if it should be 0 or 1.
22
    'L': Weak signal that should probably go to 0
23
    'H': Weak signal that should probably go to 1
24
    '-': Don't care. *)			       
25
let std_logic_cst = ["U"; "X"; "0"; "1"; "Z"; "W"; "L"; "H"; "-" ]
26

  
27
(* TODO: do we need more constructors ? *)
28
type cst_val_t = CstInt of int | CstStdLogic of string
29
[@@deriving yojson {strict = false}];;
30

  
31
(* TODO ? Shall we merge definition / declaration  *)
32
type vhdl_definition_t =
33
  | Type of {name : string ; definition: vhdl_type_t} [@name "Type"]
34
  | Subtype of {name : string ; definition: vhdl_type_t} [@name "Subtype"]
35
[@@deriving yojson {strict = false}];;
36
					
37
type vhdl_declaration_t =
38
  | VarDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t option } [@name "VarDecl"]
39
  | CstDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t  } [@name "CstDecl"]
40
  | SigDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t option } [@name "SigDecl"]
41
[@@deriving yojson {strict = false}];;
42

  
43
(************************************************************************************)		   
44
(*            Attributes for types, arrays, signals and strings                     *)
45
(************************************************************************************)		   
46

  
47
type 'basetype vhdl_type_attributes_t =
48
  | TAttNoArg of { id: string }
49
  | TAttIntArg of { id: string; arg: int }
50
  | TAttValArg of { id: string; arg: 'basetype }
51
  | TAttStringArg of { id: string; arg: string }
52
[@@deriving yojson {strict = false}];;
53

  
54
let typ_att_noarg = ["base"; "left"; "right"; "high"; "low"]
55
let typ_att_intarg = ["pos"; "val"; "succ"; "pred"; "leftof"; "rightof"]
56
let typ_att_valarg = ["image"]
57
let typ_att_stringarg = ["value"]
58
  
59
type vhdl_array_attributes_t = AAttInt of { id: string; arg: int; } | AAttAscending
60
[@@deriving yojson {strict = false}];;
61

  
62
let array_att_intarg = ["left"; "right"; "high"; "low"; "range"; "reverse_range"; "length"]  
63

  
64
type vhdl_signal_attributes_t = SigAtt of string
65
[@@deriving yojson {strict = false}];;
66

  
67
type vhdl_string_attributes_t = StringAtt of string
68
[@@deriving yojson {strict = false}];;
69

  
70
(************************************************************************************)		   
71
(*                        Expressions  / Statements                                 *)
72
(************************************************************************************)		   
73

  
74
(* TODO: call to functions? procedures? *)  
75
type vhdl_expr_t =
76
  | Var of string (* a signal or a variable *)
77
  | Op of { id: string; args: vhdl_expr_t list } 
78
[@@deriving yojson {strict = false}];;
79
					     
80
let arith_funs = ["+";"-";"*";"/";"mod"; "rem";"abs";"**"]
81
let bool_funs  = ["and"; "or"; "nand"; "nor"; "xor"; "not"]
82
let rel_funs   = ["<";">";"<=";">=";"/=";"="]
83

  
84
type vhdl_sequential_stmt_t = 
85
  | VarAssign of { lhs: string; rhs: vhdl_expr_t }
86
(*  | Case of { guard: vhdl_expr_t; branches: { case: }
87
	    | Case of { guard: vhdl_expr_t; branches 
88
 *)
89
[@@deriving yojson {strict = false}];;
90
				    
91
type signal_condition_t =
92
  {                            
93
    expr: vhdl_expr_t;              (* when expression *)
94
    else_case: vhdl_expr_t option;  (* optional else case expression. 
95
                                             If None, could be a latch  *)
96
  }
97
[@@deriving yojson {strict = false}];;
98

  
99
type signal_selection_t =
100
  {
101
    sel_lhs: string [@default ""];
102
    expr : vhdl_expr_t;
103
    when_sel: vhdl_expr_t option;
104
  }
105
[@@deriving yojson {strict = false}];;
106

  
107
type conditional_signal_t =
108
  {
109
      lhs: string [@default ""];        (* assigned signal *)
110
      rhs: vhdl_expr_t;                   (* expression *)
111
      cond: signal_condition_t option     (* conditional signal statement *)
112
  }
113
[@@deriving yojson {strict = false}];;
114

  
115
type process_t =
116
  { 
117
    id: string option [@default None];
118
    active_sigs: string list [@default []];
119
    body: vhdl_sequential_stmt_t list [@default []]
120
  }
121
[@@deriving yojson {strict = false}];;
122

  
123
type selected_signal_t = 
124
  { 
125
    sel: vhdl_expr_t;  
126
    branches: signal_selection_t list [@default []];
127
  }
128
[@@deriving yojson {strict = false}];;
129
			   
130
type vhdl_concurrent_stmt_t =
131
  | SigAssign of conditional_signal_t 
132
  | Process of process_t 
133
  | SelectedSig of selected_signal_t
134
[@@deriving yojson {strict = false}];;
135
  (*
136
type vhdl_statement_t =
137
  
138
  (* | DeclarationStmt of declaration_stmt_t *)
139
  | ConcurrentStmt of vhdl_concurrent_stmt_t
140
  | SequentialStmt of vhdl_sequential_stmt_t
141
   *)
142
		     
143
(************************************************************************************)		   
144
(*                     Entities                                                     *)
145
(************************************************************************************)		   
146
			     
147
(* TODO? Seems to appear optionally in entities *)
148
type vhdl_generic_t = unit
149
[@@deriving yojson {strict = false}];;
150
			      
151
type vhdl_port_kind_t = 
152
    InPort     [@name "in"]
153
  | OutPort    [@name "out"]
154
  | InoutPort  [@name "inout"]
155
  | BufferPort [@name "buffer"]
156
[@@deriving yojson];;
157
	     
158
type vhdl_port_t =
159
  {
160
    names: string list [@default []];
161
    kind: vhdl_port_kind_t;
162
    typ : string;
163
(*    typ: vhdl_type_t; *)
164
  }
165
[@@deriving yojson {strict = false}];;
166

  
167
type vhdl_entity_t =
168
  {
169
    name: string [@default ""];
170
    generics: vhdl_generic_t list option [@key "GENERIC_CLAUSE"] [@default Some []];
171
    ports: vhdl_port_t list [@key "PORT_CLAUSE"] [@default []];
172
  }
173
[@@deriving yojson {strict = false}];;
174

  
175
(************************************************************************************)		   
176
(*                    Packages / Library loading                                    *)
177
(************************************************************************************)		   
178
				
179
(* Optional. Describes shared definitions *)
180
type vhdl_package_t =
181
  {
182
    name: string [@default ""];
183
    shared_defs: vhdl_definition_t list [@default []];
184
  }
185
[@@deriving yojson {strict = false}];;
186

  
187
type vhdl_load_t = 
188
    Library of string list [@name "LIBRARY_CLAUSE"] [@default ""]
189
  | Use of string list [@name "USE_CLAUSE"] [@default []]
190
[@@deriving yojson];;
191

  
192
(************************************************************************************)		   
193
(*                        Architecture / VHDL Design                                *)
194
(************************************************************************************)		   
195
				       
196
type vhdl_architecture_t =
197
  {
198
    name: string [@default ""];
199
    entity: string [@default ""];
200
 (*   declarations: vhdl_declaration_t list option [@key "ARCHITECTURE_DECLARATIVE_PART"] [@default Some []];
201
    body: vhdl_concurrent_stmt_t list option [@key "ARCHITECTURE_STATEMENT_PART"] [@default Some []]; *)
202
  }
203
[@@deriving yojson {strict = false}];;
204
    
205
(* TODO. Configuration is optional *)
206
type vhdl_configuration_t = unit
207
[@@deriving yojson {strict = false}];;
208

  
209
type vhdl_design_t =
210
  {
211
    packages: vhdl_package_t list [@key "PACKAGE_DECLARATION"] [@default []];
212
    libraries: vhdl_load_t list option [@key "CONTEXT_CLAUSE"] [@default Some []];
213
    entities: vhdl_entity_t list [@key "ENTITY_DECLARATION"] [@default []];
214
    architectures: vhdl_architecture_t list [@key "ARCHITECTURE_BODY"] [@default []];
215
    configuration: vhdl_configuration_t option [@key "CONFIGURATION_DECLARATION"] [@default Some ()];
216
  }
217
[@@deriving yojson {strict = false}];;
218

  
219
type vhdl_design_file_t =
220
  {
221
    design_unit: vhdl_design_t list [@key "DESIGN_UNIT"] [@default []];
222
  }
223
[@@deriving yojson {strict = false}];;
224

  
225
type vhdl_file_t = 
226
  {
227
    design_file: vhdl_design_file_t [@key "DESIGN_FILE"];
228
  }
229
[@@deriving yojson];;
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 design_file = json |> member "DESIGN_FILE" in
127
  let designunits_list = vhdl_json_designunits_content_as_list json in
128
  `Assoc (("DESIGN_FILE", (`Assoc (("DESIGN_UNIT", designunits_list)::[])))::[])
129

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

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

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

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

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

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

  
166
let to_list_str str json =
167
  map_all json (assoc_elem_as_list str)
168

  
169
let rec to_list_content_str str json =
170
  match json with
171
  | `Assoc (l) -> if (pairlist_contains_str str l) then
172
      `Assoc (
173
         (str, to_list_content_str str (`List (assoc_elem_filter_snd l str)))
174
         ::(assoc_elem_filternot (map_snd (to_list_content_str str) l) str)
175
      )
176
    else 
177
      `Assoc (map_snd (to_list_content_str str) l)
178
  | `List (hd::tl) -> `List ((to_list_content_str str hd)::(List.map (to_list_content_str str) tl))
179
  | x -> x
180

  
181
let rec prune_null_assoc json =
182
  match json with
183
  | `Assoc ((t, `Assoc([]))::tl) -> prune_null_assoc (`Assoc tl)
184
  | `Assoc ((t, `Null)::tl) -> prune_null_assoc (`Assoc tl)
185
  | `Assoc ((t, j)::tl) -> `Assoc ((t, (prune_null_assoc j))::(map_snd prune_null_assoc tl))
186
  | `List (`Null::[]) -> `Null
187
  | `List (l) -> `List (List.map prune_null_assoc l)
188
  | x -> x
189

  
190
(*
191
Value printers
192
*)
193
let rec print_depth json depth indent =
194
  if (depth > 0) then
195
    match json with
196
    | `Assoc ((t,j)::tl) -> 
197
      (indent^t)::(List.append (print_depth j (depth-1) (indent^"  "))
198
                               (print_depth (`Assoc (tl)) depth indent))
199
    | `List (hd::tl) ->
200
      List.append (print_depth hd depth indent)
201
                  (print_depth (`List (tl)) depth indent)
202
    | _ -> []
203
  else
204
    []
205

  
206
let rec flatten_ivd json =
207
  match json with
208
  | `Assoc ((t, `List (l))::[]) -> if (String.equal t "INTERFACE_VARIABLE_DECLARATION") then
209
      `List (List.map flatten_ivd l) else `Assoc ((t, flatten_ivd (`List(l)))::[])
210
  | `Assoc (l) -> `Assoc (map_snd flatten_ivd l)
211
  | `List (hd::tl) -> `List((flatten_ivd hd)::(List.map flatten_ivd tl))
212
  | x -> x
213

  
214
(*
215
let do_stuff json =
216
  match json with
217
  | `Assoc ((t,j)::tl) -> 
218
  | `List (hd::tl) ->
219
  | `String (s) ->
220
  | _ -> x
221
*)

Also available in: Unified diff