1

(* EMF backend *)

2

(* This backup is initially motivated by the need to express Spacer computed

3

invariants as Matlab Simulink executable evidences.

4


5

Therefore the input language is more restricted. We do not expect fancy

6

datastructure, complex function calls, etc.

7


8

In case of error, use node foo inline to eliminate function calls that are

9

not seriously handled yet.

10


11


12

In terms of algorithm, the process was initially based on printing normalized

13

code. We now rely on machine code printing. The old code is preserved for

14

reference.

15

*)

16


17

open LustreSpec

18

open Machine_code

19

open Format

20

open Utils

21


22

exception Unhandled of string

23


24


25

(* Basic printing functions *)

26


27

let pp_var_string fmt v = fprintf fmt "\"%s\"" v

28

let pp_var_name fmt v = fprintf fmt "\"%a\"" Printers.pp_var_name v

29

let pp_node_args = fprintf_list ~sep:", " pp_var_name

30


31


32

(* Matlab starting counting from 1.

33

simple function to extract the element id in the list. Starts from 1. *)

34

let rec get_idx x l =

35

match l with

36

 hd::tl > if hd = x then 1 else 1+(get_idx x tl)

37

 [] > assert false

38


39

(**********************************************)

40

(* Old stuff: printing normalized code as EMF *)

41

(**********************************************)

42


43

