1

open Vhdl_ast

2

open Mini_vhdl_ast

3

open Vhdl_ast_fold_sensitivity

4


5

type db_tuple_t =

6

{

7

mutable entity: vhdl_entity_t;

8

mutable architecture: vhdl_architecture_t;

9

mutable architecture_signals: mini_vhdl_declaration_t list;

10

mutable contexts: vhdl_load_t list;

11

}

12


13

let get_sensitivity_list = object (self)

14

inherit ['acc] fold_sensitivity as super

15

end

16


17

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

18

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

19

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

20

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

21

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

22

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

23

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

24

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

25

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

26

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

27

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

28

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

29

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

30

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

31

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

32

let _ = fun (_ : 'basetype vhdl_type_attributes_t) > ()

33

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

34

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

35

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

36

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

37

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

38

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

39

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

40

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

41

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

42

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

43

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

44

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

45

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

46

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

47

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

48

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

49

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

50

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

51

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

52

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

53

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

54

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

55

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

56

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

57

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

58


59

class virtual vhdl_2_mini_vhdl_map =

60

object (self)

61

method virtual string : string > string

62

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

63

method virtual unit : unit > unit

64

method virtual bool : bool > bool

65

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

66

method virtual int : int > int

67

method virtual vhdl_name_t : vhdl_name_t > vhdl_name_t

68

method virtual vhdl_definition_t : vhdl_definition_t > vhdl_definition_t

69

method virtual vhdl_port_t : vhdl_port_t > vhdl_port_t

70

method virtual vhdl_expr_t : vhdl_expr_t > vhdl_expr_t

71

method virtual vhdl_port_mode_t : vhdl_port_mode_t > vhdl_port_mode_t

72

method virtual vhdl_element_declaration_t : vhdl_element_declaration_t > vhdl_element_declaration_t

73

method virtual vhdl_subtype_indication_t : vhdl_subtype_indication_t > vhdl_subtype_indication_t

74

method virtual vhdl_conditional_signal_t : vhdl_conditional_signal_t > vhdl_conditional_signal_t

75

method virtual vhdl_selected_signal_t : vhdl_selected_signal_t > vhdl_selected_signal_t

76

method virtual vhdl_signal_selection_t : vhdl_signal_selection_t > vhdl_signal_selection_t

77

method virtual vhdl_suffix_selection_t : vhdl_suffix_selection_t > vhdl_suffix_selection_t

78

method virtual vhdl_waveform_element_t : vhdl_waveform_element_t > vhdl_waveform_element_t

79

method virtual vhdl_signal_condition_t : vhdl_signal_condition_t > vhdl_signal_condition_t

80

method virtual vhdl_cst_val_t : vhdl_cst_val_t > vhdl_cst_val_t

81

method virtual vhdl_subprogram_spec_t : vhdl_subprogram_spec_t > vhdl_subprogram_spec_t

82

method virtual vhdl_discrete_range_t : vhdl_discrete_range_t > vhdl_discrete_range_t

83

method virtual vhdl_parameter_t : vhdl_parameter_t > vhdl_parameter_t

84

method virtual vhdl_declaration_t : vhdl_declaration_t > mini_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


91

method virtual vhdl_declarative_item_t : vhdl_declarative_item_t > mini_vhdl_declarative_item_t

92

method virtual vhdl_process_t : vhdl_process_t > mini_vhdl_process_t

93

method virtual vhdl_concurrent_stmt_t : vhdl_concurrent_stmt_t > mini_vhdl_concurrent_stmt_t

94

method virtual vhdl_sequential_stmt_t : vhdl_sequential_stmt_t > mini_vhdl_sequential_stmt_t

95

method virtual vhdl_design_file_t : vhdl_design_file_t > mini_vhdl_design_file_t

96


97

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

98

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

99

(vhdl_load_t list * vhdl_entity_t) list *

100

(vhdl_load_t list * vhdl_configuration_t) list *

101

(vhdl_load_t list * vhdl_architecture_t)) > mini_vhdl_component_t

102

method virtual vhdl_component_instantiation_t : vhdl_component_instantiation_t > mini_vhdl_component_instantiation_t

103

method virtual declarative_items_declarations : vhdl_declarative_item_t list > vhdl_declaration_t list

104

method virtual declarative_items_definitions : vhdl_declarative_item_t list > vhdl_definition_t list

105

method virtual declarative_items_uses : vhdl_declarative_item_t list > vhdl_load_t list

106

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

107

(vhdl_load_t list * vhdl_entity_t)

108


109

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

110

* Begin vhdl_name_t helpers

111

*)

