Revision ca7ff3f7
Added by Lélio Brun over 1 year ago
src/backends/VHDL/vhdl_ast.ml | ||
---|---|---|
1 | 1 |
(* source: Synario VHDL Reference Manual - March 1997 *) |
2 | 2 |
|
3 |
(************************************************************************************) |
|
4 |
(* Types *) |
|
5 |
(************************************************************************************) |
|
6 |
let base_types = ["integer"; "character"; "bit"; "real"; "natural"; "positive"; "std_logic"; "std_logic_vector" ] |
|
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 |
] |
|
7 | 17 |
|
8 | 18 |
type vhdl_type_t = |
9 | 19 |
| Base of string |
10 | 20 |
| Range of string option * int * int |
11 |
| Bit_vector of int * int
|
|
12 |
| Array of int * int * vhdl_type_t
|
|
21 |
| Bit_vector of int * int |
|
22 |
| Array of int * int * vhdl_type_t |
|
13 | 23 |
| Enumerated of string list |
14 |
|
|
24 |
|
|
15 | 25 |
let rec pp_vhdl_type fmt t = |
16 | 26 |
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 |
|
|
25 |
(************************************************************************************) |
|
26 |
(* Constants *) |
|
27 |
(************************************************************************************) |
|
28 |
|
|
29 |
(* Std_logic values : |
|
30 |
'U': uninitialized. This signal hasn't been set yet. |
|
31 |
'X': unknown. Impossible to determine this value/result. |
|
32 |
'0': logic 0 |
|
33 |
'1': logic 1 |
|
34 |
'Z': High Impedance |
|
35 |
'W': Weak signal, can't tell if it should be 0 or 1. |
|
36 |
'L': Weak signal that should probably go to 0 |
|
37 |
'H': Weak signal that should probably go to 1 |
|
38 |
'-': Don't care. *) |
|
39 |
let std_logic_cst = ["U"; "X"; "0"; "1"; "Z"; "W"; "L"; "H"; "-" ] |
|
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"; "-" ] |
|
40 | 53 |
|
41 | 54 |
(* TODO: do we need more constructors ? *) |
42 |
type cst_val_t = CstInt of int | CstStdLogic of string | CstBV of string * string |
|
55 |
type cst_val_t = |
|
56 |
| CstInt of int |
|
57 |
| CstStdLogic of string |
|
58 |
| CstBV of string * string |
|
43 | 59 |
|
44 | 60 |
let pp_cst_val fmt c = |
45 | 61 |
match c with |
46 |
| CstInt i -> Format.fprintf fmt "%i" i |
|
47 |
| 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 |
(************************************************************************************) |
|
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 |
|
53 | 68 |
|
69 |
(************************************************************************************) |
|
70 |
(* Declarations *) |
|
71 |
(************************************************************************************) |
|
54 | 72 |
|
55 | 73 |
(* TODO ? Shall we merge definition / declaration ? Do they appear at the same |
56 |
place or at different ones ? *) |
|
74 |
place or at different ones ? *)
|
|
57 | 75 |
type vhdl_definition_t = |
58 |
| Type of {name : string ; definition: vhdl_type_t}
|
|
59 |
| Subtype of {name : string ; definition: vhdl_type_t}
|
|
60 |
|
|
76 |
| Type of { name : string; definition : vhdl_type_t }
|
|
77 |
| Subtype of { name : string; definition : vhdl_type_t }
|
|
78 |
|
|
61 | 79 |
let pp_vhdl_definition fmt def = |
62 | 80 |
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 |
|
|
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 |
|
|
66 | 86 |
type vhdl_declaration_t = |
67 | 87 |
| 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 }
|
|
88 |
| CstDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t } |
|
69 | 89 |
| SigDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t option } |
70 | 90 |
|
71 | 91 |
let pp_vhdl_declaration fmt decl = |
72 | 92 |
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 | _ -> ()) |
|
91 |
|
|
92 |
|
|
93 |
(************************************************************************************) |
|
94 |
(* Attributes for types, arrays, signals and strings *) |
|
95 |
(************************************************************************************) |
|
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 |
(************************************************************************************) |
|
96 | 115 |
|
97 | 116 |
type 'basetype vhdl_type_attributes_t = |
98 |
| TAttNoArg of { id: string } |
|
99 |
| TAttIntArg of { id: string; arg: int } |
|
100 |
| TAttValArg of { id: string; arg: 'basetype } |
|
101 |
| TAttStringArg of { id: string; arg: string } |
|
102 |
|
|
103 |
let typ_att_noarg = ["base"; "left"; "right"; "high"; "low"] |
|
104 |
let typ_att_intarg = ["pos"; "val"; "succ"; "pred"; "leftof"; "rightof"] |
|
105 |
let typ_att_valarg = ["image"] |
|
106 |
let typ_att_stringarg = ["value"] |
|
107 |
|
|
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 |
|
|
108 | 130 |
let pp_type_attribute pp_val fmt tatt = |
109 | 131 |
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 |
|
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 |
|
114 | 144 |
|
115 |
type vhdl_array_attributes_t = AAttInt of { id: string; arg: int; } | AAttAscending |
|
116 | 145 |
let pp_array_attribute fmt aatt = |
117 | 146 |
match aatt with |
118 |
| AAttInt a -> Format.fprintf fmt "'%s(%i)" a.id a.arg |
|
119 |
| AAttAscending -> Format.fprintf fmt "'ascending" |
|
120 |
let array_att_intarg = ["left"; "right"; "high"; "low"; "range"; "reverse_range"; "length"] |
|
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" ] |
|
121 | 154 |
|
122 | 155 |
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 |
|
156 |
|
|
157 |
let pp_signal_attribute fmt sa = |
|
158 |
match sa with SigAtt s -> Format.fprintf fmt "'%s" s |
|
159 |
|
|
125 | 160 |
let signal_att = [ "event"; "stable"; "last_value" ] |
126 | 161 |
|
127 | 162 |
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 |
|
163 |
|
|
164 |
let pp_string_attribute fmt sa = |
|
165 |
match sa with StringAtt s -> Format.fprintf fmt "'%s" s |
|
166 |
|
|
130 | 167 |
let signal_att = [ "simple_name"; "path_name"; "instance_name" ] |
131 | 168 |
|
132 |
(************************************************************************************)
|
|
133 |
(* Expressions / Statements *)
|
|
134 |
(************************************************************************************)
|
|
169 |
(************************************************************************************) |
|
170 |
(* Expressions / Statements *)
|
|
171 |
(************************************************************************************) |
|
135 | 172 |
|
136 |
|
|
137 | 173 |
(* TODO: call to functions? procedures? component instanciations ? *) |
138 | 174 |
|
139 | 175 |
type suffix_selection_t = Idx of int | Range of int * int |
176 |
|
|
140 | 177 |
let pp_suffix_selection fmt sel = |
141 | 178 |
match sel with |
142 |
| Idx n -> Format.fprintf fmt "(%i)" n |
|
143 |
| Range(n,m) -> Format.fprintf fmt "(%i downto %i)" n m |
|
144 |
|
|
179 |
| Idx n -> |
|
180 |
Format.fprintf fmt "(%i)" n |
|
181 |
| Range (n, m) -> |
|
182 |
Format.fprintf fmt "(%i downto %i)" n m |
|
183 |
|
|
145 | 184 |
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 } |
|
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 } |
|
149 | 189 |
| SuffixMod of { expr : vhdl_expr_t; selection : suffix_selection_t } |
150 |
| Op of { id: string; args: vhdl_expr_t list }
|
|
151 |
|
|
190 |
| Op of { id : string; args : vhdl_expr_t list }
|
|
191 |
|
|
152 | 192 |
let rec pp_vhdl_expr fmt e = |
153 | 193 |
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)
|
|
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)
|
|
161 | 201 |
| SuffixMod s -> |
162 |
Format.fprintf fmt "%a %a" |
|
163 |
pp_vhdl_expr s.expr |
|
164 |
pp_suffix_selection s.selection |
|
202 |
Format.fprintf fmt "%a %a" pp_vhdl_expr s.expr pp_suffix_selection |
|
203 |
s.selection |
|
165 | 204 |
| Op op -> ( |
166 | 205 |
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 |
) |
|
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 *)) |
|
172 | 216 |
|
173 | 217 |
(* Available operators in the standard library. There are some restrictions on |
174 |
types. See reference doc. *) |
|
175 |
let arith_funs = ["+";"-";"*";"/";"mod"; "rem";"abs";"**"] |
|
176 |
let bool_funs = ["and"; "or"; "nand"; "nor"; "xor"; "not"] |
|
177 |
let rel_funs = ["<";">";"<=";">=";"/=";"="] |
|
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 = [ "<"; ">"; "<="; ">="; "/="; "=" ] |
|
178 | 224 |
|
179 |
|
|
180 | 225 |
type vhdl_if_case_t = { |
181 |
if_cond: vhdl_expr_t; |
|
182 |
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 } |
|
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 |
|
|
190 | 239 |
and vhdl_case_item_t = { |
191 |
when_cond: vhdl_expr_t;
|
|
192 |
when_stmt: vhdl_sequential_stmt_t;
|
|
193 |
}
|
|
240 |
when_cond : vhdl_expr_t;
|
|
241 |
when_stmt : vhdl_sequential_stmt_t;
|
|
242 |
} |
|
194 | 243 |
|
195 |
|
|
196 |
|
|
197 | 244 |
let rec pp_vhdl_sequential_stmt fmt stmt = |
198 | 245 |
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 |
|
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 |
|
|
226 | 275 |
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 = |
|
232 |
{ |
|
233 |
expr: vhdl_expr_t; (* when expression *) |
|
234 |
else_case: vhdl_expr_t option; (* optional else case expression. |
|
235 |
If None, could be a latch *) |
|
236 |
} |
|
237 |
|
|
238 |
type signal_selection_t = |
|
239 |
{ |
|
240 |
sel_lhs: string; |
|
241 |
expr : vhdl_expr_t; |
|
242 |
when_sel: vhdl_expr_t option; |
|
243 |
} |
|
244 |
|
|
245 |
type conditional_signal_t = |
|
246 |
{ |
|
247 |
lhs: string; (* assigned signal *) |
|
248 |
rhs: vhdl_expr_t; (* expression *) |
|
249 |
cond: signal_condition_t option (* conditional signal statement *) |
|
250 |
} |
|
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 } |
|
256 |
|
|
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 |
|
|
257 | 311 |
type vhdl_concurrent_stmt_t = |
258 |
| SigAssign of conditional_signal_t
|
|
259 |
| Process of process_t
|
|
312 |
| SigAssign of conditional_signal_t |
|
313 |
| Process of process_t |
|
260 | 314 |
| SelectedSig of selected_signal_t |
261 |
(* |
|
262 |
type vhdl_statement_t = |
|
263 |
|
|
264 |
(* | DeclarationStmt of declaration_stmt_t *) |
|
265 |
| ConcurrentStmt of vhdl_concurrent_stmt_t |
|
266 |
| SequentialStmt of vhdl_sequential_stmt_t |
|
267 |
*) |
|
268 |
|
|
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 |
|
|
269 | 320 |
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 |
) |
|
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)) |
|
292 | 333 |
in |
293 | 334 |
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 -> ()) |
|
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 -> ()) |
|
298 | 338 |
(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) |
|
339 |
if asigs <> [] then |
|
340 |
Format.fprintf fmt "(@[<hov 0>%a)@]" |
|
341 |
(Utils.fprintf_list ~sep:",@ " Format.pp_print_string) |
|
342 |
asigs) |
|
304 | 343 |
p.active_sigs |
305 |
(Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt) p.body |
|
344 |
(Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt) |
|
345 |
p.body |
|
306 | 346 |
in |
307 | 347 |
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 |
|
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 |
|
323 | 359 |
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 |
|
|
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 |
|
332 | 366 |
|
367 |
(************************************************************************************) |
|
368 |
(* Entities *) |
|
369 |
(************************************************************************************) |
|
333 | 370 |
|
334 |
(************************************************************************************) |
|
335 |
(* Entities *) |
|
336 |
(************************************************************************************) |
|
337 |
|
|
338 | 371 |
(* TODO? Seems to appear optionally in entities *) |
339 | 372 |
type vhdl_generic_t = unit |
373 |
|
|
340 | 374 |
let pp_vhdl_generic fmt g = () |
341 | 375 |
|
342 |
|
|
343 | 376 |
type vhdl_port_kind_t = InPort | OutPort | InoutPort | BufferPort |
377 |
|
|
344 | 378 |
let pp_vhdl_port_kind fmt p = |
345 | 379 |
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 |
|
|
352 |
type vhdl_port_t = |
|
353 |
{ |
|
354 |
name: string; |
|
355 |
kind: vhdl_port_kind_t; |
|
356 |
typ: vhdl_type_t; |
|
357 |
} |
|
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 } |
|
358 | 390 |
|
359 | 391 |
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 |
type vhdl_entity_t = |
|
367 |
{ |
|
368 |
name: string; |
|
369 |
generics: vhdl_generic_t list; |
|
370 |
ports: vhdl_port_t list; |
|
371 |
} |
|
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 |
|
|
372 | 401 |
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)
|
|
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)
|
|
378 | 407 |
(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) |
|
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) |
|
381 | 413 |
e.name |
382 | 414 |
|
415 |
(************************************************************************************) |
|
416 |
(* Packages / Library loading *) |
|
417 |
(************************************************************************************) |
|
383 | 418 |
|
384 |
|
|
385 |
|
|
386 |
(************************************************************************************) |
|
387 |
(* Packages / Library loading *) |
|
388 |
(************************************************************************************) |
|
389 |
|
|
390 |
|
|
391 |
|
|
392 | 419 |
(* Optional. Describes shared definitions *) |
393 |
type vhdl_package_t = |
|
394 |
{ |
|
395 |
name: string; |
|
396 |
shared_defs: vhdl_definition_t list; |
|
397 |
} |
|
420 |
type vhdl_package_t = { name : string; shared_defs : vhdl_definition_t list } |
|
398 | 421 |
|
399 | 422 |
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 |
|
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 |
|
406 | 426 |
|
407 | 427 |
type vhdl_load_t = Library of string | Use of string list |
428 |
|
|
408 | 429 |
let pp_vhdl_load fmt l = |
409 | 430 |
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 |
|
|
413 |
|
|
414 |
(************************************************************************************) |
|
415 |
(* Architecture / VHDL Design *) |
|
416 |
(************************************************************************************) |
|
417 |
|
|
418 |
|
|
419 |
type vhdl_architecture_t = |
|
420 |
{ |
|
421 |
name: string; |
|
422 |
entity: string; |
|
423 |
declarations: vhdl_declaration_t list; |
|
424 |
body: vhdl_concurrent_stmt_t list; |
|
425 |
} |
|
426 |
|
|
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 |
|
|
427 | 449 |
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 |
|
450 |
Format.fprintf fmt |
|
451 |
"@[<v 3>architecture %s of %s is@ %a@]@ @[<v 3>begin@ %a@]@ end %s;" a.name |
|
432 | 452 |
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 |
|
|
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 |
|
437 | 457 |
|
438 | 458 |
(* TODO. Configuraiton is optional *) |
439 | 459 |
type vhdl_configuration_t = unit |
440 |
let pp_vhdl_configuration fmt c = () |
|
441 |
|
|
442 | 460 |
|
461 |
let pp_vhdl_configuration fmt c = () |
|
443 | 462 |
|
444 |
type vhdl_design_t = |
|
445 |
{ |
|
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; |
|
451 |
} |
|
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 |
} |
|
452 | 470 |
|
453 | 471 |
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 |
|
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 |
|
458 | 475 |
(fun fmt -> if d.packages <> [] then Format.fprintf fmt "@ ") |
459 |
(Utils.fprintf_list ~sep:"@ " pp_vhdl_load) d.libraries |
|
476 |
(Utils.fprintf_list ~sep:"@ " pp_vhdl_load) |
|
477 |
d.libraries |
|
460 | 478 |
(fun fmt -> if d.libraries <> [] then Format.fprintf fmt "@ ") |
461 |
(Utils.fprintf_list ~sep:"@ " pp_vhdl_entity) d.entities |
|
479 |
(Utils.fprintf_list ~sep:"@ " pp_vhdl_entity) |
|
480 |
d.entities |
|
462 | 481 |
(fun fmt -> if d.entities <> [] then Format.fprintf fmt "@ ") |
463 |
(Utils.fprintf_list ~sep:"@ " pp_vhdl_architecture) d.architectures |
|
482 |
(Utils.fprintf_list ~sep:"@ " pp_vhdl_architecture) |
|
483 |
d.architectures |
|
464 | 484 |
(fun fmt -> if d.architectures <> [] then Format.fprintf fmt "@ ") |
Also available in: Unified diff
reformatting