(*

44

let pp_expr vars fmt expr =

45

let rec pp_expr fmt expr =

46

match expr.expr_desc with

47

 Expr_const c > Printers.pp_const fmt c

48

 Expr_ident id >

49

if List.mem id vars then

50

Format.fprintf fmt "u%i" (get_idx id vars)

51

else

52

assert false (* impossible to find element id in var list *)

53

 Expr_array a > fprintf fmt "[%a]" pp_tuple a

54

 Expr_access (a, d) > fprintf fmt "%a[%a]" pp_expr a Dimension.pp_dimension d

55

 Expr_power (a, d) > fprintf fmt "(%a^%a)" pp_expr a Dimension.pp_dimension d

56

 Expr_tuple el > fprintf fmt "(%a)" pp_tuple el

57

 Expr_ite (c, t, e) > fprintf fmt "if %a; y=(%a); else y=(%a); end" pp_expr c pp_expr t pp_expr e

58

 Expr_arrow (e1, e2) >(

59

match e1.expr_desc, e2.expr_desc with

60

 Expr_const c1, Expr_const c2 > if c1 = Corelang.const_of_bool true && c2 = Corelang.const_of_bool false then fprintf fmt "STEP" else assert false (* only handle true > false *)

61

 _ > assert false (* only handle true > false *)

62

)

63

 Expr_fby (e1, e2) > assert false (* not covered yet *)

64

 Expr_pre e > fprintf fmt "UNITDELAY"

65

 Expr_when (e, id, l) > assert false (* clocked based expressions are not handled yet *)

66

 Expr_merge (id, hl) > assert false (* clocked based expressions are not handled yet *)

67

 Expr_appl (id, e, r) > pp_app fmt id e r

68


69

and pp_tuple fmt el =

70

fprintf_list ~sep:"," pp_expr fmt el

71


72

and pp_app fmt id e r =

73

match r with

74

 None > pp_call fmt id e

75

 Some c > assert false (* clocked based expressions are not handled yet *)

76


77

and pp_call fmt id e =

78

match id, e.expr_desc with

79

 "+", Expr_tuple([e1;e2]) > fprintf fmt "(%a + %a)" pp_expr e1 pp_expr e2

80

 "uminus", _ > fprintf fmt "( %a)" pp_expr e

81

 "", Expr_tuple([e1;e2]) > fprintf fmt "(%a  %a)" pp_expr e1 pp_expr e2

82

 "*", Expr_tuple([e1;e2]) > fprintf fmt "(%a * %a)" pp_expr e1 pp_expr e2

83

 "/", Expr_tuple([e1;e2]) > fprintf fmt "(%a / %a)" pp_expr e1 pp_expr e2

84

 "mod", Expr_tuple([e1;e2]) > fprintf fmt "mod (%a, %a)" pp_expr e1 pp_expr e2

85

 "&&", Expr_tuple([e1;e2]) > fprintf fmt "(%a & %a)" pp_expr e1 pp_expr e2

86

 "", Expr_tuple([e1;e2]) > fprintf fmt "(%a  %a)" pp_expr e1 pp_expr e2

87

 "xor", Expr_tuple([e1;e2]) > fprintf fmt "xor (%a, %a)" pp_expr e1 pp_expr e2

88

 "impl", Expr_tuple([e1;e2]) > fprintf fmt "((~%a)  %a)" pp_expr e1 pp_expr e2

89

 "<", Expr_tuple([e1;e2]) > fprintf fmt "(%a < %a)" pp_expr e1 pp_expr e2

90

 "<=", Expr_tuple([e1;e2]) > fprintf fmt "(%a <= %a)" pp_expr e1 pp_expr e2

91

 ">", Expr_tuple([e1;e2]) > fprintf fmt "(%a > %a)" pp_expr e1 pp_expr e2

92

 ">=", Expr_tuple([e1;e2]) > fprintf fmt "(%a >= %a)" pp_expr e1 pp_expr e2

93

 "!=", Expr_tuple([e1;e2]) > fprintf fmt "(%a ~= %a)" pp_expr e1 pp_expr e2

94

 "=", Expr_tuple([e1;e2]) > fprintf fmt "(%a == %a)" pp_expr e1 pp_expr e2

95

 "not", _ > fprintf fmt "(~%a)" pp_expr e

96

 _, Expr_tuple _ > fprintf fmt "%s %a" id pp_expr e

97

 _ > fprintf fmt "%s (%a)" id pp_expr e

98


99

in

100

pp_expr fmt expr

101


102

let pp_stmt fmt stmt =

103

match stmt with

104

 Eq eq > (

105

match eq.eq_lhs with

106

[var] > (

107

(* first, we extract the expression and associated variables *)

108

let vars = Utils.ISet.elements (Corelang.get_expr_vars eq.eq_rhs) in

109


110

fprintf fmt "\"%s\": @[<v 2>{ \"expr\": \"%a\",@ \"vars\": [%a] @]}"

111

var

112

(pp_expr vars) eq.eq_rhs (* todo_pp_expr expr *)

113

(fprintf_list ~sep:", " pp_var_string) vars

114

)

115

 _ > assert false (* should not happen for input of EMF backend (cocospec generated nodes *)

116

)

117

 _ > assert false (* should not happen with EMF backend *)

118


119

let pp_node fmt nd =

120

fprintf fmt "@[<v 2>\"%s\": {@ \"inputs\": [%a],@ \"outputs\": [%a],@ "

121

nd.node_id

122

pp_node_args nd.node_inputs

123

pp_node_args nd.node_outputs;

124

fprintf fmt "\"exprs\": {@[<v 1> %a@]@ }"

125

(fprintf_list ~sep:",@ " pp_stmt ) nd.node_stmts;

126

fprintf fmt "@]@ }"

127


128

let pp_decl fmt decl =

129

match decl.top_decl_desc with

130

 Node nd > fprintf fmt "%a@ " pp_node nd

131

 ImportedNode _

132

 Const _

133

 Open _

134

 TypeDef _ > eprintf "should not happen in EMF backend"

135

*)

136


137


138

(**********************************************)

139

(* Printing machine code as EMF *)

140

(**********************************************)

141


142

(* detect whether the instruction i represents an ARROW, ie an arrow with true

143

> false *)

144

let is_arrow_fun m i =

145

match Corelang.get_instr_desc i with

146

 MStep ([var], i, vl) > (

147

let name = try (Machine_code.get_node_def i m).node_id with Not_found > Format.eprintf "Impossible to find node %s@.@?" i; raise Not_found in

148

match name, vl with

149

 "_arrow", [v1; v2] > (

150

match v1.value_desc, v2.value_desc with

151

 Cst c1, Cst c2 >

152

if c1 = Corelang.const_of_bool true && c2 = Corelang.const_of_bool false then

153

true

154

else

155

assert false (* only handle true > false *)

156

 _ > assert false

157

)

158

 _ > false

159

)

160

 _ > false

161


162

let pp_original_lustre_expression m fmt i =

163

match Corelang.get_instr_desc i with

164

 MLocalAssign _  MStateAssign _

165

 MBranch _

166

> ( match i.lustre_eq with None > ()  Some e > Printers.pp_node_eq fmt e)

167

 MStep _ when is_arrow_fun m i > () (* we print nothing, this is a STEP *)

168

 MStep _ > (match i.lustre_eq with None > ()  Some eq > Printers.pp_node_eq fmt eq)

169

 _ > ()

170


171


172

(* Print machine code values as matlab expressions. Variable identifiers are

173

replaced by uX where X is the index of the variables in the list vars of input

174

variables. *)

175

let rec pp_matlab_val vars fmt v =

176

match v.value_desc with

177

 Cst c > Printers.pp_const fmt c

178

 LocalVar v

179

 StateVar v >

180

let id = v.var_id in

181

if List.mem id vars then

182

Format.fprintf fmt "u%i" (get_idx id vars)

183

else

184

let _ = Format.eprintf "Error: looking for var %s in %a@.@?" id (Utils.fprintf_list ~sep:"," Format.pp_print_string) vars in assert false (* impossible to find element id in var list *)

185

 Fun (n, vl) > pp_fun vars n fmt vl

186

 _ > assert false (* not available in EMF backend *)

187

and pp_fun vars id fmt vl =

188

(* eprintf "print %s with %i args@.@?" id (List.length vl);*)

189

match id, vl with

190

 "+", [v1;v2] > fprintf fmt "(%a + %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2

191

 "uminus", [v] > fprintf fmt "( %a)" (pp_matlab_val vars) v

192

 "", [v1;v2] > fprintf fmt "(%a  %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2

193

 "*",[v1;v2] > fprintf fmt "(%a * %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2

194

 "/", [v1;v2] > fprintf fmt "(%a / %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2

195

 "mod", [v1;v2] > fprintf fmt "mod (%a, %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2

196

 "&&", [v1;v2] > fprintf fmt "(%a & %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2

197

 "", [v1; v2] > fprintf fmt "(%a  %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2

198

 "xor", [v1; v2] > fprintf fmt "xor (%a, %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2

199

 "impl", [v1; v2] > fprintf fmt "((~%a)  %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2

200

 "<", [v1; v2] > fprintf fmt "(%a < %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2

201

 "<=", [v1; v2] > fprintf fmt "(%a <= %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2

202

 ">", [v1; v2] > fprintf fmt "(%a > %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2

203

 ">=", [v1; v2] > fprintf fmt "(%a >= %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2

204

 "!=", [v1; v2] > fprintf fmt "(%a != %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2

205

 "=", [v1; v2] > fprintf fmt "(%a = %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2

206

 "not", [v] > fprintf fmt "(~%a)" (pp_matlab_val vars) v

207

 _ > fprintf fmt "%s (%a)" id (Utils.fprintf_list ~sep:", " (pp_matlab_val vars)) vl

208


209


210


211

(* pp_basic_instr prints regular instruction. These do not contain MStep which

212

should have been already filtered out. Another restriction which is supposed

213

to be enforced is that branching statement contain a single instruction (in

214

practice it has to be an assign) *)

215

let pp_matlab_basic_instr m vars fmt i =

216

match Corelang.get_instr_desc i with

217

 MLocalAssign (var,v)

218

 MStateAssign (var,v) > fprintf fmt "y = %a" (pp_matlab_val vars) v

219

 MReset _

220

> Format.eprintf "unhandled reset in EMF@.@?"; assert false

221

 MNoReset _

222

> Format.eprintf "unhandled noreset in EMF@.@?"; assert false

223

 MBranch _ (* branching instructions already handled *)

224

> Format.eprintf "unhandled branch statement in EMF (should have been filtered out before)@.@?";

225

assert false

226

 MStep _ (* function calls already handled, including STEP *)

227

> Format.eprintf "unhandled function call in EMF (should have been filtered out before)@.@?";

228

assert false

229

 MComment _

230

> Format.eprintf "unhandled comment in EMF@.@?"; assert false

231

(* not available for EMF output *)

232


233


234


235

let rec get_instr_lhs_var i =

236

match Corelang.get_instr_desc i with

237

 MLocalAssign (var,_)

238

 MStateAssign (var,_)

239

 MStep ([var], _, _) >

240

(* The only MStep instructions that filtered here

241

should be arrows, ie. single var *)

242

var

243

 MBranch (_,(_,case1)::_) >

244

get_instrs_var case1 (* assuming all cases define the same variables *)

245

 MStep (f,name,a) > Format.eprintf "step %s@.@?" name; assert false (* no other MStep here *)

246

 MBranch _ > assert false (* branch instruction should admit at least one case *)

247

 MReset _

248

 MNoReset _

249

 MComment _ > assert false (* not available for EMF output *)

250

and get_instrs_var il =

251

match il with

252

 i::_ > get_instr_lhs_var i (* looking for the first instr *)

253

 _ > assert false

254


255


256

let rec get_val_vars v =

257

match v.value_desc with

258

 Cst c > Utils.ISet.empty

259

 LocalVar v

260

 StateVar v > Utils.ISet.singleton v.var_id

261

 Fun (n, vl) > List.fold_left (fun res v > Utils.ISet.union (get_val_vars v) res) Utils.ISet.empty vl

262

 _ > assert false (* not available in EMF backend *)

263


264

let rec get_instr_rhs_vars i =

265

match Corelang.get_instr_desc i with

266

 MLocalAssign (_,v)

267

 MStateAssign (_,v) > get_val_vars v

268

 MStep (_, _, vl) > List.fold_left (fun res v > Utils.ISet.union res (get_val_vars v)) Utils.ISet.empty vl

269

 MBranch (c,[(_,[case1]);(_,[case2])]) >

270

Utils.ISet.union

271

(get_val_vars c)

272

(

273

Utils.ISet.union

274

(get_instr_rhs_vars case1)

275

(get_instr_rhs_vars case2)

276

)

277

 MBranch (g, branches) >

278

List.fold_left

279

(fun accu (_, il) > Utils.ISet.union accu (get_instrs_vars il))

280

(get_val_vars g)

281

branches

282

 MReset id

283

 MNoReset id > Utils.ISet.singleton id

284

 MComment _ > Utils.ISet.empty

285

and get_instrs_vars il =

286

List.fold_left (fun res i > Utils.ISet.union res (get_instr_rhs_vars i))

287

Utils.ISet.empty

288

il

289


290


291


292

let rec pp_emf_instr m fmt i =

293

(* Either it is a Step function non arrow, then we have a dedicated treatment,

294

or it has to be a single variable assigment *)

295

let arguments_vars = Utils.ISet.elements (get_instr_rhs_vars i) in

296


297

match Corelang.get_instr_desc i with

298

(* Regular node call either a statuful node or a functional one *)

299

 MStep (outputs, f, inputs) when not (is_arrow_fun m i) > (

300

fprintf fmt "\"CALL\": @[<v 2>{ \"node\": \"%s\",@ \"inputs\": [%a],@ \"vars\": [%a]@ \"lhs\": [%a],@ \"original_lustre_expr\": [%a]@]}"

301

((Machine_code.get_node_def f m).node_id) (* Node name *)

302

(Utils.fprintf_list ~sep:", " (fun fmt _val > fprintf fmt "\"%a\"" (pp_matlab_val arguments_vars) _val)) inputs (* inputs *)

303

(fprintf_list ~sep:", " pp_var_string) arguments_vars

304

(fprintf_list ~sep:", " (fun fmt v > pp_var_string fmt v.var_id)) outputs (* outputs *)

305

(pp_original_lustre_expression m) i (* original lustre expr *)

306

)

307

 MStep _ > (* Arrow case *) (

308

let var = get_instr_lhs_var i in

309

fprintf fmt "\"STEP\": @[<v 2>{ \"lhs\": \"%s\",@ \"vars\": [%a] @ \"original_lustre_expr\": [%a]@]}"

310

var.var_id

311

(fprintf_list ~sep:", " pp_var_string) arguments_vars

312

(pp_original_lustre_expression m) i

313

)

314

 MBranch (g,[(tag1,[case1]);(tag2,[case2])]) when tag1 = Corelang.tag_true  tag2 = Corelang.tag_true >

315

(* Thanks to normalization with join_guards = false, branches shall contain

316

a single expression *)

317

let var = get_instr_lhs_var i in

318

let then_case, else_case =

319

if tag1 = Corelang.tag_true then

320

case1, case2

321

else

322

case2, case1

323

in

324

fprintf fmt "\"ITE\": @[<v 2>{ \"lhs\": \"%s\",@ \"guard\": \"%a\",@ \"then_expr\": \"%a\",@ \"else_expr\": \"%a\",@ \"vars\": [%a],@ \"original_lustre_expr\": [%a]@]}"

325

var.var_id

326

(pp_matlab_val arguments_vars) g

327

(pp_matlab_basic_instr m arguments_vars) then_case

328

(pp_matlab_basic_instr m arguments_vars) else_case

329

(fprintf_list ~sep:", " pp_var_string) arguments_vars

330

(pp_original_lustre_expression m) i

331


332

 MBranch (g, [single_tag, single_branch]) >

333

(* First case: it corresponds to a clocked expression: a MBranch with a

334

single case. It shall become a subsystem with an enable port that depends on g = single_tag *)

335

(* Thanks to normalization with join_guards = false, branches shall contain

336

a single expression TODO REMOVE COMMENT THIS IS NOT TRUE *)

337

let var = get_instr_lhs_var i in

338

fprintf fmt "\"ENABLEDSUB\": @[<v 2>{ \"lhs\": \"%s\",@ \"enable_cond\": \"%a = %s\",@ \"subsystem\": {%a },@ \"vars\": [%a],@ \"original_lustre_expr\": [%a]@]}"

339

var.var_id

340

(pp_matlab_val arguments_vars) g

341

single_tag

342

(fprintf_list ~sep:",@ " (pp_emf_instr m)) single_branch

343

(fprintf_list ~sep:", " pp_var_string) arguments_vars

344

(pp_original_lustre_expression m) i

345


346

 MBranch (g, hl) >

347

(* Thanks to normalization with join_guards = false, branches shall contain

348

a single expression *)

349

fprintf fmt "\"BRANCH\": @[<v 2>{ \"guard\": \"%a\",@ \"branches\": [@[<v 0>%a@]],@ \"vars\": [%a],@ \"original_lustre_expr\": [%a]@]}"

350

(pp_matlab_val arguments_vars) g

351

(fprintf_list ~sep:",@ "

352

(fun fmt (tag, (is_tag: instr_t list)) >

353

fprintf fmt "\"%s\": [%a]"

354

tag

355

(fprintf_list ~sep:",@ " (fun fmt i_tag > match Corelang.get_instr_desc i_tag with

356

 MLocalAssign (var,v)

357

 MStateAssign (var,v) >

358

fprintf fmt "{lhs= \"%s\", rhs= \"%a\"]" var.var_id (pp_matlab_val arguments_vars) v

359

 _ > Format.eprintf "unhandled instr: %a@." Machine_code.pp_instr i_tag; assert false

360

)) is_tag

361

)) hl

362

(fprintf_list ~sep:", " pp_var_string) arguments_vars

363

(pp_original_lustre_expression m) i

364


365


366


367

 _ >

368

(* Other expressions, including "pre" *)

369

(

370

(* first, we extract the expression and associated variables *)

371

let var = get_instr_lhs_var i in

372

fprintf fmt "\"EXPR\": @[<v 2>{ \"lhs\": \"%s\",@ \"expr\": \"%a\",@ \"vars\": [%a] @ \"original_lustre_expr\": [%a]@]}"

373

var.var_id

374

(fun fmt i > match Corelang.get_instr_desc i with

375

 MStep _ > fprintf fmt "STEP"

376

 _ > pp_matlab_basic_instr m arguments_vars fmt i) i

377

(fprintf_list ~sep:", " pp_var_string) arguments_vars

378

(pp_original_lustre_expression m) i

379

)

380


381

(* A (normalized) node becomes a JSON struct

382

node foo (in1, in2: int) returns (out1, out2: int);

383

var x : int;

384

let

385

x = bar(in1, in2);  a stateful node

386

out1 = x;

387

out2 = in2;

388

tel

389


390

Since foo contains a stateful node, it is stateful itself. Its prototype is

391

extended with a reset input. When the node is reset, each of its "pre" expression

392

is reset as well as all calls to stateful node it contains.

393


394

will produce the following JSON struct:

395

"foo": {inputs: [{name: "in1", type: "int"},

396

{name: "in2", type: "int"},

397

{name: "__reset", type: "reset"}

398

],

399

outputs: [{name: "out1", type: "int"}, {name: "out2", type: "int"}],

400

locals: [{name: "x", type: "int"}],

401

instrs: [

402

{ def_x: { lhs: ["x"],

403

rhs: {type: "statefulcall", name: "bar",

404

args: [in1, in2], reset: [ni4_reset] }

405

}

406

}

407

{ def_out1: { lhs: "out1", rhs: "x" } },

408

{ def_out2: { lhs: "out2", rhs: "in2" }}

409

]

410

}

411


412

Basically we have three different definitions

413

1. classical assign of a variable to another one:

414

{ def_out1: { lhs: "out1", rhs: "x" } },

415

2. call to a stateless function, typically an operator

416

{ def_x: { lhs: ["x"],

417

rhs: {type: "statelesscall", name: "bar", args: [in1, in2]}

418

}

419

or in the operator version

420

{ def_x: { lhs: ["x"],

421

rhs: {type: "operator", name: "+", args: [in1, in2]}

422

}

423


424

In Simulink this should introduce a subsystem in the first case or a

425

regular block in the second with card(lhs) outputs and card{args} inputs.

426


427

3. call to a stateful node. It is similar to the stateless above,

428

with the addition of the reset argument

429

{ def_x: { lhs: ["x"],

430

rhs: {type: "statefulcall", name: "bar",

431

args: [in1, in2], reset: [ni4_reset] }

432

}

433

}

434


435

In lustrec compilation phases, a unique id is associated to this specific

436

instance of stateful node "bar", here ni4.

437

Instruction such as reset(ni4) or noreset(ni4) may  or not  reset this

438

specific node. This corresponds to "every c" suffix of a node call in lustre.

439


440

In Simulink this should introduce a subsystem that has this extra reset input.

441

The reset should be defined as an "OR" over (1) the input reset of the parent

442

node, __reset in the present example and (2) any occurence of reset(ni4) in

443

the instructions.

444


445

4. branching construct: (guard expr, (tag, instr list) list)

446

{ "merge_XX": { type: "branch", guard: "var_guard",

447

inputs: ["varx", "vary"],

448

outputs: ["vark", "varz"],

449

branches: ["tag1": [liste_of_definitions (14)], ...]

450

}

451

}

452


453

In Simulink, this should become one IF block to produce enable ports "var_guard == tag1", "var_guard == tag2", .... as well as one action block per branch: each of these action block shall

454

*)

455

let pp_machine fmt m =

456

try

457

fprintf fmt "@[<v 2>\"%s\": {@ \"inputs\": [%a],@ \"outputs\": [%a],@ "

458

m.mname.node_id

459

pp_node_args m.mstep.step_inputs

460

pp_node_args m.mstep.step_outputs;

461

fprintf fmt "\"exprs\": {@[<v 1> %a@]@ }"

462

(fprintf_list ~sep:",@ " (pp_emf_instr m)) m.mstep.step_instrs;

463

fprintf fmt "@]@ }"

464

with Unhandled msg > (

465

eprintf "[Error] @[<v 0>EMF backend@ Issues while translating node %s@ "

466

m.mname.node_id;

467

eprintf "%s@ " msg;

468

eprintf "node skipped  no output generated@ @]@."

469

)

470


471

(****************************************************)

472

(* Main function: iterates over node and print them *)

473

(****************************************************)

474

let pp_meta fmt basename =

475

fprintf fmt "\"meta\": @[<v 0>{@ ";

476

Utils.fprintf_list ~sep:",@ "

477

(fun fmt (k, v) > fprintf fmt "\"%s\": \"%s\"" k v)

478

fmt

479

["compilername", (Filename.basename Sys.executable_name);

480

"compilerversion", Version.number;

481

"command", (String.concat " " (Array.to_list Sys.argv));

482

"source_file", basename

483

]

484

;

485

fprintf fmt "@ @]},@ "

486


487

let translate fmt basename prog machines =

488

fprintf fmt "@[<v 0>{@ ";

489

pp_meta fmt basename;

490

fprintf fmt "\"nodes\": @[<v 0>{@ ";

491

(* Previous alternative: mapping normalized lustre to EMF:

492

fprintf_list ~sep:",@ " pp_decl fmt prog; *)

493

fprintf_list ~sep:",@ " pp_machine fmt machines;

494

fprintf fmt "@ @]}";

495

fprintf fmt "@ @]}"

496


497

(* Local Variables: *)

498

(* compilecommand: "make C ../.." *)

499

(* End: *)
