1

open Vhdl_ast

2

open Mini_vhdl_ast

3


4

type db_tuple_t =

5

{

6

mutable entity: vhdl_entity_t;

7

mutable architecture: vhdl_architecture_t;

8

mutable contexts: vhdl_load_t list;

9

}

10


11

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

12

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

13

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

14

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

15

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

16

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

17

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

18

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

19

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

20

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

21

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

22

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

23

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

24

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

25

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

26

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

27

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

28

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

29

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

30

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

31

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

32

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

33

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

34

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

35

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

36

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

37

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

38

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

39

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

40

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

41

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

42

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

43

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

44

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

45

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

46

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

47

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

48

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

49

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

50

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

51

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

52


53

class virtual vhdl_2_mini_vhdl_map =

54

object (self)

55

method virtual string : string > string

56

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

57

method virtual unit : unit > unit

58

method virtual bool : bool > bool

59

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

60

method virtual int : int > int

61

method virtual vhdl_name_t : vhdl_name_t > vhdl_name_t

62

method virtual vhdl_definition_t : vhdl_definition_t > vhdl_definition_t

63

method virtual vhdl_port_t : vhdl_port_t > vhdl_port_t

64

method virtual vhdl_expr_t : vhdl_expr_t > vhdl_expr_t

65

method virtual vhdl_port_mode_t : vhdl_port_mode_t > vhdl_port_mode_t

66

method virtual vhdl_element_declaration_t : vhdl_element_declaration_t > vhdl_element_declaration_t

67

method virtual vhdl_subtype_indication_t : vhdl_subtype_indication_t > vhdl_subtype_indication_t

68

method virtual vhdl_conditional_signal_t : vhdl_conditional_signal_t > vhdl_conditional_signal_t

69

method virtual vhdl_process_t : vhdl_process_t > vhdl_process_t

70

method virtual vhdl_selected_signal_t : vhdl_selected_signal_t > vhdl_selected_signal_t

71

method virtual vhdl_signal_selection_t : vhdl_signal_selection_t > vhdl_signal_selection_t

72

method virtual vhdl_suffix_selection_t : vhdl_suffix_selection_t > vhdl_suffix_selection_t

73

method virtual vhdl_declaration_t : vhdl_declaration_t > vhdl_declaration_t

74

method virtual vhdl_sequential_stmt_t : vhdl_sequential_stmt_t > vhdl_sequential_stmt_t

75

method virtual vhdl_declarative_item_t : vhdl_declarative_item_t > vhdl_declarative_item_t

76

method virtual vhdl_waveform_element_t : vhdl_waveform_element_t > vhdl_waveform_element_t

77

method virtual vhdl_signal_condition_t : vhdl_signal_condition_t > vhdl_signal_condition_t

78

method virtual vhdl_cst_val_t : vhdl_cst_val_t > vhdl_cst_val_t

79

method virtual vhdl_subprogram_spec_t : vhdl_subprogram_spec_t > vhdl_subprogram_spec_t

80

method virtual vhdl_discrete_range_t : vhdl_discrete_range_t > vhdl_discrete_range_t

81

method virtual vhdl_parameter_t : vhdl_parameter_t > vhdl_parameter_t

82

method virtual vhdl_concurrent_stmt_t : vhdl_concurrent_stmt_t > mini_vhdl_concurrent_stmt_t

83

method virtual vhdl_declaration_t : vhdl_declaration_t > vhdl_declaration_t

84

method virtual vhdl_configuration_t : vhdl_configuration_t > unit

85

method virtual vhdl_entity_t : vhdl_entity_t > unit

86

method virtual vhdl_library_unit_t : vhdl_library_unit_t > unit

87

method virtual vhdl_load_t : vhdl_load_t > vhdl_load_t

88

method virtual vhdl_design_unit_t : vhdl_design_unit_t > unit

89

method virtual vhdl_design_file_t : vhdl_design_file_t > mini_vhdl_design_file_t

90


91

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

92

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

93

(vhdl_load_t list * vhdl_entity_t) list *

94

(vhdl_load_t list * vhdl_configuration_t) list *

95

(vhdl_load_t list * vhdl_architecture_t)) > mini_vhdl_component_t

96

method virtual vhdl_component_instantiation_t : vhdl_component_instantiation_t > mini_vhdl_component_instantiation_t

97

method virtual declarative_items_declarations : vhdl_declarative_item_t list > vhdl_declaration_t list

98

method virtual declarative_items_definitions : vhdl_declarative_item_t list > vhdl_definition_t list