112

method simplify_name_t : vhdl_name_t > vhdl_name_t=

113

fun n >

114

let lower a = String.lowercase_ascii a in

115

let n = self#lower_vhdl_name_t n in

116

match n with

117

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

118

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

119

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

120

then self#simplify_name_t (Selected tl)

121

else n

122

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

123

then self#simplify_name_t (Selected tl)

124

else n

125

 _ > n

126


127

method lower_vhdl_name_t : vhdl_name_t > vhdl_name_t=

128

fun x >

129

let lower a = String.lowercase_ascii a in

130

match x with

131

 Simple a > Simple (lower a)

132

 Identifier a > Identifier (lower a)

133

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

134

 Index { id; exprs } >

135

let id = self#lower_vhdl_name_t id in

136

let exprs = self#list self#vhdl_expr_t exprs in

137

Index { id; exprs }

138

 Slice { id; range } >

139

let id = self#lower_vhdl_name_t id in

140

let range = self#vhdl_discrete_range_t range in

141

Slice { id; range }

142

 Attribute { id; designator; expr } >

143

let id = self#lower_vhdl_name_t id in

144

let designator = self#lower_vhdl_name_t designator in

145

let expr = self#vhdl_expr_t expr in

146

Attribute { id; designator; expr }

147

 Function { id; assoc_list } >

148

let id = self#lower_vhdl_name_t id in

149

let assoc_list = self#list self#vhdl_assoc_element_t assoc_list in

150

Function { id; assoc_list }

151

 NoName > NoName

152


153

method to_string_vhdl_name_t : vhdl_name_t > string=

154

fun x >

155

match x with

156

 Simple a > a

157

 Identifier a > a

158

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

159

 Index { id; exprs } > self#to_string_vhdl_name_t id

160

 Slice { id; range } > self#to_string_vhdl_name_t id

161

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

162

 Function { id; assoc_list } > self#to_string_vhdl_name_t id

163

 NoName > "NoName"

164


165

method flatten_vhdl_name_t : vhdl_name_t > vhdl_name_t=

166

fun x >

167

match x with

168

 Simple a > Simple (a)

169

 Identifier a > Simple (a)

170

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

171

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

172


173

method postfix_flatten_vhdl_name_t : vhdl_name_t > string > vhdl_name_t=

174

fun x >

175

fun postfix >

176

let flattened = self#flatten_vhdl_name_t x in

177

match flattened with

178

 Simple a > Simple (a ^ postfix)

179

 Identifier a > Identifier (a ^ postfix)

180

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

181


182


183

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

184

* End vhdl_name_t helpers

185

*)

186


187

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

188

* Begin DB helpers

189

*)

190

val mutable db : db_tuple_t list = []

191


192

method db_add_tuple : db_tuple_t > unit=

193

fun x > db < x::db

194


195

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

196

fun x >

197

let rec find a dbl =

198

match dbl with

199

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

200

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

201


202

method get_tuple_from_archi_and_entity_name : (vhdl_name_t * vhdl_name_t) > db_tuple_t=

203

fun (a_name,e_name) >

204

let a_name = self#simplify_name_t a_name in

205

let e_name = self#simplify_name_t e_name in

206

let rec find (a_name,e_name) dbl =

207

match dbl with

208

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

209

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

210

 e::tl >

211

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

212

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

213

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

214

then e

215

else find (a_name,e_name) tl in

216

find (a_name,e_name) db

217

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

218

* End DB helpers

219

*)

220


221

method vhdl_cst_val_t : vhdl_cst_val_t > vhdl_cst_val_t=

222

fun x >

223

match x with

224

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

225

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

226

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

227


228

method vhdl_type_t : vhdl_type_t > vhdl_type_t=

229

fun x >

230

match x with

231

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

232

 Range (a,b,c) >

233

let a = self#option self#string a in

234

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

235

 Bit_vector (a,b) >

236

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

