lustrec / src / backends / VHDL / vhdl_2_mini_vhdl_map.ml @ 010428a7
History | View | Annotate | Download (38.6 KB)
1 |
open Vhdl_ast |
---|---|
2 |
open Mini_vhdl_ast |
3 |
open Vhdl_ast_fold_sensitivity |
4 |
|
5 |
type db_tuple_t = |
6 |
{ |
7 |
mutable entity: vhdl_entity_t; |
8 |
mutable architecture: vhdl_architecture_t; |
9 |
mutable architecture_signals: mini_vhdl_declaration_t list; |
10 |
mutable architecture_ports: vhdl_port_t list; |
11 |
mutable architecture_generics: vhdl_port_t list; |
12 |
mutable assigned_names: vhdl_name_t list; |
13 |
mutable contexts: vhdl_load_t list; |
14 |
} |
15 |
|
16 |
let get_sensitivity_list = object (self) |
17 |
inherit ['acc] fold_sensitivity as super |
18 |
end |
19 |
|
20 |
let _ = fun (_ : vhdl_cst_val_t) -> () |
21 |
let _ = fun (_ : vhdl_type_t) -> () |
22 |
let _ = fun (_ : vhdl_element_declaration_t) -> () |
23 |
let _ = fun (_ : vhdl_subtype_indication_t) -> () |
24 |
let _ = fun (_ : vhdl_discrete_range_t) -> () |
25 |
let _ = fun (_ : vhdl_constraint_t) -> () |
26 |
let _ = fun (_ : vhdl_definition_t) -> () |
27 |
let _ = fun (_ : vhdl_expr_t) -> () |
28 |
let _ = fun (_ : vhdl_name_t) -> () |
29 |
let _ = fun (_ : vhdl_assoc_element_t) -> () |
30 |
let _ = fun (_ : vhdl_element_assoc_t) -> () |
31 |
let _ = fun (_ : vhdl_array_attributes_t) -> () |
32 |
let _ = fun (_ : vhdl_signal_attributes_t) -> () |
33 |
let _ = fun (_ : vhdl_string_attributes_t) -> () |
34 |
let _ = fun (_ : vhdl_suffix_selection_t) -> () |
35 |
let _ = fun (_ : 'basetype vhdl_type_attributes_t) -> () |
36 |
let _ = fun (_ : vhdl_parameter_t) -> () |
37 |
let _ = fun (_ : vhdl_subprogram_spec_t) -> () |
38 |
let _ = fun (_ : vhdl_sequential_stmt_t) -> () |
39 |
let _ = fun (_ : vhdl_if_case_t) -> () |
40 |
let _ = fun (_ : vhdl_case_item_t) -> () |
41 |
let _ = fun (_ : vhdl_declaration_t) -> () |
42 |
let _ = fun (_ : vhdl_signal_selection_t) -> () |
43 |
let _ = fun (_ : vhdl_declarative_item_t) -> () |
44 |
let _ = fun (_ : vhdl_waveform_element_t) -> () |
45 |
let _ = fun (_ : vhdl_signal_condition_t) -> () |
46 |
let _ = fun (_ : vhdl_conditional_signal_t) -> () |
47 |
let _ = fun (_ : vhdl_process_t) -> () |
48 |
let _ = fun (_ : vhdl_selected_signal_t) -> () |
49 |
let _ = fun (_ : vhdl_port_mode_t) -> () |
50 |
let _ = fun (_ : vhdl_component_instantiation_t) -> () |
51 |
let _ = fun (_ : vhdl_concurrent_stmt_t) -> () |
52 |
let _ = fun (_ : vhdl_port_t) -> () |
53 |
let _ = fun (_ : vhdl_entity_t) -> () |
54 |
let _ = fun (_ : vhdl_package_t) -> () |
55 |
let _ = fun (_ : vhdl_load_t) -> () |
56 |
let _ = fun (_ : vhdl_architecture_t) -> () |
57 |
let _ = fun (_ : vhdl_configuration_t) -> () |
58 |
let _ = fun (_ : vhdl_library_unit_t) -> () |
59 |
let _ = fun (_ : vhdl_design_unit_t) -> () |
60 |
let _ = fun (_ : vhdl_design_file_t) -> () |
61 |
|
62 |
class virtual vhdl_2_mini_vhdl_map = |
63 |
object (self) |
64 |
method virtual string : string -> string |
65 |
method virtual list : 'a . ('a -> 'a) -> 'a list -> 'a list |
66 |
method virtual unit : unit -> unit |
67 |
method virtual bool : bool -> bool |
68 |
method virtual option : 'a . ('a -> 'a) -> 'a option -> 'a option |
69 |
method virtual int : int -> int |
70 |
method virtual vhdl_name_t : vhdl_name_t -> vhdl_name_t |
71 |
method virtual vhdl_definition_t : vhdl_definition_t -> vhdl_definition_t |
72 |
method virtual vhdl_port_t : vhdl_port_t -> vhdl_port_t |
73 |
method virtual vhdl_expr_t : vhdl_expr_t -> vhdl_expr_t |
74 |
method virtual vhdl_port_mode_t : vhdl_port_mode_t -> vhdl_port_mode_t |
75 |
method virtual vhdl_element_declaration_t : vhdl_element_declaration_t -> vhdl_element_declaration_t |
76 |
method virtual vhdl_subtype_indication_t : vhdl_subtype_indication_t -> vhdl_subtype_indication_t |
77 |
method virtual vhdl_conditional_signal_t : vhdl_conditional_signal_t -> vhdl_conditional_signal_t |
78 |
method virtual vhdl_selected_signal_t : vhdl_selected_signal_t -> vhdl_selected_signal_t |
79 |
method virtual vhdl_signal_selection_t : vhdl_signal_selection_t -> vhdl_signal_selection_t |
80 |
method virtual vhdl_suffix_selection_t : vhdl_suffix_selection_t -> vhdl_suffix_selection_t |
81 |
method virtual vhdl_waveform_element_t : vhdl_waveform_element_t -> vhdl_waveform_element_t |
82 |
method virtual vhdl_signal_condition_t : vhdl_signal_condition_t -> vhdl_signal_condition_t |
83 |
method virtual vhdl_cst_val_t : vhdl_cst_val_t -> vhdl_cst_val_t |
84 |
method virtual vhdl_subprogram_spec_t : vhdl_subprogram_spec_t -> vhdl_subprogram_spec_t |
85 |
method virtual vhdl_discrete_range_t : vhdl_discrete_range_t -> vhdl_discrete_range_t |
86 |
method virtual vhdl_parameter_t : vhdl_parameter_t -> vhdl_parameter_t |
87 |
method virtual vhdl_declaration_t : vhdl_declaration_t -> mini_vhdl_declaration_t |
88 |
method virtual vhdl_configuration_t : vhdl_configuration_t -> unit |
89 |
method virtual vhdl_entity_t : vhdl_entity_t -> unit |
90 |
method virtual vhdl_library_unit_t : vhdl_library_unit_t -> unit |
91 |
method virtual vhdl_load_t : vhdl_load_t -> vhdl_load_t |
92 |
method virtual vhdl_design_unit_t : vhdl_design_unit_t -> unit |
93 |
|
94 |
method virtual vhdl_declarative_item_t : vhdl_declarative_item_t -> mini_vhdl_declarative_item_t |
95 |
method virtual vhdl_process_t : vhdl_process_t -> mini_vhdl_process_t |
96 |
method virtual vhdl_concurrent_stmt_t : vhdl_concurrent_stmt_t -> mini_vhdl_concurrent_stmt_t |
97 |
method virtual vhdl_sequential_stmt_t : vhdl_sequential_stmt_t -> mini_vhdl_sequential_stmt_t |
98 |
method virtual vhdl_design_file_t : vhdl_design_file_t -> mini_vhdl_design_file_t |
99 |
|
100 |
method virtual vhdl_package_t : (vhdl_load_t list * vhdl_package_t) -> mini_vhdl_package_t |
101 |
method virtual vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list * |
102 |
(vhdl_load_t list * vhdl_entity_t) list * |
103 |
(vhdl_load_t list * vhdl_configuration_t) list * |
104 |
(vhdl_load_t list * vhdl_architecture_t)) -> mini_vhdl_component_t |
105 |
method virtual vhdl_component_instantiation_t : vhdl_component_instantiation_t -> mini_vhdl_component_instantiation_t |
106 |
method virtual declarative_items_declarations : vhdl_declarative_item_t list -> vhdl_declaration_t list |
107 |
method virtual declarative_items_definitions : vhdl_declarative_item_t list -> vhdl_definition_t list |
108 |
method virtual declarative_items_uses : vhdl_declarative_item_t list -> vhdl_load_t list |
109 |
method virtual filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) -> |
110 |
(vhdl_load_t list * vhdl_entity_t) |
111 |
|
112 |
(************************* |
113 |
* Begin vhdl_name_t helpers |
114 |
*) |
115 |
method simplify_name_t : vhdl_name_t -> vhdl_name_t= |
116 |
fun n -> |
117 |
let lower a = String.lowercase_ascii a in |
118 |
let n = self#lower_vhdl_name_t n in |
119 |
match n with |
120 |
| Selected (a::[]) -> self#simplify_name_t a |
121 |
| Selected (NoName::tl) -> self#simplify_name_t (Selected tl) |
122 |
| Selected ((Simple (s))::tl) -> if (lower s = "work") |
123 |
then self#simplify_name_t (Selected tl) |
124 |
else n |
125 |
| Selected ((Identifier (s))::tl) -> if (lower s = "work") |
126 |
then self#simplify_name_t (Selected tl) |
127 |
else n |
128 |
| _ -> n |
129 |
|
130 |
method lower_vhdl_name_t : vhdl_name_t -> vhdl_name_t= |
131 |
fun x -> |
132 |
let lower a = String.lowercase_ascii a in |
133 |
match x with |
134 |
| Simple a -> Simple (lower a) |
135 |
| Identifier a -> Identifier (lower a) |
136 |
| Selected a -> Selected (self#list self#lower_vhdl_name_t a) |
137 |
| Index { id; exprs } -> |
138 |
let id = self#lower_vhdl_name_t id in |
139 |
let exprs = self#list self#vhdl_expr_t exprs in |
140 |
Index { id; exprs } |
141 |
| Slice { id; range } -> |
142 |
let id = self#lower_vhdl_name_t id in |
143 |
let range = self#vhdl_discrete_range_t range in |
144 |
Slice { id; range } |
145 |
| Attribute { id; designator; expr } -> |
146 |
let id = self#lower_vhdl_name_t id in |
147 |
let designator = self#lower_vhdl_name_t designator in |
148 |
let expr = self#vhdl_expr_t expr in |
149 |
Attribute { id; designator; expr } |
150 |
| Function { id; assoc_list } -> |
151 |
let id = self#lower_vhdl_name_t id in |
152 |
let assoc_list = self#list self#vhdl_assoc_element_t assoc_list in |
153 |
Function { id; assoc_list } |
154 |
| NoName -> NoName |
155 |
|
156 |
method to_string_vhdl_name_t : vhdl_name_t -> string= |
157 |
fun x -> |
158 |
match x with |
159 |
| Simple a -> a |
160 |
| Identifier a -> a |
161 |
| Selected a -> String.concat "." (List.map self#to_string_vhdl_name_t a) |
162 |
| Index { id; exprs } -> self#to_string_vhdl_name_t id |
163 |
| Slice { id; range } -> self#to_string_vhdl_name_t id |
164 |
| Attribute { id; designator; expr } -> self#to_string_vhdl_name_t id |
165 |
| Function { id; assoc_list } -> self#to_string_vhdl_name_t id |
166 |
| NoName -> "NoName" |
167 |
|
168 |
method flatten_vhdl_name_t : vhdl_name_t -> vhdl_name_t= |
169 |
fun x -> |
170 |
match x with |
171 |
| Simple a -> Simple (a) |
172 |
| Identifier a -> Simple (a) |
173 |
| Selected (hd::tl) -> Simple (String.concat "__" ((self#to_string_vhdl_name_t (self#flatten_vhdl_name_t hd))::[self#to_string_vhdl_name_t (self#flatten_vhdl_name_t (Selected (tl)))])) |
174 |
| _ -> failwith ("Impossible to flatten name value [" ^ self#to_string_vhdl_name_t x ^ "]") |
175 |
|
176 |
method postfix_flatten_vhdl_name_t : vhdl_name_t -> string -> vhdl_name_t= |
177 |
fun x -> |
178 |
fun postfix -> |
179 |
let flattened = self#flatten_vhdl_name_t x in |
180 |
match flattened with |
181 |
| Simple a -> Simple (a ^ postfix) |
182 |
| Identifier a -> Identifier (a ^ postfix) |
183 |
| _ -> failwith ("Impossible to postfix name value [" ^ self#to_string_vhdl_name_t x ^ "]") |
184 |
|
185 |
|
186 |
(************************* |
187 |
* End vhdl_name_t helpers |
188 |
*) |
189 |
|
190 |
(************************* |
191 |
* Begin DB helpers |
192 |
*) |
193 |
val mutable db : db_tuple_t list = [] |
194 |
|
195 |
method get_db : db_tuple_t list = db |
196 |
|
197 |
method db_add_tuple : db_tuple_t -> unit= |
198 |
fun x -> db <- x::db |
199 |
|
200 |
method db_get : vhdl_architecture_t -> (vhdl_entity_t * vhdl_load_t list)= |
201 |
fun x -> |
202 |
let rec find a dbl = |
203 |
match dbl with |
204 |
| [] -> failwith ("No matching tuple in DB for architecture [" ^ self#to_string_vhdl_name_t x.name ^ "]") |
205 |
| e::tl -> if (e.architecture = a) then (e.entity, e.contexts) else find a tl in find x db |
206 |
|
207 |
method get_tuple_from_archi_and_entity_name : (vhdl_name_t * vhdl_name_t) -> db_tuple_t= |
208 |
fun (a_name,e_name) -> |
209 |
let a_name = self#simplify_name_t a_name in |
210 |
let e_name = self#simplify_name_t e_name in |
211 |
let rec find (a_name,e_name) dbl = |
212 |
match dbl with |
213 |
| [] -> failwith ("No matching tuple in DB for architecture [" ^ self#to_string_vhdl_name_t a_name ^ |
214 |
"] and entity [" ^ self#to_string_vhdl_name_t e_name ^ "]") |
215 |
| e::tl -> |
216 |
let inner_e_arch_name = self#simplify_name_t e.architecture.name in |
217 |
let inner_e_ent_name = self#simplify_name_t e.entity.name in |
218 |
if ((inner_e_arch_name = a_name) && (inner_e_ent_name = e_name)) |
219 |
then e |
220 |
else find (a_name,e_name) tl in |
221 |
find (a_name,e_name) db |
222 |
|
223 |
method filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) -> |
224 |
(vhdl_load_t list * vhdl_entity_t) = |
225 |
fun ( entities_pair, filter_name ) -> |
226 |
let rec filter ep n = match ep with |
227 |
| [] -> failwith ("Impossible to find an entity with name [" ^ self#to_string_vhdl_name_t filter_name ^ "]") |
228 |
| (c,{name; generics; ports; declaration; stmts})::tl -> |
229 |
if (name = n) then |
230 |
List.hd ep |
231 |
else filter (List.tl ep) n in |
232 |
filter entities_pair filter_name |
233 |
(******************* |
234 |
* End DB helpers |
235 |
*) |
236 |
|
237 |
(******************* |
238 |
* Begin declarative_item_t projections |
239 |
*) |
240 |
method declarative_items_declarations : vhdl_declarative_item_t list -> vhdl_declaration_t list = |
241 |
fun x -> |
242 |
match x with |
243 |
| {use_clause=_; declaration=Some a;definition=_}::tl -> a::(self#declarative_items_declarations tl) |
244 |
| _::tl -> self#declarative_items_declarations tl |
245 |
| [] -> [] |
246 |
|
247 |
method declarative_items_definitions : vhdl_declarative_item_t list -> vhdl_definition_t list = |
248 |
fun x -> |
249 |
match x with |
250 |
| {use_clause=_; declaration=_;definition=Some a}::tl -> a::(self#declarative_items_definitions tl) |
251 |
| _::tl -> self#declarative_items_definitions tl |
252 |
| [] -> [] |
253 |
|
254 |
method declarative_items_uses : vhdl_declarative_item_t list -> vhdl_load_t list = |
255 |
fun x -> |
256 |
match x with |
257 |
| {use_clause=Some a; declaration=_;definition=_}::tl -> a::(self#declarative_items_uses tl) |
258 |
| _::tl -> self#declarative_items_uses tl |
259 |
| [] -> [] |
260 |
(****************** |
261 |
* End declarative_item_t projections |
262 |
*) |
263 |
|
264 |
(***************** |
265 |
* Begin names_t extraction |
266 |
*) |
267 |
method mini_vhdl_concurrent_stmt_t_assigned_signals_names : mini_vhdl_concurrent_stmt_t -> vhdl_name_t list= |
268 |
fun x -> |
269 |
match x with |
270 |
| Process a -> List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names a.body) |
271 |
| ComponentInst a -> [] |
272 |
|
273 |
method mini_vhdl_sequential_stmt_t_assigned_signals_names : |
274 |
mini_vhdl_sequential_stmt_t -> vhdl_name_t list= |
275 |
fun x -> |
276 |
match x with |
277 |
| VarAssign { label; lhs; rhs } -> [lhs] |
278 |
| SigSeqAssign { label; lhs; rhs } -> [lhs] |
279 |
| SigCondAssign { label; lhs; rhs; delay} -> [lhs] |
280 |
| SigSelectAssign { label; lhs; sel; branches; delay } -> [lhs] |
281 |
| If { label; if_cases; default } -> |
282 |
let if_cases_stmts = List.flatten (List.map (fun x -> x.if_block) if_cases) in |
283 |
List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names (if_cases_stmts@default)) |
284 |
| Case { label; guard; branches } -> |
285 |
let case_branches_stmts = List.flatten (List.map (fun x -> x.when_stmt) branches) in |
286 |
List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names case_branches_stmts) |
287 |
| ProcedureCall { label; name; assocs } -> [] (* TODO: resolve this *) |
288 |
| _ -> [] |
289 |
(**************** |
290 |
*End names_t extraction |
291 |
*) |
292 |
|
293 |
method vhdl_cst_val_t : vhdl_cst_val_t -> vhdl_cst_val_t= |
294 |
fun x -> |
295 |
match x with |
296 |
| CstInt a -> let a = self#int a in CstInt a |
297 |
| CstStdLogic a -> let a = self#string a in CstStdLogic a |
298 |
| CstLiteral a -> let a = self#string a in CstLiteral a |
299 |
|
300 |
method vhdl_type_t : vhdl_type_t -> vhdl_type_t= |
301 |
fun x -> |
302 |
match x with |
303 |
| Base a -> let a = self#string a in Base a |
304 |
| Range (a,b,c) -> |
305 |
let a = self#option self#string a in |
306 |
let b = self#int b in let c = self#int c in Range (a, b, c) |
307 |
| Bit_vector (a,b) -> |
308 |
let a = self#int a in let b = self#int b in Bit_vector (a, b) |
309 |
| Array { indexes; const; definition } -> |
310 |
let indexes = self#list self#lower_vhdl_name_t indexes in |
311 |
let const = self#option self#vhdl_constraint_t const in |
312 |
let definition = self#vhdl_subtype_indication_t definition in |
313 |
Array { indexes; const; definition } |
314 |
| Record a -> |
315 |
let a = self#list self#vhdl_element_declaration_t a in Record a |
316 |
| Enumerated a -> |
317 |
let a = self#list self#lower_vhdl_name_t a in Enumerated a |
318 |
| Void -> Void |
319 |
|
320 |
method vhdl_element_declaration_t : |
321 |
vhdl_element_declaration_t -> vhdl_element_declaration_t= |
322 |
fun { names; definition } -> |
323 |
let names = self#list self#lower_vhdl_name_t names in |
324 |
let definition = self#vhdl_subtype_indication_t definition in |
325 |
{ names; definition } |
326 |
|
327 |
method vhdl_subtype_indication_t : |
328 |
vhdl_subtype_indication_t -> vhdl_subtype_indication_t= |
329 |
fun { name; functionName; const } -> |
330 |
let name = self#lower_vhdl_name_t name in |
331 |
let functionName = self#lower_vhdl_name_t functionName in |
332 |
let const = self#vhdl_constraint_t const in |
333 |
{ name; functionName; const } |
334 |
|
335 |
method vhdl_discrete_range_t : |
336 |
vhdl_discrete_range_t -> vhdl_discrete_range_t= |
337 |
fun x -> |
338 |
match x with |
339 |
| SubDiscreteRange a -> |
340 |
let a = self#vhdl_subtype_indication_t a in SubDiscreteRange a |
341 |
| NamedRange a -> let a = self#lower_vhdl_name_t a in NamedRange a |
342 |
| DirectedRange { direction; from; _to } -> |
343 |
let direction = self#string direction in |
344 |
let from = self#vhdl_expr_t from in |
345 |
let _to = self#vhdl_expr_t _to in |
346 |
DirectedRange { direction; from; _to } |
347 |
|
348 |
method vhdl_constraint_t : vhdl_constraint_t -> vhdl_constraint_t= |
349 |
fun x -> |
350 |
match x with |
351 |
| RefConstraint { ref_name } -> |
352 |
let ref_name = self#lower_vhdl_name_t ref_name in |
353 |
RefConstraint { ref_name } |
354 |
| RangeConstraint { range } -> |
355 |
let range = self#vhdl_discrete_range_t range in |
356 |
RangeConstraint { range } |
357 |
| IndexConstraint { ranges } -> |
358 |
let ranges = self#list self#vhdl_discrete_range_t ranges in |
359 |
IndexConstraint { ranges } |
360 |
| ArrayConstraint { ranges; sub } -> |
361 |
let ranges = self#list self#vhdl_discrete_range_t ranges in |
362 |
let sub = self#vhdl_constraint_t sub in |
363 |
ArrayConstraint { ranges; sub } |
364 |
| RecordConstraint -> RecordConstraint |
365 |
| NoConstraint -> NoConstraint |
366 |
|
367 |
method vhdl_definition_t : vhdl_definition_t -> vhdl_definition_t= |
368 |
fun x -> |
369 |
match x with |
370 |
| Type { name; definition } -> |
371 |
let name = self#lower_vhdl_name_t name in |
372 |
let definition = self#vhdl_type_t definition in |
373 |
Type { name; definition } |
374 |
| Subtype { name; typ } -> |
375 |
let name = self#lower_vhdl_name_t name in |
376 |
let typ = self#vhdl_subtype_indication_t typ in |
377 |
Subtype { name; typ } |
378 |
|
379 |
method vhdl_expr_t : vhdl_expr_t -> vhdl_expr_t= |
380 |
fun x -> |
381 |
match x with |
382 |
| Call a -> let a = self#lower_vhdl_name_t a in Call a |
383 |
| Cst { value; unit_name } -> |
384 |
let value = self#vhdl_cst_val_t value in |
385 |
let unit_name = self#option self#lower_vhdl_name_t unit_name in |
386 |
Cst { value; unit_name } |
387 |
| Op { id; args } -> |
388 |
let id = self#string id in |
389 |
let args = self#list self#vhdl_expr_t args in Op { id; args } |
390 |
| IsNull -> IsNull |
391 |
| Time { value; phy_unit } -> |
392 |
let value = self#int value in |
393 |
let phy_unit = self#string phy_unit in Time { value; phy_unit } |
394 |
| Sig { name; att } -> |
395 |
let name = self#lower_vhdl_name_t name in |
396 |
let att = self#option self#vhdl_signal_attributes_t att in |
397 |
Sig { name; att } |
398 |
| SuffixMod { expr; selection } -> |
399 |
let expr = self#vhdl_expr_t expr in |
400 |
let selection = self#vhdl_suffix_selection_t selection in |
401 |
SuffixMod { expr; selection } |
402 |
| Aggregate { elems } -> |
403 |
let elems = self#list self#vhdl_element_assoc_t elems in |
404 |
Aggregate { elems } |
405 |
| QualifiedExpression { type_mark; aggregate; expression } -> |
406 |
let type_mark = self#lower_vhdl_name_t type_mark in |
407 |
let aggregate = self#list self#vhdl_element_assoc_t aggregate in |
408 |
let expression = self#option self#vhdl_expr_t expression in |
409 |
QualifiedExpression { type_mark; aggregate; expression } |
410 |
| Others -> Others |
411 |
|
412 |
method vhdl_name_t : vhdl_name_t -> vhdl_name_t= |
413 |
fun x -> |
414 |
match x with |
415 |
| Simple a -> let a = self#string a in Simple a |
416 |
| Identifier a -> let a = self#string a in Identifier a |
417 |
| Selected a -> let a = self#list self#lower_vhdl_name_t a in Selected a |
418 |
| Index { id; exprs } -> |
419 |
let id = self#lower_vhdl_name_t id in |
420 |
let exprs = self#list self#vhdl_expr_t exprs in |
421 |
Index { id; exprs } |
422 |
| Slice { id; range } -> |
423 |
let id = self#lower_vhdl_name_t id in |
424 |
let range = self#vhdl_discrete_range_t range in |
425 |
Slice { id; range } |
426 |
| Attribute { id; designator; expr } -> |
427 |
let id = self#lower_vhdl_name_t id in |
428 |
let designator = self#lower_vhdl_name_t designator in |
429 |
let expr = self#vhdl_expr_t expr in |
430 |
Attribute { id; designator; expr } |
431 |
| Function { id; assoc_list } -> |
432 |
let id = self#lower_vhdl_name_t id in |
433 |
let assoc_list = self#list self#vhdl_assoc_element_t assoc_list |
434 |
in |
435 |
Function { id; assoc_list } |
436 |
| NoName -> NoName |
437 |
|
438 |
method vhdl_assoc_element_t : |
439 |
vhdl_assoc_element_t -> vhdl_assoc_element_t= |
440 |
fun |
441 |
{ formal_name; formal_arg; actual_name; actual_designator; |
442 |
actual_expr } |
443 |
-> |
444 |
let formal_name = self#option self#lower_vhdl_name_t formal_name in |
445 |
let formal_arg = self#option self#lower_vhdl_name_t formal_arg in |
446 |
let actual_name = self#option self#lower_vhdl_name_t actual_name in |
447 |
let actual_designator = |
448 |
self#option self#lower_vhdl_name_t actual_designator in |
449 |
let actual_expr = self#option self#vhdl_expr_t actual_expr in |
450 |
{ |
451 |
formal_name; |
452 |
formal_arg; |
453 |
actual_name; |
454 |
actual_designator; |
455 |
actual_expr |
456 |
} |
457 |
|
458 |
method vhdl_element_assoc_t : |
459 |
vhdl_element_assoc_t -> vhdl_element_assoc_t= |
460 |
fun { choices; expr } -> |
461 |
let choices = self#list self#vhdl_expr_t choices in |
462 |
let expr = self#vhdl_expr_t expr in { choices; expr } |
463 |
|
464 |
method vhdl_array_attributes_t : |
465 |
vhdl_array_attributes_t -> vhdl_array_attributes_t= |
466 |
fun x -> |
467 |
match x with |
468 |
| AAttInt { id; arg } -> |
469 |
let id = self#string id in |
470 |
let arg = self#int arg in AAttInt { id; arg } |
471 |
| AAttAscending -> AAttAscending |
472 |
|
473 |
method vhdl_signal_attributes_t : |
474 |
vhdl_signal_attributes_t -> vhdl_signal_attributes_t= |
475 |
fun x -> match x with | SigAtt a -> let a = self#string a in SigAtt a |
476 |
|
477 |
method vhdl_string_attributes_t : |
478 |
vhdl_string_attributes_t -> vhdl_string_attributes_t= |
479 |
fun x -> |
480 |
match x with | StringAtt a -> let a = self#string a in StringAtt a |
481 |
|
482 |
method vhdl_suffix_selection_t : vhdl_suffix_selection_t -> vhdl_suffix_selection_t= |
483 |
fun x -> |
484 |
match x with |
485 |
| Idx a -> let a = self#int a in Idx a |
486 |
| SuffixRange (a,b) -> |
487 |
let a = self#int a in let b = self#int b in SuffixRange (a, b) |
488 |
|
489 |
method vhdl_type_attributes_t : |
490 |
'a . |
491 |
('a -> 'a) -> 'a vhdl_type_attributes_t -> 'a vhdl_type_attributes_t= |
492 |
fun _basetype -> |
493 |
fun x -> |
494 |
match x with |
495 |
| TAttNoArg { id } -> let id = self#string id in TAttNoArg { id } |
496 |
| TAttIntArg { id; arg } -> |
497 |
let id = self#string id in |
498 |
let arg = self#int arg in TAttIntArg { id; arg } |
499 |
| TAttValArg { id; arg } -> |
500 |
let id = self#string id in |
501 |
let arg = _basetype arg in TAttValArg { id; arg } |
502 |
| TAttStringArg { id; arg } -> |
503 |
let id = self#string id in |
504 |
let arg = self#string arg in TAttStringArg { id; arg } |
505 |
|
506 |
method vhdl_parameter_t : vhdl_parameter_t -> vhdl_parameter_t= |
507 |
fun { names; mode; typ; init_val } -> |
508 |
let names = self#list self#lower_vhdl_name_t names in |
509 |
let mode = self#list self#string mode in |
510 |
let typ = self#vhdl_subtype_indication_t typ in |
511 |
let init_val = self#option self#vhdl_cst_val_t init_val in |
512 |
{ names; mode; typ; init_val } |
513 |
|
514 |
method vhdl_subprogram_spec_t : |
515 |
vhdl_subprogram_spec_t -> vhdl_subprogram_spec_t= |
516 |
fun { name; subprogram_type; typeMark; parameters; isPure } -> |
517 |
let name = self#string name in |
518 |
let subprogram_type = self#string subprogram_type in |
519 |
let typeMark = self#lower_vhdl_name_t typeMark in |
520 |
let parameters = self#list self#vhdl_parameter_t parameters in |
521 |
let isPure = self#bool isPure in |
522 |
{ name; subprogram_type; typeMark; parameters; isPure } |
523 |
|
524 |
method vhdl_sequential_stmt_t : |
525 |
vhdl_sequential_stmt_t -> mini_vhdl_sequential_stmt_t= |
526 |
fun x -> |
527 |
match x with |
528 |
| VarAssign { label; lhs; rhs } -> |
529 |
let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in |
530 |
let lhs = self#lower_vhdl_name_t lhs in |
531 |
let rhs = self#vhdl_expr_t rhs in VarAssign { label; lhs; rhs } |
532 |
| SigSeqAssign { label; lhs; rhs } -> |
533 |
let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in |
534 |
let lhs = self#lower_vhdl_name_t lhs in |
535 |
let rhs = self#list self#vhdl_waveform_element_t rhs in |
536 |
SigSeqAssign { label; lhs; rhs } |
537 |
| If { label; if_cases; default } -> |
538 |
let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in |
539 |
let if_cases = List.map self#vhdl_if_case_t if_cases in |
540 |
let default = List.map self#vhdl_sequential_stmt_t default in |
541 |
If { label; if_cases; default } |
542 |
| Case { label; guard; branches } -> |
543 |
let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in |
544 |
let guard = self#vhdl_expr_t guard in |
545 |
let branches = List.map self#vhdl_case_item_t branches in |
546 |
Case { label; guard; branches } |
547 |
| Exit { label; loop_label; condition } -> |
548 |
let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in |
549 |
let loop_label = self#option self#string loop_label in |
550 |
let condition = self#option self#vhdl_expr_t condition in |
551 |
Exit { label; loop_label; condition } |
552 |
| Assert { label; cond; report; severity } -> |
553 |
let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in |
554 |
let cond = self#vhdl_expr_t cond in |
555 |
let report = self#vhdl_expr_t report in |
556 |
let severity = self#vhdl_expr_t severity in |
557 |
Assert { label; cond; report; severity } |
558 |
| ProcedureCall { label; name; assocs } -> |
559 |
let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in |
560 |
let name = self#lower_vhdl_name_t name in |
561 |
let assocs = self#list self#vhdl_assoc_element_t assocs in |
562 |
ProcedureCall { label; name; assocs } |
563 |
| Wait -> Wait |
564 |
| Null { label } -> |
565 |
let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in |
566 |
Null { label } |
567 |
| Return { label; expr } -> |
568 |
let label = self#option self#lower_vhdl_name_t label in |
569 |
let expr = self#option self#vhdl_expr_t expr in |
570 |
Return { label; expr } |
571 |
|
572 |
method vhdl_if_case_t : vhdl_if_case_t -> mini_vhdl_if_case_t= |
573 |
fun { if_cond; if_block } -> |
574 |
let if_cond = self#vhdl_expr_t if_cond in |
575 |
let if_block = List.map self#vhdl_sequential_stmt_t if_block in |
576 |
{ if_cond; if_block } |
577 |
|
578 |
method vhdl_case_item_t : vhdl_case_item_t -> mini_vhdl_case_item_t= |
579 |
fun { when_cond; when_stmt } -> |
580 |
let when_cond = self#list self#vhdl_expr_t when_cond in |
581 |
let when_stmt = List.map self#vhdl_sequential_stmt_t when_stmt in |
582 |
{ when_cond; when_stmt } |
583 |
|
584 |
method vhdl_declaration_t : vhdl_declaration_t -> mini_vhdl_declaration_t= |
585 |
fun x -> |
586 |
match x with |
587 |
| VarDecl { names; typ; init_val } -> |
588 |
let names = self#list self#lower_vhdl_name_t names in |
589 |
let typ = self#vhdl_subtype_indication_t typ in |
590 |
let init_val = self#vhdl_expr_t init_val in |
591 |
VarDecl { names; typ; init_val } |
592 |
| CstDecl { names; typ; init_val } -> |
593 |
let names = self#list self#lower_vhdl_name_t names in |
594 |
let typ = self#vhdl_subtype_indication_t typ in |
595 |
let init_val = self#vhdl_expr_t init_val in |
596 |
CstDecl { names; typ; init_val } |
597 |
| SigDecl { names; typ; init_val } -> |
598 |
let names = self#list self#lower_vhdl_name_t names in |
599 |
let typ = self#vhdl_subtype_indication_t typ in |
600 |
let init_val = self#vhdl_expr_t init_val in |
601 |
SigDecl { names; typ; init_val } |
602 |
| ComponentDecl { name; generics; ports } -> |
603 |
let name = self#lower_vhdl_name_t name in |
604 |
let generics = self#list self#vhdl_port_t generics in |
605 |
let ports = self#list self#vhdl_port_t ports in |
606 |
ComponentDecl { name; generics; ports } |
607 |
| Subprogram { spec; decl_part; stmts } -> |
608 |
let spec = self#vhdl_subprogram_spec_t spec in |
609 |
let decl_part = List.map self#vhdl_declaration_t decl_part in |
610 |
let stmts = List.map self#vhdl_sequential_stmt_t stmts in |
611 |
Subprogram { spec; decl_part; stmts } |
612 |
|
613 |
method vhdl_declarative_item_t : |
614 |
vhdl_declarative_item_t -> mini_vhdl_declarative_item_t= |
615 |
fun { use_clause; declaration; definition } -> |
616 |
let use_clause = self#option self#vhdl_load_t use_clause in |
617 |
let declaration = |
618 |
match declaration with |
619 |
| None -> None |
620 |
| Some a -> Some (self#vhdl_declaration_t a) in |
621 |
let definition = self#option self#vhdl_definition_t definition in |
622 |
{ use_clause; declaration; definition } |
623 |
|
624 |
method vhdl_waveform_element_t : |
625 |
vhdl_waveform_element_t -> vhdl_waveform_element_t= |
626 |
fun { value; delay } -> |
627 |
let value = self#option self#vhdl_expr_t value in |
628 |
let delay = self#option self#vhdl_expr_t delay in { value; delay } |
629 |
|
630 |
method vhdl_signal_condition_t : |
631 |
vhdl_signal_condition_t -> vhdl_signal_condition_t= |
632 |
fun { expr; cond } -> |
633 |
let expr = self#list self#vhdl_waveform_element_t expr in |
634 |
let cond = self#option self#vhdl_expr_t cond in { expr; cond } |
635 |
|
636 |
method vhdl_signal_selection_t : |
637 |
vhdl_signal_selection_t -> vhdl_signal_selection_t= |
638 |
fun { expr; when_sel } -> |
639 |
let expr = self#list self#vhdl_waveform_element_t expr in |
640 |
let when_sel = self#list self#vhdl_expr_t when_sel in |
641 |
{ expr; when_sel } |
642 |
|
643 |
method vhdl_conditional_signal_t : |
644 |
vhdl_conditional_signal_t -> vhdl_conditional_signal_t= |
645 |
fun { postponed; label; lhs; rhs; delay } -> |
646 |
let postponed = self#bool postponed in |
647 |
let label = self#lower_vhdl_name_t label in |
648 |
let lhs = self#lower_vhdl_name_t lhs in |
649 |
let rhs = self#list self#vhdl_signal_condition_t rhs in |
650 |
let delay = self#vhdl_expr_t delay in |
651 |
{ postponed; label; lhs; rhs; delay } |
652 |
|
653 |
method vhdl_process_t : vhdl_process_t -> mini_vhdl_process_t= |
654 |
fun { id; declarations; active_sigs; body } -> |
655 |
let id = self#lower_vhdl_name_t id in |
656 |
let declarations = List.map self#vhdl_declarative_item_t declarations in |
657 |
let active_sigs = self#list self#lower_vhdl_name_t active_sigs in |
658 |
let body = List.map self#vhdl_sequential_stmt_t body in |
659 |
let postponed = false in |
660 |
let label = None in |
661 |
{ id; declarations; active_sigs; body; postponed; label } |
662 |
|
663 |
method vhdl_selected_signal_t : |
664 |
vhdl_selected_signal_t -> vhdl_selected_signal_t= |
665 |
fun { postponed; label; lhs; sel; branches; delay } -> |
666 |
let postponed = self#bool postponed in |
667 |
let label = self#lower_vhdl_name_t label in |
668 |
let lhs = self#lower_vhdl_name_t lhs in |
669 |
let sel = self#vhdl_expr_t sel in |
670 |
let branches = self#list self#vhdl_signal_selection_t branches in |
671 |
let delay = self#option self#vhdl_expr_t delay in |
672 |
{ postponed; label; lhs; sel; branches; delay } |
673 |
|
674 |
method vhdl_port_mode_t : vhdl_port_mode_t -> vhdl_port_mode_t= |
675 |
fun x -> x |
676 |
|
677 |
method vhdl_component_instantiation_t : |
678 |
vhdl_component_instantiation_t -> mini_vhdl_component_instantiation_t= |
679 |
fun { name; inst_unit; inst_unit_type; archi_name; generic_map; port_map } -> |
680 |
let name = self#lower_vhdl_name_t name in |
681 |
let archi_name = self#option self#lower_vhdl_name_t archi_name in |
682 |
let inst_unit = self#lower_vhdl_name_t inst_unit in |
683 |
let db_tuple = match archi_name with |
684 |
| None -> failwith ("Component [" ^ self#to_string_vhdl_name_t name ^ "] is not an entity") |
685 |
| Some a -> self#get_tuple_from_archi_and_entity_name (a, inst_unit) in (* Get corresponding tuple in db *) |
686 |
let archi = db_tuple.architecture in |
687 |
let entity = db_tuple.entity in |
688 |
let generic_map = self#list self#vhdl_assoc_element_t generic_map in |
689 |
let port_map = self#list self#vhdl_assoc_element_t port_map in |
690 |
{ name; archi; entity; generic_map; port_map } |
691 |
|
692 |
method vhdl_concurrent_stmt_t : |
693 |
vhdl_concurrent_stmt_t -> mini_vhdl_concurrent_stmt_t= |
694 |
fun x -> |
695 |
match x with |
696 |
| SigAssign a -> |
697 |
Process { |
698 |
id = self#postfix_flatten_vhdl_name_t a.lhs "__implicit_process"; |
699 |
declarations = []; |
700 |
active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x []; |
701 |
body = (SigCondAssign { |
702 |
label = None; |
703 |
lhs = a.lhs; |
704 |
rhs = a.rhs; |
705 |
delay = match a.delay with | IsNull -> None | _ -> Some a.delay |
706 |
})::[]; |
707 |
postponed = a.postponed; |
708 |
label = match a.label with | NoName -> None | _ -> Some a.label |
709 |
} |
710 |
| Process a -> let a = self#vhdl_process_t a in Process a |
711 |
| SelectedSig a -> |
712 |
Process { |
713 |
id = self#postfix_flatten_vhdl_name_t a.lhs "__implicit_process"; |
714 |
declarations = []; |
715 |
active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x []; |
716 |
body = (SigSelectAssign { |
717 |
label = None; |
718 |
lhs = a.lhs; |
719 |
sel = a.sel; |
720 |
branches = a.branches; |
721 |
delay = a.delay |
722 |
})::[]; |
723 |
postponed = a.postponed; |
724 |
label = match a.label with | NoName -> None | _ -> Some a.label |
725 |
} |
726 |
| ComponentInst a -> let a = self#vhdl_component_instantiation_t a in ComponentInst a |
727 |
|
728 |
method vhdl_port_t : vhdl_port_t -> vhdl_port_t= |
729 |
fun { names; mode; typ; expr } -> |
730 |
let names = self#list self#lower_vhdl_name_t names in |
731 |
let mode = self#vhdl_port_mode_t mode in |
732 |
let typ = self#vhdl_subtype_indication_t typ in |
733 |
let expr = self#vhdl_expr_t expr in { names; mode; typ; expr } |
734 |
|
735 |
method vhdl_entity_t : vhdl_entity_t -> unit = |
736 |
fun { name; generics; ports; declaration; stmts } -> () |
737 |
|
738 |
method vhdl_package_t : (vhdl_load_t list * vhdl_package_t) -> mini_vhdl_package_t= |
739 |
fun ( ctxs, {name; shared_defs; shared_decls; shared_uses }) -> |
740 |
let name = self#lower_vhdl_name_t name in |
741 |
let shared_defs = self#list self#vhdl_definition_t shared_defs in |
742 |
let shared_decls = List.map self#vhdl_declaration_t shared_decls in |
743 |
let shared_uses = self#list self#vhdl_load_t shared_uses @ ctxs in |
744 |
{ name; shared_defs; shared_decls; shared_uses } |
745 |
|
746 |
method vhdl_load_t : vhdl_load_t -> vhdl_load_t= |
747 |
fun x -> |
748 |
match x with |
749 |
| Library a -> let a = self#list self#lower_vhdl_name_t a in Library a |
750 |
| Use a -> let a = self#list self#lower_vhdl_name_t a in Use a |
751 |
|
752 |
method vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list * |
753 |
(vhdl_load_t list * vhdl_entity_t) list * |
754 |
(vhdl_load_t list * vhdl_configuration_t) list * |
755 |
(vhdl_load_t list * vhdl_architecture_t)) -> mini_vhdl_component_t= |
756 |
fun ( packs_pairs, ents_pairs, confs_pairs, (arch_ctx, arch) ) -> |
757 |
let names = arch.name::(arch.entity::[]) in |
758 |
let (ref_ent_ctx,ref_ent) = self#filter_entity (ents_pairs, arch.entity) in |
759 |
let contexts = |
760 |
ref_ent_ctx @ (* Referenced entity context elements *) |
761 |
arch_ctx @ (* Architecture context elements *) |
762 |
self#declarative_items_uses ref_ent.declaration @ (* Referenced entity inner context elements *) |
763 |
self#declarative_items_uses arch.declarations in (* Architecture inner context elements *) |
764 |
let declarations = |
765 |
self#declarative_items_declarations ref_ent.declaration @ (* Referenced entity inner declarations *) |
766 |
self#declarative_items_declarations arch.declarations in (* Architecture inner declarations *) |
767 |
let definitions = |
768 |
self#declarative_items_definitions ref_ent.declaration @ (* Referenced entity inner definitions *) |
769 |
self#declarative_items_definitions arch.declarations in (* Architecture inner definitions *) |
770 |
let body = |
771 |
List.map self#vhdl_concurrent_stmt_t ref_ent.stmts @ (* Referenced entity concurrent statement *) |
772 |
List.map self#vhdl_concurrent_stmt_t arch.body in (* Architecture concurrent statements *) |
773 |
let generics = ref_ent.generics in (* Referenced entity generics *) |
774 |
let ports = ref_ent.ports in (* Referenced entity ports *) |
775 |
let declarations = List.map self#vhdl_declaration_t declarations in |
776 |
let signals = |
777 |
let rec find_sig_decls declarations = |
778 |
match declarations with |
779 |
| [] -> [] |
780 |
| (SigDecl (s))::tl -> (SigDecl (s))::find_sig_decls tl |
781 |
| _::tl -> find_sig_decls tl in find_sig_decls declarations in |
782 |
let assigned_names = List.flatten (List.map self#mini_vhdl_concurrent_stmt_t_assigned_signals_names body) in |
783 |
(* TODO: Flatten component instantiation from here *) |
784 |
self#db_add_tuple { entity=ref_ent; |
785 |
architecture=arch; |
786 |
architecture_signals=signals; |
787 |
architecture_ports=ports; |
788 |
architecture_generics=generics; |
789 |
assigned_names=assigned_names; |
790 |
contexts=contexts; |
791 |
}; |
792 |
{ names; |
793 |
generics=generics; |
794 |
ports=ports; |
795 |
contexts=contexts; |
796 |
declarations=declarations; |
797 |
definitions=definitions; |
798 |
body=body |
799 |
} |
800 |
|
801 |
method vhdl_configuration_t : |
802 |
vhdl_configuration_t -> unit= self#unit |
803 |
|
804 |
method vhdl_library_unit_t : vhdl_library_unit_t -> unit= |
805 |
fun x -> () |
806 |
|
807 |
method vhdl_design_unit_t : vhdl_design_unit_t -> unit= |
808 |
fun { contexts; library } -> () |
809 |
|
810 |
method vhdl_design_file_t : vhdl_design_file_t -> mini_vhdl_design_file_t= |
811 |
fun { design_units } -> |
812 |
let rec inline_df l packs ents archs confs = match l with |
813 |
| [] -> (List.rev packs, List.rev ents, List.rev archs, List.rev confs) |
814 |
| {contexts = c; library = lib}::tl -> match lib with |
815 |
| Package p -> inline_df tl ((c,p)::packs) ents archs confs |
816 |
| Entities e -> inline_df tl packs ((c,e)::ents) archs confs |
817 |
| Architecture a -> inline_df tl packs ents ((c,a)::archs) confs |
818 |
| Configuration conf -> inline_df tl packs ents archs ((c,conf)::confs) in |
819 |
let (p,e,a,con) = inline_df design_units [] [] [] [] in |
820 |
let app x = self#vhdl_architecture_t (p,e,con,x) in |
821 |
let components = List.map app a in |
822 |
let packages = List.map self#vhdl_package_t p in |
823 |
{ components; packages } |
824 |
|
825 |
end |