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_array_attributes_t) > ()

37

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

38

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

39

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

40

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

41

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

42

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

43

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

44

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

45

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

46

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

47

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

48

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

49

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

50

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

51

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

52

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

53

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

54

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

55

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

56

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

57

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

58

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

59

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

60

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

61

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

62

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

63

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

64


65

class virtual vhdl_2_mini_vhdl_map =

66

object (self)

67

method virtual string : string > string

68

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

69

method virtual unit : unit > unit

70

method virtual bool : bool > bool

71

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

72

method virtual int : int > int

73

method virtual vhdl_name_t : vhdl_name_t > vhdl_name_t

74

method virtual vhdl_definition_t : vhdl_definition_t > vhdl_definition_t

75

method virtual vhdl_port_t : vhdl_port_t > vhdl_port_t

76

method virtual vhdl_expr_t : vhdl_expr_t > vhdl_expr_t

77

method virtual vhdl_port_mode_t : vhdl_port_mode_t > vhdl_port_mode_t

78

method virtual vhdl_element_declaration_t : vhdl_element_declaration_t > vhdl_element_declaration_t

79

method virtual vhdl_subtype_indication_t : vhdl_subtype_indication_t > vhdl_subtype_indication_t

80

method virtual vhdl_conditional_signal_t : vhdl_conditional_signal_t > vhdl_conditional_signal_t

81

method virtual vhdl_selected_signal_t : vhdl_selected_signal_t > vhdl_selected_signal_t

82

method virtual vhdl_signal_selection_t : vhdl_signal_selection_t > vhdl_signal_selection_t

83

method virtual vhdl_suffix_selection_t : vhdl_suffix_selection_t > vhdl_suffix_selection_t

84

method virtual vhdl_waveform_element_t : vhdl_waveform_element_t > vhdl_waveform_element_t

85

method virtual vhdl_signal_condition_t : vhdl_signal_condition_t > vhdl_signal_condition_t

86

method virtual vhdl_cst_val_t : vhdl_cst_val_t > vhdl_cst_val_t

87

method virtual vhdl_subprogram_spec_t : vhdl_subprogram_spec_t > vhdl_subprogram_spec_t

88

method virtual vhdl_discrete_range_t : vhdl_discrete_range_t > vhdl_discrete_range_t

89

method virtual vhdl_parameter_t : vhdl_parameter_t > vhdl_parameter_t

90

method virtual vhdl_declaration_t : vhdl_declaration_t > mini_vhdl_declaration_t

91

method virtual vhdl_configuration_t : vhdl_configuration_t > unit

92

method virtual vhdl_entity_t : vhdl_entity_t > unit

93

method virtual vhdl_library_unit_t : vhdl_library_unit_t > unit

94

method virtual vhdl_load_t : vhdl_load_t > vhdl_load_t

95

method virtual vhdl_design_unit_t : vhdl_design_unit_t > unit

96


97

method virtual vhdl_declarative_item_t : vhdl_declarative_item_t > mini_vhdl_declarative_item_t

98

method virtual vhdl_process_t : vhdl_process_t > mini_vhdl_process_t

99

method virtual vhdl_concurrent_stmt_t : vhdl_concurrent_stmt_t > mini_vhdl_concurrent_stmt_t

100

method virtual vhdl_sequential_stmt_t : vhdl_sequential_stmt_t > mini_vhdl_sequential_stmt_t

101

method virtual vhdl_design_file_t : vhdl_design_file_t > mini_vhdl_design_file_t

102


103

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

104

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

105

(vhdl_load_t list * vhdl_entity_t) list *

106

(vhdl_load_t list * vhdl_configuration_t) list *

107

(vhdl_load_t list * vhdl_architecture_t)) > mini_vhdl_component_t

108

method virtual vhdl_component_instantiation_t : vhdl_component_instantiation_t > mini_vhdl_component_instantiation_t

109

method virtual declarative_items_declarations : vhdl_declarative_item_t list > vhdl_declaration_t list

110

method virtual declarative_items_definitions : vhdl_declarative_item_t list > vhdl_definition_t list

111

method virtual declarative_items_uses : vhdl_declarative_item_t list > vhdl_load_t list

