lustrec / src / backends / VHDL / vhdl_2_mini_vhdl_map.ml @ 4a92cb37
History  View  Annotate  Download (33.7 KB)
1 
open Vhdl_ast 

2 
open Mini_vhdl_ast 
3  
4 
type db_tuple_t = 
5 
{ 
6 
mutable entity: vhdl_entity_t; 
7 
mutable architecture: vhdl_architecture_t; 
8 
mutable architecture_signals_names: vhdl_name_t list; 
9 
mutable contexts: vhdl_load_t list; 
10 
} 
11  
12 
let _ = fun (_ : vhdl_cst_val_t) > () 
13 
let _ = fun (_ : vhdl_type_t) > () 
14 
let _ = fun (_ : vhdl_element_declaration_t) > () 
15 
let _ = fun (_ : vhdl_subtype_indication_t) > () 
16 
let _ = fun (_ : vhdl_discrete_range_t) > () 
17 
let _ = fun (_ : vhdl_constraint_t) > () 
18 
let _ = fun (_ : vhdl_definition_t) > () 
19 
let _ = fun (_ : vhdl_expr_t) > () 
20 
let _ = fun (_ : vhdl_name_t) > () 
21 
let _ = fun (_ : vhdl_assoc_element_t) > () 
22 
let _ = fun (_ : vhdl_element_assoc_t) > () 
23 
let _ = fun (_ : vhdl_array_attributes_t) > () 
24 
let _ = fun (_ : vhdl_signal_attributes_t) > () 
25 
let _ = fun (_ : vhdl_string_attributes_t) > () 
26 
let _ = fun (_ : vhdl_suffix_selection_t) > () 
27 
let _ = fun (_ : 'basetype vhdl_type_attributes_t) > () 
28 
let _ = fun (_ : vhdl_parameter_t) > () 
29 
let _ = fun (_ : vhdl_subprogram_spec_t) > () 
30 
let _ = fun (_ : vhdl_sequential_stmt_t) > () 
31 
let _ = fun (_ : vhdl_if_case_t) > () 
32 
let _ = fun (_ : vhdl_case_item_t) > () 
33 
let _ = fun (_ : vhdl_declaration_t) > () 
34 
let _ = fun (_ : vhdl_signal_selection_t) > () 
35 
let _ = fun (_ : vhdl_declarative_item_t) > () 
36 
let _ = fun (_ : vhdl_waveform_element_t) > () 
37 
let _ = fun (_ : vhdl_signal_condition_t) > () 
38 
let _ = fun (_ : vhdl_conditional_signal_t) > () 
39 
let _ = fun (_ : vhdl_process_t) > () 
40 
let _ = fun (_ : vhdl_selected_signal_t) > () 
41 
let _ = fun (_ : vhdl_port_mode_t) > () 
42 
let _ = fun (_ : vhdl_component_instantiation_t) > () 
43 
let _ = fun (_ : vhdl_concurrent_stmt_t) > () 
44 
let _ = fun (_ : vhdl_port_t) > () 
45 
let _ = fun (_ : vhdl_entity_t) > () 
46 
let _ = fun (_ : vhdl_package_t) > () 
47 
let _ = fun (_ : vhdl_load_t) > () 
48 
let _ = fun (_ : vhdl_architecture_t) > () 
49 
let _ = fun (_ : vhdl_configuration_t) > () 
50 
let _ = fun (_ : vhdl_library_unit_t) > () 
51 
let _ = fun (_ : vhdl_design_unit_t) > () 
52 
let _ = fun (_ : vhdl_design_file_t) > () 
53  
54 
class virtual vhdl_2_mini_vhdl_map = 
55 
object (self) 
56 
method virtual string : string > string 
57 
method virtual list : 'a . ('a > 'a) > 'a list > 'a list 
58 
method virtual unit : unit > unit 
59 
method virtual bool : bool > bool 
60 
method virtual option : 'a . ('a > 'a) > 'a option > 'a option 
61 
method virtual int : int > int 
62 
method virtual vhdl_name_t : vhdl_name_t > vhdl_name_t 
63 
method virtual vhdl_definition_t : vhdl_definition_t > vhdl_definition_t 
64 
method virtual vhdl_port_t : vhdl_port_t > vhdl_port_t 
65 
method virtual vhdl_expr_t : vhdl_expr_t > vhdl_expr_t 
66 
method virtual vhdl_port_mode_t : vhdl_port_mode_t > vhdl_port_mode_t 
67 
method virtual vhdl_element_declaration_t : vhdl_element_declaration_t > vhdl_element_declaration_t 
68 
method virtual vhdl_subtype_indication_t : vhdl_subtype_indication_t > vhdl_subtype_indication_t 
69 
method virtual vhdl_conditional_signal_t : vhdl_conditional_signal_t > vhdl_conditional_signal_t 
70 
method virtual vhdl_process_t : vhdl_process_t > vhdl_process_t 
71 
method virtual vhdl_selected_signal_t : vhdl_selected_signal_t > vhdl_selected_signal_t 
72 
method virtual vhdl_signal_selection_t : vhdl_signal_selection_t > vhdl_signal_selection_t 
73 
method virtual vhdl_suffix_selection_t : vhdl_suffix_selection_t > vhdl_suffix_selection_t 
74 
method virtual vhdl_declaration_t : vhdl_declaration_t > vhdl_declaration_t 
75 
method virtual vhdl_sequential_stmt_t : vhdl_sequential_stmt_t > vhdl_sequential_stmt_t 
76 
method virtual vhdl_declarative_item_t : vhdl_declarative_item_t > vhdl_declarative_item_t 
77 
method virtual vhdl_waveform_element_t : vhdl_waveform_element_t > vhdl_waveform_element_t 
78 
method virtual vhdl_signal_condition_t : vhdl_signal_condition_t > vhdl_signal_condition_t 
79 
method virtual vhdl_cst_val_t : vhdl_cst_val_t > vhdl_cst_val_t 
80 
method virtual vhdl_subprogram_spec_t : vhdl_subprogram_spec_t > vhdl_subprogram_spec_t 
81 
method virtual vhdl_discrete_range_t : vhdl_discrete_range_t > vhdl_discrete_range_t 
82 
method virtual vhdl_parameter_t : vhdl_parameter_t > vhdl_parameter_t 
83 
method virtual vhdl_concurrent_stmt_t : vhdl_concurrent_stmt_t > mini_vhdl_concurrent_stmt_t 
84 
method virtual vhdl_declaration_t : vhdl_declaration_t > vhdl_declaration_t 
85 
method virtual vhdl_configuration_t : vhdl_configuration_t > unit 
86 
method virtual vhdl_entity_t : vhdl_entity_t > unit 
87 
method virtual vhdl_library_unit_t : vhdl_library_unit_t > unit 
88 
method virtual vhdl_load_t : vhdl_load_t > vhdl_load_t 
89 
method virtual vhdl_design_unit_t : vhdl_design_unit_t > unit 
90 
method virtual vhdl_design_file_t : vhdl_design_file_t > mini_vhdl_design_file_t 
91  
92 
method virtual vhdl_package_t : (vhdl_load_t list * vhdl_package_t) > vhdl_package_t 
93 
method virtual vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list * 
94 
(vhdl_load_t list * vhdl_entity_t) list * 
95 
(vhdl_load_t list * vhdl_configuration_t) list * 
96 
(vhdl_load_t list * vhdl_architecture_t)) > mini_vhdl_component_t 
97 
method virtual vhdl_component_instantiation_t : vhdl_component_instantiation_t > mini_vhdl_component_instantiation_t 
98 
method virtual declarative_items_declarations : vhdl_declarative_item_t list > vhdl_declaration_t list 
99 
method virtual declarative_items_definitions : vhdl_declarative_item_t list > vhdl_definition_t list 
100 
method virtual declarative_items_uses : vhdl_declarative_item_t list > vhdl_load_t list 
101 
method virtual filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) > 
102 
(vhdl_load_t list * vhdl_entity_t) 
103  
104 
(************************* 
105 
* Begin vhdl_name_t helpers 
106 
*) 
107 
method simplify_name_t : vhdl_name_t > vhdl_name_t= 
108 
fun n > 
109 
let lower a = String.lowercase_ascii a in 
110 
let n = self#lower_vhdl_name_t n in 
111 
match n with 
112 
 Selected (a::[]) > self#simplify_name_t a 