237

 Array { indexes; const; definition } >

238

let indexes = self#list self#lower_vhdl_name_t indexes in

239

let const = self#option self#vhdl_constraint_t const in

240

let definition = self#vhdl_subtype_indication_t definition in

241

Array { indexes; const; definition }

242

 Record a >

243

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

244

 Enumerated a >

245

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

246

 Void > Void

247


248

method vhdl_element_declaration_t :

249

vhdl_element_declaration_t > vhdl_element_declaration_t=

250

fun { names; definition } >

251

let names = self#list self#lower_vhdl_name_t names in

252

let definition = self#vhdl_subtype_indication_t definition in

253

{ names; definition }

254


255

method vhdl_subtype_indication_t :

256

vhdl_subtype_indication_t > vhdl_subtype_indication_t=

257

fun { name; functionName; const } >

258

let name = self#lower_vhdl_name_t name in

259

let functionName = self#lower_vhdl_name_t functionName in

260

let const = self#vhdl_constraint_t const in

261

{ name; functionName; const }

262


263

method vhdl_discrete_range_t :

264

vhdl_discrete_range_t > vhdl_discrete_range_t=

265

fun x >

266

match x with

267

 SubDiscreteRange a >

268

let a = self#vhdl_subtype_indication_t a in SubDiscreteRange a

269

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

270

 DirectedRange { direction; from; _to } >

271

let direction = self#string direction in

272

let from = self#vhdl_expr_t from in

273

let _to = self#vhdl_expr_t _to in

274

DirectedRange { direction; from; _to }

275


276

method vhdl_constraint_t : vhdl_constraint_t > vhdl_constraint_t=

277

fun x >

278

match x with

279

 RefConstraint { ref_name } >

280

let ref_name = self#lower_vhdl_name_t ref_name in

281

RefConstraint { ref_name }

282

 RangeConstraint { range } >

283

let range = self#vhdl_discrete_range_t range in

284

RangeConstraint { range }

285

 IndexConstraint { ranges } >

286

let ranges = self#list self#vhdl_discrete_range_t ranges in

287

IndexConstraint { ranges }

288

 ArrayConstraint { ranges; sub } >

289

let ranges = self#list self#vhdl_discrete_range_t ranges in

290

let sub = self#vhdl_constraint_t sub in

291

ArrayConstraint { ranges; sub }

292

 RecordConstraint > RecordConstraint

293

 NoConstraint > NoConstraint

294


295

method vhdl_definition_t : vhdl_definition_t > vhdl_definition_t=

296

fun x >

297

match x with

298

 Type { name; definition } >

299

let name = self#lower_vhdl_name_t name in

300

let definition = self#vhdl_type_t definition in

301

Type { name; definition }

302

 Subtype { name; typ } >

303

let name = self#lower_vhdl_name_t name in

304

let typ = self#vhdl_subtype_indication_t typ in

305

Subtype { name; typ }

306


307

method vhdl_expr_t : vhdl_expr_t > vhdl_expr_t=

308

fun x >

309

match x with

310

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

311

 Cst { value; unit_name } >

312

let value = self#vhdl_cst_val_t value in

313

let unit_name = self#option self#lower_vhdl_name_t unit_name in

314

Cst { value; unit_name }

315

 Op { id; args } >

316

let id = self#string id in

317

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

318

 IsNull > IsNull

319

 Time { value; phy_unit } >

320

let value = self#int value in

321

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

322

 Sig { name; att } >

323

let name = self#lower_vhdl_name_t name in

324

let att = self#option self#vhdl_signal_attributes_t att in

325

Sig { name; att }

326

 SuffixMod { expr; selection } >

327

let expr = self#vhdl_expr_t expr in

328

let selection = self#vhdl_suffix_selection_t selection in

329

SuffixMod { expr; selection }

330

 Aggregate { elems } >

331

let elems = self#list self#vhdl_element_assoc_t elems in

332

Aggregate { elems }

333

 QualifiedExpression { type_mark; aggregate; expression } >

334

let type_mark = self#lower_vhdl_name_t type_mark in

335

let aggregate = self#list self#vhdl_element_assoc_t aggregate in

336

let expression = self#option self#vhdl_expr_t expression in

337

QualifiedExpression { type_mark; aggregate; expression }