112

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

113

(vhdl_load_t list * vhdl_entity_t)

114


115

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

116

* Begin vhdl_name_t helpers

117

*)

118

method simplify_name_t : vhdl_name_t > vhdl_name_t=

119

fun n >

120

let lower a = String.lowercase_ascii a in

121

let n = self#lower_vhdl_name_t n in

122

match n with

123

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

124

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

125

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

126

then self#simplify_name_t (Selected tl)

127

else n

128

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

129

then self#simplify_name_t (Selected tl)

130

else n

131

 _ > n

132


133

method lower_vhdl_name_t : vhdl_name_t > vhdl_name_t=

134

fun x >

135

let lower a = String.lowercase_ascii a in

136

match x with

137

 Simple a > Simple (lower a)

138

 Identifier a > Identifier (lower a)

139

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

140

 Index { id; exprs } >

141

let id = self#lower_vhdl_name_t id in

142

let exprs = self#list self#vhdl_expr_t exprs in

143

Index { id; exprs }

144

 Slice { id; range } >

145

let id = self#lower_vhdl_name_t id in

146

let range = self#vhdl_discrete_range_t range in

147

Slice { id; range }

148

 Attribute { id; designator; expr } >

149

let id = self#lower_vhdl_name_t id in

150

let designator = self#lower_vhdl_name_t designator in

151

let expr = self#vhdl_expr_t expr in

152

Attribute { id; designator; expr }

153

 Function { id; assoc_list } >

154

let id = self#lower_vhdl_name_t id in

155

let assoc_list = self#list self#vhdl_assoc_element_t assoc_list in

156

Function { id; assoc_list }

157

 NoName > NoName

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


171

method flatten_vhdl_name_t : vhdl_name_t > vhdl_name_t=

172

fun x >

173

match x with

174

 Simple a > Simple (a)

175

 Identifier a > Simple (a)

176

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

177

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

178


179

method postfix_flatten_vhdl_name_t : vhdl_name_t > string > vhdl_name_t=

180

fun x >

181

fun postfix >

182

let flattened = self#flatten_vhdl_name_t x in

183

match flattened with

184

 Simple a > Simple (a ^ postfix)

185

 Identifier a > Identifier (a ^ postfix)

186

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

187


188


189

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

190

* End vhdl_name_t helpers

191

*)

192


193

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

194

* Begin DB helpers

195

*)

196

val mutable db : db_tuple_t list = []

197


198

method get_db : db_tuple_t list = db

199


200

method db_add_tuple : db_tuple_t > unit=

201

fun x > db < x::db

202


203

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

204

fun x >

205

let rec find a dbl =

206

match dbl with

207

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

208

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

209


210

method get_tuple_from_archi_and_entity_name : (vhdl_name_t * vhdl_name_t) > db_tuple_t=

211

fun (a_name,e_name) >

212

let a_name = self#simplify_name_t a_name in

213

let e_name = self#simplify_name_t e_name in

214

let rec find (a_name,e_name) dbl =

215

match dbl with

216

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

217

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

218

 e::tl >

219

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

220

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

221

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

222

then e

223

else find (a_name,e_name) tl in

224

find (a_name,e_name) db

225


226

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

227

(vhdl_load_t list * vhdl_entity_t) =

228

fun ( entities_pair, filter_name ) >

229

let rec filter ep n = match ep with

230

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

231

 (c,{name; generics; ports; declaration; stmts})::tl >

232

if (name = n) then

233

List.hd ep

234

else filter (List.tl ep) n in

235

filter entities_pair filter_name

236

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

237

* End DB helpers

238

*)

239


240

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

241

* Begin declarative_item_t projections

242

*)

243

method declarative_items_declarations : vhdl_declarative_item_t list > vhdl_declaration_t list =

244

fun x >

245

match x with

246

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

247

 _::tl > self#declarative_items_declarations tl

248

 [] > []

249


250

method declarative_items_definitions : vhdl_declarative_item_t list > vhdl_definition_t list =

251

fun x >

252

match x with

253

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

254

 _::tl > self#declarative_items_definitions tl

