1
|
(* source: Synario VHDL Reference Manual - March 1997 *)
|
2
|
|
3
|
(************************************************************************************)
|
4
|
(* Types *)
|
5
|
(************************************************************************************)
|
6
|
let base_types =
|
7
|
[
|
8
|
"integer";
|
9
|
"character";
|
10
|
"bit";
|
11
|
"real";
|
12
|
"natural";
|
13
|
"positive";
|
14
|
"std_logic";
|
15
|
"std_logic_vector";
|
16
|
]
|
17
|
|
18
|
type vhdl_type_t =
|
19
|
| Base of string
|
20
|
| Range of string option * int * int
|
21
|
| Bit_vector of int * int
|
22
|
| Array of int * int * vhdl_type_t
|
23
|
| Enumerated of string list
|
24
|
|
25
|
let rec pp_vhdl_type fmt t =
|
26
|
match t with
|
27
|
| Base s ->
|
28
|
Format.fprintf fmt "%s" s
|
29
|
| Bit_vector (n, m) ->
|
30
|
Format.fprintf fmt "bit_vector(%i downto %i)" n m
|
31
|
| Range (base, n, m) ->
|
32
|
Format.fprintf fmt "%trange %i to %i"
|
33
|
(fun fmt ->
|
34
|
match base with Some s -> Format.fprintf fmt "%s " s | None -> ())
|
35
|
n m
|
36
|
| Array (n, m, base) ->
|
37
|
Format.fprintf fmt "array (%i to %i) of %a" n m pp_vhdl_type base
|
38
|
| Enumerated sl ->
|
39
|
Format.fprintf fmt "(%a)"
|
40
|
(Utils.fprintf_list ~sep:", " Format.pp_print_string)
|
41
|
sl
|
42
|
|
43
|
(************************************************************************************)
|
44
|
(* Constants *)
|
45
|
(************************************************************************************)
|
46
|
|
47
|
(* Std_logic values : 'U': uninitialized. This signal hasn't been set yet. 'X':
|
48
|
unknown. Impossible to determine this value/result. '0': logic 0 '1': logic 1
|
49
|
'Z': High Impedance 'W': Weak signal, can't tell if it should be 0 or 1. 'L':
|
50
|
Weak signal that should probably go to 0 'H': Weak signal that should
|
51
|
probably go to 1 '-': Don't care. *)
|
52
|
let std_logic_cst = [ "U"; "X"; "0"; "1"; "Z"; "W"; "L"; "H"; "-" ]
|
53
|
|
54
|
(* TODO: do we need more constructors ? *)
|
55
|
type cst_val_t =
|
56
|
| CstInt of int
|
57
|
| CstStdLogic of string
|
58
|
| CstBV of string * string
|
59
|
|
60
|
let pp_cst_val fmt c =
|
61
|
match c with
|
62
|
| CstInt i ->
|
63
|
Format.fprintf fmt "%i" i
|
64
|
| CstStdLogic s ->
|
65
|
if List.mem s std_logic_cst then Format.fprintf fmt "%s" s else assert false
|
66
|
| CstBV (pref, suff) ->
|
67
|
Format.fprintf fmt "%s\"%s\"" pref suff
|
68
|
|
69
|
(************************************************************************************)
|
70
|
(* Declarations *)
|
71
|
(************************************************************************************)
|
72
|
|
73
|
(* TODO ? Shall we merge definition / declaration ? Do they appear at the same
|
74
|
place or at different ones ? *)
|
75
|
type vhdl_definition_t =
|
76
|
| Type of { name : string; definition : vhdl_type_t }
|
77
|
| Subtype of { name : string; definition : vhdl_type_t }
|
78
|
|
79
|
let pp_vhdl_definition fmt def =
|
80
|
match def with
|
81
|
| Type s ->
|
82
|
Format.fprintf fmt "type %s is %a;" s.name pp_vhdl_type s.definition
|
83
|
| Subtype s ->
|
84
|
Format.fprintf fmt "subtype %s is %a;" s.name pp_vhdl_type s.definition
|
85
|
|
86
|
type vhdl_declaration_t =
|
87
|
| VarDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t option }
|
88
|
| CstDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t }
|
89
|
| SigDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t option }
|
90
|
|
91
|
let pp_vhdl_declaration fmt decl =
|
92
|
match decl with
|
93
|
| VarDecl v ->
|
94
|
Format.fprintf fmt "variable %s : %a%t;" v.name pp_vhdl_type v.typ
|
95
|
(fun fmt ->
|
96
|
match v.init_val with
|
97
|
| Some initv ->
|
98
|
Format.fprintf fmt " := %a" pp_cst_val initv
|
99
|
| _ ->
|
100
|
())
|
101
|
| CstDecl v ->
|
102
|
Format.fprintf fmt "constant %s : %a := %a;" v.name pp_vhdl_type v.typ
|
103
|
pp_cst_val v.init_val
|
104
|
| SigDecl v ->
|
105
|
Format.fprintf fmt "signal %s : %a%t;" v.name pp_vhdl_type v.typ (fun fmt ->
|
106
|
match v.init_val with
|
107
|
| Some initv ->
|
108
|
Format.fprintf fmt " := %a" pp_cst_val initv
|
109
|
| _ ->
|
110
|
())
|
111
|
|
112
|
(************************************************************************************)
|
113
|
(* Attributes for types, arrays, signals and strings *)
|
114
|
(************************************************************************************)
|
115
|
|
116
|
type 'basetype vhdl_type_attributes_t =
|
117
|
| TAttNoArg of { id : string }
|
118
|
| TAttIntArg of { id : string; arg : int }
|
119
|
| TAttValArg of { id : string; arg : 'basetype }
|
120
|
| TAttStringArg of { id : string; arg : string }
|
121
|
|
122
|
let typ_att_noarg = [ "base"; "left"; "right"; "high"; "low" ]
|
123
|
|
124
|
let typ_att_intarg = [ "pos"; "val"; "succ"; "pred"; "leftof"; "rightof" ]
|
125
|
|
126
|
let typ_att_valarg = [ "image" ]
|
127
|
|
128
|
let typ_att_stringarg = [ "value" ]
|
129
|
|
130
|
let pp_type_attribute pp_val fmt tatt =
|
131
|
match tatt with
|
132
|
| TAttNoArg a ->
|
133
|
Format.fprintf fmt "'%s" a.id
|
134
|
| TAttIntArg a ->
|
135
|
Format.fprintf fmt "'%s(%i)" a.id a.arg
|
136
|
| TAttValArg a ->
|
137
|
Format.fprintf fmt "'%s(%a)" a.id pp_val a.arg
|
138
|
| TAttStringArg a ->
|
139
|
Format.fprintf fmt "'%s(%s)" a.id a.arg
|
140
|
|
141
|
type vhdl_array_attributes_t =
|
142
|
| AAttInt of { id : string; arg : int }
|
143
|
| AAttAscending
|
144
|
|
145
|
let pp_array_attribute fmt aatt =
|
146
|
match aatt with
|
147
|
| AAttInt a ->
|
148
|
Format.fprintf fmt "'%s(%i)" a.id a.arg
|
149
|
| AAttAscending ->
|
150
|
Format.fprintf fmt "'ascending"
|
151
|
|
152
|
let array_att_intarg =
|
153
|
[ "left"; "right"; "high"; "low"; "range"; "reverse_range"; "length" ]
|
154
|
|
155
|
type vhdl_signal_attributes_t = SigAtt of string
|
156
|
|
157
|
let pp_signal_attribute fmt sa =
|
158
|
match sa with SigAtt s -> Format.fprintf fmt "'%s" s
|
159
|
|
160
|
let signal_att = [ "event"; "stable"; "last_value" ]
|
161
|
|
162
|
type vhdl_string_attributes_t = StringAtt of string
|
163
|
|
164
|
let pp_string_attribute fmt sa =
|
165
|
match sa with StringAtt s -> Format.fprintf fmt "'%s" s
|
166
|
|
167
|
let signal_att = [ "simple_name"; "path_name"; "instance_name" ]
|
168
|
|
169
|
(************************************************************************************)
|
170
|
(* Expressions / Statements *)
|
171
|
(************************************************************************************)
|
172
|
|
173
|
(* TODO: call to functions? procedures? component instanciations ? *)
|
174
|
|
175
|
type suffix_selection_t = Idx of int | Range of int * int
|
176
|
|
177
|
let pp_suffix_selection fmt sel =
|
178
|
match sel with
|
179
|
| Idx n ->
|
180
|
Format.fprintf fmt "(%i)" n
|
181
|
| Range (n, m) ->
|
182
|
Format.fprintf fmt "(%i downto %i)" n m
|
183
|
|
184
|
type vhdl_expr_t =
|
185
|
| Cst of cst_val_t
|
186
|
| Var of string
|
187
|
(* a signal or a variable *)
|
188
|
| Sig of { name : string; att : vhdl_signal_attributes_t option }
|
189
|
| SuffixMod of { expr : vhdl_expr_t; selection : suffix_selection_t }
|
190
|
| Op of { id : string; args : vhdl_expr_t list }
|
191
|
|
192
|
let rec pp_vhdl_expr fmt e =
|
193
|
match e with
|
194
|
| Cst c ->
|
195
|
pp_cst_val fmt c
|
196
|
| Var s ->
|
197
|
Format.fprintf fmt "%s" s
|
198
|
| Sig s ->
|
199
|
Format.fprintf fmt "%s%t" s.name (fun fmt ->
|
200
|
match s.att with None -> () | Some att -> pp_signal_attribute fmt att)
|
201
|
| SuffixMod s ->
|
202
|
Format.fprintf fmt "%a %a" pp_vhdl_expr s.expr pp_suffix_selection
|
203
|
s.selection
|
204
|
| Op op -> (
|
205
|
match op.args with
|
206
|
| [] ->
|
207
|
assert false
|
208
|
| [ e1; e2 ] ->
|
209
|
Format.fprintf fmt "@[<hov 3>%a %s %a@]" pp_vhdl_expr e1 op.id
|
210
|
pp_vhdl_expr e2
|
211
|
| _ ->
|
212
|
assert false
|
213
|
(* all ops are binary up to now *)
|
214
|
(* | _ -> Format.fprintf fmt "@[<hov 3>%s (%a)@]" op.id
|
215
|
(Utils.fprintf_list ~sep:",@ " pp_vhdl_expr) op.args *))
|
216
|
|
217
|
(* Available operators in the standard library. There are some restrictions on
|
218
|
types. See reference doc. *)
|
219
|
let arith_funs = [ "+"; "-"; "*"; "/"; "mod"; "rem"; "abs"; "**" ]
|
220
|
|
221
|
let bool_funs = [ "and"; "or"; "nand"; "nor"; "xor"; "not" ]
|
222
|
|
223
|
let rel_funs = [ "<"; ">"; "<="; ">="; "/="; "=" ]
|
224
|
|
225
|
type vhdl_if_case_t = {
|
226
|
if_cond : vhdl_expr_t;
|
227
|
if_block : vhdl_sequential_stmt_t list;
|
228
|
}
|
229
|
|
230
|
and vhdl_sequential_stmt_t =
|
231
|
| VarAssign of { lhs : string; rhs : vhdl_expr_t }
|
232
|
| SigSeqAssign of { lhs : string; rhs : vhdl_expr_t }
|
233
|
| If of {
|
234
|
if_cases : vhdl_if_case_t list;
|
235
|
default : vhdl_sequential_stmt_t list option;
|
236
|
}
|
237
|
| Case of { guard : vhdl_expr_t; branches : vhdl_case_item_t list }
|
238
|
|
239
|
and vhdl_case_item_t = {
|
240
|
when_cond : vhdl_expr_t;
|
241
|
when_stmt : vhdl_sequential_stmt_t;
|
242
|
}
|
243
|
|
244
|
let rec pp_vhdl_sequential_stmt fmt stmt =
|
245
|
match stmt with
|
246
|
| VarAssign va ->
|
247
|
Format.fprintf fmt "%s := %a;" va.lhs pp_vhdl_expr va.rhs
|
248
|
| SigSeqAssign va ->
|
249
|
Format.fprintf fmt "%s <= %a;" va.lhs pp_vhdl_expr va.rhs
|
250
|
| If ifva ->
|
251
|
List.iteri
|
252
|
(fun idx ifcase ->
|
253
|
if idx = 0 then Format.fprintf fmt "@[<v 3>if"
|
254
|
else Format.fprintf fmt "@ @[<v 3>elsif";
|
255
|
Format.fprintf fmt " %a then@ %a@]" pp_vhdl_expr ifcase.if_cond
|
256
|
pp_vhdl_sequential_stmts ifcase.if_block)
|
257
|
ifva.if_cases;
|
258
|
let _ =
|
259
|
match ifva.default with
|
260
|
| None ->
|
261
|
()
|
262
|
| Some bl ->
|
263
|
Format.fprintf fmt "@ @[<v 3>else@ %a@]" pp_vhdl_sequential_stmts bl
|
264
|
in
|
265
|
Format.fprintf fmt "@ end if;"
|
266
|
| Case caseva ->
|
267
|
Format.fprintf fmt "@[<v 3>case %a is@ %a@]@ end case;" pp_vhdl_expr
|
268
|
caseva.guard
|
269
|
(Utils.fprintf_list ~sep:"@ " pp_vhdl_case)
|
270
|
caseva.branches
|
271
|
|
272
|
and pp_vhdl_sequential_stmts fmt l =
|
273
|
Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt fmt l
|
274
|
|
275
|
and pp_vhdl_case fmt case =
|
276
|
Format.fprintf fmt "when %a => %a" pp_vhdl_expr case.when_cond
|
277
|
pp_vhdl_sequential_stmt case.when_stmt
|
278
|
|
279
|
type signal_condition_t = {
|
280
|
expr : vhdl_expr_t;
|
281
|
(* when expression *)
|
282
|
else_case : vhdl_expr_t option;
|
283
|
(* optional else case expression. If None, could be a latch *)
|
284
|
}
|
285
|
|
286
|
type signal_selection_t = {
|
287
|
sel_lhs : string;
|
288
|
expr : vhdl_expr_t;
|
289
|
when_sel : vhdl_expr_t option;
|
290
|
}
|
291
|
|
292
|
type conditional_signal_t = {
|
293
|
lhs : string;
|
294
|
(* assigned signal *)
|
295
|
rhs : vhdl_expr_t;
|
296
|
(* expression *)
|
297
|
cond : signal_condition_t option; (* conditional signal statement *)
|
298
|
}
|
299
|
|
300
|
type process_t = {
|
301
|
id : string option;
|
302
|
active_sigs : string list;
|
303
|
body : vhdl_sequential_stmt_t list;
|
304
|
}
|
305
|
|
306
|
type selected_signal_t = {
|
307
|
sel : vhdl_expr_t;
|
308
|
branches : signal_selection_t list;
|
309
|
}
|
310
|
|
311
|
type vhdl_concurrent_stmt_t =
|
312
|
| SigAssign of conditional_signal_t
|
313
|
| Process of process_t
|
314
|
| SelectedSig of selected_signal_t
|
315
|
(* type vhdl_statement_t =
|
316
|
|
317
|
(* | DeclarationStmt of declaration_stmt_t *) | ConcurrentStmt of
|
318
|
vhdl_concurrent_stmt_t | SequentialStmt of vhdl_sequential_stmt_t *)
|
319
|
|
320
|
let pp_vhdl_concurrent_stmt fmt stmt =
|
321
|
let pp_sig_cond fmt va =
|
322
|
Format.fprintf fmt "%s <= %a%t;" va.lhs pp_vhdl_expr va.rhs (fun fmt ->
|
323
|
match va.cond with
|
324
|
| None ->
|
325
|
()
|
326
|
| Some cond ->
|
327
|
Format.fprintf fmt " when %a%t" pp_vhdl_expr cond.expr (fun fmt ->
|
328
|
match cond.else_case with
|
329
|
| None ->
|
330
|
()
|
331
|
| Some else_case ->
|
332
|
Format.fprintf fmt " else %a" pp_vhdl_expr else_case))
|
333
|
in
|
334
|
let pp_process fmt p =
|
335
|
Format.fprintf fmt "@[<v 0>%tprocess %a@ @[<v 3>begin@ %a@]@ end process;@]"
|
336
|
(fun fmt ->
|
337
|
match p.id with Some id -> Format.fprintf fmt "%s: " id | None -> ())
|
338
|
(fun fmt asigs ->
|
339
|
if asigs <> [] then
|
340
|
Format.fprintf fmt "(@[<hov 0>%a)@]"
|
341
|
(Utils.fprintf_list ~sep:",@ " Format.pp_print_string)
|
342
|
asigs)
|
343
|
p.active_sigs
|
344
|
(Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt)
|
345
|
p.body
|
346
|
in
|
347
|
let pp_sig_sel fmt va =
|
348
|
Format.fprintf fmt "@[<v 3>with %a select@ %a;@]" pp_vhdl_expr va.sel
|
349
|
(Utils.fprintf_list ~sep:"@ " (fun fmt b ->
|
350
|
Format.fprintf fmt "%s <= %a when %t" b.sel_lhs pp_vhdl_expr b.expr
|
351
|
(fun fmt ->
|
352
|
match b.when_sel with
|
353
|
| None ->
|
354
|
Format.fprintf fmt "others"
|
355
|
| Some w ->
|
356
|
pp_vhdl_expr fmt w)))
|
357
|
va.branches
|
358
|
in
|
359
|
match stmt with
|
360
|
| SigAssign va ->
|
361
|
pp_sig_cond fmt va
|
362
|
| Process p ->
|
363
|
pp_process fmt p
|
364
|
| SelectedSig va ->
|
365
|
pp_sig_sel fmt va
|
366
|
|
367
|
(************************************************************************************)
|
368
|
(* Entities *)
|
369
|
(************************************************************************************)
|
370
|
|
371
|
(* TODO? Seems to appear optionally in entities *)
|
372
|
type vhdl_generic_t = unit
|
373
|
|
374
|
let pp_vhdl_generic fmt g = ()
|
375
|
|
376
|
type vhdl_port_kind_t = InPort | OutPort | InoutPort | BufferPort
|
377
|
|
378
|
let pp_vhdl_port_kind fmt p =
|
379
|
match p with
|
380
|
| InPort ->
|
381
|
Format.fprintf fmt "in"
|
382
|
| OutPort ->
|
383
|
Format.fprintf fmt "in"
|
384
|
| InoutPort ->
|
385
|
Format.fprintf fmt "inout"
|
386
|
| BufferPort ->
|
387
|
Format.fprintf fmt "buffer"
|
388
|
|
389
|
type vhdl_port_t = { name : string; kind : vhdl_port_kind_t; typ : vhdl_type_t }
|
390
|
|
391
|
let pp_vhdl_port fmt p =
|
392
|
Format.fprintf fmt "%s : %a %a" p.name pp_vhdl_port_kind p.kind pp_vhdl_type
|
393
|
p.typ
|
394
|
|
395
|
type vhdl_entity_t = {
|
396
|
name : string;
|
397
|
generics : vhdl_generic_t list;
|
398
|
ports : vhdl_port_t list;
|
399
|
}
|
400
|
|
401
|
let pp_vhdl_entity fmt e =
|
402
|
Format.fprintf fmt "@[<v 3>entity %s is@ %t%t@]@ end %s;@ " e.name
|
403
|
(fun fmt ->
|
404
|
List.iter
|
405
|
(fun g -> Format.fprintf fmt "generic %a;@ " pp_vhdl_generic g)
|
406
|
e.generics)
|
407
|
(fun fmt ->
|
408
|
if e.ports = [] then ()
|
409
|
else
|
410
|
Format.fprintf fmt "port (@[<hov 0>%a@]);"
|
411
|
(Utils.fprintf_list ~sep:",@ " pp_vhdl_port)
|
412
|
e.ports)
|
413
|
e.name
|
414
|
|
415
|
(************************************************************************************)
|
416
|
(* Packages / Library loading *)
|
417
|
(************************************************************************************)
|
418
|
|
419
|
(* Optional. Describes shared definitions *)
|
420
|
type vhdl_package_t = { name : string; shared_defs : vhdl_definition_t list }
|
421
|
|
422
|
let pp_vhdl_package fmt p =
|
423
|
Format.fprintf fmt "@[<v 3>package %s is@ %a@]@ end %s;@ " p.name
|
424
|
(Utils.fprintf_list ~sep:"@ " pp_vhdl_definition)
|
425
|
p.shared_defs p.name
|
426
|
|
427
|
type vhdl_load_t = Library of string | Use of string list
|
428
|
|
429
|
let pp_vhdl_load fmt l =
|
430
|
match l with
|
431
|
| Library s ->
|
432
|
Format.fprintf fmt "library %s;@ " s
|
433
|
| Use sl ->
|
434
|
Format.fprintf fmt "use %a;@ "
|
435
|
(Utils.fprintf_list ~sep:"." Format.pp_print_string)
|
436
|
sl
|
437
|
|
438
|
(************************************************************************************)
|
439
|
(* Architecture / VHDL Design *)
|
440
|
(************************************************************************************)
|
441
|
|
442
|
type vhdl_architecture_t = {
|
443
|
name : string;
|
444
|
entity : string;
|
445
|
declarations : vhdl_declaration_t list;
|
446
|
body : vhdl_concurrent_stmt_t list;
|
447
|
}
|
448
|
|
449
|
let pp_vhdl_architecture fmt a =
|
450
|
Format.fprintf fmt
|
451
|
"@[<v 3>architecture %s of %s is@ %a@]@ @[<v 3>begin@ %a@]@ end %s;" a.name
|
452
|
a.entity
|
453
|
(Utils.fprintf_list ~sep:"@ " pp_vhdl_declaration)
|
454
|
a.declarations
|
455
|
(Utils.fprintf_list ~sep:"@ " pp_vhdl_concurrent_stmt)
|
456
|
a.body a.name
|
457
|
|
458
|
(* TODO. Configuraiton is optional *)
|
459
|
type vhdl_configuration_t = unit
|
460
|
|
461
|
let pp_vhdl_configuration fmt c = ()
|
462
|
|
463
|
type vhdl_design_t = {
|
464
|
packages : vhdl_package_t list;
|
465
|
libraries : vhdl_load_t list;
|
466
|
entities : vhdl_entity_t list;
|
467
|
architectures : vhdl_architecture_t list;
|
468
|
configuration : vhdl_configuration_t option;
|
469
|
}
|
470
|
|
471
|
let pp_vhdl_design fmt d =
|
472
|
Format.fprintf fmt "@[<v 0>%a%t%a%t%a%t%a%t@]"
|
473
|
(Utils.fprintf_list ~sep:"@ " pp_vhdl_package)
|
474
|
d.packages
|
475
|
(fun fmt -> if d.packages <> [] then Format.fprintf fmt "@ ")
|
476
|
(Utils.fprintf_list ~sep:"@ " pp_vhdl_load)
|
477
|
d.libraries
|
478
|
(fun fmt -> if d.libraries <> [] then Format.fprintf fmt "@ ")
|
479
|
(Utils.fprintf_list ~sep:"@ " pp_vhdl_entity)
|
480
|
d.entities
|
481
|
(fun fmt -> if d.entities <> [] then Format.fprintf fmt "@ ")
|
482
|
(Utils.fprintf_list ~sep:"@ " pp_vhdl_architecture)
|
483
|
d.architectures
|
484
|
(fun fmt -> if d.architectures <> [] then Format.fprintf fmt "@ ")
|