1

open Vhdl_ast

2

open Vhdl_ast_pp

3

open Mini_vhdl_ast

4

open Vhdl_2_mini_vhdl_map

5

open Lustre_types

6

open Utils

7


8

class virtual mini_vhdl_to_lustre_map =

9

object (self)

10


11

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

12

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

13

method virtual string : string > string

14

method virtual int : int > int

15


16

(*

17

* Lustre structure constructors

18

*)

19

method lustre_mk_var_decl : vhdl_port_mode_t > vhdl_name_t list > vhdl_subtype_indication_t > var_decl list=

20

fun mode > fun names > fun typ >

21

let var_id_list = List.map show_vhdl_name_t names in

22

let var_orig = match mode with InPort > true  _ > false in

23

let var_dec_type = self#vhdl_subtype_indication_t_type_dec typ in

24

let var_dec_clock = {ck_dec_desc = Ckdec_any; ck_dec_loc = Location.dummy_loc } in

25

let var_dec_const = false in

26

let var_dec_value = None in

27

let var_parent_nodeid = None in

28

let var_type = self#vhdl_subtype_indication_t typ in

29

let var_clock = Clocks.new_ck Cvar false in

30

let var_loc = Location.dummy_loc in

31

List.map (fun var_id > {var_id;var_orig;var_dec_type;var_dec_clock;var_dec_const;

32

var_dec_value;var_parent_nodeid;var_type;var_clock;var_loc}) var_id_list

33


34

method lustre_mk_node : vhdl_name_t list > var_decl list > vhdl_port_t list > mini_vhdl_concurrent_stmt_t list > top_decl_desc=

35

fun names > fun node_locals > fun ports > fun c_stmts >

36

let node_id = String.concat "__" (List.map show_vhdl_name_t names) in

37

let node_type = Types.new_var () in

38

let node_clock = Clocks.new_ck Cvar false in

39

let in_ports = Mini_vhdl_utils.get_ports ports InPort in

40

let inports_names = List.map Mini_vhdl_utils.get_names in_ports in

41

let inports_types = List.map (fun x > x.port_typ) in_ports in

42

