Project

General

Profile

Revision 40364f53

View differences:

src/backends/VHDL/vhdl_ast.ml
1
(* source: Synario VHDL Reference Manual - March 1997 *)
2

  
3
(************************************************************************************)		   
4
(*                       Types                                                      *)
5
(************************************************************************************)		   
6 1
let base_types = ["integer"; "character"; "bit"; "real"; "natural"; "positive"; "std_logic"; "std_logic_vector" ]
7

  
8
type vhdl_type_t =
9
  | Base of string
10
  | Range of string option * int * int
11
  | Bit_vector of int * int			  
12
  | Array of int * int * vhdl_type_t 
13
  | Enumerated of string list
14
  
15
let rec pp_vhdl_type fmt t =
16
  match t with
17
  | Base s -> Format.fprintf fmt "%s" s 
18
  | Bit_vector (n,m) -> Format.fprintf fmt "bit_vector(%i downto %i)" n m
19
  | 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
20
  | Array (n, m, base) -> Format.fprintf fmt "array (%i to %i) of %a" n m pp_vhdl_type base
21
  | Enumerated sl -> Format.fprintf fmt "(%a)" (Utils.fprintf_list ~sep:", " Format.pp_print_string) sl
22

  
23

  
24

  
2
 
25 3
(************************************************************************************)		   
26 4
(*                     Constants                                                    *)
27 5
(************************************************************************************)		   
......
37 15
    'H': Weak signal that should probably go to 1
38 16
    '-': Don't care. *)			       
39 17
let std_logic_cst = ["U"; "X"; "0"; "1"; "Z"; "W"; "L"; "H"; "-" ]
18
let literal_base = ["B"; "O"; "X"; "UB"; "UO"; "UX"; "SB"; "SO"; "SX"; "D"] (* Prefix of CstLiteral *)
40 19

  
41 20
(* TODO: do we need more constructors ? *)
42
type cst_val_t = CstInt of int | CstStdLogic of string | CstBV of string * string
21
type vhdl_cst_val_t = 
22
    CstInt of int 
23
  | CstStdLogic of string
24
  | CstLiteral of string [@name "CST_LITERAL"]
25
[@@deriving show { with_path = false }, yojson {strict = false}];;
43 26

  
27
(*
44 28
let pp_cst_val fmt c =
45 29
  match c with
46 30
  | CstInt i -> Format.fprintf fmt "%i" i
47 31
  | CstStdLogic s -> if List.mem s std_logic_cst then Format.fprintf fmt "%s" s else assert false
48
  | CstBV (pref,suff) -> Format.fprintf fmt "%s\"%s\"" pref suff
49

  
50
(************************************************************************************)		   
51
(*                     Declarations                                                 *)
52
(************************************************************************************)		   
53

  
54

  
55
(* TODO ? Shall we merge definition / declaration ? Do they appear at the same
56
place or at different ones ? *)
57
type vhdl_definition_t =
58
  | Type of {name : string ; definition: vhdl_type_t}
59
  | Subtype of {name : string ; definition: vhdl_type_t}
60
					
61
let pp_vhdl_definition fmt def =
62
  match def with
63
  | Type s -> Format.fprintf fmt "type %s is %a;" s.name pp_vhdl_type s.definition
64
  | Subtype s -> Format.fprintf fmt "subtype %s is %a;" s.name pp_vhdl_type s.definition
65
		      
66
type vhdl_declaration_t =
67
  | VarDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t option }
68
  | CstDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t  }
69
  | SigDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t option }
70

  
71
let pp_vhdl_declaration fmt decl =
72
  match decl with
73
  | VarDecl v -> Format.fprintf
74
		   fmt
75
		   "variable %s : %a%t;"
76
		   v.name
77
		   pp_vhdl_type v.typ
78
		   (fun fmt -> match v.init_val with Some initv -> Format.fprintf fmt " := %a" pp_cst_val initv | _ -> ())
79
  | CstDecl v -> Format.fprintf
80
		   fmt
81
		   "constant %s : %a := %a;"
82
		   v.name
83
		   pp_vhdl_type v.typ
84
		   pp_cst_val v.init_val
85
  | SigDecl v -> Format.fprintf
86
		   fmt
87
		   "signal %s : %a%t;"
88
		   v.name
89
		   pp_vhdl_type v.typ
90
		   (fun fmt -> match v.init_val with Some initv -> Format.fprintf fmt " := %a" pp_cst_val initv | _ -> ())
32
  | CstLiteral s -> Format.fprintf fmt "%s" s
33
*)
91 34

  
35
type vhdl_type_t =
36
  | Base of string
37
  | Range of string option * int * int
38
  | Bit_vector of int * int
39
  | Array of int * int * vhdl_type_t
40
  | Enumerated of string list
41
  | Void
42
and vhdl_subtype_indication_t =
43
  {
44
    name : vhdl_name_t [@default NoName];
45
    functionName : vhdl_name_t [@default NoName];
46
    const: vhdl_constraint_t [@default NoConstraint];
47
  }
48
and vhdl_discrete_range_t =
49
  | SubDiscreteRange of vhdl_subtype_indication_t [@name "SUB_DISCRETE_RANGE"]
50
  | NamedRange of vhdl_name_t [@name "NAMED_RANGE"]
51
  | DirectedRange of { direction: string; from: vhdl_expr_t; _to: vhdl_expr_t } [@name "RANGE_WITH_DIRECTION"]
52
and vhdl_constraint_t =
53
  | RefConstraint of { ref_name: vhdl_name_t; }
54
  | RangeConstraint of { range: vhdl_discrete_range_t } [@name "RANGE_CONSTRAINT"]
55
  | IndexConstraint of { ranges: vhdl_discrete_range_t list; } [@name "INDEX_CONSTRAINT"]
56
  | ArrayConstraint of { ranges: vhdl_discrete_range_t list; sub: vhdl_constraint_t } [@name "ARRAY_CONSTRAINT"]
57
  | RecordConstraint
58
  | NoConstraint
59
and vhdl_definition_t =
60
  | Type of {name : vhdl_name_t ; definition: vhdl_type_t} [@name "TYPE_DECLARATION"]
61
  | Subtype of {name : vhdl_name_t ; typ : vhdl_subtype_indication_t} [@name "SUBTYPE_DECLARATION"]
62
and vhdl_expr_t =
63
  | Call of vhdl_name_t [@name "CALL"]
64
  | Cst of vhdl_cst_val_t [@name "CONSTANT_VALUE"]
65
  | Op of { id: string [@default ""]; args: vhdl_expr_t list [@default []]} [@name "EXPRESSION"]
66
  | IsNull [@name "IsNull"]
67
  | Time of { value: int; phy_unit: string [@default ""]}
68
  | Sig of { name: vhdl_name_t; att: vhdl_signal_attributes_t option }
69
  | SuffixMod of { expr : vhdl_expr_t; selection : vhdl_suffix_selection_t }
70
  | Aggregate of { elems : vhdl_element_assoc_t list } [@name "AGGREGATE"]
71
  | Others [@name "OTHERS"]
72
and vhdl_name_t =
73
  | Simple of string [@name "SIMPLE_NAME"]
74
  | Identifier of string [@name "IDENTIFIER"]
75
  | Selected of vhdl_name_t list [@name "SELECTED_NAME"]
76
  | Index of { id: vhdl_name_t; exprs: vhdl_expr_t list } [@name "INDEXED_NAME"]
77
  | Slice of { id: vhdl_name_t; range: vhdl_discrete_range_t } [@name "SLICE_NAME"]
78
  | Attribute of { id: vhdl_name_t; designator: vhdl_name_t; expr: vhdl_expr_t [@default IsNull]} [@name "ATTRIBUTE_NAME"]
79
  | Function of { id: vhdl_name_t; assoc_list: vhdl_assoc_element_t list } [@name "FUNCTION_CALL"]
80
  | NoName
81
and vhdl_assoc_element_t =
82
  {
83
    formal_name: vhdl_name_t option [@default Some NoName];
84
    formal_arg: vhdl_name_t option [@default Some NoName];
85
    actual_name: vhdl_name_t option [@default Some NoName];
86
    actual_designator: vhdl_name_t option [@default Some NoName];
87
    actual_expr: vhdl_expr_t option [@default Some IsNull];
88
  }
89
and vhdl_element_assoc_t =
90
  {
91
    choices: vhdl_expr_t list;
92
    expr: vhdl_expr_t;
93
  }
94
and vhdl_array_attributes_t = 
95
  | AAttInt of { id: string; arg: int; } 
96
  | AAttAscending
