1

open Vhdl_ast

2

open Mini_vhdl_ast

3

open Mini_vhdl_utils

4

open Vhdl_ast_fold_sensitivity

5


6

type db_tuple_t =

7

{

8

mutable entity: vhdl_entity_t;

9

mutable architecture: vhdl_architecture_t;

10

mutable architecture_signals: mini_vhdl_declaration_t list;

11

mutable architecture_ports: vhdl_port_t list;

12

mutable architecture_generics: vhdl_port_t list;

13

mutable assigned_signals_names: vhdl_name_t list;

14

mutable functions: (vhdl_name_t * vhdl_parameter_t list * vhdl_name_t) list;

15

mutable memories: vhdl_name_t list;

16

mutable contexts: vhdl_load_t list;

17

}

18


19

type assoc_element_mode_t = Positional  Named  Named_arg

20


21

let get_sensitivity_list = object (self)

22

inherit ['acc] fold_sensitivity as super

23

end

24


25

let _ = fun (_ : vhdl_cst_val_t) > ()

26

let _ = fun (_ : vhdl_type_t) > ()

27

let _ = fun (_ : vhdl_element_declaration_t) > ()

28

let _ = fun (_ : vhdl_subtype_indication_t) > ()

29

let _ = fun (_ : vhdl_discrete_range_t) > ()

30

let _ = fun (_ : vhdl_constraint_t) > ()

31

let _ = fun (_ : vhdl_definition_t) > ()

32

let _ = fun (_ : vhdl_expr_t) > ()

33

let _ = fun (_ : vhdl_name_t) > ()

34

let _ = fun (_ : vhdl_assoc_element_t) > ()

35

let _ = fun (_ : vhdl_element_assoc_t) > ()

36

let _ = fun (_ : vhdl_signal_attributes_t) > ()

37

let _ = fun (_ : vhdl_suffix_selection_t) > ()

38

let _ = fun (_ : vhdl_parameter_t) > ()

39

let _ = fun (_ : vhdl_subprogram_spec_t) > ()

40

let _ = fun (_ : vhdl_sequential_stmt_t) > ()

41

let _ = fun (_ : vhdl_if_case_t) > ()

42

let _ = fun (_ : vhdl_case_item_t) > ()

43

let _ = fun (_ : vhdl_declaration_t) > ()

44

let _ = fun (_ : vhdl_signal_selection_t) > ()

45

let _ = fun (_ : vhdl_declarative_item_t) > ()

46

let _ = fun (_ : vhdl_waveform_element_t) > ()

47

let _ = fun (_ : vhdl_signal_condition_t) > ()

48

let _ = fun (_ : vhdl_conditional_signal_t) > ()

49

let _ = fun (_ : vhdl_process_t) > ()

50

let _ = fun (_ : vhdl_selected_signal_t) > ()

51

let _ = fun (_ : vhdl_port_mode_t) > ()

52

let _ = fun (_ : vhdl_component_instantiation_t) > ()

53

let _ = fun (_ : vhdl_concurrent_stmt_t) > ()

54

let _ = fun (_ : vhdl_port_t) > ()

55

let _ = fun (_ : vhdl_entity_t) > ()

56

let _ = fun (_ : vhdl_package_t) > ()

57

let _ = fun (_ : vhdl_load_t) > ()

58

let _ = fun (_ : vhdl_architecture_t) > ()

59

let _ = fun (_ : vhdl_configuration_t) > ()

60

let _ = fun (_ : vhdl_library_unit_t) > ()

61

let _ = fun (_ : vhdl_design_unit_t) > ()

62

let _ = fun (_ : vhdl_design_file_t) > ()

63


64

class virtual vhdl_2_mini_vhdl_map =

65

object (self)

66

method virtual string : string > string

67

method virtual list : 'a . ('a > 'a) > 'a list > 'a list

68

method virtual unit : unit > unit

69

method virtual bool : bool > bool

70

method virtual option : 'a . ('a > 'a) > 'a option > 'a option

71

method virtual int : int > int

72

method virtual vhdl_name_t : vhdl_name_t > vhdl_name_t

73

method virtual vhdl_definition_t : vhdl_definition_t > vhdl_definition_t

74

method virtual vhdl_port_t : vhdl_port_t > vhdl_port_t

75

method virtual vhdl_expr_t : vhdl_expr_t > vhdl_expr_t

76

method virtual vhdl_port_mode_t : vhdl_port_mode_t > vhdl_port_mode_t

77

method virtual vhdl_element_declaration_t : vhdl_element_declaration_t > vhdl_element_declaration_t

78

method virtual vhdl_subtype_indication_t : vhdl_subtype_indication_t > vhdl_subtype_indication_t

79

method virtual vhdl_conditional_signal_t : vhdl_conditional_signal_t > vhdl_conditional_signal_t

80

method virtual vhdl_selected_signal_t : vhdl_selected_signal_t > vhdl_selected_signal_t

81

method virtual vhdl_signal_selection_t : vhdl_signal_selection_t > vhdl_signal_selection_t

82

method virtual vhdl_suffix_selection_t : vhdl_suffix_selection_t > vhdl_suffix_selection_t

83

method virtual vhdl_waveform_element_t : vhdl_waveform_element_t > vhdl_waveform_element_t

84

method virtual vhdl_signal_condition_t : vhdl_signal_condition_t > vhdl_signal_condition_t

85

method virtual vhdl_cst_val_t : vhdl_cst_val_t > vhdl_cst_val_t

86

method virtual vhdl_subprogram_spec_t : vhdl_subprogram_spec_t > vhdl_subprogram_spec_t

87

method virtual vhdl_discrete_range_t : vhdl_discrete_range_t > vhdl_discrete_range_t

88

method virtual vhdl_parameter_t : vhdl_parameter_t > vhdl_parameter_t

89

method virtual vhdl_declaration_t : vhdl_declaration_t > mini_vhdl_declaration_t

90

method virtual vhdl_configuration_t : vhdl_configuration_t > unit

91

method virtual vhdl_entity_t : vhdl_entity_t > unit

92

method virtual vhdl_library_unit_t : vhdl_library_unit_t > unit

93

method virtual vhdl_load_t : vhdl_load_t > vhdl_load_t

94

method virtual vhdl_design_unit_t : vhdl_design_unit_t > unit

95


96

method virtual vhdl_declarative_item_t : vhdl_declarative_item_t > mini_vhdl_declarative_item_t

97

method virtual vhdl_process_t : vhdl_process_t > mini_vhdl_process_t

98

method virtual vhdl_concurrent_stmt_t : vhdl_concurrent_stmt_t > mini_vhdl_concurrent_stmt_t

99

method virtual vhdl_sequential_stmt_t : vhdl_sequential_stmt_t > mini_vhdl_sequential_stmt_t

100

method virtual vhdl_design_file_t : vhdl_design_file_t > mini_vhdl_design_file_t

101


102

method virtual vhdl_package_t : (vhdl_load_t list * vhdl_package_t) > mini_vhdl_package_t

103

method virtual vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list *

104

(vhdl_load_t list * vhdl_entity_t) list *

105

(vhdl_load_t list * vhdl_configuration_t) list *

106

(vhdl_load_t list * vhdl_architecture_t)) > mini_vhdl_component_t