255

 [] > []

256


257

method declarative_items_uses : vhdl_declarative_item_t list > vhdl_load_t list =

258

fun x >

259

match x with

260

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

261

 _::tl > self#declarative_items_uses tl

262

 [] > []

263

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

264

* End declarative_item_t projections

265

*)

266


267

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

268

* Begin names_t extraction (assigned signals)

269

*)

270

method mini_vhdl_concurrent_stmt_t_assigned_signals_names : mini_vhdl_concurrent_stmt_t > vhdl_name_t list=

271

fun x >

272

match x with

273

 Process a > List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names a.body)

274

 ComponentInst a > []

275


276

method mini_vhdl_sequential_stmt_t_assigned_signals_names :

277

mini_vhdl_sequential_stmt_t > vhdl_name_t list=

278

fun x >

279

match x with

280

 VarAssign { label; lhs; rhs } > []

281

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

282

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

283

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

284

 If { label; if_cases; default } >

285

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

286

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

287

 Case { label; guard; branches } >

288

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

289

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

290

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

291

 _ > []

292


293

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

294

*End names_t extraction

295

*)

296


297

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

298

* Begin Implicit memories extraction

299

*)

300


301

method mini_vhdl_concurrent_stmt_t_memories : vhdl_name_t list > mini_vhdl_concurrent_stmt_t > vhdl_name_t list=

302

fun assigned_signals > fun x >

303

match x with

304

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

305

 ComponentInst a > []

306


307

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

308

fun assigned_signals > fun mems > fun x >

309

match x with

310

 If { label; if_cases; default } >

311

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

312

let if_cases_assigned_signals =

313

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

314

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

315

let mems = if_cases_memories@mems in

316


317

(match default with

318

 [] > (List.flatten if_cases_assigned_signals)@mems

319

 _ > mems)

320

 Case { label; guard; branches } >

321

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

322

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

323

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

324

cases_memories@mems

325

 _ > mems

326


327

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

328

*End memories extraction

329

*)

330


331


332

method vhdl_cst_val_t : vhdl_cst_val_t > vhdl_cst_val_t=

333

fun x >

334

match x with

335

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

336

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

337

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

338


339

method vhdl_type_t : vhdl_type_t > vhdl_type_t=

340

fun x >

341

match x with

342

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

343

 Range (a,b,c) >

344

let a = self#option self#string a in

345

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

346

 Bit_vector (a,b) >

347

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

348

 Array { indexes; const; definition } >

349

let indexes = self#list self#lower_vhdl_name_t indexes in

350

let const = self#option self#vhdl_constraint_t const in

351

let definition = self#vhdl_subtype_indication_t definition in

352

Array { indexes; const; definition }

353

 Record a >

354

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

355

 Enumerated a >

356

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

357

 Void > Void

358


359

method vhdl_element_declaration_t :

360

vhdl_element_declaration_t > vhdl_element_declaration_t=

361

fun { names; definition } >

362

let names = self#list self#lower_vhdl_name_t names in

363

let definition = self#vhdl_subtype_indication_t definition in

364

{ names; definition }

365


366

method vhdl_subtype_indication_t :

367

vhdl_subtype_indication_t > vhdl_subtype_indication_t=

368

fun { name; functionName; const } >

369

let name = self#lower_vhdl_name_t name in

370

let functionName = self#lower_vhdl_name_t functionName in

371

let const = self#vhdl_constraint_t const in

372

{ name; functionName; const }

373


374

method vhdl_discrete_range_t :

375

vhdl_discrete_range_t > vhdl_discrete_range_t=

376

fun x >

377

match x with

378

 SubDiscreteRange a >

379

let a = self#vhdl_subtype_indication_t a in SubDiscreteRange a

380

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

381

 DirectedRange { direction; from; _to } >

382

let direction = self#string direction in

383

let from = self#vhdl_expr_t from in

384

let _to = self#vhdl_expr_t _to in

385

DirectedRange { direction; from; _to }

386


387

method vhdl_constraint_t : vhdl_constraint_t > vhdl_constraint_t=

388

fun x >

389

match x with

390

 RefConstraint { ref_name } >

391