97
and vhdl_signal_attributes_t = SigAtt of string
98
and vhdl_string_attributes_t = StringAtt of string
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
*)
92 112

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

  
103 124
let typ_att_noarg = ["base"; "left"; "right"; "high"; "low"]
104 125
let typ_att_intarg = ["pos"; "val"; "succ"; "pred"; "leftof"; "rightof"]
105 126
let typ_att_valarg = ["image"]
106 127
let typ_att_stringarg = ["value"]
107 128
  
108
let pp_type_attribute pp_val fmt tatt =
109
  match tatt with
110
  | TAttNoArg a -> Format.fprintf fmt "'%s" a.id
111
  | TAttIntArg a -> Format.fprintf fmt "'%s(%i)" a.id a.arg
112
  | TAttValArg a -> Format.fprintf fmt "'%s(%a)" a.id pp_val a.arg
113
  | TAttStringArg a -> Format.fprintf fmt "'%s(%s)" a.id a.arg
114

  
115
type vhdl_array_attributes_t = AAttInt of { id: string; arg: int; } | AAttAscending
116
let pp_array_attribute fmt aatt =
117
  match aatt with
118
  | AAttInt a -> Format.fprintf fmt "'%s(%i)" a.id a.arg
119
  | AAttAscending -> Format.fprintf fmt "'ascending"
120 129
let array_att_intarg = ["left"; "right"; "high"; "low"; "range"; "reverse_range"; "length"]  
121 130

  
122
type vhdl_signal_attributes_t = SigAtt of string
123
let pp_signal_attribute fmt sa = match sa with
124
  | SigAtt s -> Format.fprintf fmt "'%s" s
125
let signal_att = [ "event"; "stable"; "last_value" ]
131
type vhdl_parameter_t =
132
  {
133
    names: vhdl_name_t list;
134
    mode: string list [@default []];
135
    typ: vhdl_subtype_indication_t;
136
    init_val: vhdl_cst_val_t option [@default Some (CstInt (0))];
137
  }
138
[@@deriving show { with_path = false }, yojson {strict = false}];;
126 139

  
127
type vhdl_string_attributes_t = StringAtt of string
128
let pp_string_attribute fmt sa = match sa with
129
  | StringAtt s -> Format.fprintf fmt "'%s" s
130
let signal_att = [ "simple_name"; "path_name"; "instance_name" ]
140
type vhdl_subprogram_spec_t =
141
  {
142
    name: string [@default ""];
143
    typeMark: vhdl_name_t [@default NoName];
144
    parameters: vhdl_parameter_t list;
145
    isPure: bool [@default false];
146
  }
147
[@@deriving show { with_path = false }, yojson {strict = false}];;
131 148

  
132 149
(************************************************************************************)		   
133 150
(*                        Expressions  / Statements                                 *)
134 151
(************************************************************************************)		   
135 152

  
136
			      
137
(* TODO: call to functions? procedures? component instanciations ? *)
138

  
139
type suffix_selection_t = Idx of int | Range of int * int
140
let pp_suffix_selection fmt sel =
141
  match sel with
142
  | Idx n -> Format.fprintf fmt "(%i)" n
143
  | Range(n,m) -> Format.fprintf fmt "(%i downto %i)" n m
144
							
145
type vhdl_expr_t =
146
  | Cst of cst_val_t 
147
  | Var of string (* a signal or a variable *)
148
  | Sig of { name: string; att: vhdl_signal_attributes_t option }
149
  | SuffixMod of { expr : vhdl_expr_t; selection : suffix_selection_t }
150
  | Op of { id: string; args: vhdl_expr_t list } 
151
					     
152
let rec pp_vhdl_expr fmt e =
153
  match e with
154
  | Cst c ->  pp_cst_val fmt c
155
  | Var s -> Format.fprintf fmt "%s" s
156
  | Sig s -> Format.fprintf
157
	       fmt
158
	       "%s%t"
159
	       s.name
160
	       (fun fmt -> match s.att with None -> () | Some att -> pp_signal_attribute fmt att)
161
  | SuffixMod s ->
162
     Format.fprintf fmt "%a %a"
163
		    pp_vhdl_expr s.expr
164
		    pp_suffix_selection s.selection
165
  | Op op -> (
166
    match op.args with
167
    | [] -> assert false
168
    | [ e1; e2] -> Format.fprintf fmt "@[<hov 3>%a %s %a@]" pp_vhdl_expr e1 op.id pp_vhdl_expr e2
169
    | _ -> assert false (* all ops are binary up to now *)
170
    (* | _ -> Format.fprintf fmt "@[<hov 3>%s (%a)@]" op.id (Utils.fprintf_list ~sep:",@ " pp_vhdl_expr) op.args *)
171
  )
172

  
173
(* Available operators in the standard library. There are some restrictions on
174
types. See reference doc. *)
175
let arith_funs = ["+";"-";"*";"/";"mod"; "rem";"abs";"**"]
153
let arith_funs = ["+";"-";"*";"/";"mod"; "rem";"abs";"**";"&"]
176 154
let bool_funs  = ["and"; "or"; "nand"; "nor"; "xor"; "not"]
177
let rel_funs   = ["<";">";"<=";">=";"/=";"="]
178

  
179
			  