107

method virtual vhdl_component_instantiation_t : vhdl_component_instantiation_t > mini_vhdl_component_instantiation_t

108

method virtual declarative_items_declarations : vhdl_declarative_item_t list > vhdl_declaration_t list

109

method virtual declarative_items_definitions : vhdl_declarative_item_t list > vhdl_definition_t list

110

method virtual declarative_items_uses : vhdl_declarative_item_t list > vhdl_load_t list

111

method virtual filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) >

112

(vhdl_load_t list * vhdl_entity_t)

113


114

(*************************

115

* Begin vhdl_name_t helpers

116

*)

117

method simplify_name_t : vhdl_name_t > vhdl_name_t=

118

fun n >

119

let lower a = String.lowercase_ascii a in

120

let n = self#lower_vhdl_name_t n in

121

match n with

122

 Selected (a::[]) > self#simplify_name_t a

123

 Selected (NoName::tl) > self#simplify_name_t (Selected tl)

124

 Selected ((Simple (s))::tl) > if (lower s = "work")

125

then self#simplify_name_t (Selected tl)

126

else n

127

 Selected ((Identifier (s))::tl) > if (lower s = "work")

128

then self#simplify_name_t (Selected tl)

129

else n

130

 _ > n

131


132

method lower_vhdl_name_t : vhdl_name_t > vhdl_name_t=

133

fun x >

134

let lower a = String.lowercase_ascii a in

135

match x with

136

 Simple a > Simple (lower a)

137

 Identifier a > Identifier (lower a)

138

 Selected a > Selected (self#list self#lower_vhdl_name_t a)

139

 Index { id; exprs } >

140

let id = self#lower_vhdl_name_t id in

141

let exprs = self#list self#vhdl_expr_t exprs in

142

Index { id; exprs }

143

 Slice { id; range } >

144

let id = self#lower_vhdl_name_t id in

145

let range = self#vhdl_discrete_range_t range in

146

Slice { id; range }

147

 Attribute { id; designator; expr } >

148

let id = self#lower_vhdl_name_t id in

149

let designator = self#lower_vhdl_name_t designator in

150

let expr = self#vhdl_expr_t expr in

151

Attribute { id; designator; expr }

152

 Function { id; assoc_list } >

153

let id = self#lower_vhdl_name_t id in

154

let assoc_list = self#list self#vhdl_assoc_element_t assoc_list in

155

Function { id; assoc_list }

156

 NoName > NoName

157

 Open > Open

158


159

method to_string_vhdl_name_t : vhdl_name_t > string=

160

fun x >

161

match x with

162

 Simple a > a

163

 Identifier a > a

164

 Selected a > String.concat "." (List.map self#to_string_vhdl_name_t a)

165

 Index { id; exprs } > self#to_string_vhdl_name_t id

166

 Slice { id; range } > self#to_string_vhdl_name_t id

167

 Attribute { id; designator; expr } > self#to_string_vhdl_name_t id

168

 Function { id; assoc_list } > self#to_string_vhdl_name_t id

169

 NoName > "NoName"

170

 Open > "Open"

171


172

method flatten_vhdl_name_t : vhdl_name_t > vhdl_name_t=

173

fun x >

174

match x with

175

 Simple a > Simple (a)

176

 Identifier a > Simple (a)

177

 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)))]))