let ref_name = self#lower_vhdl_name_t ref_name in

392

RefConstraint { ref_name }

393

 RangeConstraint { range } >

394

let range = self#vhdl_discrete_range_t range in

395

RangeConstraint { range }

396

 IndexConstraint { ranges } >

397

let ranges = self#list self#vhdl_discrete_range_t ranges in

398

IndexConstraint { ranges }

399

 ArrayConstraint { ranges; sub } >

400

let ranges = self#list self#vhdl_discrete_range_t ranges in

401

let sub = self#vhdl_constraint_t sub in

402

ArrayConstraint { ranges; sub }

403

 RecordConstraint > RecordConstraint

404

 NoConstraint > NoConstraint

405


406

method vhdl_definition_t : vhdl_definition_t > vhdl_definition_t=

407

fun x >

408

match x with

409

 Type { name; definition } >

410

let name = self#lower_vhdl_name_t name in

411

let definition = self#vhdl_type_t definition in

412

Type { name; definition }

413

 Subtype { name; typ } >

414

let name = self#lower_vhdl_name_t name in

415

let typ = self#vhdl_subtype_indication_t typ in

416

Subtype { name; typ }

417


418

method vhdl_expr_t : vhdl_expr_t > vhdl_expr_t=

419

fun x >

420

match x with

421

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

422

 Cst { value; unit_name } >

423

let value = self#vhdl_cst_val_t value in

424

let unit_name = self#option self#lower_vhdl_name_t unit_name in

425

Cst { value; unit_name }

426

 Op { id; args } >

427

let id = self#string id in

428

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

429

 IsNull > IsNull

430

 Time { value; phy_unit } >

431

let value = self#int value in

432

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

433

 Sig { name; att } >

434

let name = self#lower_vhdl_name_t name in

435

let att = self#option self#vhdl_signal_attributes_t att in

436

Sig { name; att }

437

 SuffixMod { expr; selection } >

438

let expr = self#vhdl_expr_t expr in

439

let selection = self#vhdl_suffix_selection_t selection in

440

SuffixMod { expr; selection }

441

 Aggregate { elems } >

442

let elems = self#list self#vhdl_element_assoc_t elems in

443

Aggregate { elems }

444

 QualifiedExpression { type_mark; aggregate; expression } >

445

let type_mark = self#lower_vhdl_name_t type_mark in

446

let aggregate = self#list self#vhdl_element_assoc_t aggregate in

447

let expression = self#option self#vhdl_expr_t expression in

448

QualifiedExpression { type_mark; aggregate; expression }

449

 Others > Others

450


451

method vhdl_name_t : vhdl_name_t > vhdl_name_t=

452

fun x >

453

match x with

454

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

455

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

456

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

457

 Index { id; exprs } >

458

let id = self#lower_vhdl_name_t id in

459

let exprs = self#list self#vhdl_expr_t exprs in

460

Index { id; exprs }

461

 Slice { id; range } >

462

let id = self#lower_vhdl_name_t id in

463

let range = self#vhdl_discrete_range_t range in

464

Slice { id; range }

465

 Attribute { id; designator; expr } >

466

let id = self#lower_vhdl_name_t id in

467

let designator = self#lower_vhdl_name_t designator in

468

let expr = self#vhdl_expr_t expr in

469

Attribute { id; designator; expr }

470

 Function { id; assoc_list } >

471

let id = self#lower_vhdl_name_t id in

472

let assoc_list = self#list self#vhdl_assoc_element_t assoc_list in

473

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

474

Function { id; assoc_list }

475

 NoName > NoName

476


477

method vhdl_assoc_element_t :

478

vhdl_assoc_element_t > vhdl_assoc_element_t=

479

fun

480

{ formal_name; formal_arg; actual_name; actual_designator;

481

actual_expr }

482

>

483

let formal_name = self#option self#vhdl_name_t formal_name in

484

let formal_arg = self#option self#vhdl_name_t formal_arg in

485

let actual_name = self#option self#vhdl_name_t actual_name in

486

let actual_designator = self#option self#vhdl_name_t actual_designator in

487

let actual_expr = self#option self#vhdl_expr_t actual_expr in