338

 Others > Others

339


340

method vhdl_name_t : vhdl_name_t > vhdl_name_t=

341

fun x >

342

match x with

343

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

344

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

345

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

346

 Index { id; exprs } >

347

let id = self#lower_vhdl_name_t id in

348

let exprs = self#list self#vhdl_expr_t exprs in

349

Index { id; exprs }

350

 Slice { id; range } >

351

let id = self#lower_vhdl_name_t id in

352

let range = self#vhdl_discrete_range_t range in

353

Slice { id; range }

354

 Attribute { id; designator; expr } >

355

let id = self#lower_vhdl_name_t id in

356

let designator = self#lower_vhdl_name_t designator in

357

let expr = self#vhdl_expr_t expr in

358

Attribute { id; designator; expr }

359

 Function { id; assoc_list } >

360

let id = self#lower_vhdl_name_t id in

361

let assoc_list = self#list self#vhdl_assoc_element_t assoc_list

362

in

363

Function { id; assoc_list }

364

 NoName > NoName

365


366

method vhdl_assoc_element_t :

367

vhdl_assoc_element_t > vhdl_assoc_element_t=

368

fun

369

{ formal_name; formal_arg; actual_name; actual_designator;

370

actual_expr }

371

>

372

let formal_name = self#option self#lower_vhdl_name_t formal_name in

373

let formal_arg = self#option self#lower_vhdl_name_t formal_arg in

374

let actual_name = self#option self#lower_vhdl_name_t actual_name in

375

let actual_designator =

376

self#option self#lower_vhdl_name_t actual_designator in

377

let actual_expr = self#option self#vhdl_expr_t actual_expr in

378

{

379

formal_name;

380

formal_arg;

381

actual_name;

382

actual_designator;

383

actual_expr

384

}

385


386

method vhdl_element_assoc_t :

387

vhdl_element_assoc_t > vhdl_element_assoc_t=

388

fun { choices; expr } >

389

let choices = self#list self#vhdl_expr_t choices in

390

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

391


392

method vhdl_array_attributes_t :

393

vhdl_array_attributes_t > vhdl_array_attributes_t=

394

fun x >

395

match x with

396

 AAttInt { id; arg } >

397

let id = self#string id in

398

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

399

 AAttAscending > AAttAscending

400


401

method vhdl_signal_attributes_t :

402

vhdl_signal_attributes_t > vhdl_signal_attributes_t=

403

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

404


405

method vhdl_string_attributes_t :

406

vhdl_string_attributes_t > vhdl_string_attributes_t=

407

fun x >

408

match x with  StringAtt a > let a = self#string a in StringAtt a

409


410

method vhdl_suffix_selection_t : vhdl_suffix_selection_t > vhdl_suffix_selection_t=

411

fun x >

412

match x with

413

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

414

 SuffixRange (a,b) >

415

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

416


417

method vhdl_type_attributes_t :

418

'a .

419

('a > 'a) > 'a vhdl_type_attributes_t > 'a vhdl_type_attributes_t=

420

fun _basetype >

421

fun x >

422

match x with

423

 TAttNoArg { id } > let id = self#string id in TAttNoArg { id }

424

 TAttIntArg { id; arg } >

425

let id = self#string id in

426

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

427

 TAttValArg { id; arg } >

428

let id = self#string id in

429

let arg = _basetype arg in TAttValArg { id; arg }

430

 TAttStringArg { id; arg } >

431

let id = self#string id in

432

let arg = self#string arg in TAttStringArg { id; arg }

433


434

method vhdl_parameter_t : vhdl_parameter_t > vhdl_parameter_t=

435

fun { names; mode; typ; init_val } >

436

let names = self#list self#lower_vhdl_name_t names in

437

let mode = self#list self#string mode in

438

let typ = self#vhdl_subtype_indication_t typ in

439

let init_val = self#option self#vhdl_cst_val_t init_val in

440

{ names; mode; typ; init_val }

441


442

method vhdl_subprogram_spec_t :

443

vhdl_subprogram_spec_t > vhdl_subprogram_spec_t=

444

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

445

let name = self#string name in

446

let subprogram_type = self#string subprogram_type in

447

let typeMark = self#lower_vhdl_name_t typeMark in

448