178

 _ > failwith ("Impossible to flatten name value [" ^ self#to_string_vhdl_name_t x ^ "]")

179


180

method postfix_flatten_vhdl_name_t : vhdl_name_t > string > vhdl_name_t=

181

fun x >

182

fun postfix >

183

let flattened = self#flatten_vhdl_name_t x in

184

match flattened with

185

 Simple a > Simple (a ^ postfix)

186

 Identifier a > Identifier (a ^ postfix)

187

 _ > failwith ("Impossible to postfix name value [" ^ self#to_string_vhdl_name_t x ^ "]")

188


189


190

(*************************

191

* End vhdl_name_t helpers

192

*)

193


194

(*************************

195

* Begin DB helpers

196

*)

197

val mutable db : db_tuple_t list = []

198

val mutable db_current : db_tuple_t = {

199

entity = { e_name = NoName; generics = []; ports = []; e_declaration = []; stmts = [] };

200

architecture = { a_name = NoName; entity = NoName; a_declarations = []; a_body = [] };

201

architecture_signals = [];

202

architecture_ports = [];

203

architecture_generics = [];

204

assigned_signals_names = [];

205

functions = [];

206

memories = [];

207

contexts = [];

208

}

209


210

method get_db : db_tuple_t list = db

211


212

method db_get_current : db_tuple_t = db_current

213

method db_set_current : db_tuple_t > unit=

214

fun x > db_current < x

215


216

method db_add_tuple : db_tuple_t > unit=

217

fun x > db < x::db

218


219

method db_get : vhdl_architecture_t > (vhdl_entity_t * vhdl_load_t list)=

220

fun x >

221

let rec find a dbl =

222

match dbl with

223

 [] > failwith ("No matching tuple in DB for architecture [" ^ self#to_string_vhdl_name_t x.a_name ^ "]")

224

 e::tl > if (e.architecture = a) then (e.entity, e.contexts) else find a tl in find x db

225


226

method get_tuple_from_archi_and_entity_name : (vhdl_name_t * vhdl_name_t) > db_tuple_t=

227

fun (a_name,e_name) >

228

let a_name = self#simplify_name_t a_name in

229

let e_name = self#simplify_name_t e_name in

230

let rec find (a_name,e_name) dbl =

231

match dbl with

232

 [] > failwith ("No matching tuple in DB for architecture [" ^ self#to_string_vhdl_name_t a_name ^

233

"] and entity [" ^ self#to_string_vhdl_name_t e_name ^ "]")

234

 e::tl >

235

let inner_e_arch_name = self#simplify_name_t e.architecture.a_name in

236

let inner_e_ent_name = self#simplify_name_t e.entity.e_name in

237

if ((inner_e_arch_name = a_name) && (inner_e_ent_name = e_name))

238

then e

239

else find (a_name,e_name) tl in

240

find (a_name,e_name) db

241


242

method filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) >

243

(vhdl_load_t list * vhdl_entity_t) =

244

fun ( entities_pair, filter_name ) >

245

let rec filter ep n = match ep with

246

 [] > failwith ("Impossible to find an entity with name [" ^ self#to_string_vhdl_name_t filter_name ^ "]")

247

 (c,{e_name; generics; ports; e_declaration; stmts})::tl >

248

if (e_name = n) then

249

List.hd ep

250

else filter (List.tl ep) n in

251

filter entities_pair filter_name

252

(*******************

253

* End DB helpers

254

*)

255


256

(*******************

257

* Begin declarative_item_t projections

258

*)

259

method declarative_items_declarations : vhdl_declarative_item_t list > vhdl_declaration_t list =

260

fun x >

261

match x with

262

 {use_clause=_; di_declaration=Some a; di_definition=_}::tl > a::(self#declarative_items_declarations tl)

263

 _::tl > self#declarative_items_declarations tl

264

 [] > []

265


266

method declarative_items_definitions : vhdl_declarative_item_t list > vhdl_definition_t list =

267

fun x >

268

match x with

269

 {use_clause=_; di_declaration=_; di_definition=Some a}::tl > a::(self#declarative_items_definitions tl)

270

 _::tl > self#declarative_items_definitions tl

271

 [] > []

272


273

method declarative_items_uses : vhdl_declarative_item_t list > vhdl_load_t list =

274

fun x >

275

match x with

276

 {use_clause=Some a; di_declaration=_; di_definition=_}::tl > a::(self#declarative_items_uses tl)

277

 _::tl > self#declarative_items_uses tl

278

 [] > []

279

(******************

280

* End declarative_item_t projections

281

*)

282


283

(*****************

284

* Begin names_t extraction (assigned signals)

285

*)

286

method mini_vhdl_concurrent_stmt_t_assigned_signals_names : mini_vhdl_concurrent_stmt_t > vhdl_name_t list=

287

fun x >

288

match x with

289

 Process a > List.sort_uniq compare (

290

List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names a.p_body)

291

)

292

 ComponentInst a >

293

let out_ports_positions = get_ports_pos a.entity.ports OutPort 0 in

294

let inout_ports_positions = get_ports_pos a.entity.ports InoutPort 0 in

295

let assigned_out_ports_names = List.map (fun x > x.actual_designator) a.port_map in

296

let out_ports_pos = out_ports_positions@inout_ports_positions in

297

List.map (List.nth (remove_opt assigned_out_ports_names)) out_ports_pos

298


299

method mini_vhdl_sequential_stmt_t_assigned_signals_names :

300

mini_vhdl_sequential_stmt_t > vhdl_name_t list=

301

fun x >

302

match x with

303

 VarAssign { label; lhs; rhs } > []

304

 SigSeqAssign { label; lhs; rhs } > [lhs]

305

 SigCondAssign { label; lhs; rhs; delay} > [lhs]

306

 SigSelectAssign { label; lhs; sel; branches; delay } > [lhs]

307

 If { label; if_cases; default } >

308

let if_cases_stmts = List.flatten (List.map (fun x > x.if_block) if_cases) in

309

List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names (if_cases_stmts@default))

310

 Case { label; guard; branches } >

311

let case_branches_stmts = List.flatten (List.map (fun x > x.when_stmt) branches) in

312

List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names case_branches_stmts)

313

 ProcedureCall { label; name; assocs } > [] (* TODO: resolve this *)

314

 _ > []

315


316

(****************

317

*End names_t extraction

318

*)

319


320

(*****************

321

* Begin Implicit memories explicitation

322

*)

323


324

method mini_vhdl_concurrent_stmt_t_memories : vhdl_name_t list > mini_vhdl_concurrent_stmt_t > vhdl_name_t list=

325

fun assigned_signals > fun x >

326

match x with

327

 Process a > List.flatten (List.map (self#memories assigned_signals []) a.p_body)

328

 ComponentInst a > [] (* Nothing to be reported here as memories are checked for each component *)

329


330

method memories: vhdl_name_t list > vhdl_name_t list > mini_vhdl_sequential_stmt_t > vhdl_name_t list=

331

fun assigned_signals > fun mems > fun x >

332

match x with

333

 If { label; if_cases; default } >

334

let if_cases_stmts = List.map (fun x > x.if_block) if_cases in

335

let if_cases_assigned_signals =

336

List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names (List.flatten (if_cases_stmts@[default])) in

337

let if_cases_memories = List.flatten (List.map (fun x > List.flatten (List.map (self#memories assigned_signals []) x)) (if_cases_stmts@[default])) in

338

let mems = if_cases_memories@mems in

339


340

(match default with

341

 [] > (List.flatten if_cases_assigned_signals)@mems

342

 _ > mems)

343

 Case { label; guard; branches } >

344

let case_branches_stmts = List.map (fun x > x.when_stmt) branches in

345

(* let case_assigned_signals = List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names (List.flatten (case_branches_stmts)) in *)

346

let cases_memories = List.flatten (List.map (fun x > List.flatten (List.map (self#memories assigned_signals []) x)) (case_branches_stmts)) in

347

cases_memories@mems

348

 _ > mems

349


350

(****************

351

*End memories explicitation

352

*)

353


354

(****************

355

* Begin Association element resolution

356

*)

357


358

method vhdl_assoc_element_t_mode : vhdl_assoc_element_t > assoc_element_mode_t=

359

fun { formal_name; formal_arg; actual_name; actual_designator; actual_expr } >

360

match (formal_name, formal_arg) with

361

 (None, None) > Positional

362

 (Some NoName, Some NoName) > Positional

363

 (_, None) > Named

364

 (_, Some NoName) > Named

365

 _ > Named_arg

366


367

method vhdl_assoc_simplify : vhdl_assoc_element_t > vhdl_assoc_element_t=

368

fun elem >

369

let mode = self#vhdl_assoc_element_t_mode elem in

370

match mode with

371

 Positional > elem

372

 Named > {formal_name=None;

373

formal_arg=None;

374

actual_name=elem.actual_name;

375

actual_designator=elem.actual_designator;

376

actual_expr=elem.actual_expr }

377

 Named_arg >

378

match elem.formal_name with

379

 None > failwith "Unreachable error (Named arg assoc_element_t without formal name)  vhdl_assoc_resolve"

380

 Some a > {formal_name=None;

381

formal_arg=None;

382

actual_name= Some (Function {id=a;

383

assoc_list=

384

[{formal_name=None;

385

formal_arg=None;

386

actual_name=elem.actual_name;

387

actual_designator=elem.actual_designator;

388

actual_expr=elem.actual_expr }]});

389

actual_designator=None;

390

actual_expr=None}

391


392

method vhdl_assoc_element_t_resolve : vhdl_assoc_element_t list > vhdl_name_t list > vhdl_assoc_element_t list=

393

fun elements > fun names >

394

let rec index_of e l i =

395

match l with [] > failwith "Unreachable error (Non existing element in self list index_of)  map_ports"

396

 hd::tl > if hd = e then i else index_of e tl (i+1) in

397

let modes = List.map self#vhdl_assoc_element_t_mode elements in

398

let match_assoc_mode a m = match m with

399

 Positional > (index_of a elements 0, a)

400

 Named >

401

(match a.formal_name with

402

 None > failwith "Unreachable error (Named assoc_element_t without formal name)  map_ports"

403

 Some e > (find_vhdl_name_t names e, a))

404

 Named_arg >

405

(match a.formal_arg with

406

 None > failwith "Unreachable error (Named_arg assoc_element_t without formal arg)  map_ports"

407

 Some e > (find_vhdl_name_t names e, a)) in

408

let positioned = List.map2 (match_assoc_mode) elements modes in

409

let compare_index_assoc_pairs a b = compare (fst a) (fst b) in

410

let ordered_elements = List.map snd (List.sort compare_index_assoc_pairs positioned) in

411

List.map self#vhdl_assoc_simplify ordered_elements

412


413

(****************

414

* End Association element resolution

415

*)

416


417

method vhdl_cst_val_t : vhdl_cst_val_t > vhdl_cst_val_t=

418

fun x >

419

match x with

420

 CstInt a > let a = self#int a in CstInt a

421

 CstStdLogic a > let a = self#string a in CstStdLogic a

422

 CstLiteral a > let a = self#string a in CstLiteral a

423


424

method vhdl_type_t : vhdl_type_t > vhdl_type_t=

425

fun x >

426

match x with

427

 Base a > let a = self#string a in Base a

428

 Range (a,b,c) >

429

let a = self#option self#string a in

430

let b = self#int b in let c = self#int c in Range (a, b, c)

431

 Bit_vector (a,b) >

432

let a = self#int a in let b = self#int b in Bit_vector (a, b)

433

 Array { indexes; const; definition } >

434

let indexes = self#list self#lower_vhdl_name_t indexes in

435

let const = self#option self#vhdl_constraint_t const in

436

let definition = self#vhdl_subtype_indication_t definition in

437

Array { indexes; const; definition }

438

 Record a >

439

let a = self#list self#vhdl_element_declaration_t a in Record a

440

 Enumerated a >

441

let a = self#list self#lower_vhdl_name_t a in Enumerated a

442

 Void > Void

443


444

method vhdl_element_declaration_t :

445

vhdl_element_declaration_t > vhdl_element_declaration_t=

446

fun { ed_names; definition } >

447

let ed_names = self#list self#lower_vhdl_name_t ed_names in

448

let definition = self#vhdl_subtype_indication_t definition in

449

{ ed_names; definition }

450


451

method vhdl_subtype_indication_t :

452

vhdl_subtype_indication_t > vhdl_subtype_indication_t=

453

fun { si_name; functionName; const } >

454

let si_name = self#lower_vhdl_name_t si_name in

455

let functionName = self#lower_vhdl_name_t functionName in

456

let const = self#vhdl_constraint_t const in

457

{ si_name; functionName; const }

458


459

method vhdl_discrete_range_t :

460

vhdl_discrete_range_t > vhdl_discrete_range_t=

461

fun x >

462

match x with

463

 SubDiscreteRange a >

464

let a = self#vhdl_subtype_indication_t a in SubDiscreteRange a

465

 NamedRange a > let a = self#lower_vhdl_name_t a in NamedRange a

466

 DirectedRange { direction; from; _to } >

467

let direction = self#string direction in

468

let from = self#vhdl_expr_t from in

469

let _to = self#vhdl_expr_t _to in

470

DirectedRange { direction; from; _to }

471


472

method vhdl_constraint_t : vhdl_constraint_t > vhdl_constraint_t=

473

fun x >

474

match x with

475

 RefConstraint { ref_name } >

476

let ref_name = self#lower_vhdl_name_t ref_name in

477

RefConstraint { ref_name }

478

 RangeConstraint { range } >

479

let range = self#vhdl_discrete_range_t range in

480

RangeConstraint { range }

481

 IndexConstraint { ranges } >

482

let ranges = self#list self#vhdl_discrete_range_t ranges in

483

IndexConstraint { ranges }

484

 ArrayConstraint { ranges; sub } >

485

let ranges = self#list self#vhdl_discrete_range_t ranges in

486

let sub = self#vhdl_constraint_t sub in

487

ArrayConstraint { ranges; sub }

488

 RecordConstraint > RecordConstraint

489

 NoConstraint > NoConstraint

490


491

method vhdl_definition_t : vhdl_definition_t > vhdl_definition_t=

492

fun x >

493

match x with

494

 Type { name; definition } >

495

let name = self#lower_vhdl_name_t name in

496

let definition = self#vhdl_type_t definition in

497

Type { name; definition }

498

 Subtype { name; typ } >

499

let name = self#lower_vhdl_name_t name in

500

let typ = self#vhdl_subtype_indication_t typ in

501

Subtype { name; typ }

502


503

method vhdl_expr_t : vhdl_expr_t > vhdl_expr_t=

504

fun x >

505

match x with

506

 Call a > let a = self#lower_vhdl_name_t a in Call a

507

 Cst { value; unit_name } >

508

let value = self#vhdl_cst_val_t value in

509

let unit_name = self#option self#lower_vhdl_name_t unit_name in

510

Cst { value; unit_name }

511

 Op { id; args } >

512

let id = self#string id in

513

let args = self#list self#vhdl_expr_t args in Op { id; args }

514

 IsNull > IsNull

515

 Time { value; phy_unit } >

516

let value = self#int value in

517

let phy_unit = self#string phy_unit in Time { value; phy_unit }

518

 Sig { name; att } >

519

let name = self#lower_vhdl_name_t name in

520

let att = self#option self#vhdl_signal_attributes_t att in

521

Sig { name; att }

522

 SuffixMod { expr; selection } >

523

let expr = self#vhdl_expr_t expr in

524

let selection = self#vhdl_suffix_selection_t selection in

525

SuffixMod { expr; selection }

526

 Aggregate { elems } >

527

let elems = self#list self#vhdl_element_assoc_t elems in

528

Aggregate { elems }

529

 QualifiedExpression { type_mark; aggregate; expression } >

530

let type_mark = self#lower_vhdl_name_t type_mark in

531

let aggregate = self#list self#vhdl_element_assoc_t aggregate in

532

let expression = self#option self#vhdl_expr_t expression in

533

QualifiedExpression { type_mark; aggregate; expression }

534

 Others > Others

535


536

method vhdl_name_t : vhdl_name_t > vhdl_name_t=

537

fun x >

538

match x with

539

 Simple a > let a = self#string a in Simple a

540

 Identifier a > let a = self#string a in Identifier a

541

 Selected a > let a = self#list self#lower_vhdl_name_t a in Selected a

542

 Index { id; exprs } >

543

let id = self#lower_vhdl_name_t id in

544

let exprs = self#list self#vhdl_expr_t exprs in

545

Index { id; exprs }

546

 Slice { id; range } >

547

let id = self#lower_vhdl_name_t id in

548

let range = self#vhdl_discrete_range_t range in

549

Slice { id; range }

550

 Attribute { id; designator; expr } >

551

let id = self#lower_vhdl_name_t id in

552

let designator = self#lower_vhdl_name_t designator in

553

let expr = self#vhdl_expr_t expr in

554

Attribute { id; designator; expr }

555

 Function { id; assoc_list } >

556

let id = self#lower_vhdl_name_t id in

557

let assoc_list = self#list self#vhdl_assoc_element_t assoc_list in

558

(* TODO: get function declaration and resolve assoc elements *)

559

(* let entity_ports_names = List.flatten (List.map port_t_names_proj entity.ports) in

560

let port_map = self#vhdl_assoc_element_t_resolve port_map entity_ports_names in *)

561

Function { id; assoc_list }

562

 NoName > NoName

563

 Open > Open

564


565

method vhdl_assoc_element_t :

566

vhdl_assoc_element_t > vhdl_assoc_element_t=

567

fun

568

{ formal_name; formal_arg; actual_name; actual_designator;

569

actual_expr }

570

>

571

let formal_name = self#option self#vhdl_name_t formal_name in

572

let formal_arg = self#option self#vhdl_name_t formal_arg in

573

let actual_name = self#option self#vhdl_name_t actual_name in

574

let actual_designator = self#option self#vhdl_name_t actual_designator in

575

let actual_expr = self#option self#vhdl_expr_t actual_expr in

576

{ formal_name; formal_arg; actual_name; actual_designator; actual_expr }

577


578

method vhdl_element_assoc_t :

579

vhdl_element_assoc_t > vhdl_element_assoc_t=

580

fun { choices; expr } >

581

let choices = self#list self#vhdl_expr_t choices in

582

let expr = self#vhdl_expr_t expr in { choices; expr }

583


584

method vhdl_signal_attributes_t :

585

vhdl_signal_attributes_t > vhdl_signal_attributes_t=

586

fun x > match x with  SigAtt a > let a = self#string a in SigAtt a

587


588

method vhdl_suffix_selection_t : vhdl_suffix_selection_t > vhdl_suffix_selection_t=

589

fun x >

590

match x with

591

 Idx a > let a = self#int a in Idx a

592

 SuffixRange (a,b) >

593

let a = self#int a in let b = self#int b in SuffixRange (a, b)

594


595

method vhdl_parameter_t : vhdl_parameter_t > vhdl_parameter_t=

596

fun { parameter_names; parameter_mode; parameter_typ; init_val } >

597

let parameter_names = self#list self#lower_vhdl_name_t parameter_names in

598

let parameter_mode = self#list self#string parameter_mode in

599

let parameter_typ = self#vhdl_subtype_indication_t parameter_typ in

600

let init_val = self#option self#vhdl_cst_val_t init_val in

601

{ parameter_names; parameter_mode; parameter_typ; init_val }

602


603

method vhdl_subprogram_spec_t :

604

vhdl_subprogram_spec_t > vhdl_subprogram_spec_t=

605

fun { ss_name; subprogram_type; typeMark; parameters; isPure } >

606

let ss_name = self#string ss_name in

607

let subprogram_type = self#string subprogram_type in

608

let typeMark = self#lower_vhdl_name_t typeMark in

609

let parameters = self#list self#vhdl_parameter_t parameters in

610

let isPure = self#bool isPure in

611

{ ss_name; subprogram_type; typeMark; parameters; isPure }

612


613

method vhdl_sequential_stmt_t :

614

vhdl_sequential_stmt_t > mini_vhdl_sequential_stmt_t=

615

fun x >

616

match x with

617

 VarAssign { label; seqs_lhs; rhs } >

618

let label = match label with NoName > None  _ > Some (self#lower_vhdl_name_t label) in

619

let lhs = self#lower_vhdl_name_t seqs_lhs in

620

let rhs = self#vhdl_expr_t rhs in VarAssign { label; lhs; rhs }

621

 SigSeqAssign { label; seqs_lhs; rhs } >

622

let label = match label with NoName > None  _ > Some (self#lower_vhdl_name_t label) in

623

let lhs = self#lower_vhdl_name_t seqs_lhs in

624

let rhs = self#list self#vhdl_waveform_element_t rhs in

625

SigSeqAssign { label; lhs; rhs }

626

 If { label; if_cases; default } >

627

let label = match label with NoName > None  _ > Some (self#lower_vhdl_name_t label) in

628

let if_cases = List.map self#vhdl_if_case_t if_cases in

629

let default = List.map self#vhdl_sequential_stmt_t default in

630

If { label; if_cases; default }

631

 Case { label; guard; branches } >

632

let label = match label with NoName > None  _ > Some (self#lower_vhdl_name_t label) in

633

let guard = self#vhdl_expr_t guard in

634

let branches = List.map self#vhdl_case_item_t branches in

635

Case { label; guard; branches }

636

 Exit { label; loop_label; condition } >

637

let label = match label with NoName > None  _ > Some (self#lower_vhdl_name_t label) in

638

let loop_label = self#option self#string loop_label in

639

let condition = self#option self#vhdl_expr_t condition in

640

Exit { label; loop_label; condition }

641

 Assert { label; cond; report; severity } >

642

let label = match label with NoName > None  _ > Some (self#lower_vhdl_name_t label) in

643

let cond = self#vhdl_expr_t cond in

644

let report = self#vhdl_expr_t report in

645

let severity = self#vhdl_expr_t severity in

646

Assert { label; cond; report; severity }

647

 ProcedureCall { label; name; assocs } >

648

let label = match label with NoName > None  _ > Some (self#lower_vhdl_name_t label) in

649

let name = self#lower_vhdl_name_t name in

650

let assocs = self#list self#vhdl_assoc_element_t assocs in

651

(* TODO: get procedure declaration and map assoc_elements *)

652

ProcedureCall { label; name; assocs }

653

 Wait > Wait

654

 Null { label } >

655

let label = match label with NoName > None  _ > Some (self#lower_vhdl_name_t label) in

656

Null { label }

657

 Return { label; expr } >

658

let label = self#option self#lower_vhdl_name_t label in

659

let expr = self#option self#vhdl_expr_t expr in

660

Return { label; expr }

661


662

method vhdl_if_case_t : vhdl_if_case_t > mini_vhdl_if_case_t=

663

fun { if_cond; if_block } >

664

let if_cond = self#vhdl_expr_t if_cond in

665

let if_block = List.map self#vhdl_sequential_stmt_t if_block in

666

{ if_cond; if_block }

667


668

method vhdl_case_item_t : vhdl_case_item_t > mini_vhdl_case_item_t=

669

fun { when_cond; when_stmt } >

670

let when_cond = self#list self#vhdl_expr_t when_cond in

671

let when_stmt = List.map self#vhdl_sequential_stmt_t when_stmt in

672

{ when_cond; when_stmt }

673


674

method vhdl_declaration_t : vhdl_declaration_t > mini_vhdl_declaration_t=

675

fun x >

676

match x with

677

 VarDecl { names; typ; init_val } >

678

let names = self#list self#lower_vhdl_name_t names in

679

let typ = self#vhdl_subtype_indication_t typ in

680

let init_val = self#vhdl_expr_t init_val in

681

VarDecl { names; typ; init_val }

682

 CstDecl { names; typ; init_val } >

683

let names = self#list self#lower_vhdl_name_t names in

684

let typ = self#vhdl_subtype_indication_t typ in

685

let init_val = self#vhdl_expr_t init_val in

686

CstDecl { names; typ; init_val }

687

 SigDecl { names; typ; init_val } >

688

let names = self#list self#lower_vhdl_name_t names in

689

let typ = self#vhdl_subtype_indication_t typ in

690

let init_val = self#vhdl_expr_t init_val in

691

SigDecl { names; typ; init_val }

692

 ComponentDecl { name; generics; ports } >

693

let name = self#lower_vhdl_name_t name in

694

let generics = self#list self#vhdl_port_t generics in

695

let ports = self#list self#vhdl_port_t ports in

696

ComponentDecl { name; generics; ports }

697

 Subprogram { spec; decl_part; stmts } >

698

let spec = self#vhdl_subprogram_spec_t spec in

699

let decl_part = List.map self#vhdl_declaration_t decl_part in

700

let stmts = List.map self#vhdl_sequential_stmt_t stmts in

701

(* TODO: Explicit memories *)

702

Subprogram { spec; decl_part; stmts }

703


704

method vhdl_declarative_item_t :

705

vhdl_declarative_item_t > mini_vhdl_declarative_item_t=

706

fun { use_clause; di_declaration; di_definition } >

707

let use_clause = self#option self#vhdl_load_t use_clause in

708

let declaration =

709

match di_declaration with

710

 None > None

711

 Some a > Some (self#vhdl_declaration_t a) in

712

let definition = self#option self#vhdl_definition_t di_definition in

713

{ use_clause; declaration; definition }

714


715

method vhdl_waveform_element_t :

716

vhdl_waveform_element_t > vhdl_waveform_element_t=

717

fun { value; we_delay } >

718

let value = self#option self#vhdl_expr_t value in

719

let we_delay = self#option self#vhdl_expr_t we_delay in { value; we_delay }

720


721

method vhdl_signal_condition_t :

722

vhdl_signal_condition_t > vhdl_signal_condition_t=

723

fun { sc_expr; cond } >

724

let sc_expr = self#list self#vhdl_waveform_element_t sc_expr in

725

let cond = self#option self#vhdl_expr_t cond in { sc_expr; cond }

726


727

method vhdl_signal_selection_t :

728

vhdl_signal_selection_t > vhdl_signal_selection_t=

729

fun { ss_expr; when_sel } >

730

let ss_expr = self#list self#vhdl_waveform_element_t ss_expr in

731

let when_sel = self#list self#vhdl_expr_t when_sel in

732

{ ss_expr; when_sel }

733


734

method vhdl_conditional_signal_t :

735

vhdl_conditional_signal_t > vhdl_conditional_signal_t=

736

fun { cs_postponed; cs_label; cs_lhs; rhs; cs_delay } >

737

let cs_postponed = self#bool cs_postponed in

738

let cs_label = self#lower_vhdl_name_t cs_label in

739

let cs_lhs = self#lower_vhdl_name_t cs_lhs in

740

let rhs = self#list self#vhdl_signal_condition_t rhs in

741

let cs_delay = self#vhdl_expr_t cs_delay in

742

{ cs_postponed; cs_label; cs_lhs; rhs; cs_delay }

743


744

method vhdl_process_t : vhdl_process_t > mini_vhdl_process_t=

745

fun { id; p_declarations; active_sigs; p_body } >

746

let id = self#lower_vhdl_name_t id in

747

let p_declarations = List.map self#vhdl_declarative_item_t p_declarations in

748

let active_sigs = self#list self#lower_vhdl_name_t active_sigs in

749

let p_body = List.map self#vhdl_sequential_stmt_t p_body in

750

(* TODO: Explicit memories *)

751

let postponed = false in

752

let label = None in

753

{ id; p_declarations; active_sigs; p_body; postponed; label }

754


755

method vhdl_selected_signal_t :

756

vhdl_selected_signal_t > vhdl_selected_signal_t=

757

fun { ss_postponed; ss_label; ss_lhs; sel; branches; ss_delay } >

758

let ss_postponed = self#bool ss_postponed in

759

let ss_label = self#lower_vhdl_name_t ss_label in

760

let ss_lhs = self#lower_vhdl_name_t ss_lhs in

761

let sel = self#vhdl_expr_t sel in

762

let branches = self#list self#vhdl_signal_selection_t branches in

763

let ss_delay = self#option self#vhdl_expr_t ss_delay in

764

{ ss_postponed; ss_label; ss_lhs; sel; branches; ss_delay }

765


766

method vhdl_port_mode_t : vhdl_port_mode_t > vhdl_port_mode_t=

767

fun x > x

768


769

method vhdl_component_instantiation_t :

770

vhdl_component_instantiation_t > mini_vhdl_component_instantiation_t=

771

fun { ci_name; inst_unit; inst_unit_type; archi_name; generic_map; port_map } >

772

let ci_name = self#lower_vhdl_name_t ci_name in

773

let archi_name = self#option self#lower_vhdl_name_t archi_name in

774

let inst_unit = self#lower_vhdl_name_t inst_unit in

775

let db_tuple = match archi_name with

776

 None > failwith ("Component [" ^ self#to_string_vhdl_name_t ci_name ^ "] is not an entity")

777

 Some a > self#get_tuple_from_archi_and_entity_name (a, inst_unit) in (* Get corresponding tuple in db *)

778

let archi = db_tuple.architecture in

779

let entity = db_tuple.entity in

780

let generic_map = self#list self#vhdl_assoc_element_t generic_map in

781

let port_map = self#list self#vhdl_assoc_element_t port_map in

782

let port_t_names_proj : vhdl_port_t > vhdl_name_t list= fun x > x.port_names in

783

(* port_map resolution *)

784

let entity_ports_names = List.flatten (List.map port_t_names_proj entity.ports) in

785

let port_map = self#vhdl_assoc_element_t_resolve port_map entity_ports_names in

786

(* generic_map resolution *)

787

let entity_generics_names = List.flatten (List.map port_t_names_proj entity.generics) in

788

let generic_map = self#vhdl_assoc_element_t_resolve generic_map entity_generics_names in

789

{ ci_name; archi; entity; generic_map; port_map }

790


791

method vhdl_concurrent_stmt_t :

792

vhdl_concurrent_stmt_t > mini_vhdl_concurrent_stmt_t=

793

fun x >

794

match x with

795

 SigAssign a >

796

Process {

797

id = self#postfix_flatten_vhdl_name_t a.cs_lhs "__implicit_process";

798

p_declarations = [];

799

active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x [];

800

p_body = (SigCondAssign {

801

label = None;

802

lhs = a.cs_lhs;

803

rhs = a.rhs;

804

delay = match a.cs_delay with  IsNull > None  _ > Some a.cs_delay

805

})::[];

806

postponed = a.cs_postponed;

807

label = match a.cs_label with  NoName > None  _ > Some a.cs_label

808

}

809

 Process a > let a = self#vhdl_process_t a in Process a

810

 SelectedSig a >

811

Process {

812

id = self#postfix_flatten_vhdl_name_t a.ss_lhs "__implicit_process";

813

p_declarations = [];

814

active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x [];

815

p_body = (SigSelectAssign {

816

label = None;

817

lhs = a.ss_lhs;

818

sel = a.sel;

819

branches = a.branches;

820

delay = a.ss_delay

821

})::[];

822

postponed = a.ss_postponed;

823

label = match a.ss_label with  NoName > None  _ > Some a.ss_label

824

}

825

 ComponentInst a > let a = self#vhdl_component_instantiation_t a in ComponentInst a

826


827

method vhdl_port_t : vhdl_port_t > vhdl_port_t=

828

fun { port_names; port_mode; port_typ; port_expr } >

829

let port_names = self#list self#lower_vhdl_name_t port_names in

830

let port_mode = self#vhdl_port_mode_t port_mode in

831

let port_typ = self#vhdl_subtype_indication_t port_typ in

832

let port_expr = self#vhdl_expr_t port_expr in { port_names; port_mode; port_typ; port_expr }

833


834

method vhdl_entity_t : vhdl_entity_t > unit =

835

fun { e_name; generics; ports; e_declaration; stmts } > ()

836


837

method vhdl_package_t : (vhdl_load_t list * vhdl_package_t) > mini_vhdl_package_t=

838

fun ( ctxs, {p_name; shared_defs; shared_decls; shared_uses }) >

839

let p_name = self#lower_vhdl_name_t p_name in

840

let shared_defs = self#list self#vhdl_definition_t shared_defs in

841

let shared_decls = List.map self#vhdl_declaration_t shared_decls in

842

let shared_uses = self#list self#vhdl_load_t shared_uses @ ctxs in

843

{ p_name; shared_defs; shared_decls; shared_uses }

844


845

method vhdl_load_t : vhdl_load_t > vhdl_load_t=

846

fun x >

847

match x with

848

 Library a > let a = self#list self#lower_vhdl_name_t a in Library a

849

 Use a > let a = self#list self#lower_vhdl_name_t a in Use a

850


851

method vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list *

852

(vhdl_load_t list * vhdl_entity_t) list *

853

(vhdl_load_t list * vhdl_configuration_t) list *

854

(vhdl_load_t list * vhdl_architecture_t)) > mini_vhdl_component_t=

855

fun ( packs_pairs, ents_pairs, confs_pairs, (arch_ctx, arch) ) >

856

let names = arch.a_name::(arch.entity::[]) in

857

let (ref_ent_ctx,ref_ent) = self#filter_entity (ents_pairs, arch.entity) in

858

let contexts =

859

ref_ent_ctx @ (* Referenced entity context elements *)

860

arch_ctx @ (* Architecture context elements *)

861

self#declarative_items_uses ref_ent.e_declaration @ (* Referenced entity inner context elements *)

862

self#declarative_items_uses arch.a_declarations in (* Architecture inner context elements *)

863

let declarations =

864

self#declarative_items_declarations ref_ent.e_declaration @ (* Referenced entity inner declarations *)

865

self#declarative_items_declarations arch.a_declarations in (* Architecture inner declarations *)

866

let definitions =

867

self#declarative_items_definitions ref_ent.e_declaration @ (* Referenced entity inner definitions *)

868

self#declarative_items_definitions arch.a_declarations in (* Architecture inner definitions *)

869

let c_body =

870

List.map self#vhdl_concurrent_stmt_t ref_ent.stmts @ (* Referenced entity concurrent statement *)

871

List.map self#vhdl_concurrent_stmt_t arch.a_body in (* Architecture concurrent statements *)

872

let generics = ref_ent.generics in (* Referenced entity generics *)

873

let ports = ref_ent.ports in (* Referenced entity ports *)

874

let c_declarations = List.map self#vhdl_declaration_t declarations in

875

let (signals, subprograms) =

876

let rec find_decls c_declarations acc_s acc_p =

877

match c_declarations with

878

 [] > (acc_s, acc_p)

879

 (SigDecl (s))::tl > find_decls tl ((SigDecl (s))::acc_s) (acc_p)

880

 (Subprogram (s))::tl > find_decls tl (acc_s) ((Subprogram (s))::acc_p)

881

 _::tl > find_decls tl acc_s acc_p in find_decls c_declarations [] [] in

882

let assigned_signals_names = List.flatten (List.map self#mini_vhdl_concurrent_stmt_t_assigned_signals_names c_body) in

883

let functions = List.map (

884

fun x > match x with Subprogram (s) > (Simple s.spec.ss_name, s.spec.parameters, s.spec.typeMark)  _ > failwith "Unreachable error (map on subprograms)"

885

) subprograms in

886

let memories = List.flatten (List.map (self#mini_vhdl_concurrent_stmt_t_memories assigned_signals_names) c_body) in

887

let new_tuple = { entity=ref_ent;

888

architecture=arch;

889

architecture_signals=signals;

890

architecture_ports=ports;

891

architecture_generics=generics;

892

assigned_signals_names=assigned_signals_names;

893

functions=functions;

894

memories=memories;

895

contexts=contexts } in

896

self#db_add_tuple new_tuple;

897

self#db_set_current new_tuple;

898

{ names; generics=generics; ports=ports; contexts=contexts; c_declarations=c_declarations; definitions=definitions; c_body=c_body }

899


900

method vhdl_configuration_t :

901

vhdl_configuration_t > unit= self#unit

902


903

method vhdl_library_unit_t : vhdl_library_unit_t > unit=

904

fun x > ()

905


906

method vhdl_design_unit_t : vhdl_design_unit_t > unit=

907

fun { contexts; library } > ()

908


909

method vhdl_design_file_t : vhdl_design_file_t > mini_vhdl_design_file_t=

910

fun { design_units } >

911

let rec inline_df l packs ents archs confs = match l with

912

 [] > (List.rev packs, List.rev ents, List.rev archs, List.rev confs)

913

 {contexts = c; library = lib}::tl > match lib with

914

 Package p > inline_df tl ((c,p)::packs) ents archs confs

915

 Entities e > inline_df tl packs ((c,e)::ents) archs confs

916

 Architecture a > inline_df tl packs ents ((c,a)::archs) confs

917

 Configuration conf > inline_df tl packs ents archs ((c,conf)::confs) in

918

let (p,e,a,con) = inline_df design_units [] [] [] [] in

919

let app x = self#vhdl_architecture_t (p,e,con,x) in

920

let components = List.map app a in

921

let packages = List.map self#vhdl_package_t p in

922

{ components; packages }

923


924

(**

925

* Second pass for:

926

* functions/procedures call association list resolution

927

* May not be necessary (functions can be provided as input of generic association list resolution

928

*)

929


930

method sndpass_mini_vhdl_component_t : mini_vhdl_component_t > mini_vhdl_component_t=

931

fun { names; generics; ports; contexts; c_declarations; definitions; c_body } >

932

(* TODO: resolve association list for function/procedures calls *)

933

{ names; generics; ports; contexts; c_declarations; definitions; c_body }

934


935

method sndpass_mini_vhdl_design_file_t : mini_vhdl_design_file_t > mini_vhdl_design_file_t=

936

fun { components; packages } >

937

let components = List.map self#sndpass_mini_vhdl_component_t components in

938

{ components; packages }

939


940

end