488

{

489

formal_name;

490

formal_arg;

491

actual_name;

492

actual_designator;

493

actual_expr

494

}

495


496

method vhdl_element_assoc_t :

497

vhdl_element_assoc_t > vhdl_element_assoc_t=

498

fun { choices; expr } >

499

let choices = self#list self#vhdl_expr_t choices in

500

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

501


502

method vhdl_array_attributes_t :

503

vhdl_array_attributes_t > vhdl_array_attributes_t=

504

fun x >

505

match x with

506

 AAttInt { id; arg } >

507

let id = self#string id in

508

let arg = self#int arg in AAttInt { id; arg }

509

 AAttAscending > AAttAscending

510


511

method vhdl_signal_attributes_t :

512

vhdl_signal_attributes_t > vhdl_signal_attributes_t=

513

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

514


515

method vhdl_suffix_selection_t : vhdl_suffix_selection_t > vhdl_suffix_selection_t=

516

fun x >

517

match x with

518

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

519

 SuffixRange (a,b) >

520

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

521


522

method vhdl_parameter_t : vhdl_parameter_t > vhdl_parameter_t=

523

fun { names; mode; typ; init_val } >

524

let names = self#list self#lower_vhdl_name_t names in

525

let mode = self#list self#string mode in

526

let typ = self#vhdl_subtype_indication_t typ in

527

let init_val = self#option self#vhdl_cst_val_t init_val in

528

{ names; mode; typ; init_val }

529


530

method vhdl_subprogram_spec_t :

531

vhdl_subprogram_spec_t > vhdl_subprogram_spec_t=

532

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

533

let name = self#string name in

534

let subprogram_type = self#string subprogram_type in

535

let typeMark = self#lower_vhdl_name_t typeMark in

536

let parameters = self#list self#vhdl_parameter_t parameters in

537

let isPure = self#bool isPure in

538

{ name; subprogram_type; typeMark; parameters; isPure }

539


540

method vhdl_sequential_stmt_t :

541

vhdl_sequential_stmt_t > mini_vhdl_sequential_stmt_t=

542

fun x >

543

match x with

544

 VarAssign { label; lhs; rhs } >

545

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

546

let lhs = self#lower_vhdl_name_t lhs in

547

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

548

 SigSeqAssign { label; lhs; rhs } >

549

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

550

let lhs = self#lower_vhdl_name_t lhs in

551

let rhs = self#list self#vhdl_waveform_element_t rhs in

552

SigSeqAssign { label; lhs; rhs }

553

 If { label; if_cases; default } >

554

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

555

let if_cases = List.map self#vhdl_if_case_t if_cases in

556

let default = List.map self#vhdl_sequential_stmt_t default in

557

If { label; if_cases; default }

558

 Case { label; guard; branches } >

559

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

560

let guard = self#vhdl_expr_t guard in

561

let branches = List.map self#vhdl_case_item_t branches in

562

Case { label; guard; branches }

563

 Exit { label; loop_label; condition } >

564

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

565

let loop_label = self#option self#string loop_label in

566

let condition = self#option self#vhdl_expr_t condition in

567

Exit { label; loop_label; condition }

568

 Assert { label; cond; report; severity } >

569

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

570

let cond = self#vhdl_expr_t cond in

571

let report = self#vhdl_expr_t report in

572

let severity = self#vhdl_expr_t severity in

573

Assert { label; cond; report; severity }

574

 ProcedureCall { label; name; assocs } >

575

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

576

let name = self#lower_vhdl_name_t name in

577

let assocs = self#list self#vhdl_assoc_element_t assocs in

578

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

579

ProcedureCall { label; name; assocs }

580

 Wait > Wait

581

 Null { label } >

582

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

583

Null { label }

584

 Return { label; expr } >

585

let label = self#option self#lower_vhdl_name_t label in

586

let expr = self#option self#vhdl_expr_t expr in

587

Return { label; expr }

588


589

method vhdl_if_case_t : vhdl_if_case_t > mini_vhdl_if_case_t=

590

fun { if_cond; if_block } >

591

let if_cond = self#vhdl_expr_t if_cond in

592