180
type vhdl_if_case_t = {
155
let rel_funs   = ["<";">";"<=";">=";"/=";"=";"?=";"?/=";"?<";"?<=";"?>";"?>=";"??"]
156
let shift_funs = ["sll";"srl";"sla";"sra";"rol";"ror"]
157

  
158
type vhdl_sequential_stmt_t = 
159
  | VarAssign of { label: vhdl_name_t [@default NoName]; lhs: vhdl_name_t; rhs: vhdl_expr_t } [@name "VARIABLE_ASSIGNMENT_STATEMENT"]
160
  | SigSeqAssign of { label: vhdl_name_t [@default NoName]; lhs: vhdl_name_t; rhs: vhdl_expr_t list} [@name "SIGNAL_ASSIGNMENT_STATEMENT"]
161
  | If of { label: vhdl_name_t [@default NoName]; if_cases: vhdl_if_case_t list;
162
    default: vhdl_sequential_stmt_t list [@default []]; } [@name "IF_STATEMENT"]
163
  | Case of { label: vhdl_name_t [@default NoName]; guard: vhdl_expr_t; branches: vhdl_case_item_t list } [@name "CASE_STATEMENT_TREE"]
164
  | Exit of { label: vhdl_name_t [@default NoName]; loop_label: string option [@default Some ""]; condition: vhdl_expr_t option [@default Some IsNull]} [@name "EXIT_STATEMENT"]
165
  | Assert of { label: vhdl_name_t [@default NoName]; cond: vhdl_expr_t; report: vhdl_expr_t [@default IsNull]; severity: vhdl_expr_t [@default IsNull]} [@name "ASSERTION_STATEMENT"]
166
  | Wait [@name "WAIT_STATEMENT"]
167
  | Null of { label: vhdl_name_t [@default NoName]} [@name "NULL_STATEMENT"]
168
  | Return of { label: vhdl_name_t [@default NoName]} [@name "RETURN_STATEMENT"]
169
and vhdl_if_case_t = 
170
  {
181 171
    if_cond: vhdl_expr_t;
182 172
    if_block: vhdl_sequential_stmt_t list;
183
  }	   
184
 and vhdl_sequential_stmt_t = 
185
   | VarAssign of { lhs: string; rhs: vhdl_expr_t }
186
   | SigSeqAssign of { lhs: string; rhs: vhdl_expr_t }
187
   | If of { if_cases: vhdl_if_case_t list;
188
	    default: (vhdl_sequential_stmt_t list) option; }
189
   | Case of { guard: vhdl_expr_t; branches: vhdl_case_item_t list }
190
and vhdl_case_item_t = {
191
    when_cond: vhdl_expr_t;
192
    when_stmt: vhdl_sequential_stmt_t;
193 173
  }
174
and vhdl_case_item_t = 
175
  {
176
    when_cond: vhdl_expr_t list;
177
    when_stmt: vhdl_sequential_stmt_t list;
178
  }
179
[@@deriving show { with_path = false }, yojson {strict = false}];;
194 180

  
195
					    
196
		 
197
let rec pp_vhdl_sequential_stmt fmt stmt =
198
  match stmt with
199
  | VarAssign va -> Format.fprintf fmt "%s := %a;" va.lhs pp_vhdl_expr va.rhs
200
  | SigSeqAssign va -> Format.fprintf fmt "%s <= %a;" va.lhs pp_vhdl_expr va.rhs
201
  | If ifva -> (
202
     List.iteri (fun idx ifcase ->
203
		 if idx = 0 then
204
		   Format.fprintf fmt "@[<v 3>if"
205
		 else
206
		   Format.fprintf fmt "@ @[<v 3>elsif";
207
		 Format.fprintf fmt " %a then@ %a@]"
208
				pp_vhdl_expr ifcase.if_cond
209
				pp_vhdl_sequential_stmts ifcase.if_block
210
		) ifva.if_cases;
211
     let _ =
212
       match ifva.default with
213
       | None -> ()
214
       | Some bl -> Format.fprintf fmt "@ @[<v 3>else@ %a@]" pp_vhdl_sequential_stmts bl
215
     in
216
     Format.fprintf fmt "@ end if;"
217
  )
218
  | Case caseva -> (
219
    Format.fprintf fmt "@[<v 3>case %a is@ %a@]@ end case;"
220
		   pp_vhdl_expr caseva.guard
221
		   (Utils.fprintf_list ~sep:"@ " pp_vhdl_case) caseva.branches
222
  )
223

  
224
     
225
and pp_vhdl_sequential_stmts fmt l  = Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt fmt l
226
and pp_vhdl_case fmt case =
227
  Format.fprintf fmt "when %a => %a"
228
		 pp_vhdl_expr case.when_cond
229
		 pp_vhdl_sequential_stmt case.when_stmt
230
						  
231
type signal_condition_t =
181
type vhdl_declaration_t =
182
  | VarDecl of {
183
      names : vhdl_name_t list; 
184
      typ : vhdl_subtype_indication_t; 
185
      init_val : vhdl_cst_val_t option [@default Some (CstInt (0))] 
186
    } [@name "VARIABLE_DECLARATION"]
187
  | CstDecl of { 
188
      names : vhdl_name_t list; 
189
      typ : vhdl_subtype_indication_t; 
190
      init_val : vhdl_cst_val_t 
191
    } [@name "CONSTANT_DECLARATION"]
192
  | SigDecl of { 
193
      names : vhdl_name_t list; 
194
      typ : vhdl_subtype_indication_t; 
195
      init_val : vhdl_cst_val_t option [@default Some (CstInt (0))] 
196
    } [@name "SIGNAL_DECLARATION"]
197
  | Subprogram of {
198
      name: vhdl_name_t [@default NoName]; 
199
      kind: string [@default ""]; 
200
      spec: vhdl_subprogram_spec_t [@default {name="";typeMark=NoName;parameters=[];isPure=false}]; 
201
      decl_part: vhdl_declaration_t list [@default []]; 
202
      stmts: vhdl_sequential_stmt_t list [@default []]
203
    } [@name "SUBPROGRAM_BODY"]
204
[@@deriving show { with_path = false }, yojson {strict = false}];;
205

  
206
type vhdl_signal_condition_t =
232 207
  {                            
233
    expr: vhdl_expr_t;              (* when expression *)
234
    else_case: vhdl_expr_t option;  (* optional else case expression. 
208
    expr: vhdl_expr_t list;              (* when expression *)
209
    cond: vhdl_expr_t [@default IsNull];  (* optional else case expression. 
235 210
                                             If None, could be a latch  *)
236 211
  }
212
[@@deriving show { with_path = false }, yojson {strict = false}];;
237 213

  
238
type signal_selection_t =
214
type vhdl_signal_selection_t =
239 215
  {
240
    sel_lhs: string;
241 216
    expr : vhdl_expr_t;
242
    when_sel: vhdl_expr_t option;
217
    when_sel: vhdl_expr_t list [@default []];
243 218
  }
219
[@@deriving show { with_path = false }, yojson {strict = false}];;
244 220

  
245
type conditional_signal_t =
221
type vhdl_conditional_signal_t =
246 222
  {
247
      lhs: string;                        (* assigned signal *)
248
      rhs: vhdl_expr_t;                   (* expression *)
249
      cond: signal_condition_t option     (* conditional signal statement *)
223
    postponed: bool [@default false];
224
    label: vhdl_name_t [@default NoName];
225
    lhs: vhdl_name_t;        (* assigned signal = target*)
226
    rhs: vhdl_signal_condition_t list;                   (* expression *)
227
    cond: vhdl_expr_t [@default IsNull];
228
    delay: vhdl_expr_t [@default IsNull];
250 229
  }
251

  
252
type process_t =
253
  { id: string option; active_sigs: string list; body: vhdl_sequential_stmt_t list }
254

  
255
type selected_signal_t = { sel: vhdl_expr_t;  branches: signal_selection_t list }
230
[@@deriving show { with_path = false }, yojson {strict = false}];;
231

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

  
241
type vhdl_selected_signal_t = 
242
  { 
243
    postponed: bool [@default false];
244
    label: vhdl_name_t [@default NoName];
245
    lhs: vhdl_name_t;      (* assigned signal = target *)
246
    sel: vhdl_expr_t;  
247
    branches: vhdl_signal_selection_t list [@default []];
248
    delay: vhdl_expr_t option;
249
  }
250
[@@deriving show { with_path = false }, yojson {strict = false}];;
256 251
			   
257 252
type vhdl_concurrent_stmt_t =
258
  | SigAssign of conditional_signal_t 
259
  | Process of process_t 
260
  | SelectedSig of selected_signal_t
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}];;
261 257
  (*
262 258
type vhdl_statement_t =
263 259
  
......
266 262
  | SequentialStmt of vhdl_sequential_stmt_t
267 263
   *)
268 264
		     
269
let pp_vhdl_concurrent_stmt fmt stmt =
270
  let pp_sig_cond fmt va = 
271
    Format.fprintf
272
      fmt
273
      "%s <= %a%t;"
274
      va.lhs
275
      pp_vhdl_expr va.rhs
276
      (fun fmt -> match va.cond with
277
		  | None -> ()
278
		  | Some cond ->
279
		     Format.fprintf
280
		       fmt
281
		       " when %a%t"
282
		       pp_vhdl_expr cond.expr
283
		       (fun fmt -> match cond.else_case with
284
				   | None -> ()
285
				   | Some else_case ->
286
				      Format.fprintf
287
					fmt
288
					" else %a"
289
					pp_vhdl_expr else_case
290
		       )
291
      )
292
  in
293
  let pp_process fmt p =
294
    Format.fprintf
295
      fmt
296
      "@[<v 0>%tprocess %a@ @[<v 3>begin@ %a@]@ end process;@]"
297
      (fun fmt -> match p.id with Some id -> Format.fprintf fmt "%s: " id| None -> ())
298
      (fun fmt asigs ->
299
       if asigs <> [] then
300
	 Format.fprintf
301
	   fmt
302
	   "(@[<hov 0>%a)@]"
303
	   (Utils.fprintf_list ~sep:",@ " Format.pp_print_string) asigs)
304
      p.active_sigs
305
      (Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt) p.body
306
  in
307
  let pp_sig_sel fmt va =
308
    Format.fprintf fmt "@[<v 3>with %a select@ %a;@]"
309
		   pp_vhdl_expr va.sel
310
		   (Utils.fprintf_list
311
		      ~sep:"@ "
312
		      (fun fmt b ->
313
		       Format.fprintf
314
			 fmt
315
			 "%s <= %a when %t"
316
			 b.sel_lhs
317
			 pp_vhdl_expr b.expr
318
			 (fun fmt -> match b.when_sel with
319
				     | None -> Format.fprintf fmt "others"
320
				     | Some w -> pp_vhdl_expr fmt w
321
			 ))
322
		   ) va.branches  in
323
  match stmt with
324
  | SigAssign va -> pp_sig_cond fmt va       
325
  | Process p -> pp_process fmt p
326
  | SelectedSig va -> pp_sig_sel fmt va
327
 
328

  
329
  
330
       
331

  
332

  
333

  
334 265
(************************************************************************************)		   
335 266
(*                     Entities                                                     *)
336 267
(************************************************************************************)		   
337 268
			     
338
(* TODO? Seems to appear optionally in entities *)
339
type vhdl_generic_t = unit
340
let pp_vhdl_generic fmt g = ()
341

  
342
			      
343
type vhdl_port_kind_t = InPort | OutPort | InoutPort | BufferPort
344
let pp_vhdl_port_kind fmt p =
345
  match p with
346
  | InPort -> Format.fprintf fmt "in"
347
  | OutPort -> Format.fprintf fmt "in"
348
  | InoutPort -> Format.fprintf fmt "inout"
349
  | BufferPort -> Format.fprintf fmt "buffer"
350

  
351
		     
269
type vhdl_port_mode_t = 
270
    InPort     [@name "in"]
271
  | OutPort    [@name "out"]
272
  | InoutPort  [@name "inout"]
273
  | BufferPort [@name "buffer"]
274
[@@deriving show { with_path = false }, yojson];;
275
	     
352 276
type vhdl_port_t =
353 277
  {
354
    name: string;
355
    kind: vhdl_port_kind_t;
356
    typ: vhdl_type_t;
278
    names: vhdl_name_t list [@default []];
279
    mode: vhdl_port_mode_t [@default InPort];
280
    typ: vhdl_subtype_indication_t;
281
    expr: vhdl_expr_t [@default IsNull];
357 282
  }
