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 