let if_block = List.map self#vhdl_sequential_stmt_t if_block in

593

{ if_cond; if_block }

594


595

method vhdl_case_item_t : vhdl_case_item_t > mini_vhdl_case_item_t=

596

fun { when_cond; when_stmt } >

597

let when_cond = self#list self#vhdl_expr_t when_cond in

598

let when_stmt = List.map self#vhdl_sequential_stmt_t when_stmt in

599

{ when_cond; when_stmt }

600


601

method vhdl_declaration_t : vhdl_declaration_t > mini_vhdl_declaration_t=

602

fun x >

603

match x with

604

 VarDecl { names; typ; init_val } >

605

let names = self#list self#lower_vhdl_name_t names in

606

let typ = self#vhdl_subtype_indication_t typ in

607

let init_val = self#vhdl_expr_t init_val in

608

VarDecl { names; typ; init_val }

609

 CstDecl { names; typ; init_val } >

610

let names = self#list self#lower_vhdl_name_t names in

611

let typ = self#vhdl_subtype_indication_t typ in

612

let init_val = self#vhdl_expr_t init_val in

613

CstDecl { names; typ; init_val }

614

 SigDecl { names; typ; init_val } >

615

let names = self#list self#lower_vhdl_name_t names in

616

let typ = self#vhdl_subtype_indication_t typ in

617

let init_val = self#vhdl_expr_t init_val in

618

SigDecl { names; typ; init_val }

619

 ComponentDecl { name; generics; ports } >

620

let name = self#lower_vhdl_name_t name in

621

let generics = self#list self#vhdl_port_t generics in

622

let ports = self#list self#vhdl_port_t ports in

623

ComponentDecl { name; generics; ports }

624

 Subprogram { spec; decl_part; stmts } >

625

let spec = self#vhdl_subprogram_spec_t spec in

626

let decl_part = List.map self#vhdl_declaration_t decl_part in

627

let stmts = List.map self#vhdl_sequential_stmt_t stmts in

628

(* TODO: Explicit memories *)

629

Subprogram { spec; decl_part; stmts }

630


631

method vhdl_declarative_item_t :

632

vhdl_declarative_item_t > mini_vhdl_declarative_item_t=

633

fun { use_clause; declaration; definition } >

634

let use_clause = self#option self#vhdl_load_t use_clause in

635

let declaration =

636

match declaration with

637

 None > None