let parameters = self#list self#vhdl_parameter_t parameters in

449

let isPure = self#bool isPure in

450

{ name; subprogram_type; typeMark; parameters; isPure }

451


452

method vhdl_sequential_stmt_t :

453

vhdl_sequential_stmt_t > mini_vhdl_sequential_stmt_t=

454

fun x >

455

match x with

456

 VarAssign { label; lhs; rhs } >

457

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

458

let lhs = self#lower_vhdl_name_t lhs in

459

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

460

 SigSeqAssign { label; lhs; rhs } >

461

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

462

let lhs = self#lower_vhdl_name_t lhs in

463

let rhs = self#list self#vhdl_waveform_element_t rhs in

464

SigSeqAssign { label; lhs; rhs }

465

 If { label; if_cases; default } >

466

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

467

let if_cases = List.map self#vhdl_if_case_t if_cases in

468

let default = List.map self#vhdl_sequential_stmt_t default in

469

If { label; if_cases; default }

470

 Case { label; guard; branches } >

471

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

472

let guard = self#vhdl_expr_t guard in

473

let branches = List.map self#vhdl_case_item_t branches in

474

Case { label; guard; branches }

475

 Exit { label; loop_label; condition } >

476

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

477

let loop_label = self#option self#string loop_label in

478

let condition = self#option self#vhdl_expr_t condition in

479

Exit { label; loop_label; condition }

480

 Assert { label; cond; report; severity } >

481

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

482

let cond = self#vhdl_expr_t cond in

483

let report = self#vhdl_expr_t report in

484

let severity = self#vhdl_expr_t severity in

485

Assert { label; cond; report; severity }

486

 ProcedureCall { label; name; assocs } >

487

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

488

let name = self#lower_vhdl_name_t name in

489

let assocs = self#list self#vhdl_assoc_element_t assocs in

490

ProcedureCall { label; name; assocs }

491

 Wait > Wait

492

 Null { label } >

493

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

494

Null { label }

495

 Return { label; expr } >

496

let label = self#option self#lower_vhdl_name_t label in

497

let expr = self#option self#vhdl_expr_t expr in

498

Return { label; expr }

499


500

method vhdl_if_case_t : vhdl_if_case_t > mini_vhdl_if_case_t=

501

fun { if_cond; if_block } >

502

let if_cond = self#vhdl_expr_t if_cond in

503

let if_block = List.map self#vhdl_sequential_stmt_t if_block in

504

{ if_cond; if_block }

505


506

method vhdl_case_item_t : vhdl_case_item_t > mini_vhdl_case_item_t=

507

fun { when_cond; when_stmt } >

508

let when_cond = self#list self#vhdl_expr_t when_cond in

509

let when_stmt = List.map self#vhdl_sequential_stmt_t when_stmt in

510

{ when_cond; when_stmt }

511


512

method vhdl_declaration_t : vhdl_declaration_t > mini_vhdl_declaration_t=

513

fun x >

514

match x with

515

 VarDecl { names; typ; init_val } >

516

let names = self#list self#lower_vhdl_name_t names in

517

let typ = self#vhdl_subtype_indication_t typ in

518

let init_val = self#vhdl_expr_t init_val in

519

VarDecl { names; typ; init_val }

520

 CstDecl { names; typ; init_val } >

521

let names = self#list self#lower_vhdl_name_t names in

522

let typ = self#vhdl_subtype_indication_t typ in

523

let init_val = self#vhdl_expr_t init_val in

524

CstDecl { names; typ; init_val }

525

 SigDecl { names; typ; init_val } >

526

let names = self#list self#lower_vhdl_name_t names in

527

let typ = self#vhdl_subtype_indication_t typ in

528

let init_val = self#vhdl_expr_t init_val in

529

SigDecl { names; typ; init_val }

530

 ComponentDecl { name; generics; ports } >

531

let name = self#lower_vhdl_name_t name in

532

let generics = self#list self#vhdl_port_t generics in

533

let ports = self#list self#vhdl_port_t ports in

534

ComponentDecl { name; generics; ports }

535

 Subprogram { spec; decl_part; stmts } >

536

let spec = self#vhdl_subprogram_spec_t spec in

537

let decl_part = List.map self#vhdl_declaration_t decl_part in

538