283
[@@deriving show { with_path = false }, yojson {strict = false}];;
358 284

  
359
let pp_vhdl_port fmt p =
360
  Format.fprintf fmt "%s : %a %a"
361
		 p.name
362
		 pp_vhdl_port_kind p.kind
363
		 pp_vhdl_type p.typ
364
	 
365
			     
366 285
type vhdl_entity_t =
367 286
  {
368
    name: string;
369
    generics: vhdl_generic_t list;
370
    ports: vhdl_port_t list;
287
    name: vhdl_name_t [@default NoName];
288
    generics: vhdl_port_t list [@default []];
289
    ports: vhdl_port_t list [@default []];
290
    declaration: vhdl_declaration_t list [@key "ENTITY_DECLARATIVE_PART"] [@default []];
291
    stmts: vhdl_concurrent_stmt_t list [@key "ENTITY_STATEMENT_PART"] [@default []]; 
371 292
  }
372
let pp_vhdl_entity fmt e =
373
  Format.fprintf
374
    fmt
375
    "@[<v 3>entity %s is@ %t%t@]@ end %s;@ "
376
    e.name
377
    (fun fmt -> List.iter (fun g -> Format.fprintf fmt "generic %a;@ " pp_vhdl_generic g) e.generics)
378
    (fun fmt ->
379
     if e.ports = [] then () else
380
       Format.fprintf fmt "port (@[<hov 0>%a@]);" (Utils.fprintf_list ~sep:",@ " pp_vhdl_port) e.ports)
381
    e.name
382

  
383

  
384

  
293
[@@deriving show { with_path = false }, yojson {strict = false}];;
385 294

  
386 295
(************************************************************************************)		   
387 296
(*                    Packages / Library loading                                    *)
388 297
(************************************************************************************)		   
389

  
390
				
391 298
				
392 299
(* Optional. Describes shared definitions *)
393 300
type vhdl_package_t =
394 301
  {
395
    name: string;
396
    shared_defs: vhdl_definition_t list;
302
    name: vhdl_name_t [@default NoName];
303
    shared_defs: vhdl_definition_t list [@default []];
397 304
  }
305
[@@deriving show { with_path = false }, yojson {strict = false}];;
398 306

  
399
let pp_vhdl_package fmt p =
400
  Format.fprintf
401
    fmt
402
    "@[<v 3>package %s is@ %a@]@ end %s;@ "
403
    p.name
404
    (Utils.fprintf_list  ~sep:"@ " pp_vhdl_definition) p.shared_defs
405
    p.name
406

  
407
type vhdl_load_t = Library of string | Use of string list
408
let pp_vhdl_load fmt l =
409
  match l with
410
  | Library s -> Format.fprintf fmt "library %s;@ " s
411
  | Use sl -> Format.fprintf fmt "use %a;@ " (Utils.fprintf_list ~sep:"." Format.pp_print_string) sl
412

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

  
414 312
(************************************************************************************)		   
415 313
(*                        Architecture / VHDL Design                                *)
416 314
(************************************************************************************)		   
417 315
				       
418
				       
419 316
type vhdl_architecture_t =
420 317
  {
421
    name: string;
422
    entity: string;
423
    declarations: vhdl_declaration_t list;
424
    body: vhdl_concurrent_stmt_t list;
318
    name: vhdl_name_t [@default NoName];
319
    entity: vhdl_name_t [@default NoName];
320
    declarations: vhdl_declaration_t list [@key "ARCHITECTURE_DECLARATIVE_PART"] [@default []];
321
    body: vhdl_concurrent_stmt_t list [@key "ARCHITECTURE_STATEMENT_PART"] [@default []]; 
425 322
  }
323
[@@deriving show { with_path = false }, yojson {strict = false}];;
426 324
    
427
let pp_vhdl_architecture fmt a =
428
  Format.fprintf
429
    fmt
430
    "@[<v 3>architecture %s of %s is@ %a@]@ @[<v 3>begin@ %a@]@ end %s;"
431
    a.name
432
    a.entity
433
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_declaration) a.declarations
434
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_concurrent_stmt) a.body
435
    a.name
436
    
437

  
438
(* TODO. Configuraiton is optional *)
325
(* TODO. Configuration is optional *)
439 326
type vhdl_configuration_t = unit
440
let pp_vhdl_configuration fmt c = ()
327
[@@deriving show { with_path = false }, yojson {strict = false}];;
441 328

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

  
336
type vhdl_design_unit_t =
337
  {
338
    contexts: vhdl_load_t list [@default []];
339
    library: vhdl_library_unit_t;
340
  }
341
[@@deriving show { with_path = false }, yojson {strict = false}];;
443 342

  
444
type vhdl_design_t =
343
type vhdl_design_file_t =
445 344
  {
446
    packages: vhdl_package_t list;
447
    libraries: vhdl_load_t list;
448
    entities: vhdl_entity_t list;
449
    architectures: vhdl_architecture_t list;
450
    configuration: vhdl_configuration_t option;
345
    design_units: vhdl_design_unit_t list [@default []];
451 346
  }
347
[@@deriving show { with_path = false }, yojson {strict = false}];;
452 348

  
453
let pp_vhdl_design fmt d =
454
  Format.fprintf
455
    fmt
456
    "@[<v 0>%a%t%a%t%a%t%a%t@]"
457
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_package) d.packages
458
    (fun fmt -> if d.packages <> [] then Format.fprintf fmt "@ ")
459
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_load) d.libraries
460
    (fun fmt -> if d.libraries <> [] then Format.fprintf fmt "@ ")
461
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_entity) d.entities
462
    (fun fmt -> if d.entities <> [] then Format.fprintf fmt "@ ")
463
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_architecture) d.architectures
464
    (fun fmt -> if d.architectures <> [] then Format.fprintf fmt "@ ")
349
type vhdl_file_t = 
350
  {
351
    design_file: vhdl_design_file_t [@default {design_units=[]}] [@key "DESIGN_FILE"];
352
  }
353
[@@deriving show { with_path = false }, yojson];;
src/backends/VHDL/vhdl_ast_deriving.ml
1
let base_types =
2
  ["integer";
3
  "character";
4
  "bit";
5
  "real";
6
  "natural";
7
  "positive";
8
  "std_logic";
9
  "std_logic_vector"] 
10
let std_logic_cst = ["U"; "X"; "0"; "1"; "Z"; "W"; "L"; "H"; "-"] 
11
let literal_base = ["B"; "O"; "X"; "UB"; "UO"; "UX"; "SB"; "SO"; "SX"; "D"] 
12
type vhdl_cst_val_t =
13
  | CstInt of int 
14
  | CstStdLogic of string 
15
  | CstLiteral of string [@name "CST_LITERAL"]
16

  
17
let rec (pp_vhdl_cst_val_t :
18
          Format.formatter -> vhdl_cst_val_t -> Ppx_deriving_runtime.unit)
19
  =
20
  ((let open! Ppx_deriving_runtime in
21
      fun fmt  ->
22
        function
23
        | CstInt a0 ->
24
            (Format.fprintf fmt "(@[<2>CstInt@ ";
25
             (Format.fprintf fmt "%d") a0;
26
             Format.fprintf fmt "@])")
27
        | CstStdLogic a0 ->
28
            (Format.fprintf fmt "(@[<2>CstStdLogic@ ";
29
             (Format.fprintf fmt "%S") a0;
30
             Format.fprintf fmt "@])")
31
        | CstLiteral a0 ->
32
            (Format.fprintf fmt "(@[<2>CstLiteral@ ";
33
             (Format.fprintf fmt "%S") a0;
34
             Format.fprintf fmt "@])"))
35
  [@ocaml.warning "-A"])
36

  
37
and show_vhdl_cst_val_t : vhdl_cst_val_t -> Ppx_deriving_runtime.string =
38
  fun x  -> Format.asprintf "%a" pp_vhdl_cst_val_t x