638

 Some a > Some (self#vhdl_declaration_t a) in

639

let definition = self#option self#vhdl_definition_t definition in

640

{ use_clause; declaration; definition }

641


642

method vhdl_waveform_element_t :

643

vhdl_waveform_element_t > vhdl_waveform_element_t=

644

fun { value; delay } >

645

let value = self#option self#vhdl_expr_t value in

646

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

647


648

method vhdl_signal_condition_t :

649

vhdl_signal_condition_t > vhdl_signal_condition_t=

650

fun { expr; cond } >

651

let expr = self#list self#vhdl_waveform_element_t expr in

652

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

653


654

method vhdl_signal_selection_t :

655

vhdl_signal_selection_t > vhdl_signal_selection_t=

656

fun { expr; when_sel } >

657

let expr = self#list self#vhdl_waveform_element_t expr in

658

let when_sel = self#list self#vhdl_expr_t when_sel in

659

{ expr; when_sel }

660


661

method vhdl_conditional_signal_t :

662

vhdl_conditional_signal_t > vhdl_conditional_signal_t=

663

fun { postponed; label; lhs; rhs; delay } >

664

let postponed = self#bool postponed in

665

let label = self#lower_vhdl_name_t label in

666

let lhs = self#lower_vhdl_name_t lhs in

667

let rhs = self#list self#vhdl_signal_condition_t rhs in

668

let delay = self#vhdl_expr_t delay in

669

{ postponed; label; lhs; rhs; delay }

670


671

method vhdl_process_t : vhdl_process_t > mini_vhdl_process_t=

672

fun { id; declarations; active_sigs; body } >

673

let id = self#lower_vhdl_name_t id in

674

let declarations = List.map self#vhdl_declarative_item_t declarations in

675

let active_sigs = self#list self#lower_vhdl_name_t active_sigs in

676

let body = List.map self#vhdl_sequential_stmt_t body in

677

(* TODO: Explicit memories *)

678

let postponed = false in

679

let label = None in

680

{ id; declarations; active_sigs; body; postponed; label }

681


682

method vhdl_selected_signal_t :

683

vhdl_selected_signal_t > vhdl_selected_signal_t=

684

fun { postponed; label; lhs; sel; branches; delay } >

685

let postponed = self#bool postponed in

686

let label = self#lower_vhdl_name_t label in

687

let lhs = self#lower_vhdl_name_t lhs in

688

let sel = self#vhdl_expr_t sel in

689

let branches = self#list self#vhdl_signal_selection_t branches in

690

let delay = self#option self#vhdl_expr_t delay in

691

{ postponed; label; lhs; sel; branches; delay }

692


693

method vhdl_port_mode_t : vhdl_port_mode_t > vhdl_port_mode_t=

694

fun x > x

695


696

method vhdl_assoc_element_t_mode : vhdl_assoc_element_t > assoc_element_mode_t=

697

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

698

match (formal_name, formal_arg) with

699

 (None, None) > Positional

700

 (Some NoName, Some NoName) > Positional

701

 (_, None) > Named

702

 (_, Some NoName) > Named

703

 _ > Named_arg

704


705

method map_ports : vhdl_assoc_element_t list > assoc_element_mode_t list > vhdl_name_t list > vhdl_assoc_element_t list=

706

fun elements > fun modes > fun names >

707

let rec index_of e l i =

708

match l with [] > failwith "Non existing element"  hd::tl > if hd = e then i else index_of e tl (i+1) in

709

let match_assoc_mode a m = match m with

710

 Positional > (index_of a elements 0, a)

711

 Named >

712

(match a.formal_name with

713

 None > failwith "Unreachable error"

714

 Some e > (find_vhdl_name_t names e, a))

715

 Named_arg >

716

(match a.formal_arg with

717

 None > failwith "Unreachable error"

718

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

719

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

720

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

721

List.map snd (List.sort compare_index_assoc_pairs positioned)

722


723

method vhdl_assoc_resolve : vhdl_assoc_element_t > vhdl_assoc_element_t=

724

fun elem >

725

let mode = self#vhdl_assoc_element_t_mode elem in

726

match mode with

727

 Positional > elem

728

 Named > {formal_name=None;

729

formal_arg=None;

730

actual_name=elem.actual_name;

731

actual_designator=elem.actual_designator;

732

actual_expr=elem.actual_expr }

733

 Named_arg >

734

match elem.formal_name with

735

 None > failwith "Unreachable code"

736

 Some a > {formal_name=None;

737

formal_arg=None;

738

actual_name= Some (Function {id=a;

739

assoc_list=

740

[{formal_name=None;

741

formal_arg=None;

742

actual_name=elem.actual_name;

743

actual_designator=elem.actual_designator;

744

actual_expr=elem.actual_expr }]});

745

actual_designator=None;

746

actual_expr=None}

747


748

method vhdl_component_instantiation_t :

749

vhdl_component_instantiation_t > mini_vhdl_component_instantiation_t=

750

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

751

let name = self#lower_vhdl_name_t name in

752

let archi_name = self#option self#lower_vhdl_name_t archi_name in

753

let inst_unit = self#lower_vhdl_name_t inst_unit in

754

let db_tuple = match archi_name with

755

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

756

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

757

let archi = db_tuple.architecture in

758

let entity = db_tuple.entity in

759

let generic_map = self#list self#vhdl_assoc_element_t generic_map in

760

let port_map = self#list self#vhdl_assoc_element_t port_map in

761

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

762

(* port_map resolution *)

763

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

764

let component_port_map_modes = List.map self#vhdl_assoc_element_t_mode port_map in

765

let port_map = self#map_ports port_map component_port_map_modes entity_ports_names in

766

let port_map = List.map self#vhdl_assoc_resolve port_map in

767

(* generic_map resolution *)

768

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

769

let component_generics_map_modes = List.map self#vhdl_assoc_element_t_mode generic_map in

770

let generic_map = self#map_ports generic_map component_generics_map_modes entity_generics_names in

771

let generic_map = List.map self#vhdl_assoc_resolve generic_map in

772

{ name; archi; entity; generic_map; port_map }

773


774

method vhdl_concurrent_stmt_t :

775

vhdl_concurrent_stmt_t > mini_vhdl_concurrent_stmt_t=

776

fun x >

777

match x with

778

 SigAssign a >

779

Process {

780

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

781

declarations = [];

782

active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x [];

783

body = (SigCondAssign {

784

label = None;

785

lhs = a.lhs;

786

rhs = a.rhs;

787

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

788

})::[];

789

postponed = a.postponed;

790

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

791

}

792

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

793

 SelectedSig a >

794

Process {

795

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

796

declarations = [];

797

active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x [];

798

body = (SigSelectAssign {

799

label = None;

800

lhs = a.lhs;

801

sel = a.sel;

802

branches = a.branches;

803

delay = a.delay

804

})::[];

805

postponed = a.postponed;

806

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

807

}

808

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

809


810

method vhdl_port_t : vhdl_port_t > vhdl_port_t=

811

fun { names; mode; typ; expr } >

812

let names = self#list self#lower_vhdl_name_t names in

813

let mode = self#vhdl_port_mode_t mode in

814

let typ = self#vhdl_subtype_indication_t typ in

815

let expr = self#vhdl_expr_t expr in { names; mode; typ; expr }

816


817

method vhdl_entity_t : vhdl_entity_t > unit =

818

fun { name; generics; ports; declaration; stmts } > ()

819


820

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

821

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

822

let name = self#lower_vhdl_name_t name in

823

let shared_defs = self#list self#vhdl_definition_t shared_defs in

824

let shared_decls = List.map self#vhdl_declaration_t shared_decls in

825

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

826

{ name; shared_defs; shared_decls; shared_uses }

827


828

method vhdl_load_t : vhdl_load_t > vhdl_load_t=

829

fun x >

830

match x with

831

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

832

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

833


834

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

835

(vhdl_load_t list * vhdl_entity_t) list *

836

(vhdl_load_t list * vhdl_configuration_t) list *

837

(vhdl_load_t list * vhdl_architecture_t)) > mini_vhdl_component_t=

838

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

839

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

840

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

841

let contexts =

842

ref_ent_ctx @ (* Referenced entity context elements *)

843

arch_ctx @ (* Architecture context elements *)

844

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

845

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

846

let declarations =

847

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

848

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

849

let definitions =

850

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

851

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

852

let body =

853

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

854

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

855

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

856

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

857

let declarations = List.map self#vhdl_declaration_t declarations in

858

let (signals, subprograms) =

859

let rec find_decls declarations acc_s acc_p =

860

match declarations with

861

 [] > (acc_s, acc_p)

862

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

863

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

864

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

865

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

866

let functions = List.map (

867

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

868

) subprograms in

869

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

870

self#db_add_tuple { entity=ref_ent;

871

architecture=arch;

872

architecture_signals=signals;

873

architecture_ports=ports;

874

architecture_generics=generics;

875

assigned_signals_names=assigned_signals_names;

876

functions=functions;

877

memories=memories;

878

contexts=contexts;

879

};

880

{ names;

881

generics=generics;

882

ports=ports;

883

contexts=contexts;

884

declarations=declarations;

885

definitions=definitions;

886

body=body

887

}

888


889

method vhdl_configuration_t :

890

vhdl_configuration_t > unit= self#unit

891


892

method vhdl_library_unit_t : vhdl_library_unit_t > unit=

893

fun x > ()

894


895

method vhdl_design_unit_t : vhdl_design_unit_t > unit=

896

fun { contexts; library } > ()

897


898

method vhdl_design_file_t : vhdl_design_file_t > mini_vhdl_design_file_t=

899

fun { design_units } >

900

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

901

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

902

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

903

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

904

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

905

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

906

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

907

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

908

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

909

let components = List.map app a in

910

let packages = List.map self#vhdl_package_t p in

911

{ components; packages }

912


913

end