99

method virtual declarative_items_uses : vhdl_declarative_item_t list > vhdl_load_t list

100

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

101

(vhdl_load_t list * vhdl_entity_t)

102


103

val mutable db : db_tuple_t list = []

104


105

method simplify_name_t : vhdl_name_t > vhdl_name_t=

106

fun n >

107

match n with

108

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

109

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

110

then self#simplify_name_t (Selected tl)

111

else n

112

 Selected (a::[]) > a

113

 _ > n

114


115

method db_add_tuple : db_tuple_t > unit=

116

fun x > db < x::db

117


118

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

119

fun x >

120

let rec find a dbl =

121

match dbl with

122

 [] > failwith "No matching tuple in DB"

123

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

124


125

method get_get_from_archi_entity_name : (vhdl_name_t * vhdl_name_t) > db_tuple_t=

126

fun (a_name,e_name) >

127

let rec find (a_name,e_name) dbl =

128

match dbl with

129

 [] > failwith "No matching tuple in DB"

130

 e::tl > if ((self#simplify_name_t e.architecture.name = self#simplify_name_t a_name) && (self#simplify_name_t e.entity.name = self#simplify_name_t e_name))

131

then e

132

else find (a_name,e_name) tl in

133

find (a_name,e_name) db

134


135

method vhdl_cst_val_t : vhdl_cst_val_t > vhdl_cst_val_t=

136

fun x >

137

match x with

138

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

139

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

140

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

141


142

method vhdl_type_t : vhdl_type_t > vhdl_type_t=

143

fun x >

144

match x with

145

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

146

 Range (a,b,c) >

147

let a = self#option self#string a in

148

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

149

 Bit_vector (a,b) >

150

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

151

 Array { indexes; const; definition } >

152

let indexes = self#list self#vhdl_name_t indexes in

153

let const = self#option self#vhdl_constraint_t const in

154

let definition = self#vhdl_subtype_indication_t definition in

155

Array { indexes; const; definition }

156

 Record a >

157

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

158

 Enumerated a >

159

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

160

 Void > Void

161

method vhdl_element_declaration_t :

162

vhdl_element_declaration_t > vhdl_element_declaration_t=

163

fun { names; definition } >

164

let names = self#list self#vhdl_name_t names in

165

let definition = self#vhdl_subtype_indication_t definition in

166

{ names; definition }

167

method vhdl_subtype_indication_t :

168

vhdl_subtype_indication_t > vhdl_subtype_indication_t=

169

fun { name; functionName; const } >

170

let name = self#vhdl_name_t name in

171

let functionName = self#vhdl_name_t functionName in

172

let const = self#vhdl_constraint_t const in

173

{ name; functionName; const }

174

method vhdl_discrete_range_t :

175

vhdl_discrete_range_t > vhdl_discrete_range_t=

176

fun x >

177

match x with

178

 SubDiscreteRange a >

179

let a = self#vhdl_subtype_indication_t a in SubDiscreteRange a

180

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

181

 DirectedRange { direction; from; _to } >

182

let direction = self#string direction in

183

let from = self#vhdl_expr_t from in

184

let _to = self#vhdl_expr_t _to in

185

DirectedRange { direction; from; _to }

186


187

method vhdl_constraint_t : vhdl_constraint_t > vhdl_constraint_t=

188

fun x >

189

match x with

190

 RefConstraint { ref_name } >

191

let ref_name = self#vhdl_name_t ref_name in

192

RefConstraint { ref_name }

193

 RangeConstraint { range } >

194

let range = self#vhdl_discrete_range_t range in

195

RangeConstraint { range }

196

 IndexConstraint { ranges } >

197

let ranges = self#list self#vhdl_discrete_range_t ranges in

198

IndexConstraint { ranges }

199

 ArrayConstraint { ranges; sub } >

200

let ranges = self#list self#vhdl_discrete_range_t ranges in

201

let sub = self#vhdl_constraint_t sub in

202

ArrayConstraint { ranges; sub }

203

 RecordConstraint > RecordConstraint

204

 NoConstraint > NoConstraint

205


206

method vhdl_definition_t : vhdl_definition_t > vhdl_definition_t=

207

fun x >

208

match x with

209

 Type { name; definition } >

210

let name = self#vhdl_name_t name in

211

let definition = self#vhdl_type_t definition in

212

Type { name; definition }

213

 Subtype { name; typ } >

214

let name = self#vhdl_name_t name in

215

let typ = self#vhdl_subtype_indication_t typ in

216

Subtype { name; typ }

217

method vhdl_expr_t : vhdl_expr_t > vhdl_expr_t=

218

fun x >

219

match x with

220

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

221

 Cst { value; unit_name } >

222

let value = self#vhdl_cst_val_t value in

223

let unit_name = self#option self#vhdl_name_t unit_name in

224

Cst { value; unit_name }

225

 Op { id; args } >

226

let id = self#string id in

227

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

228

 IsNull > IsNull

229

 Time { value; phy_unit } >

230

let value = self#int value in

231

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

232

 Sig { name; att } >

233

let name = self#vhdl_name_t name in

234

let att = self#option self#vhdl_signal_attributes_t att in

235

Sig { name; att }

236

 SuffixMod { expr; selection } >

237

let expr = self#vhdl_expr_t expr in

238

let selection = self#vhdl_suffix_selection_t selection in

239

SuffixMod { expr; selection }

240

 Aggregate { elems } >

241

let elems = self#list self#vhdl_element_assoc_t elems in

242

Aggregate { elems }

243

 QualifiedExpression { type_mark; aggregate; expression } >

244

let type_mark = self#vhdl_name_t type_mark in

245

let aggregate = self#list self#vhdl_element_assoc_t aggregate in

246

let expression = self#option self#vhdl_expr_t expression in

247

QualifiedExpression { type_mark; aggregate; expression }

248

 Others > Others

249

method vhdl_name_t : vhdl_name_t > vhdl_name_t=

250

fun x >

251

match x with

252

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

253

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

254

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

255

 Index { id; exprs } >

256

let id = self#vhdl_name_t id in

257

let exprs = self#list self#vhdl_expr_t exprs in

258

Index { id; exprs }

259

 Slice { id; range } >

260

let id = self#vhdl_name_t id in

261

let range = self#vhdl_discrete_range_t range in

262

Slice { id; range }

263

 Attribute { id; designator; expr } >

264

let id = self#vhdl_name_t id in

265

let designator = self#vhdl_name_t designator in

266

let expr = self#vhdl_expr_t expr in

267

Attribute { id; designator; expr }

268

 Function { id; assoc_list } >

269

let id = self#vhdl_name_t id in

270

let assoc_list = self#list self#vhdl_assoc_element_t assoc_list

271

in

272

Function { id; assoc_list }

273

 NoName > NoName

274

method vhdl_assoc_element_t :

275

vhdl_assoc_element_t > vhdl_assoc_element_t=

276

fun

277

{ formal_name; formal_arg; actual_name; actual_designator;

278

actual_expr }

279

>

280

let formal_name = self#option self#vhdl_name_t formal_name in

281

let formal_arg = self#option self#vhdl_name_t formal_arg in

282

let actual_name = self#option self#vhdl_name_t actual_name in

283

let actual_designator =

284

self#option self#vhdl_name_t actual_designator in

285

let actual_expr = self#option self#vhdl_expr_t actual_expr in

286

{

287

formal_name;

288

formal_arg;

289

actual_name;

290

actual_designator;

291

actual_expr

292

}

293

method vhdl_element_assoc_t :

294

vhdl_element_assoc_t > vhdl_element_assoc_t=

295

fun { choices; expr } >

296

let choices = self#list self#vhdl_expr_t choices in

297

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

298

method vhdl_array_attributes_t :

299

vhdl_array_attributes_t > vhdl_array_attributes_t=

300

fun x >

301

match x with

302

 AAttInt { id; arg } >

303

let id = self#string id in

304

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

305

 AAttAscending > AAttAscending

306

method vhdl_signal_attributes_t :

307

vhdl_signal_attributes_t > vhdl_signal_attributes_t=

308

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

309

method vhdl_string_attributes_t :

310

vhdl_string_attributes_t > vhdl_string_attributes_t=

311

fun x >

312

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

313

method vhdl_suffix_selection_t : vhdl_suffix_selection_t > vhdl_suffix_selection_t=

314

fun x >

315

match x with

316

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

317

 SuffixRange (a,b) >

318

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

319


320

method vhdl_type_attributes_t :

321

'a .

322

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

323

fun _basetype >

324

fun x >

325

match x with

326

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

327

 TAttIntArg { id; arg } >

328

let id = self#string id in

329

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

330

 TAttValArg { id; arg } >

331

let id = self#string id in

332

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

333

 TAttStringArg { id; arg } >

334

let id = self#string id in

335

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

336


337

method vhdl_parameter_t : vhdl_parameter_t > vhdl_parameter_t=

338

fun { names; mode; typ; init_val } >

339

let names = self#list self#vhdl_name_t names in

340

let mode = self#list self#string mode in

341

let typ = self#vhdl_subtype_indication_t typ in

342

let init_val = self#option self#vhdl_cst_val_t init_val in

343

{ names; mode; typ; init_val }

344


345

method vhdl_subprogram_spec_t :

346

vhdl_subprogram_spec_t > vhdl_subprogram_spec_t=

347

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

348

let name = self#string name in

349

let subprogram_type = self#string subprogram_type in

350

let typeMark = self#vhdl_name_t typeMark in

351

let parameters = self#list self#vhdl_parameter_t parameters in

352

let isPure = self#bool isPure in

353

{ name; subprogram_type; typeMark; parameters; isPure }

354


355

method vhdl_sequential_stmt_t :

356

vhdl_sequential_stmt_t > vhdl_sequential_stmt_t=

357

fun x >

358

match x with

359

 VarAssign { label; lhs; rhs } >

360

let label = self#vhdl_name_t label in

361

let lhs = self#vhdl_name_t lhs in

362

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

363

 SigSeqAssign { label; lhs; rhs } >

364

let label = self#vhdl_name_t label in

365

let lhs = self#vhdl_name_t lhs in

366

let rhs = self#list self#vhdl_waveform_element_t rhs in

367

SigSeqAssign { label; lhs; rhs }

368

 If { label; if_cases; default } >

369

let label = self#vhdl_name_t label in

370

let if_cases = self#list self#vhdl_if_case_t if_cases in

371

let default = self#list self#vhdl_sequential_stmt_t default in

372

If { label; if_cases; default }

373

 Case { label; guard; branches } >

374

let label = self#vhdl_name_t label in

375

let guard = self#vhdl_expr_t guard in

376

let branches = self#list self#vhdl_case_item_t branches in

377

Case { label; guard; branches }

378

 Exit { label; loop_label; condition } >

379

let label = self#vhdl_name_t label in

380

let loop_label = self#option self#string loop_label in

381

let condition = self#option self#vhdl_expr_t condition in

382

Exit { label; loop_label; condition }

383

 Assert { label; cond; report; severity } >

384

let label = self#vhdl_name_t label in

385

let cond = self#vhdl_expr_t cond in

386

let report = self#vhdl_expr_t report in

387

let severity = self#vhdl_expr_t severity in

388

Assert { label; cond; report; severity }

389

 ProcedureCall { label; name; assocs } >

390

let label = self#vhdl_name_t label in

391

let name = self#vhdl_name_t name in

392

let assocs = self#list self#vhdl_assoc_element_t assocs in

393

ProcedureCall { label; name; assocs }

394

 Wait > Wait

395

 Null { label } >

396

let label = self#vhdl_name_t label in Null { label }

397

 Return { label; expr } >

398

let label = self#option self#vhdl_name_t label in

399

let expr = self#option self#vhdl_expr_t expr in

400

Return { label; expr }

401

method vhdl_if_case_t : vhdl_if_case_t > vhdl_if_case_t=

402

fun { if_cond; if_block } >

403

let if_cond = self#vhdl_expr_t if_cond in

404

let if_block = self#list self#vhdl_sequential_stmt_t if_block in

405

{ if_cond; if_block }

406

method vhdl_case_item_t : vhdl_case_item_t > vhdl_case_item_t=

407

fun { when_cond; when_stmt } >

408

let when_cond = self#list self#vhdl_expr_t when_cond in

409

let when_stmt = self#list self#vhdl_sequential_stmt_t when_stmt in

410

{ when_cond; when_stmt }

411


412

method vhdl_declaration_t : vhdl_declaration_t > vhdl_declaration_t=

413

fun x >

414

match x with

415

 VarDecl { names; typ; init_val } >

416

let names = self#list self#vhdl_name_t names in

417

let typ = self#vhdl_subtype_indication_t typ in

418

let init_val = self#vhdl_expr_t init_val in

419

VarDecl { names; typ; init_val }

420

 CstDecl { names; typ; init_val } >

421

let names = self#list self#vhdl_name_t names in

422

let typ = self#vhdl_subtype_indication_t typ in

423

let init_val = self#vhdl_expr_t init_val in

424

CstDecl { names; typ; init_val }

425

 SigDecl { names; typ; init_val } >

426

let names = self#list self#vhdl_name_t names in

427

let typ = self#vhdl_subtype_indication_t typ in

428

let init_val = self#vhdl_expr_t init_val in

429

SigDecl { names; typ; init_val }

430

 ComponentDecl { name; generics; ports } >

431

let name = self#vhdl_name_t name in

432

let generics = self#list self#vhdl_port_t generics in

433

let ports = self#list self#vhdl_port_t ports in

434

ComponentDecl { name; generics; ports }

435

 Subprogram { spec; decl_part; stmts } >

436

let spec = self#vhdl_subprogram_spec_t spec in

437

let decl_part = self#list self#vhdl_declaration_t decl_part in

438

let stmts = self#list self#vhdl_sequential_stmt_t stmts in

439

Subprogram { spec; decl_part; stmts }

440


441

method vhdl_declarative_item_t :

442

vhdl_declarative_item_t > vhdl_declarative_item_t=

443

fun { use_clause; declaration; definition } >

444

let use_clause = self#option self#vhdl_load_t use_clause in

445

let declaration = self#option self#vhdl_declaration_t declaration in

446

let definition = self#option self#vhdl_definition_t definition in

447

{ use_clause; declaration; definition }

448


449

method vhdl_waveform_element_t :

450

vhdl_waveform_element_t > vhdl_waveform_element_t=

451

fun { value; delay } >

452

let value = self#option self#vhdl_expr_t value in

453

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

454


455

method vhdl_signal_condition_t :

456

vhdl_signal_condition_t > vhdl_signal_condition_t=

457

fun { expr; cond } >

458

let expr = self#list self#vhdl_waveform_element_t expr in

459

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

460


461

method vhdl_signal_selection_t :

462

vhdl_signal_selection_t > vhdl_signal_selection_t=

463

fun { expr; when_sel } >

464

let expr = self#list self#vhdl_waveform_element_t expr in

465

let when_sel = self#list self#vhdl_expr_t when_sel in

466

{ expr; when_sel }

467


468

method vhdl_conditional_signal_t :

469

vhdl_conditional_signal_t > vhdl_conditional_signal_t=

470

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

471

let postponed = self#bool postponed in

472

let label = self#vhdl_name_t label in

473

let lhs = self#vhdl_name_t lhs in

474

let rhs = self#list self#vhdl_signal_condition_t rhs in

475

let delay = self#vhdl_expr_t delay in

476

{ postponed; label; lhs; rhs; delay }

477


478

method vhdl_process_t : vhdl_process_t > vhdl_process_t=

479

fun { id; declarations; active_sigs; body } >

480

let id = self#vhdl_name_t id in

481

let declarations = self#list self#vhdl_declarative_item_t declarations in

482

let active_sigs = self#list self#vhdl_name_t active_sigs in

483

let body = self#list self#vhdl_sequential_stmt_t body in

484

{ id; declarations; active_sigs; body }

485


486

method vhdl_selected_signal_t :

487

vhdl_selected_signal_t > vhdl_selected_signal_t=

488

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

489

let postponed = self#bool postponed in

490

let label = self#vhdl_name_t label in

491

let lhs = self#vhdl_name_t lhs in

492

let sel = self#vhdl_expr_t sel in

493

let branches = self#list self#vhdl_signal_selection_t branches in

494

let delay = self#option self#vhdl_expr_t delay in

495

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

496


497

method vhdl_port_mode_t : vhdl_port_mode_t > vhdl_port_mode_t=

498

fun x > x

499


500

method vhdl_component_instantiation_t :

501

vhdl_component_instantiation_t > mini_vhdl_component_instantiation_t=

502

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

503

let name = self#vhdl_name_t name in

504

let archi_name = self#option self#vhdl_name_t archi_name in

505

let db_tuple = match archi_name with

506

 None > failwith "Component is not an entity"

507

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

508

let archi = db_tuple.architecture in

509

let entity = db_tuple.entity in

510

let generic_map = self#list self#vhdl_assoc_element_t generic_map in

511

let port_map = self#list self#vhdl_assoc_element_t port_map in

512

{ name; archi; entity; generic_map; port_map }

513


514

method vhdl_concurrent_stmt_t :

515

vhdl_concurrent_stmt_t > mini_vhdl_concurrent_stmt_t=

516

fun x >

517

match x with

518

 SigAssign a > let a = self#vhdl_conditional_signal_t a in SigAssign a

519

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

520

 SelectedSig a > let a = self#vhdl_selected_signal_t a in SelectedSig a

521

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

522


523

method vhdl_port_t : vhdl_port_t > vhdl_port_t=

524

fun { names; mode; typ; expr } >

525

let names = self#list self#vhdl_name_t names in

526

let mode = self#vhdl_port_mode_t mode in

527

let typ = self#vhdl_subtype_indication_t typ in

528

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

529


530

method vhdl_entity_t : vhdl_entity_t > unit =

531

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

532

(* let name = self#vhdl_name_t name in

533

let generics = self#list self#vhdl_port_t generics in

534

let ports = self#list self#vhdl_port_t ports in

535

let declaration = self#list self#vhdl_declarative_item_t declaration

536

in

537

let stmts = self#list self#vhdl_concurrent_stmt_t stmts in () *)

538


539


540


541

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

542

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

543

let name = self#vhdl_name_t name in

544

let shared_defs = self#list self#vhdl_definition_t shared_defs in

545

let shared_decls = self#list self#vhdl_declaration_t shared_decls in

546

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

547

{ name; shared_defs; shared_decls; shared_uses }

548


549

method vhdl_load_t : vhdl_load_t > vhdl_load_t=

550

fun x >

551

match x with

552

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

553

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

554


555

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

556

(vhdl_load_t list * vhdl_entity_t) list *

557

(vhdl_load_t list * vhdl_configuration_t) list *

558

(vhdl_load_t list * vhdl_architecture_t)) > mini_vhdl_component_t=

559

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

560

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

561

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

562

self#db_add_tuple {entity=ref_ent; architecture=arch; contexts=ref_ent_ctx@arch_ctx};

563

let contexts =

564

ref_ent_ctx @ (* Referenced entity context elements *)

565

arch_ctx @ (* Architecture context elements *)

566

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

567

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

568

let declarations =

569

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

570

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

571

let definitions =

572

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

573

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

574

let body =

575

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

576

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

577

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

578

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

579

{ names; generics=generics; ports=ports; contexts=contexts; declarations=declarations; definitions=definitions; body=body }

580


581

method declarative_items_declarations : vhdl_declarative_item_t list > vhdl_declaration_t list =

582

fun x >

583

let rec map_decls l = match l with

584

 {use_clause=_; declaration=Some a;definition=_}::tl > a::map_decls tl

585

 _::tl > map_decls tl

586

 [] > [] in map_decls x

587


588

method declarative_items_definitions : vhdl_declarative_item_t list > vhdl_definition_t list =

589

fun x >

590

let rec map_decls l = match l with

591

 {use_clause=_; declaration=_;definition=Some a}::tl > a::map_decls tl

592

 _::tl > map_decls tl

593

 [] > [] in map_decls x

594


595

method declarative_items_uses : vhdl_declarative_item_t list > vhdl_load_t list =

596

fun x >

597

let rec map_decls l = match l with

598

 {use_clause=Some a; declaration=_;definition=_}::tl > a::map_decls tl

599

 _::tl > map_decls tl

600

 [] > [] in map_decls x

601


602

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

603

(vhdl_load_t list * vhdl_entity_t) =

604

fun ( entities_pair, filter_name ) >

605

let rec filter ep n = match ep with

606

 [] > failwith "Impossible to find a matching entity"

607

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

608

if (name = n) then

609

List.hd ep

610

else filter (List.tl ep) n in

611

filter entities_pair filter_name

612


613

method vhdl_configuration_t :

614

vhdl_configuration_t > unit= self#unit

615


616

method vhdl_library_unit_t : vhdl_library_unit_t > unit=

617

fun x > ()

618

(* match x with

619

 Package a > let a = self#vhdl_package_t ([],a) in ()

620

 Entities a > let a = self#vhdl_entity_t a in ()

621

 Architecture a >

622

let a = self#vhdl_architecture_t ([],[],[],([],a)) in ()

623

 Configuration a >

624

let a = self#vhdl_configuration_t a in () *)

625


626

method vhdl_design_unit_t : vhdl_design_unit_t > unit=

627

fun { contexts; library } > ()

628

(* let contexts = self#list self#vhdl_load_t contexts in

629

let library = self#vhdl_library_unit_t library in () *)

630


631

method vhdl_design_file_t : vhdl_design_file_t > mini_vhdl_design_file_t=

632

fun { design_units } >

633

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

634

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

635

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

636

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

637

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

638

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

639

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

640

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

641

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

642

let components = List.map app a in

643

let packages = List.map self#vhdl_package_t p in

644

{ components; packages }

645


646

end