113 
 Selected (NoName::tl) > self#simplify_name_t (Selected tl) 
114 
 Selected ((Simple (s))::tl) > if (lower s = "work") 
115 
then self#simplify_name_t (Selected tl) 
116 
else n 
117 
 Selected ((Identifier (s))::tl) > if (lower s = "work") 
118 
then self#simplify_name_t (Selected tl) 
119 
else n 
120 
 _ > n 
121  
122 
method lower_vhdl_name_t : vhdl_name_t > vhdl_name_t= 
123 
fun x > 
124 
let lower a = String.lowercase_ascii a in 
125 
match x with 
126 
 Simple a > Simple (lower a) 
127 
 Identifier a > Identifier (lower a) 
128 
 Selected a > Selected (self#list self#lower_vhdl_name_t a) 
129 
 Index { id; exprs } > 
130 
let id = self#lower_vhdl_name_t id in 
131 
let exprs = self#list self#vhdl_expr_t exprs in 
132 
Index { id; exprs } 
133 
 Slice { id; range } > 
134 
let id = self#lower_vhdl_name_t id in 
135 
let range = self#vhdl_discrete_range_t range in 
136 
Slice { id; range } 
137 
 Attribute { id; designator; expr } > 
138 
let id = self#lower_vhdl_name_t id in 
139 
let designator = self#lower_vhdl_name_t designator in 
140 
let expr = self#vhdl_expr_t expr in 
141 
Attribute { id; designator; expr } 
142 
 Function { id; assoc_list } > 
143 
let id = self#lower_vhdl_name_t id in 
144 
let assoc_list = self#list self#vhdl_assoc_element_t assoc_list in 
145 
Function { id; assoc_list } 
146 
 NoName > NoName 
147 

148 
method to_string_vhdl_name_t : vhdl_name_t > string= 
149 
fun x > 
150 
match x with 
151 
 Simple a > a 
152 
 Identifier a > a 
153 
 Selected a > String.concat "." (List.map self#to_string_vhdl_name_t a) 
154 
 Index { id; exprs } > self#to_string_vhdl_name_t id 
155 
 Slice { id; range } > self#to_string_vhdl_name_t id 
156 
 Attribute { id; designator; expr } > self#to_string_vhdl_name_t id 
157 
 Function { id; assoc_list } > self#to_string_vhdl_name_t id 
158 
 NoName > "NoName" 
159 
(************************* 
160 
* End vhdl_name_t helpers 
161 
*) 
162  
163 
(************************* 
164 
* Begin DB helpers 
165 
*) 
166 
val mutable db : db_tuple_t list = [] 
167  
168 
method db_add_tuple : db_tuple_t > unit= 
169 
fun x > db < x::db 
170  
171 
method db_get : vhdl_architecture_t > (vhdl_entity_t * vhdl_load_t list)= 
172 
fun x > 
173 
let rec find a dbl = 
174 
match dbl with 
175 
 [] > failwith ("No matching tuple in DB for architecture [" ^ self#to_string_vhdl_name_t x.name ^ "]") 
176 
 e::tl > if (e.architecture = a) then (e.entity, e.contexts) else find a tl in find x db 
177  
178 
method get_tuple_from_archi_and_entity_name : (vhdl_name_t * vhdl_name_t) > db_tuple_t= 
179 
fun (a_name,e_name) > 
180 
let a_name = self#simplify_name_t a_name in 
181 
let e_name = self#simplify_name_t e_name in 
182 
let rec find (a_name,e_name) dbl = 
183 
match dbl with 
184 
 [] > failwith ("No matching tuple in DB for architecture [" ^ self#to_string_vhdl_name_t a_name ^ 
185 
"] and entity [" ^ self#to_string_vhdl_name_t e_name ^ "]") 
186 
 e::tl > 
187 
let inner_e_arch_name = self#simplify_name_t e.architecture.name in 
188 
let inner_e_ent_name = self#simplify_name_t e.entity.name in 
189 
if ((inner_e_arch_name = a_name) && (inner_e_ent_name = e_name)) 
190 
then e 
191 
else find (a_name,e_name) tl in 
192 
find (a_name,e_name) db 
193 
(******************* 
194 
* End DB helpers 
195 
*) 
196  
197 
method vhdl_cst_val_t : vhdl_cst_val_t > vhdl_cst_val_t= 
198 
fun x > 
199 
match x with 
200 
 CstInt a > let a = self#int a in CstInt a 
201 
 CstStdLogic a > let a = self#string a in CstStdLogic a 
202 
 CstLiteral a > let a = self#string a in CstLiteral a 
203  
204 
method vhdl_type_t : vhdl_type_t > vhdl_type_t= 
205 
fun x > 
206 
match x with 
207 
 Base a > let a = self#string a in Base a 
208 
 Range (a,b,c) > 
209 
let a = self#option self#string a in 
210 
let b = self#int b in let c = self#int c in Range (a, b, c) 
211 
 Bit_vector (a,b) > 
212 
let a = self#int a in let b = self#int b in Bit_vector (a, b) 
213 
 Array { indexes; const; definition } > 
214 
let indexes = self#list self#lower_vhdl_name_t indexes in 
215 
let const = self#option self#vhdl_constraint_t const in 
216 
let definition = self#vhdl_subtype_indication_t definition in 
217 
Array { indexes; const; definition } 
218 
 Record a > 
219 
let a = self#list self#vhdl_element_declaration_t a in Record a 
220 
 Enumerated a > 
221 
let a = self#list self#lower_vhdl_name_t a in Enumerated a 
222 
 Void > Void 
223  
224 
method vhdl_element_declaration_t : 
225 
vhdl_element_declaration_t > vhdl_element_declaration_t= 
226 
fun { names; definition } > 
227 
let names = self#list self#lower_vhdl_name_t names in 
228 
let definition = self#vhdl_subtype_indication_t definition in 
229 
{ names; definition } 
230  
231 
method vhdl_subtype_indication_t : 
232 
vhdl_subtype_indication_t > vhdl_subtype_indication_t= 
233 
fun { name; functionName; const } > 
234 
let name = self#lower_vhdl_name_t name in 
235 
let functionName = self#lower_vhdl_name_t functionName in 
236 
let const = self#vhdl_constraint_t const in 
237 
{ name; functionName; const } 
238  
239 
method vhdl_discrete_range_t : 
240 
vhdl_discrete_range_t > vhdl_discrete_range_t= 
241 
fun x > 
242 
match x with 
243 
 SubDiscreteRange a > 
244 
let a = self#vhdl_subtype_indication_t a in SubDiscreteRange a 
245 
 NamedRange a > let a = self#lower_vhdl_name_t a in NamedRange a 
246 
 DirectedRange { direction; from; _to } > 
247 
let direction = self#string direction in 
248 
let from = self#vhdl_expr_t from in 
249 
let _to = self#vhdl_expr_t _to in 
250 
DirectedRange { direction; from; _to } 
251  
252 
method vhdl_constraint_t : vhdl_constraint_t > vhdl_constraint_t= 
253 
fun x > 
254 
match x with 
255 
 RefConstraint { ref_name } > 
256 
let ref_name = self#lower_vhdl_name_t ref_name in 
257 
RefConstraint { ref_name } 
258 
 RangeConstraint { range } > 
259 
let range = self#vhdl_discrete_range_t range in 
260 
RangeConstraint { range } 
261 
 IndexConstraint { ranges } > 
262 
let ranges = self#list self#vhdl_discrete_range_t ranges in 
263 
IndexConstraint { ranges } 
264 
 ArrayConstraint { ranges; sub } > 
265 
let ranges = self#list self#vhdl_discrete_range_t ranges in 
266 
let sub = self#vhdl_constraint_t sub in 
267 
ArrayConstraint { ranges; sub } 
268 
 RecordConstraint > RecordConstraint 
269 
 NoConstraint > NoConstraint 
270  
271 
method vhdl_definition_t : vhdl_definition_t > vhdl_definition_t= 
272 
fun x > 
273 
match x with 
274 
 Type { name; definition } > 
275 
let name = self#lower_vhdl_name_t name in 
276 
let definition = self#vhdl_type_t definition in 
277 
Type { name; definition } 
278 
 Subtype { name; typ } > 
279 
let name = self#lower_vhdl_name_t name in 
280 
let typ = self#vhdl_subtype_indication_t typ in 
281 
Subtype { name; typ } 
282  
283 
method vhdl_expr_t : vhdl_expr_t > vhdl_expr_t= 
284 
fun x > 
285 
match x with 
286 
 Call a > let a = self#lower_vhdl_name_t a in Call a 
287 
 Cst { value; unit_name } > 
288 
let value = self#vhdl_cst_val_t value in 
289 
let unit_name = self#option self#lower_vhdl_name_t unit_name in 
290 
Cst { value; unit_name } 
291 
 Op { id; args } > 
292 
let id = self#string id in 
293 
let args = self#list self#vhdl_expr_t args in Op { id; args } 
294 
 IsNull > IsNull 
295 
 Time { value; phy_unit } > 
296 
let value = self#int value in 
297 
let phy_unit = self#string phy_unit in Time { value; phy_unit } 
298 
 Sig { name; att } > 
299 
let name = self#lower_vhdl_name_t name in 
300 
let att = self#option self#vhdl_signal_attributes_t att in 
301 
Sig { name; att } 
302 
 SuffixMod { expr; selection } > 
303 
let expr = self#vhdl_expr_t expr in 
304 
let selection = self#vhdl_suffix_selection_t selection in 
305 
SuffixMod { expr; selection } 
306 
 Aggregate { elems } > 
307 
let elems = self#list self#vhdl_element_assoc_t elems in 
308 
Aggregate { elems } 
309 
 QualifiedExpression { type_mark; aggregate; expression } > 
310 
let type_mark = self#lower_vhdl_name_t type_mark in 
311 
let aggregate = self#list self#vhdl_element_assoc_t aggregate in 
312 
let expression = self#option self#vhdl_expr_t expression in 
313 
QualifiedExpression { type_mark; aggregate; expression } 
314 
 Others > Others 
315  
316 
method vhdl_name_t : vhdl_name_t > vhdl_name_t= 
317 
fun x > 
318 
match x with 
319 
 Simple a > let a = self#string a in Simple a 
320 
 Identifier a > let a = self#string a in Identifier a 
321 
 Selected a > let a = self#list self#lower_vhdl_name_t a in Selected a 
322 
 Index { id; exprs } > 
323 
let id = self#lower_vhdl_name_t id in 
324 
let exprs = self#list self#vhdl_expr_t exprs in 
325 
Index { id; exprs } 
326 
 Slice { id; range } > 
327 
let id = self#lower_vhdl_name_t id in 
328 
let range = self#vhdl_discrete_range_t range in 
329 
Slice { id; range } 
330 
 Attribute { id; designator; expr } > 
331 
let id = self#lower_vhdl_name_t id in 
332 
let designator = self#lower_vhdl_name_t designator in 
333 
let expr = self#vhdl_expr_t expr in 
334 
Attribute { id; designator; expr } 
335 
 Function { id; assoc_list } > 
336 
let id = self#lower_vhdl_name_t id in 
337 
let assoc_list = self#list self#vhdl_assoc_element_t assoc_list 
338 
in 
339 
Function { id; assoc_list } 
340 
 NoName > NoName 
341  
342 
method vhdl_assoc_element_t : 
343 
vhdl_assoc_element_t > vhdl_assoc_element_t= 
344 
fun 
345 
{ formal_name; formal_arg; actual_name; actual_designator; 
346 
actual_expr } 
347 
> 
348 
let formal_name = self#option self#lower_vhdl_name_t formal_name in 
349 
let formal_arg = self#option self#lower_vhdl_name_t formal_arg in 
350 
let actual_name = self#option self#lower_vhdl_name_t actual_name in 
351 
let actual_designator = 
352 
self#option self#lower_vhdl_name_t actual_designator in 
353 
let actual_expr = self#option self#vhdl_expr_t actual_expr in 
354 
{ 
355 
formal_name; 
356 
formal_arg; 
357 
actual_name; 
358 
actual_designator; 
359 
actual_expr 
360 
} 
361  
362 
method vhdl_element_assoc_t : 
363 
vhdl_element_assoc_t > vhdl_element_assoc_t= 
364 
fun { choices; expr } > 
365 
let choices = self#list self#vhdl_expr_t choices in 
366 
let expr = self#vhdl_expr_t expr in { choices; expr } 
367  
368 
method vhdl_array_attributes_t : 
369 
vhdl_array_attributes_t > vhdl_array_attributes_t= 
370 
fun x > 
371 
match x with 
372 
 AAttInt { id; arg } > 
373 
let id = self#string id in 
374 
let arg = self#int arg in AAttInt { id; arg } 
375 
 AAttAscending > AAttAscending 
376  
377 
method vhdl_signal_attributes_t : 
378 
vhdl_signal_attributes_t > vhdl_signal_attributes_t= 
379 
fun x > match x with  SigAtt a > let a = self#string a in SigAtt a 
380  
381 
method vhdl_string_attributes_t : 
382 
vhdl_string_attributes_t > vhdl_string_attributes_t= 
383 
fun x > 
384 
match x with  StringAtt a > let a = self#string a in StringAtt a 
385  
386 
method vhdl_suffix_selection_t : vhdl_suffix_selection_t > vhdl_suffix_selection_t= 
387 
fun x > 
388 
match x with 
389 
 Idx a > let a = self#int a in Idx a 
390 
 SuffixRange (a,b) > 
391 
let a = self#int a in let b = self#int b in SuffixRange (a, b) 
392  
393 
method vhdl_type_attributes_t : 
394 
'a . 
395 
('a > 'a) > 'a vhdl_type_attributes_t > 'a vhdl_type_attributes_t= 
396 
fun _basetype > 
397 
fun x > 
398 
match x with 
399 
 TAttNoArg { id } > let id = self#string id in TAttNoArg { id } 
400 
 TAttIntArg { id; arg } > 
401 
let id = self#string id in 
402 
let arg = self#int arg in TAttIntArg { id; arg } 
403 
 TAttValArg { id; arg } > 
404 
let id = self#string id in 
405 
let arg = _basetype arg in TAttValArg { id; arg } 
406 
 TAttStringArg { id; arg } > 
407 
let id = self#string id in 
408 
let arg = self#string arg in TAttStringArg { id; arg } 
409  
410 
method vhdl_parameter_t : vhdl_parameter_t > vhdl_parameter_t= 
411 
fun { names; mode; typ; init_val } > 
412 
let names = self#list self#lower_vhdl_name_t names in 
413 
let mode = self#list self#string mode in 
414 
let typ = self#vhdl_subtype_indication_t typ in 
415 
let init_val = self#option self#vhdl_cst_val_t init_val in 
416 
{ names; mode; typ; init_val } 
417  
418 
method vhdl_subprogram_spec_t : 
419 
vhdl_subprogram_spec_t > vhdl_subprogram_spec_t= 
420 
fun { name; subprogram_type; typeMark; parameters; isPure } > 
421 
let name = self#string name in 
422 
let subprogram_type = self#string subprogram_type in 
423 
let typeMark = self#lower_vhdl_name_t typeMark in 
424 
let parameters = self#list self#vhdl_parameter_t parameters in 
425 
let isPure = self#bool isPure in 
426 
{ name; subprogram_type; typeMark; parameters; isPure } 
427  
428 
method vhdl_sequential_stmt_t : 
429 
vhdl_sequential_stmt_t > vhdl_sequential_stmt_t= 
430 
fun x > 
431 
match x with 
432 
 VarAssign { label; lhs; rhs } > 
433 
let label = self#lower_vhdl_name_t label in 
434 
let lhs = self#lower_vhdl_name_t lhs in 
435 
let rhs = self#vhdl_expr_t rhs in VarAssign { label; lhs; rhs } 
436 
 SigSeqAssign { label; lhs; rhs } > 
437 
let label = self#lower_vhdl_name_t label in 
438 
let lhs = self#lower_vhdl_name_t lhs in 
439 
let rhs = self#list self#vhdl_waveform_element_t rhs in 
440 
SigSeqAssign { label; lhs; rhs } 
441 
 If { label; if_cases; default } > 
442 
let label = self#lower_vhdl_name_t label in 
443 
let if_cases = self#list self#vhdl_if_case_t if_cases in 
444 
let default = self#list self#vhdl_sequential_stmt_t default in 
445 
If { label; if_cases; default } 
446 
 Case { label; guard; branches } > 
447 
let label = self#lower_vhdl_name_t label in 
448 
let guard = self#vhdl_expr_t guard in 
449 
let branches = self#list self#vhdl_case_item_t branches in 
450 
Case { label; guard; branches } 
451 
 Exit { label; loop_label; condition } > 
452 
let label = self#lower_vhdl_name_t label in 
453 
let loop_label = self#option self#string loop_label in 
454 
let condition = self#option self#vhdl_expr_t condition in 
455 
Exit { label; loop_label; condition } 
456 
 Assert { label; cond; report; severity } > 
457 
let label = self#lower_vhdl_name_t label in 
458 
let cond = self#vhdl_expr_t cond in 
459 
let report = self#vhdl_expr_t report in 
460 
let severity = self#vhdl_expr_t severity in 
461 
Assert { label; cond; report; severity } 
462 
 ProcedureCall { label; name; assocs } > 
463 
let label = self#lower_vhdl_name_t label in 
464 
let name = self#lower_vhdl_name_t name in 
465 
let assocs = self#list self#vhdl_assoc_element_t assocs in 
466 
ProcedureCall { label; name; assocs } 
467 
 Wait > Wait 
468 
 Null { label } > 
469 
let label = self#lower_vhdl_name_t label in Null { label } 
470 
 Return { label; expr } > 
471 
let label = self#option self#lower_vhdl_name_t label in 
472 
let expr = self#option self#vhdl_expr_t expr in 
473 
Return { label; expr } 
474  
475 
method vhdl_if_case_t : vhdl_if_case_t > vhdl_if_case_t= 
476 
fun { if_cond; if_block } > 
477 
let if_cond = self#vhdl_expr_t if_cond in 
478 
let if_block = self#list self#vhdl_sequential_stmt_t if_block in 
479 
{ if_cond; if_block } 
480  
481 
method vhdl_case_item_t : vhdl_case_item_t > vhdl_case_item_t= 
482 
fun { when_cond; when_stmt } > 
483 
let when_cond = self#list self#vhdl_expr_t when_cond in 
484 
let when_stmt = self#list self#vhdl_sequential_stmt_t when_stmt in 
485 
{ when_cond; when_stmt } 
486  
487 
method vhdl_declaration_t : vhdl_declaration_t > vhdl_declaration_t= 
488 
fun x > 
489 
match x with 
490 
 VarDecl { names; typ; init_val } > 
491 
let names = self#list self#lower_vhdl_name_t names in 
492 
let typ = self#vhdl_subtype_indication_t typ in 
493 
let init_val = self#vhdl_expr_t init_val in 
494 
VarDecl { names; typ; init_val } 
495 
 CstDecl { names; typ; init_val } > 
496 
let names = self#list self#lower_vhdl_name_t names in 
497 
let typ = self#vhdl_subtype_indication_t typ in 
498 
let init_val = self#vhdl_expr_t init_val in 
499 
CstDecl { names; typ; init_val } 
500 
 SigDecl { names; typ; init_val } > 
501 
let names = self#list self#lower_vhdl_name_t names in 
502 
let typ = self#vhdl_subtype_indication_t typ in 
503 
let init_val = self#vhdl_expr_t init_val in 
504 
SigDecl { names; typ; init_val } 
505 
 ComponentDecl { name; generics; ports } > 
506 
let name = self#lower_vhdl_name_t name in 
507 
let generics = self#list self#vhdl_port_t generics in 
508 
let ports = self#list self#vhdl_port_t ports in 
509 
ComponentDecl { name; generics; ports } 
510 
 Subprogram { spec; decl_part; stmts } > 
511 
let spec = self#vhdl_subprogram_spec_t spec in 
512 
let decl_part = self#list self#vhdl_declaration_t decl_part in 
513 
let stmts = self#list self#vhdl_sequential_stmt_t stmts in 
514 
Subprogram { spec; decl_part; stmts } 
515  
516 
method vhdl_declarative_item_t : 
517 
vhdl_declarative_item_t > vhdl_declarative_item_t= 
518 
fun { use_clause; declaration; definition } > 
519 
let use_clause = self#option self#vhdl_load_t use_clause in 
520 
let declaration = self#option self#vhdl_declaration_t declaration in 
521 
let definition = self#option self#vhdl_definition_t definition in 
522 
{ use_clause; declaration; definition } 
523  
524 
method vhdl_waveform_element_t : 
525 
vhdl_waveform_element_t > vhdl_waveform_element_t= 
526 
fun { value; delay } > 
527 
let value = self#option self#vhdl_expr_t value in 
528 
let delay = self#option self#vhdl_expr_t delay in { value; delay } 
529  
530 
method vhdl_signal_condition_t : 
531 
vhdl_signal_condition_t > vhdl_signal_condition_t= 
532 
fun { expr; cond } > 
533 
let expr = self#list self#vhdl_waveform_element_t expr in 
534 
let cond = self#option self#vhdl_expr_t cond in { expr; cond } 
535  
536 
method vhdl_signal_selection_t : 
537 
vhdl_signal_selection_t > vhdl_signal_selection_t= 
538 
fun { expr; when_sel } > 
539 
let expr = self#list self#vhdl_waveform_element_t expr in 
540 
let when_sel = self#list self#vhdl_expr_t when_sel in 
541 
{ expr; when_sel } 
542  
543 
method vhdl_conditional_signal_t : 
544 
vhdl_conditional_signal_t > vhdl_conditional_signal_t= 
545 
fun { postponed; label; lhs; rhs; delay } > 
546 
let postponed = self#bool postponed in 
547 
let label = self#lower_vhdl_name_t label in 
548 
let lhs = self#lower_vhdl_name_t lhs in 
549 
let rhs = self#list self#vhdl_signal_condition_t rhs in 
550 
let delay = self#vhdl_expr_t delay in 
551 
{ postponed; label; lhs; rhs; delay } 
552  
553 
method vhdl_process_t : vhdl_process_t > vhdl_process_t= 
554 
fun { id; declarations; active_sigs; body } > 
555 
let id = self#lower_vhdl_name_t id in 
556 
let declarations = self#list self#vhdl_declarative_item_t declarations in 
557 
let active_sigs = self#list self#lower_vhdl_name_t active_sigs in 
558 
let body = self#list self#vhdl_sequential_stmt_t body in 
559 
{ id; declarations; active_sigs; body } 
560  
561 
method vhdl_selected_signal_t : 
562 
vhdl_selected_signal_t > vhdl_selected_signal_t= 
563 
fun { postponed; label; lhs; sel; branches; delay } > 
564 
let postponed = self#bool postponed in 
565 
let label = self#lower_vhdl_name_t label in 
566 
let lhs = self#lower_vhdl_name_t lhs in 
567 
let sel = self#vhdl_expr_t sel in 
568 
let branches = self#list self#vhdl_signal_selection_t branches in 
569 
let delay = self#option self#vhdl_expr_t delay in 
570 
{ postponed; label; lhs; sel; branches; delay } 
571  
572 
method vhdl_port_mode_t : vhdl_port_mode_t > vhdl_port_mode_t= 
573 
fun x > x 
574  
575 
method vhdl_component_instantiation_t : 
576 
vhdl_component_instantiation_t > mini_vhdl_component_instantiation_t= 
577 
fun { name; inst_unit; inst_unit_type; archi_name; generic_map; port_map } > 
578 
let name = self#lower_vhdl_name_t name in 
579 
let archi_name = self#option self#lower_vhdl_name_t archi_name in 
580 
let inst_unit = self#lower_vhdl_name_t inst_unit in 
581 
let db_tuple = match archi_name with 
582 
 None > failwith ("Component [" ^ self#to_string_vhdl_name_t name ^ "] is not an entity") 
583 
 Some a > self#get_tuple_from_archi_and_entity_name (a, inst_unit) in (* Get corresponding tuple in db *) 
584 
let archi = db_tuple.architecture in 
585 
let entity = db_tuple.entity in 
586 
let generic_map = self#list self#vhdl_assoc_element_t generic_map in 
587 
let port_map = self#list self#vhdl_assoc_element_t port_map in 
588 
{ name; archi; entity; generic_map; port_map } 
589  
590 
method vhdl_concurrent_stmt_t : 
591 
vhdl_concurrent_stmt_t > mini_vhdl_concurrent_stmt_t= 
592 
fun x > 
593 
match x with 
594 
 SigAssign a > let a = self#vhdl_conditional_signal_t a in SigAssign a 
595 
 Process a > let a = self#vhdl_process_t a in Process a 
596 
 SelectedSig a > let a = self#vhdl_selected_signal_t a in SelectedSig a 
597 
 ComponentInst a > let a = self#vhdl_component_instantiation_t a in ComponentInst a 
598  
599 
method vhdl_port_t : vhdl_port_t > vhdl_port_t= 
600 
fun { names; mode; typ; expr } > 
601 
let names = self#list self#lower_vhdl_name_t names in 
602 
let mode = self#vhdl_port_mode_t mode in 
603 
let typ = self#vhdl_subtype_indication_t typ in 
604 
let expr = self#vhdl_expr_t expr in { names; mode; typ; expr } 
605  
606 
method vhdl_entity_t : vhdl_entity_t > unit = 
607 
fun { name; generics; ports; declaration; stmts } > () 
608  
609 
method vhdl_package_t : (vhdl_load_t list * vhdl_package_t) > vhdl_package_t= 
610 
fun ( ctxs, {name; shared_defs; shared_decls; shared_uses }) > 
611 
let name = self#lower_vhdl_name_t name in 
612 
let shared_defs = self#list self#vhdl_definition_t shared_defs in 
613 
let shared_decls = self#list self#vhdl_declaration_t shared_decls in 
614 
let shared_uses = self#list self#vhdl_load_t shared_uses @ ctxs in 
615 
{ name; shared_defs; shared_decls; shared_uses } 
616  
617 
method vhdl_load_t : vhdl_load_t > vhdl_load_t= 
618 
fun x > 
619 
match x with 
620 
 Library a > let a = self#list self#lower_vhdl_name_t a in Library a 
621 
 Use a > let a = self#list self#lower_vhdl_name_t a in Use a 
622  
623 
method vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list * 
624 
(vhdl_load_t list * vhdl_entity_t) list * 
625 
(vhdl_load_t list * vhdl_configuration_t) list * 
626 
(vhdl_load_t list * vhdl_architecture_t)) > mini_vhdl_component_t= 
627 
fun ( packs_pairs, ents_pairs, confs_pairs, (arch_ctx, arch) ) > 
628 
let names = arch.name::(arch.entity::[]) in 
629 
let (ref_ent_ctx,ref_ent) = self#filter_entity (ents_pairs, arch.entity) in 
630 
self#db_add_tuple {entity=ref_ent; architecture=arch; architecture_signals_names=[]; contexts=ref_ent_ctx@arch_ctx}; 
631 
let contexts = 
632 
ref_ent_ctx @ (* Referenced entity context elements *) 
633 
arch_ctx @ (* Architecture context elements *) 
634 
self#declarative_items_uses ref_ent.declaration @ (* Referenced entity inner context elements *) 
635 
self#declarative_items_uses arch.declarations in (* Architecture inner context elements *) 
636 
let declarations = 
637 
self#declarative_items_declarations ref_ent.declaration @ (* Referenced entity inner declarations *) 
638 
self#declarative_items_declarations arch.declarations in (* Architecture inner declarations *) 
639 
let definitions = 
640 
self#declarative_items_definitions ref_ent.declaration @ (* Referenced entity inner definitions *) 
641 
self#declarative_items_definitions arch.declarations in (* Architecture inner definitions *) 
642 
let body = 
643 
List.map self#vhdl_concurrent_stmt_t ref_ent.stmts @ (* Referenced entity concurrent statement *) 
644 
List.map self#vhdl_concurrent_stmt_t arch.body in (* Architecture concurrent statements *) 
645 
let generics = ref_ent.generics in (* Referenced entity generics *) 
646 
let ports = ref_ent.ports in (* Referenced entity ports *) 
647 
(* Add declarations names in db *) 
648 
{ names; generics=generics; ports=ports; contexts=contexts; declarations=declarations; definitions=definitions; body=body } 
649  
650 
method declarative_items_declarations : vhdl_declarative_item_t list > vhdl_declaration_t list = 
651 
fun x > 
652 
let rec map_decls l = match l with 
653 
 {use_clause=_; declaration=Some a;definition=_}::tl > a::map_decls tl 
654 
 _::tl > map_decls tl 
655 
 [] > [] in map_decls x 
656  
657 
method declarative_items_definitions : vhdl_declarative_item_t list > vhdl_definition_t list = 
658 
fun x > 
659 
let rec map_decls l = match l with 
660 
 {use_clause=_; declaration=_;definition=Some a}::tl > a::map_decls tl 
661 
 _::tl > map_decls tl 
662 
 [] > [] in map_decls x 
663  
664 
method declarative_items_uses : vhdl_declarative_item_t list > vhdl_load_t list = 
665 
fun x > 
666 
let rec map_decls l = match l with 
667 
 {use_clause=Some a; declaration=_;definition=_}::tl > a::map_decls tl 
668 
 _::tl > map_decls tl 
669 
 [] > [] in map_decls x 
670  
671 
method filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) > 
672 
(vhdl_load_t list * vhdl_entity_t) = 
673 
fun ( entities_pair, filter_name ) > 
674 
let rec filter ep n = match ep with 
675 
 [] > failwith ("Impossible to find an entity with name [" ^ self#to_string_vhdl_name_t filter_name ^ "]") 
676 
 (c,{name; generics; ports; declaration;stmts})::tl > 
677 
if (name = n) then 
678 
List.hd ep 
679 
else filter (List.tl ep) n in 
680 
filter entities_pair filter_name 
681  
682 
method vhdl_configuration_t : 
683 
vhdl_configuration_t > unit= self#unit 
684  
685 
method vhdl_library_unit_t : vhdl_library_unit_t > unit= 
686 
fun x > () 
687  
688 
method vhdl_design_unit_t : vhdl_design_unit_t > unit= 
689 
fun { contexts; library } > () 
690  
691 
method vhdl_design_file_t : vhdl_design_file_t > mini_vhdl_design_file_t= 
692 
fun { design_units } > 
693 
let rec inline_df l packs ents archs confs = match l with 
694 
 [] > (List.rev packs, List.rev ents, List.rev archs, List.rev confs) 
695 
 {contexts = c; library = lib}::tl > match lib with 
696 
 Package p > inline_df tl ((c,p)::packs) ents archs confs 
697 
 Entities e > inline_df tl packs ((c,e)::ents) archs confs 
698 
 Architecture a > inline_df tl packs ents ((c,a)::archs) confs 
699 
 Configuration conf > inline_df tl packs ents archs ((c,conf)::confs) in 
700 
let (p,e,a,con) = inline_df design_units [] [] [] [] in 
701 
let app x = self#vhdl_architecture_t (p,e,con,x) in 
702 
let components = List.map app a in 
703 
let packages = List.map self#vhdl_package_t p in 
704 
{ components; packages } 
705  
706 
end 