let stmts = List.map self#vhdl_sequential_stmt_t stmts in

539

Subprogram { spec; decl_part; stmts }

540


541

method vhdl_declarative_item_t :

542

vhdl_declarative_item_t > mini_vhdl_declarative_item_t=

543

fun { use_clause; declaration; definition } >

544

let use_clause = self#option self#vhdl_load_t use_clause in

545

let declaration =

546

match declaration with

547

 None > None

548

 Some a > Some (self#vhdl_declaration_t a) in

549

let definition = self#option self#vhdl_definition_t definition in

550

{ use_clause; declaration; definition }

551


552

method vhdl_waveform_element_t :

553

vhdl_waveform_element_t > vhdl_waveform_element_t=

554

fun { value; delay } >

555

let value = self#option self#vhdl_expr_t value in

556

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

557


558

method vhdl_signal_condition_t :

559

vhdl_signal_condition_t > vhdl_signal_condition_t=

560

fun { expr; cond } >

561

let expr = self#list self#vhdl_waveform_element_t expr in

562

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

563


564

method vhdl_signal_selection_t :

565

vhdl_signal_selection_t > vhdl_signal_selection_t=

566

fun { expr; when_sel } >

567

let expr = self#list self#vhdl_waveform_element_t expr in

568

let when_sel = self#list self#vhdl_expr_t when_sel in

569

{ expr; when_sel }

570


571

method vhdl_conditional_signal_t :

572

vhdl_conditional_signal_t > vhdl_conditional_signal_t=

573

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

574

let postponed = self#bool postponed in

575

let label = self#lower_vhdl_name_t label in

576

let lhs = self#lower_vhdl_name_t lhs in

577

let rhs = self#list self#vhdl_signal_condition_t rhs in

578

let delay = self#vhdl_expr_t delay in

579

{ postponed; label; lhs; rhs; delay }

580


581

method vhdl_process_t : vhdl_process_t > mini_vhdl_process_t=

582

fun { id; declarations; active_sigs; body } >

583

let id = self#lower_vhdl_name_t id in

584

let declarations = List.map self#vhdl_declarative_item_t declarations in

585

let active_sigs = self#list self#lower_vhdl_name_t active_sigs in

586

let body = List.map self#vhdl_sequential_stmt_t body in

587

let postponed = false in

588

let label = None in

589

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

590


591

method vhdl_selected_signal_t :

592

vhdl_selected_signal_t > vhdl_selected_signal_t=

593

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

594

let postponed = self#bool postponed in

595

let label = self#lower_vhdl_name_t label in

596

let lhs = self#lower_vhdl_name_t lhs in

597

let sel = self#vhdl_expr_t sel in

598

let branches = self#list self#vhdl_signal_selection_t branches in

599

let delay = self#option self#vhdl_expr_t delay in

600

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

601


602

method vhdl_port_mode_t : vhdl_port_mode_t > vhdl_port_mode_t=

603

fun x > x

604


605

method vhdl_component_instantiation_t :

606

vhdl_component_instantiation_t > mini_vhdl_component_instantiation_t=

607

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

608

let name = self#lower_vhdl_name_t name in

609

let archi_name = self#option self#lower_vhdl_name_t archi_name in

610

let inst_unit = self#lower_vhdl_name_t inst_unit in

611

let db_tuple = match archi_name with

612

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

613

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

614

let archi = db_tuple.architecture in

615

let entity = db_tuple.entity in

616

let generic_map = self#list self#vhdl_assoc_element_t generic_map in

617

let port_map = self#list self#vhdl_assoc_element_t port_map in

618

{ name; archi; entity; generic_map; port_map }

619


620

method vhdl_concurrent_stmt_t :

621

vhdl_concurrent_stmt_t > mini_vhdl_concurrent_stmt_t=

622

fun x >

623

match x with

624

 SigAssign a >

625

Process {

626

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

627

declarations = [];

628

active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x []; (* TODO: Resolve sensitivity list from here *)

629

body = (SigCondAssign {

630

label = None;

631

lhs = a.lhs;

632

rhs = a.rhs;

633

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

634

})::[];

635

postponed = a.postponed;

636

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

637

}

638

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

639

 SelectedSig a >

640

Process {

641

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

642

declarations = [];

643

active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x []; (* TODO: Resolve sensitivity list from here *)

644

body = (SigSelectAssign {

645

label = None;

646

lhs = a.lhs;

647

sel = a.sel;

648

branches = a.branches;

649

delay = a.delay

650

})::[];

651

postponed = a.postponed;

652

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

653

}

654

 ComponentInst a > let a = self#vhdl_component_instantiation_t a in ComponentInst a (* TODO: instantiate *)

655


656

method vhdl_port_t : vhdl_port_t > vhdl_port_t=

657

fun { names; mode; typ; expr } >

658

let names = self#list self#lower_vhdl_name_t names in

659

let mode = self#vhdl_port_mode_t mode in

660

let typ = self#vhdl_subtype_indication_t typ in

661

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

662


663

method vhdl_entity_t : vhdl_entity_t > unit =

664

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

665


666

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

667

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

668

let name = self#lower_vhdl_name_t name in

669

let shared_defs = self#list self#vhdl_definition_t shared_defs in

670

let shared_decls = List.map self#vhdl_declaration_t shared_decls in

671

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

672

{ name; shared_defs; shared_decls; shared_uses }

673


674

method vhdl_load_t : vhdl_load_t > vhdl_load_t=

675

fun x >

676

match x with

677

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

678

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

679


680

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

681

(vhdl_load_t list * vhdl_entity_t) list *

682

(vhdl_load_t list * vhdl_configuration_t) list *

683

(vhdl_load_t list * vhdl_architecture_t)) > mini_vhdl_component_t=