let node_inputs = List.flatten (List.map2 (self#lustre_mk_var_decl InPort) inports_names inports_types) in

43

let out_ports = Mini_vhdl_utils.get_ports ports OutPort in

44

let outports_names = List.map Mini_vhdl_utils.get_names out_ports in

45

let outports_types = List.map (fun x > x.port_typ) out_ports in

46

let node_outputs = List.flatten (List.map2 (self#lustre_mk_var_decl OutPort) outports_names outports_types) in

47

(* TODO: deal with inout ports *)

48

let body = List.map self#mini_vhdl_concurrent_stmt_t c_stmts in

49

Node { node_id; node_type; node_clock;

50

node_inputs; node_outputs; node_locals;

51

node_gencalls = []; node_checks = []; node_asserts = [];

52

node_stmts = body; node_dec_stateless = false; node_stateless = None;

53

node_spec = None; node_annot = [] }

54


55

(*

56

* Mini_vhdl to lustre tranformation

57

*)

58

method vhdl_port_t : vhdl_port_t > vhdl_port_t= fun x > x

59


60

method vhdl_type_t : vhdl_type_t > vhdl_type_t=

61

fun x >

62

match x with

63

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

64

 Range (a,b,c) >

65

let a = self#option self#string a in

66

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

67

 Bit_vector (a,b) >

68

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

69

 Array { indexes; const; definition } >

70

let indexes = indexes in

71

let const = self#option self#vhdl_constraint_t const in

72

(*let definition = self#vhdl_subtype_indication_t definition in*)

73

Array { indexes; const; definition }

74

 Record a >

75

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

76

 Enumerated a >

77

(*let a = self#list self#vhdl_name_t a in *)

78

Enumerated a

79

 Void > Void

80


81

method vhdl_element_declaration_t :

82

vhdl_element_declaration_t > vhdl_element_declaration_t=

83

fun { ed_names; definition } >

84

(*let names = self#list self#vhdl_name_t names in

85

let definition = self#vhdl_subtype_indication_t definition in*)

86

{ ed_names; definition }

87


88

method vhdl_subtype_indication_t :

89

vhdl_subtype_indication_t > Types.type_expr=

90

fun { si_name; functionName; const } >

91

let si_name = self#vhdl_name_t si_name in

92

(*let functionName = self#vhdl_name_t functionName in

93

let const = self#vhdl_constraint_t const in*)

94

let desc = match si_name with

95

 "integer" > Types.Tbasic (Tint)

96

 "boolean" > Types.Tbasic (Tbool)

97

 _ > Tconst (si_name) in

98

Types.new_ty desc;

99


100

method vhdl_subtype_indication_t_type_dec :

101

vhdl_subtype_indication_t > type_dec=

102

fun { si_name; functionName; const } >

103

let si_name = self#vhdl_name_t si_name in

104

(*let functionName = self#vhdl_name_t functionName in

105

let const = self#vhdl_constraint_t const in*)

106

{ty_dec_desc = Tydec_const si_name;

107

ty_dec_loc = Location.dummy_loc }

108


109

method vhdl_discrete_range_t :

110

vhdl_discrete_range_t > vhdl_discrete_range_t=

111

fun x >

112

match x with

113

 SubDiscreteRange a >

114

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

115

SubDiscreteRange a

116

 NamedRange a >

117

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

118

NamedRange a

119

 DirectedRange { direction; from; _to } >

120

let direction = self#string direction in

121

let from = self#vhdl_expr_t from in

122

let _to = self#vhdl_expr_t _to in

123

DirectedRange { direction; from; _to }

124


125

method vhdl_constraint_t : vhdl_constraint_t > vhdl_constraint_t=

126

fun x >

127

x

128

(* match x with

129

 RefConstraint { ref_name } >

130

let ref_name = self#vhdl_name_t ref_name in

131

RefConstraint { ref_name }

132

 RangeConstraint { range } >

133

let range = self#vhdl_discrete_range_t range in

134

RangeConstraint { range }

135

 IndexConstraint { ranges } >

136

let ranges = self#list self#vhdl_discrete_range_t ranges in

137

IndexConstraint { ranges }

138

 ArrayConstraint { ranges; sub } >

139

let ranges = self#list self#vhdl_discrete_range_t ranges in

140

let sub = self#vhdl_constraint_t sub in

141

ArrayConstraint { ranges; sub }

142

 RecordConstraint > RecordConstraint

143

 NoConstraint > NoConstraint*)

144


145

method vhdl_definition_t : vhdl_definition_t > vhdl_definition_t=

146

fun x >

147

x

148

(* match x with

149

 Type { name; definition } >

150

let name = self#vhdl_name_t name in

151

let definition = self#vhdl_type_t definition in

152

Type { name; definition }

153

 Subtype { name; typ } >

154

let name = self#vhdl_name_t name in

155

let typ = self#vhdl_subtype_indication_t typ in

156

Subtype { name; typ }*)

157


158

method vhdl_expr_t : vhdl_expr_t > vhdl_expr_t=

159

fun x >

160

x

161

(* match x with

162

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

163

 Cst { value; unit_name } >

164

let value = self#vhdl_cst_val_t value in

165

let unit_name = self#option self#vhdl_name_t unit_name in

166

Cst { value; unit_name }

167

 Op { id; args } >

168

let id = self#string id in

169

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

170

 IsNull > IsNull

171

 Time { value; phy_unit } >

172

let value = self#int value in

173

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

174

 Sig { name; att } >

175

let name = self#vhdl_name_t name in

176

let att = self#option self#vhdl_signal_attributes_t att in

177

Sig { name; att }

178

 SuffixMod { expr; selection } >

179

let expr = self#vhdl_expr_t expr in

180

let selection = self#vhdl_suffix_selection_t selection in

181

SuffixMod { expr; selection }

182

 Aggregate { elems } >

183

let elems = self#list self#vhdl_element_assoc_t elems in

184

Aggregate { elems }

185

 QualifiedExpression { type_mark; aggregate; expression } >

186

let type_mark = self#vhdl_name_t type_mark in

187

let aggregate = self#list self#vhdl_element_assoc_t aggregate in

188

let expression = self#option self#vhdl_expr_t expression in

189

QualifiedExpression { type_mark; aggregate; expression }

190

 Others > Others*)

191


192

method vhdl_name_t : vhdl_name_t > string=

193

fun x >

194

show_vhdl_name_t x

195


196

method vhdl_assoc_element_t :

197

vhdl_assoc_element_t > vhdl_assoc_element_t=

198

fun

199

{ formal_name; formal_arg; actual_name; actual_designator;

200

actual_expr }

201

(* At this point of the transformation, association elements have been resolved.

202

* formal_[namearg] are empty

203

* A simple variable name is of the form: actual_designator

204

* A function call is of the form: actual_name ( [actual_designator  actual_expr] )

205

* A conversion function is of the form: actual_name ( [actual_designator  actual_expr] )

206

*)

207

>

208

(* let formal_name = self#option self#vhdl_name_t formal_name in

209

let formal_arg = self#option self#vhdl_name_t formal_arg in

210

let actual_name = self#option self#vhdl_name_t actual_name in

211

let actual_designator =

212

self#option self#vhdl_name_t actual_designator in

213

let actual_expr = self#option self#vhdl_expr_t actual_expr in*)

214

{

215

formal_name;

216

formal_arg;

217

actual_name;

218

actual_designator;

219

actual_expr

220

}

221


222

method vhdl_element_assoc_t :

223

vhdl_element_assoc_t > vhdl_element_assoc_t=

224

fun { choices; expr } >

225

let choices = self#list self#vhdl_expr_t choices in

226

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

227


228

method vhdl_array_attributes_t :

229

vhdl_array_attributes_t > vhdl_array_attributes_t=

230

fun x >

231

match x with

232

 AAttInt { id; arg } >

233

let id = self#string id in

234

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

235

 AAttAscending > AAttAscending

236


237

method vhdl_signal_attributes_t :

238

vhdl_signal_attributes_t > vhdl_signal_attributes_t=

239

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

240


241

method vhdl_string_attributes_t :

242

vhdl_string_attributes_t > vhdl_string_attributes_t=

243

fun x >

244

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

245


246

method vhdl_suffix_selection_t :

247

vhdl_suffix_selection_t > vhdl_suffix_selection_t=

248

fun x >

249

match x with

250

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

251

 SuffixRange (a,b) >

252

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

253


254

(* TODO *)

255

method mini_vhdl_sequential_stmt_t :

256

mini_vhdl_sequential_stmt_t > mini_vhdl_sequential_stmt_t=

257

fun x >

258

x

259

(* match x with

260

 VarAssign { label; lhs; rhs } >

261

let label = self#option self#vhdl_name_t label in

262

let lhs = self#vhdl_name_t lhs in

263

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

264

 SigSeqAssign { label; lhs; rhs } >

265

let label = self#option self#vhdl_name_t label in

266

let lhs = self#vhdl_name_t lhs in

267

let rhs = self#list self#vhdl_waveform_element_t rhs in

268

SigSeqAssign { label; lhs; rhs }

269

 SigCondAssign { label; lhs; rhs; delay } >

270

let label = self#option self#vhdl_name_t label in

271

let lhs = self#vhdl_name_t lhs in

272

let rhs = self#list self#vhdl_signal_condition_t rhs in

273

let delay = self#option self#vhdl_expr_t delay in

274

SigCondAssign { label; lhs; rhs; delay }

275

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

276

let label = self#option self#vhdl_name_t label in

277

let lhs = self#vhdl_name_t lhs in

278

let sel = self#vhdl_expr_t sel in

279

let branches = self#list self#vhdl_signal_selection_t branches

280

in

281

let delay = self#option self#vhdl_expr_t delay in

282

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

283

 If { label; if_cases; default } >

284

let label = self#option self#vhdl_name_t label in

285

let if_cases = self#list self#mini_vhdl_if_case_t if_cases in

286

let default = self#list self#mini_vhdl_sequential_stmt_t default

287

in

288

If { label; if_cases; default }

289

 Case { label; guard; branches } >

290

let label = self#option self#vhdl_name_t label in

291

let guard = self#vhdl_expr_t guard in

292

let branches = self#list self#mini_vhdl_case_item_t branches in

293

Case { label; guard; branches }

294

 Exit { label; loop_label; condition } >

295

let label = self#option self#vhdl_name_t label in

296

let loop_label = self#option self#string loop_label in

297

let condition = self#option self#vhdl_expr_t condition in

298

Exit { label; loop_label; condition }

299

 Assert { label; cond; report; severity } >

300

let label = self#option self#vhdl_name_t label in

301

let cond = self#vhdl_expr_t cond in

302

let report = self#vhdl_expr_t report in

303

let severity = self#vhdl_expr_t severity in

304

Assert { label; cond; report; severity }

305

 ProcedureCall { label; name; assocs } >

306

let label = self#option self#vhdl_name_t label in

307

let name = self#vhdl_name_t name in

308

let assocs = self#list self#vhdl_assoc_element_t assocs in

309

ProcedureCall { label; name; assocs }

310

 Wait > Wait

311

 Null { label } >

312

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

313

 Return { label; expr } >

314

let label = self#option self#vhdl_name_t label in

315

let expr = self#option self#vhdl_expr_t expr in

316

Return { label; expr }*)

317


318

method mini_vhdl_if_case_t : mini_vhdl_if_case_t > mini_vhdl_if_case_t=

319

fun { if_cond; if_block } >

320

let if_cond = self#vhdl_expr_t if_cond in

321

let if_block = self#list self#mini_vhdl_sequential_stmt_t if_block

322

in

323

{ if_cond; if_block }

324


325

method mini_vhdl_case_item_t :

326

mini_vhdl_case_item_t > mini_vhdl_case_item_t=

327

fun { when_cond; when_stmt } >

328

let when_cond = self#list self#vhdl_expr_t when_cond in

329

let when_stmt = self#list self#mini_vhdl_sequential_stmt_t when_stmt

330

in

331

{ when_cond; when_stmt }

332


333

method mini_vhdl_declaration_t :

334

mini_vhdl_declaration_t > var_decl list=

335

fun x >

336

match x with

337

 VarDecl { names; typ; init_val } >

338

self#lustre_mk_var_decl InPort names typ

339

(* let names = self#list self#vhdl_name_t names in

340

let typ = self#vhdl_subtype_indication_t typ in

341

let init_val = self#vhdl_expr_t init_val in

342

VarDecl { names; typ; init_val }*)

343

 CstDecl { names; typ; init_val } >

344

self#lustre_mk_var_decl InPort names typ

345

(* let names = self#list self#vhdl_name_t names in

346

let typ = self#vhdl_subtype_indication_t typ in

347

let init_val = self#vhdl_expr_t init_val in

348

CstDecl { names; typ; init_val }*)

349

 SigDecl { names; typ; init_val } >

350

self#lustre_mk_var_decl InPort names typ

351

(* let names = self#list self#vhdl_name_t names in

352

let typ = self#vhdl_subtype_indication_t typ in

353

let init_val = self#vhdl_expr_t init_val in

354

SigDecl { names; typ; init_val }*)

355

 ComponentDecl { name; generics; ports } >

356

[]

357

(* let name = self#vhdl_name_t name in

358

let generics = self#list self#vhdl_port_t generics in

359

let ports = self#list self#vhdl_port_t ports in

360

ComponentDecl { name; generics; ports }*)

361

 Subprogram { spec; decl_part; stmts } >

362

[]

363

(* let spec = self#vhdl_subprogram_spec_t spec in

364

let decl_part = self#list self#mini_vhdl_declaration_t decl_part

365

in

366

let stmts = self#list self#mini_vhdl_sequential_stmt_t stmts in

367

Subprogram { spec; decl_part; stmts }*)

368


369

method vhdl_load_t : vhdl_load_t > vhdl_load_t=

370

fun x > x

371


372

method mini_vhdl_declarative_item_t :

373

mini_vhdl_declarative_item_t > mini_vhdl_declarative_item_t=

374

fun { use_clause; declaration; definition } >

375

let use_clause = self#option self#vhdl_load_t use_clause in

376

(* let declaration = self#option self#mini_vhdl_declaration_t declaration in *)

377

let definition = self#option self#vhdl_definition_t definition in

378

{ use_clause; declaration; definition }

379


380

(* TODO : transform this as a new node *)

381

method mini_vhdl_process_t : mini_vhdl_process_t > mini_vhdl_process_t=

382

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

383

(* let id = self#vhdl_name_t id in

384

let declarations =

385

self#list self#mini_vhdl_declarative_item_t declarations in

386

let active_sigs = self#list self#vhdl_name_t active_sigs in

387

let body = self#list self#mini_vhdl_sequential_stmt_t body in

388

let postponed = self#bool postponed in

389

let label = self#option self#vhdl_name_t label in *)

390

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

391


392

(* TODO : transform this as a node call *)

393

method mini_vhdl_component_instantiation_t :

394

mini_vhdl_component_instantiation_t > statement=

395

fun { ci_name; archi; entity; generic_map; port_map } >

396

let ci_name = self#vhdl_name_t ci_name in

397

(*let archi = archi in

398

let entity = entity in

399

let generic_map = self#list self#vhdl_assoc_element_t generic_map in

400

let port_map = self#list self#vhdl_assoc_element_t port_map in*)

401

Eq {eq_lhs=[ci_name];

402

eq_rhs={expr_tag=Utils.new_tag (); expr_desc=Expr_ident "toto";

403

expr_type={tdesc=Tconst "cst"; tid=0}; expr_clock={cdesc=Cvar;cscoped=false;cid=0};

404

expr_delay={ddesc=Dundef;did=0}; expr_annot=None; expr_loc=Location.dummy_loc};

405

eq_loc=Location.dummy_loc}

406


407

(* TODO : Process is a new node; ComponentInst is a node call *)

408

method mini_vhdl_concurrent_stmt_t :

409

mini_vhdl_concurrent_stmt_t > statement=

410

fun x >

411

match x with

412

 Process a > (*let a = self#mini_vhdl_process_t a in*)

413

Eq {eq_lhs=["Process"];

414

eq_rhs={expr_tag=Utils.new_tag (); expr_desc=Expr_ident "toto";

415

expr_type={tdesc=Tconst "cst"; tid=0}; expr_clock={cdesc=Cvar;cscoped=false;cid=0};

416

expr_delay={ddesc=Dundef;did=0}; expr_annot=None; expr_loc=Location.dummy_loc};

417

eq_loc=Location.dummy_loc}

418

 ComponentInst a >

419

let a = self#mini_vhdl_component_instantiation_t a in a

420


421

method mini_vhdl_package_t : mini_vhdl_package_t > top_decl_desc=

422

fun { p_name; shared_defs; shared_decls; shared_uses } >

423

let node_id = self#vhdl_name_t p_name in

424

(*let shared_defs = self#list self#vhdl_definition_t shared_defs in

425

let shared_decls = List.map self#mini_vhdl_declaration_t shared_decls in

426

let shared_uses = self#list self#vhdl_load_t shared_uses in*)

427

let node_type = Types.new_var () in

428

let node_clock = Clocks.new_ck Cvar false in

429

Node { node_id; node_type; node_clock;

430

node_inputs=[]; node_outputs = []; node_locals = [];

431

node_gencalls = []; node_checks = []; node_asserts = [];

432

node_stmts = []; node_dec_stateless = false; node_stateless = None;

433

node_spec = None; node_annot = [] }

434


435

method mini_vhdl_component_t :

436

mini_vhdl_component_t > top_decl_desc =

437

fun

438

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

439

>

440

(*let generics = self#list self#vhdl_port_t generics in*)

441

let ports = self#list self#vhdl_port_t ports in

442

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

443

let c_declarations = List.flatten (List.map self#mini_vhdl_declaration_t c_declarations) in

444

(*let definitions = List.map self#vhdl_definition_t definitions in (* TODO: add the result of this transformation to mk_node call *)

445

let node_id = String.concat "__" (List.map show_vhdl_name_t names) in

446

let node_type = Types.new_var () in

447

let node_clock = Clocks.new_ck Cvar false in*)

448

self#lustre_mk_node names c_declarations ports c_body

449


450

method mini_vhdl_design_file_t :

451

mini_vhdl_design_file_t > program_t =

452

fun { components; packages } >

453

let components = List.map self#mini_vhdl_component_t components in

454

let packages = List.map self#mini_vhdl_package_t packages in

455

let desc x = { top_decl_desc = x;

456

top_decl_owner = "";

457

top_decl_itf = false;

458

top_decl_loc = Location.dummy_loc } in

459

let desc1 = List.map desc components in

460

let desc2 = List.map desc packages in

461

desc1 @ desc2

462

end