39

  
40
let rec (vhdl_cst_val_t_to_yojson : vhdl_cst_val_t -> Yojson.Safe.json) =
41
  ((let open! Ppx_deriving_yojson_runtime in
42
      function
43
      | CstInt arg0 ->
44
          `List
45
            [`String "CstInt";
46
            ((fun (x : Ppx_deriving_runtime.int)  -> `Int x)) arg0]
47
      | CstStdLogic arg0 ->
48
          `List
49
            [`String "CstStdLogic";
50
            ((fun (x : Ppx_deriving_runtime.string)  -> `String x)) arg0]
51
      | CstLiteral arg0 ->
52
          `List
53
            [`String "CST_LITERAL";
54
            ((fun (x : Ppx_deriving_runtime.string)  -> `String x)) arg0])
55
  [@ocaml.warning "-A"])
56

  
57
and (vhdl_cst_val_t_of_yojson :
58
      Yojson.Safe.json -> vhdl_cst_val_t Ppx_deriving_yojson_runtime.error_or)
59
  =
60
  ((let open! Ppx_deriving_yojson_runtime in
61
      function
62
      | `List ((`String "CstInt")::arg0::[]) ->
63
          ((function
64
            | `Int x -> Result.Ok x
65
            | _ -> Result.Error "Vhdl_ast.vhdl_cst_val_t") arg0) >>=
66
            ((fun arg0  -> Result.Ok (CstInt arg0)))
67
      | `List ((`String "CstStdLogic")::arg0::[]) ->
68
          ((function
69
            | `String x -> Result.Ok x
70
            | _ -> Result.Error "Vhdl_ast.vhdl_cst_val_t") arg0) >>=
71
            ((fun arg0  -> Result.Ok (CstStdLogic arg0)))
72
      | `List ((`String "CST_LITERAL")::arg0::[]) ->
73
          ((function
74
            | `String x -> Result.Ok x
75
            | _ -> Result.Error "Vhdl_ast.vhdl_cst_val_t") arg0) >>=
76
            ((fun arg0  -> Result.Ok (CstLiteral arg0)))
77
      | _ -> Result.Error "Vhdl_ast.vhdl_cst_val_t")
78
  [@ocaml.warning "-A"])
79

  
80
type vhdl_type_t =
81
  | Base of string 
82
  | Range of string option * int * int 
83
  | Bit_vector of int * int 
84
  | Array of int * int * vhdl_type_t 
85
  | Enumerated of string list 
86
  | Void 
87
and vhdl_subtype_indication_t =
88
  {
89
  name: vhdl_name_t [@default NoName];
90
  functionName: vhdl_name_t [@default NoName];
91
  const: vhdl_constraint_t [@default NoConstraint]}
92
and vhdl_discrete_range_t =
93
  | SubDiscreteRange of vhdl_subtype_indication_t
94
  [@name "SUB_DISCRETE_RANGE"]
95
  | NamedRange of vhdl_name_t [@name "NAMED_RANGE"]
96
  | DirectedRange of
97
  {
98
  direction: string ;
99
  from: vhdl_expr_t ;
100
  _to: vhdl_expr_t } [@name "RANGE_WITH_DIRECTION"]
101
and vhdl_constraint_t =
102
  | RefConstraint of {
103
  ref_name: vhdl_name_t } 
104
  | RangeConstraint of {
105
  range: vhdl_discrete_range_t } [@name "RANGE_CONSTRAINT"]
106
  | IndexConstraint of {
107
  ranges: vhdl_discrete_range_t list } [@name "INDEX_CONSTRAINT"]
108
  | ArrayConstraint of
109
  {
110
  ranges: vhdl_discrete_range_t list ;
111
  sub: vhdl_constraint_t } [@name "ARRAY_CONSTRAINT"]
112
  | RecordConstraint 
113
  | NoConstraint 
114
and vhdl_definition_t =
115
  | Type of {
116
  name: vhdl_name_t ;
117
  definition: vhdl_type_t } [@name "TYPE_DECLARATION"]
118
  | Subtype of {
119
  name: vhdl_name_t ;
120
  typ: vhdl_subtype_indication_t } [@name "SUBTYPE_DECLARATION"]
121
and vhdl_expr_t =
122
  | Call of vhdl_name_t [@name "CALL"]
123
  | Cst of vhdl_cst_val_t [@name "CONSTANT_VALUE"]
124
  | Op of {
125
  id: string [@default ""];
126
  args: vhdl_expr_t list [@default []]} [@name "EXPRESSION"]
127
  | IsNull [@name "IsNull"]
128
  | Time of {
129
  value: int ;
130
  phy_unit: string [@default ""]} 
131
  | Sig of {
132
  name: vhdl_name_t ;
133
  att: vhdl_signal_attributes_t option } 
134
  | SuffixMod of {
135
  expr: vhdl_expr_t ;
136
  selection: vhdl_suffix_selection_t } 
137
  | Aggregate of {
138
  elems: vhdl_element_assoc_t list } [@name "AGGREGATE"]
139
  | Others [@name "OTHERS"]
140
and vhdl_name_t =
141
  | Simple of string [@name "SIMPLE_NAME"]
142
  | Identifier of string [@name "IDENTIFIER"]
143
  | Selected of vhdl_name_t list [@name "SELECTED_NAME"]
144
  | Index of {
145
  id: vhdl_name_t ;
146
  exprs: vhdl_expr_t list } [@name "INDEXED_NAME"]
147
  | Slice of {
148
  id: vhdl_name_t ;
149
  range: vhdl_discrete_range_t } [@name "SLICE_NAME"]
150
  | Attribute of
151
  {
152
  id: vhdl_name_t ;
153
  designator: vhdl_name_t ;
154
  expr: vhdl_expr_t [@default IsNull]} [@name "ATTRIBUTE_NAME"]
155
  | Function of {
156
  id: vhdl_name_t ;
157
  assoc_list: vhdl_assoc_element_t list } [@name "FUNCTION_CALL"]
158
  | NoName 
159
and vhdl_assoc_element_t =
160
  {
161
  formal_name: vhdl_name_t option [@default Some NoName];
162
  formal_arg: vhdl_name_t option [@default Some NoName];
163
  actual_name: vhdl_name_t option [@default Some NoName];
164
  actual_designator: vhdl_name_t option [@default Some NoName];
165
  actual_expr: vhdl_expr_t option [@default Some IsNull]}
166
and vhdl_element_assoc_t = {
167
  choices: vhdl_expr_t list ;
168
  expr: vhdl_expr_t }
169
and vhdl_array_attributes_t =
170
  | AAttInt of {
171
  id: string ;
172
  arg: int } 
173
  | AAttAscending 
174
and vhdl_signal_attributes_t =
175
  | SigAtt of string 
176
and vhdl_string_attributes_t =
177
  | StringAtt of string 
178
and vhdl_suffix_selection_t =
179
  | Idx of int 
180
  | SuffixRange of int * int
181

  
182
let rec pp_vhdl_type_t :
183
  Format.formatter -> vhdl_type_t -> Ppx_deriving_runtime.unit =
184
  let __0 () = pp_vhdl_type_t  in
185
  ((let open! Ppx_deriving_runtime in
186
      fun fmt  ->
187
        function
188
        | Base a0 ->
189
            (Format.fprintf fmt "(@[<2>Base@ ";
190
             (Format.fprintf fmt "%S") a0;
191
             Format.fprintf fmt "@])")
192
        | Range (a0,a1,a2) ->
193
            (Format.fprintf fmt "(@[<2>Range (@,";
194
             ((((function
195
                 | None  -> Format.pp_print_string fmt "None"
196
                 | Some x ->
197
                     (Format.pp_print_string fmt "(Some ";
198
                      (Format.fprintf fmt "%S") x;
199
                      Format.pp_print_string fmt ")"))) a0;
200
               Format.fprintf fmt ",@ ";
201
               (Format.fprintf fmt "%d") a1);
202
              Format.fprintf fmt ",@ ";
203
              (Format.fprintf fmt "%d") a2);
204
             Format.fprintf fmt "@,))@]")
205
        | Bit_vector (a0,a1) ->
206
            (Format.fprintf fmt "(@[<2>Bit_vector (@,";
207
             ((Format.fprintf fmt "%d") a0;
208
              Format.fprintf fmt ",@ ";
209
              (Format.fprintf fmt "%d") a1);
210
             Format.fprintf fmt "@,))@]")
211
        | Array (a0,a1,a2) ->
212
            (Format.fprintf fmt "(@[<2>Array (@,";
213
             (((Format.fprintf fmt "%d") a0;
214
               Format.fprintf fmt ",@ ";
215
               (Format.fprintf fmt "%d") a1);
216
              Format.fprintf fmt ",@ ";
217
              ((__0 ()) fmt) a2);
218
             Format.fprintf fmt "@,))@]")
219
        | Enumerated a0 ->
220
            (Format.fprintf fmt "(@[<2>Enumerated@ ";
221
             ((fun x  ->
222
                 Format.fprintf fmt "@[<2>[";
223
                 ignore
224
                   (List.fold_left
225
                      (fun sep  ->
226
                         fun x  ->
227
                           if sep then Format.fprintf fmt ";@ ";
228
                           (Format.fprintf fmt "%S") x;
229
                           true) false x);
230
                 Format.fprintf fmt "@,]@]")) a0;
231
             Format.fprintf fmt "@])")
232
        | Void  -> Format.pp_print_string fmt "Void")
233
    [@ocaml.warning "-A"])
234

  
235
and show_vhdl_type_t : vhdl_type_t -> Ppx_deriving_runtime.string =
236
  fun x  -> Format.asprintf "%a" pp_vhdl_type_t x
237

  
238
and pp_vhdl_subtype_indication_t :
239
  Format.formatter -> vhdl_subtype_indication_t -> Ppx_deriving_runtime.unit
240
  =
241
  let __2 () = pp_vhdl_constraint_t
242
  
243
  and __1 () = pp_vhdl_name_t
244
  
245
  and __0 () = pp_vhdl_name_t
246
   in
247
  ((let open! Ppx_deriving_runtime in
248
      fun fmt  ->
249
        fun x  ->
250
          Format.fprintf fmt "@[<2>{ ";
251
          (((Format.fprintf fmt "@[%s =@ " "name";
252
             ((__0 ()) fmt) x.name;
253
             Format.fprintf fmt "@]");
254
            Format.fprintf fmt ";@ ";
255
            Format.fprintf fmt "@[%s =@ " "functionName";
256
            ((__1 ()) fmt) x.functionName;
257
            Format.fprintf fmt "@]");
258
           Format.fprintf fmt ";@ ";
259
           Format.fprintf fmt "@[%s =@ " "const";
260
           ((__2 ()) fmt) x.const;
261
           Format.fprintf fmt "@]");
262
          Format.fprintf fmt "@ }@]")
263
    [@ocaml.warning "-A"])
264

  
265
and show_vhdl_subtype_indication_t :
266
  vhdl_subtype_indication_t -> Ppx_deriving_runtime.string =
267
  fun x  -> Format.asprintf "%a" pp_vhdl_subtype_indication_t x
268

  
269
and pp_vhdl_discrete_range_t :
270
  Format.formatter -> vhdl_discrete_range_t -> Ppx_deriving_runtime.unit =
271
  let __3 () = pp_vhdl_expr_t
272
  
273
  and __2 () = pp_vhdl_expr_t
274
  
275
  and __1 () = pp_vhdl_name_t
276
  
277
  and __0 () = pp_vhdl_subtype_indication_t
278
   in
279
  ((let open! Ppx_deriving_runtime in
280
      fun fmt  ->
281
        function
282
        | SubDiscreteRange a0 ->
283
            (Format.fprintf fmt "(@[<2>SubDiscreteRange@ ";
284
             ((__0 ()) fmt) a0;
285
             Format.fprintf fmt "@])")
286
        | NamedRange a0 ->
287
            (Format.fprintf fmt "(@[<2>NamedRange@ ";
288
             ((__1 ()) fmt) a0;
289
             Format.fprintf fmt "@])")
290
        | DirectedRange { direction = adirection; from = afrom; _to = a_to }
291
            ->
292
            (Format.fprintf fmt "@[<2>DirectedRange {@,";
293
             (((Format.fprintf fmt "@[%s =@ " "direction";
294
                (Format.fprintf fmt "%S") adirection;
295
                Format.fprintf fmt "@]");
296
               Format.fprintf fmt ";@ ";
297
               Format.fprintf fmt "@[%s =@ " "from";
298
               ((__2 ()) fmt) afrom;
299
               Format.fprintf fmt "@]");
300
              Format.fprintf fmt ";@ ";
301
              Format.fprintf fmt "@[%s =@ " "_to";
302
              ((__3 ()) fmt) a_to;
303
              Format.fprintf fmt "@]");
304
             Format.fprintf fmt "@]}"))
305
    [@ocaml.warning "-A"])
306

  
307
and show_vhdl_discrete_range_t :
308
  vhdl_discrete_range_t -> Ppx_deriving_runtime.string =
309
  fun x  -> Format.asprintf "%a" pp_vhdl_discrete_range_t x
310

  
311
and pp_vhdl_constraint_t :
312
  Format.formatter -> vhdl_constraint_t -> Ppx_deriving_runtime.unit =
313
  let __4 () = pp_vhdl_constraint_t
314
  
315
  and __3 () = pp_vhdl_discrete_range_t
316
  
317
  and __2 () = pp_vhdl_discrete_range_t
318
  
319
  and __1 () = pp_vhdl_discrete_range_t
320
  
321
  and __0 () = pp_vhdl_name_t
322
   in
323
  ((let open! Ppx_deriving_runtime in
324
      fun fmt  ->
325
        function
326
        | RefConstraint { ref_name = aref_name } ->
327
            (Format.fprintf fmt "@[<2>RefConstraint {@,";
328
             (Format.fprintf fmt "@[%s =@ " "ref_name";
329
              ((__0 ()) fmt) aref_name;
330
              Format.fprintf fmt "@]");
331
             Format.fprintf fmt "@]}")
332
        | RangeConstraint { range = arange } ->
333
            (Format.fprintf fmt "@[<2>RangeConstraint {@,";
334
             (Format.fprintf fmt "@[%s =@ " "range";
335
              ((__1 ()) fmt) arange;
336
              Format.fprintf fmt "@]");
337
             Format.fprintf fmt "@]}")
338
        | IndexConstraint { ranges = aranges } ->
339
            (Format.fprintf fmt "@[<2>IndexConstraint {@,";
340
             (Format.fprintf fmt "@[%s =@ " "ranges";
341
              ((fun x  ->
342
                  Format.fprintf fmt "@[<2>[";
343
                  ignore
344
                    (List.fold_left
345
                       (fun sep  ->
346
                          fun x  ->
347
                            if sep then Format.fprintf fmt ";@ ";
348
                            ((__2 ()) fmt) x;
349
                            true) false x);
350
                  Format.fprintf fmt "@,]@]")) aranges;
351
              Format.fprintf fmt "@]");
352
             Format.fprintf fmt "@]}")
353
        | ArrayConstraint { ranges = aranges; sub = asub } ->
354
            (Format.fprintf fmt "@[<2>ArrayConstraint {@,";
355
             ((Format.fprintf fmt "@[%s =@ " "ranges";
356
               ((fun x  ->
357
                   Format.fprintf fmt "@[<2>[";
358
                   ignore
359
                     (List.fold_left
360
                        (fun sep  ->
361
                           fun x  ->
362
                             if sep then Format.fprintf fmt ";@ ";
363
                             ((__3 ()) fmt) x;
364
                             true) false x);
365
                   Format.fprintf fmt "@,]@]")) aranges;
366
               Format.fprintf fmt "@]");
367
              Format.fprintf fmt ";@ ";
368
              Format.fprintf fmt "@[%s =@ " "sub";
369
              ((__4 ()) fmt) asub;
370
              Format.fprintf fmt "@]");
371
             Format.fprintf fmt "@]}")
372
        | RecordConstraint  -> Format.pp_print_string fmt "RecordConstraint"
373
        | NoConstraint  -> Format.pp_print_string fmt "NoConstraint")
374
    [@ocaml.warning "-A"])
375

  
376
and show_vhdl_constraint_t : vhdl_constraint_t -> Ppx_deriving_runtime.string
377
  = fun x  -> Format.asprintf "%a" pp_vhdl_constraint_t x
378

  
379
and pp_vhdl_definition_t :
380
  Format.formatter -> vhdl_definition_t -> Ppx_deriving_runtime.unit =
381
  let __3 () = pp_vhdl_subtype_indication_t
382
  
383
  and __2 () = pp_vhdl_name_t
384
  
385
  and __1 () = pp_vhdl_type_t
386
  
387
  and __0 () = pp_vhdl_name_t
388
   in
389
  ((let open! Ppx_deriving_runtime in
390
      fun fmt  ->
391
        function
392
        | Type { name = aname; definition = adefinition } ->
393
            (Format.fprintf fmt "@[<2>Type {@,";
394
             ((Format.fprintf fmt "@[%s =@ " "name";
395
               ((__0 ()) fmt) aname;
396
               Format.fprintf fmt "@]");
397
              Format.fprintf fmt ";@ ";
398
              Format.fprintf fmt "@[%s =@ " "definition";
399
              ((__1 ()) fmt) adefinition;
400
              Format.fprintf fmt "@]");
401
             Format.fprintf fmt "@]}")
402
        | Subtype { name = aname; typ = atyp } ->
403
            (Format.fprintf fmt "@[<2>Subtype {@,";
404
             ((Format.fprintf fmt "@[%s =@ " "name";
405
               ((__2 ()) fmt) aname;
406
               Format.fprintf fmt "@]");
407
              Format.fprintf fmt ";@ ";
408
              Format.fprintf fmt "@[%s =@ " "typ";
409
              ((__3 ()) fmt) atyp;
410
              Format.fprintf fmt "@]");
411
             Format.fprintf fmt "@]}"))
412
    [@ocaml.warning "-A"])
413

  
414
and show_vhdl_definition_t : vhdl_definition_t -> Ppx_deriving_runtime.string
415
  = fun x  -> Format.asprintf "%a" pp_vhdl_definition_t x
416

  
417
and pp_vhdl_expr_t :
418
  Format.formatter -> vhdl_expr_t -> Ppx_deriving_runtime.unit =
419
  let __7 () = pp_vhdl_element_assoc_t
420
  
421
  and __6 () = pp_vhdl_suffix_selection_t
422
  
423
  and __5 () = pp_vhdl_expr_t
424
  
425
  and __4 () = pp_vhdl_signal_attributes_t
426
  
427
  and __3 () = pp_vhdl_name_t
428
  
429
  and __2 () = pp_vhdl_expr_t
430
  
431
  and __1 () = pp_vhdl_cst_val_t
432
  
433
  and __0 () = pp_vhdl_name_t
434
   in
435
  ((let open! Ppx_deriving_runtime in
436
      fun fmt  ->
437
        function
438
        | Call a0 ->
439
            (Format.fprintf fmt "(@[<2>Call@ ";
440
             ((__0 ()) fmt) a0;
441
             Format.fprintf fmt "@])")
442
        | Cst a0 ->
443
            (Format.fprintf fmt "(@[<2>Cst@ ";
444
             ((__1 ()) fmt) a0;
445
             Format.fprintf fmt "@])")
446
        | Op { id = aid; args = aargs } ->
447
            (Format.fprintf fmt "@[<2>Op {@,";
448
             ((Format.fprintf fmt "@[%s =@ " "id";
449
               (Format.fprintf fmt "%S") aid;
450
               Format.fprintf fmt "@]");
451
              Format.fprintf fmt ";@ ";
452
              Format.fprintf fmt "@[%s =@ " "args";
453
              ((fun x  ->
454
                  Format.fprintf fmt "@[<2>[";
455
                  ignore
456
                    (List.fold_left
457
                       (fun sep  ->
458
                          fun x  ->
459
                            if sep then Format.fprintf fmt ";@ ";
460
                            ((__2 ()) fmt) x;
461
                            true) false x);
462
                  Format.fprintf fmt "@,]@]")) aargs;
463
              Format.fprintf fmt "@]");
464
             Format.fprintf fmt "@]}")
465
        | IsNull  -> Format.pp_print_string fmt "IsNull"
466
        | Time { value = avalue; phy_unit = aphy_unit } ->
467
            (Format.fprintf fmt "@[<2>Time {@,";
468
             ((Format.fprintf fmt "@[%s =@ " "value";
469
               (Format.fprintf fmt "%d") avalue;
470
               Format.fprintf fmt "@]");
471
              Format.fprintf fmt ";@ ";
472
              Format.fprintf fmt "@[%s =@ " "phy_unit";
473
              (Format.fprintf fmt "%S") aphy_unit;
474
              Format.fprintf fmt "@]");
475
             Format.fprintf fmt "@]}")
476
        | Sig { name = aname; att = aatt } ->
477
            (Format.fprintf fmt "@[<2>Sig {@,";
478
             ((Format.fprintf fmt "@[%s =@ " "name";
479
               ((__3 ()) fmt) aname;
480
               Format.fprintf fmt "@]");
481
              Format.fprintf fmt ";@ ";
482
              Format.fprintf fmt "@[%s =@ " "att";
483
              ((function
484
                | None  -> Format.pp_print_string fmt "None"
485
                | Some x ->
486
                    (Format.pp_print_string fmt "(Some ";
487
                     ((__4 ()) fmt) x;
488
                     Format.pp_print_string fmt ")"))) aatt;
489
              Format.fprintf fmt "@]");
490
             Format.fprintf fmt "@]}")
491
        | SuffixMod { expr = aexpr; selection = aselection } ->
492
            (Format.fprintf fmt "@[<2>SuffixMod {@,";
493
             ((Format.fprintf fmt "@[%s =@ " "expr";
494
               ((__5 ()) fmt) aexpr;
495
               Format.fprintf fmt "@]");
496
              Format.fprintf fmt ";@ ";
497
              Format.fprintf fmt "@[%s =@ " "selection";
498
              ((__6 ()) fmt) aselection;
499
              Format.fprintf fmt "@]");
500
             Format.fprintf fmt "@]}")
501
        | Aggregate { elems = aelems } ->
502
            (Format.fprintf fmt "@[<2>Aggregate {@,";
503
             (Format.fprintf fmt "@[%s =@ " "elems";
504
              ((fun x  ->
505
                  Format.fprintf fmt "@[<2>[";
506
                  ignore
507
                    (List.fold_left
508
                       (fun sep  ->
509
                          fun x  ->
510
                            if sep then Format.fprintf fmt ";@ ";
511
                            ((__7 ()) fmt) x;
512
                            true) false x);
513
                  Format.fprintf fmt "@,]@]")) aelems;
514
              Format.fprintf fmt "@]");
515
             Format.fprintf fmt "@]}")
516
        | Others  -> Format.pp_print_string fmt "Others")
517
    [@ocaml.warning "-A"])
518

  
519
and show_vhdl_expr_t : vhdl_expr_t -> Ppx_deriving_runtime.string =
520
  fun x  -> Format.asprintf "%a" pp_vhdl_expr_t x
521

  
522
and pp_vhdl_name_t :
523
  Format.formatter -> vhdl_name_t -> Ppx_deriving_runtime.unit =
524
  let __9 () = pp_vhdl_assoc_element_t
525
  
526
  and __8 () = pp_vhdl_name_t
527
  
528
  and __7 () = pp_vhdl_expr_t
529
  
530
  and __6 () = pp_vhdl_name_t
531
  
532
  and __5 () = pp_vhdl_name_t
533
  
534
  and __4 () = pp_vhdl_discrete_range_t
535
  
536
  and __3 () = pp_vhdl_name_t
537
  
538
  and __2 () = pp_vhdl_expr_t
539
  
540
  and __1 () = pp_vhdl_name_t
541
  
542
  and __0 () = pp_vhdl_name_t
543
   in
544
  ((let open! Ppx_deriving_runtime in
545
      fun fmt  ->
546
        function
547
        | Simple a0 ->
548
            (Format.fprintf fmt "(@[<2>Simple@ ";
549
             (Format.fprintf fmt "%S") a0;
550
             Format.fprintf fmt "@])")
551
        | Identifier a0 ->
552
            (Format.fprintf fmt "(@[<2>Identifier@ ";
553
             (Format.fprintf fmt "%S") a0;
554
             Format.fprintf fmt "@])")
555
        | Selected a0 ->
556
            (Format.fprintf fmt "(@[<2>Selected@ ";
557
             ((fun x  ->
558
                 Format.fprintf fmt "@[<2>[";
559
                 ignore
560
                   (List.fold_left
561
                      (fun sep  ->
562
                         fun x  ->
563
                           if sep then Format.fprintf fmt ";@ ";
564
                           ((__0 ()) fmt) x;
565
                           true) false x);
566
                 Format.fprintf fmt "@,]@]")) a0;
567
             Format.fprintf fmt "@])")
568
        | Index { id = aid; exprs = aexprs } ->
569
            (Format.fprintf fmt "@[<2>Index {@,";
570
             ((Format.fprintf fmt "@[%s =@ " "id";
571
               ((__1 ()) fmt) aid;
572
               Format.fprintf fmt "@]");
573
              Format.fprintf fmt ";@ ";
574
              Format.fprintf fmt "@[%s =@ " "exprs";
575
              ((fun x  ->
576
                  Format.fprintf fmt "@[<2>[";
577
                  ignore
578
                    (List.fold_left
579
                       (fun sep  ->
580
                          fun x  ->
581
                            if sep then Format.fprintf fmt ";@ ";
582
                            ((__2 ()) fmt) x;
583
                            true) false x);
584
                  Format.fprintf fmt "@,]@]")) aexprs;
585
              Format.fprintf fmt "@]");
586
             Format.fprintf fmt "@]}")
587
        | Slice { id = aid; range = arange } ->
588
            (Format.fprintf fmt "@[<2>Slice {@,";
589
             ((Format.fprintf fmt "@[%s =@ " "id";
590
               ((__3 ()) fmt) aid;
591
               Format.fprintf fmt "@]");
592
              Format.fprintf fmt ";@ ";
593
              Format.fprintf fmt "@[%s =@ " "range";
594
              ((__4 ()) fmt) arange;
595
              Format.fprintf fmt "@]");
596
             Format.fprintf fmt "@]}")
597
        | Attribute { id = aid; designator = adesignator; expr = aexpr } ->
598
            (Format.fprintf fmt "@[<2>Attribute {@,";
599
             (((Format.fprintf fmt "@[%s =@ " "id";
600
                ((__5 ()) fmt) aid;
601
                Format.fprintf fmt "@]");
602
               Format.fprintf fmt ";@ ";
603
               Format.fprintf fmt "@[%s =@ " "designator";
604
               ((__6 ()) fmt) adesignator;
605
               Format.fprintf fmt "@]");
606
              Format.fprintf fmt ";@ ";
607
              Format.fprintf fmt "@[%s =@ " "expr";
608
              ((__7 ()) fmt) aexpr;
609
              Format.fprintf fmt "@]");
610
             Format.fprintf fmt "@]}")
611
        | Function { id = aid; assoc_list = aassoc_list } ->
612
            (Format.fprintf fmt "@[<2>Function {@,";
613
             ((Format.fprintf fmt "@[%s =@ " "id";
614
               ((__8 ()) fmt) aid;
615
               Format.fprintf fmt "@]");
616
              Format.fprintf fmt ";@ ";
617
              Format.fprintf fmt "@[%s =@ " "assoc_list";
618
              ((fun x  ->
619
                  Format.fprintf fmt "@[<2>[";
620
                  ignore
621
                    (List.fold_left
622
                       (fun sep  ->
623
                          fun x  ->
624
                            if sep then Format.fprintf fmt ";@ ";
625
                            ((__9 ()) fmt) x;
626
                            true) false x);
627
                  Format.fprintf fmt "@,]@]")) aassoc_list;
628
              Format.fprintf fmt "@]");
629
             Format.fprintf fmt "@]}")
630
        | NoName  -> Format.pp_print_string fmt "NoName")
631
    [@ocaml.warning "-A"])
632

  
633
and show_vhdl_name_t : vhdl_name_t -> Ppx_deriving_runtime.string =
634
  fun x  -> Format.asprintf "%a" pp_vhdl_name_t x
635

  
636
and pp_vhdl_assoc_element_t :
637
  Format.formatter -> vhdl_assoc_element_t -> Ppx_deriving_runtime.unit =
638
  let __4 () = pp_vhdl_expr_t
639
  
640
  and __3 () = pp_vhdl_name_t
641
  
642
  and __2 () = pp_vhdl_name_t
643
  
644
  and __1 () = pp_vhdl_name_t
645
  
646
  and __0 () = pp_vhdl_name_t
647
   in
648
  ((let open! Ppx_deriving_runtime in
649
      fun fmt  ->
650
        fun x  ->
651
          Format.fprintf fmt "@[<2>{ ";
652
          (((((Format.fprintf fmt "@[%s =@ " "formal_name";
653
               ((function
654
                 | None  -> Format.pp_print_string fmt "None"
655
                 | Some x ->
656
                     (Format.pp_print_string fmt "(Some ";
657
                      ((__0 ()) fmt) x;
658
                      Format.pp_print_string fmt ")"))) x.formal_name;
659
               Format.fprintf fmt "@]");
660
              Format.fprintf fmt ";@ ";
661
              Format.fprintf fmt "@[%s =@ " "formal_arg";
662
              ((function
663
                | None  -> Format.pp_print_string fmt "None"
664
                | Some x ->
665
                    (Format.pp_print_string fmt "(Some ";
666
                     ((__1 ()) fmt) x;
667
                     Format.pp_print_string fmt ")"))) x.formal_arg;
668
              Format.fprintf fmt "@]");
669
             Format.fprintf fmt ";@ ";
670
             Format.fprintf fmt "@[%s =@ " "actual_name";
671
             ((function
672
               | None  -> Format.pp_print_string fmt "None"
673
               | Some x ->
674
                   (Format.pp_print_string fmt "(Some ";
675
                    ((__2 ()) fmt) x;
676
                    Format.pp_print_string fmt ")"))) x.actual_name;
677
             Format.fprintf fmt "@]");
678
            Format.fprintf fmt ";@ ";
679
            Format.fprintf fmt "@[%s =@ " "actual_designator";
680
            ((function
681
              | None  -> Format.pp_print_string fmt "None"
682
              | Some x ->
683
                  (Format.pp_print_string fmt "(Some ";
684
                   ((__3 ()) fmt) x;
685
                   Format.pp_print_string fmt ")"))) x.actual_designator;
686
            Format.fprintf fmt "@]");
687
           Format.fprintf fmt ";@ ";
688
           Format.fprintf fmt "@[%s =@ " "actual_expr";
689
           ((function
690
             | None  -> Format.pp_print_string fmt "None"
691
             | Some x ->
692
                 (Format.pp_print_string fmt "(Some ";
693
                  ((__4 ()) fmt) x;
694
                  Format.pp_print_string fmt ")"))) x.actual_expr;
695
           Format.fprintf fmt "@]");
696
          Format.fprintf fmt "@ }@]")
697
    [@ocaml.warning "-A"])
698

  
699
and show_vhdl_assoc_element_t :
700
  vhdl_assoc_element_t -> Ppx_deriving_runtime.string =
701
  fun x  -> Format.asprintf "%a" pp_vhdl_assoc_element_t x
702

  
703
and pp_vhdl_element_assoc_t :
704
  Format.formatter -> vhdl_element_assoc_t -> Ppx_deriving_runtime.unit =
705
  let __1 () = pp_vhdl_expr_t
706
  
707
  and __0 () = pp_vhdl_expr_t
708
   in
709
  ((let open! Ppx_deriving_runtime in
710
      fun fmt  ->
711
        fun x  ->
712
          Format.fprintf fmt "@[<2>{ ";
713
          ((Format.fprintf fmt "@[%s =@ " "choices";
714
            ((fun x  ->
715
                Format.fprintf fmt "@[<2>[";
716
                ignore
717
                  (List.fold_left
718
                     (fun sep  ->
719
                        fun x  ->
720
                          if sep then Format.fprintf fmt ";@ ";
721
                          ((__0 ()) fmt) x;
722
                          true) false x);
723
                Format.fprintf fmt "@,]@]")) x.choices;
724
            Format.fprintf fmt "@]");
725
           Format.fprintf fmt ";@ ";
726
           Format.fprintf fmt "@[%s =@ " "expr";
727
           ((__1 ()) fmt) x.expr;
728
           Format.fprintf fmt "@]");
729
          Format.fprintf fmt "@ }@]")
730
    [@ocaml.warning "-A"])
731

  
732
and show_vhdl_element_assoc_t :
733
  vhdl_element_assoc_t -> Ppx_deriving_runtime.string =
734
  fun x  -> Format.asprintf "%a" pp_vhdl_element_assoc_t x
735

  
736
and (pp_vhdl_array_attributes_t :
737
      Format.formatter ->
738
        vhdl_array_attributes_t -> Ppx_deriving_runtime.unit)
739
  =
740
  ((let open! Ppx_deriving_runtime in
741
      fun fmt  ->
742
        function
743
        | AAttInt { id = aid; arg = aarg } ->
744
            (Format.fprintf fmt "@[<2>AAttInt {@,";
745
             ((Format.fprintf fmt "@[%s =@ " "id";
746
               (Format.fprintf fmt "%S") aid;
747
               Format.fprintf fmt "@]");
748
              Format.fprintf fmt ";@ ";
749
              Format.fprintf fmt "@[%s =@ " "arg";
750
              (Format.fprintf fmt "%d") aarg;
751
              Format.fprintf fmt "@]");
752
             Format.fprintf fmt "@]}")
753
        | AAttAscending  -> Format.pp_print_string fmt "AAttAscending")
754
  [@ocaml.warning "-A"])
755

  
756
and show_vhdl_array_attributes_t :
757
  vhdl_array_attributes_t -> Ppx_deriving_runtime.string =
758
  fun x  -> Format.asprintf "%a" pp_vhdl_array_attributes_t x
759

  
760
and (pp_vhdl_signal_attributes_t :
761
      Format.formatter ->
762
        vhdl_signal_attributes_t -> Ppx_deriving_runtime.unit)
763
  =
764
  ((let open! Ppx_deriving_runtime in
765
      fun fmt  ->
766
        function
767
        | SigAtt a0 ->
768
            (Format.fprintf fmt "(@[<2>SigAtt@ ";
769
             (Format.fprintf fmt "%S") a0;
770
             Format.fprintf fmt "@])"))
771
  [@ocaml.warning "-A"])
772

  
773
and show_vhdl_signal_attributes_t :
774
  vhdl_signal_attributes_t -> Ppx_deriving_runtime.string =
775
  fun x  -> Format.asprintf "%a" pp_vhdl_signal_attributes_t x
776

  
777
and (pp_vhdl_string_attributes_t :
778
      Format.formatter ->
779
        vhdl_string_attributes_t -> Ppx_deriving_runtime.unit)
780
  =
781
  ((let open! Ppx_deriving_runtime in
782
      fun fmt  ->
783
        function
784
        | StringAtt a0 ->
785
            (Format.fprintf fmt "(@[<2>StringAtt@ ";
786
             (Format.fprintf fmt "%S") a0;
787
             Format.fprintf fmt "@])"))
788
  [@ocaml.warning "-A"])
789

  
... This diff was truncated because it exceeds the maximum size that can be displayed.

Also available in: Unified diff