684

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

685

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

686

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

687

let contexts =

688

ref_ent_ctx @ (* Referenced entity context elements *)

689

arch_ctx @ (* Architecture context elements *)

690

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

691

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

692

let declarations =

693

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

694

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

695

let definitions =

696

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

697

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

698

let body =

699

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

700

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

701

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

702

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

703

let declarations = List.map self#vhdl_declaration_t declarations in

704

let signals =

705

let rec find_sig_decls declarations =

706

match declarations with

707

 [] > []

708

 (SigDecl (s))::tl > (SigDecl (s))::find_sig_decls tl

709

 _::tl > find_sig_decls tl in find_sig_decls declarations in

710

self#db_add_tuple { entity=ref_ent;

711

architecture=arch;

712

architecture_signals=signals;

713

contexts=ref_ent_ctx@arch_ctx

714

};

715

{ names;

716

generics=generics;

717

ports=ports;

718

contexts=contexts;

719

declarations=declarations;

720

definitions=definitions;

721

body=body (* TODO: Flatten component instantiation from here *)

722

}

723


724

method declarative_items_declarations : vhdl_declarative_item_t list > vhdl_declaration_t list =

725

fun x >

726

match x with

727

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

728

 _::tl > self#declarative_items_declarations tl

729

 [] > []

730


731

method declarative_items_definitions : vhdl_declarative_item_t list > vhdl_definition_t list =

732

fun x >

733

match x with

734

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

735

 _::tl > self#declarative_items_definitions tl

736

 [] > []

737


738

method declarative_items_uses : vhdl_declarative_item_t list > vhdl_load_t list =

739

fun x >

740

match x with

741

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

742

 _::tl > self#declarative_items_uses tl

743

 [] > []

744


745

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

746

(vhdl_load_t list * vhdl_entity_t) =

747

fun ( entities_pair, filter_name ) >

748

let rec filter ep n = match ep with

749

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

750

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

751

if (name = n) then

752

List.hd ep

753

else filter (List.tl ep) n in

754

filter entities_pair filter_name

755


756

method vhdl_configuration_t :

757

vhdl_configuration_t > unit= self#unit

758


759

method vhdl_library_unit_t : vhdl_library_unit_t > unit=

760

fun x > ()

761


762

method vhdl_design_unit_t : vhdl_design_unit_t > unit=

763

fun { contexts; library } > ()

764


765

method vhdl_design_file_t : vhdl_design_file_t > mini_vhdl_design_file_t=

766

fun { design_units } >

767

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

768

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

769

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

770

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

771

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

772

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

773

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

774

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

775

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

776

let components = List.map app a in

777

let packages = List.map self#vhdl_package_t p in

778

{ components; packages }

779


780

end
