1

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

2

(* *)

3

(* The LustreC compiler toolset / The LustreC Development Team *)

4

(* Copyright 2012   ONERA  CNRS  INPT *)

5

(* *)

6

(* LustreC is free software, distributed WITHOUT ANY WARRANTY *)

7

(* under the terms of the GNU Lesser General Public License *)

8

(* version 2.1. *)

9

(* *)

10

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

11


12

open Graph

13


14

type rat = int*int

15

type ident = string

16

type tag = int

17

type longident = (string * tag) list

18


19

exception TransposeError of int*int

20


21

(** General utility functions. *)

22

let create_hashtable size init =

23

let tbl = Hashtbl.create size in

24

List.iter (fun (key, data) > Hashtbl.add tbl key data) init;

25

tbl

26


27

module IdentModule =

28

struct (* Node module *)

29

type t = ident

30

let compare = compare

31

let hash n = Hashtbl.hash n

32

let equal n1 n2 = n1 = n2

33

end

34


35

module IMap =

36

struct

37

include Map.Make(IdentModule)

38

let elements m = fold (fun i n res > (i, n)::res) m []

39

end

40


41

module ISet = Set.Make(IdentModule)

42

module IdentDepGraph = Imperative.Digraph.ConcreteBidirectional (IdentModule)

43

module TopologicalDepGraph = Topological.Make(IdentDepGraph)

44

module ComponentsDepGraph = Components.Make(IdentDepGraph)

45


46

(*module DotGraph = Graphviz.Dot (IdentDepGraph)*)

47

module Bfs = Traverse.Bfs (IdentDepGraph)

48


49


50

exception DeSome

51

let desome x = match x with Some x > x  None > raise DeSome

52


53

let option_map f o =

54

match o with

55

 None > None

56

 Some e > Some (f e)

57


58

let add_cons x l =

59

if List.mem x l then l else x::l

60


61

let rec remove_duplicates l =

62

match l with

63

 [] > []

64

 t::q > add_cons t (remove_duplicates q)

65


66

let position pred l =

67

let rec pos p l =

68

match l with

69

 [] > assert false

70

 t::q > if pred t then p else pos (p+1) q

71

in pos 0 l

72


73

let rec duplicate x n =

74

if n < 0 then [] else x :: duplicate x (n  1)

75


76

let enumerate n =

77

let rec aux i =

78

if i >= n then [] else i :: aux (i+1)

79

in aux 0

80


81

let rec repeat n f x =

82

if n <= 0 then x else repeat (n1) f (f x)

83


84

let transpose_list ll =

85

let rec transpose ll =

86

match ll with

87

 [] > []

88

 [l] > List.map (fun el > [el]) l

89

 l::q > List.map2 (fun el eq > el::eq) l (transpose q)

90

in match ll with

91

 [] > []

92

 l::q > let length_l = List.length l in

93

List.iter (fun l' > let length_l' = List.length l'

94

in if length_l <> length_l' then raise (TransposeError (length_l, length_l'))) q;

95

transpose ll

96


97

let rec filter_upto p n l =

98

if n = 0 then [] else

99

match l with

100

 [] > []

101

 t::q > if p t then t :: filter_upto p (n1) q else filter_upto p n q

102


103

(* Warning: bad complexity *)

104

let list_of_imap imap =

105

IMap.fold (fun i v (il,vl) > (i::il,v::vl)) imap ([],[])

106


107

(** [gcd a b] returns the greatest common divisor of [a] and [b]. *)

108

let rec gcd a b =

109

if b = 0 then a

110

else gcd b (a mod b)

111


112

(** [lcm a b] returns the least common multiple of [a] and [b]. *)

113

let lcm a b =

114

if a = 0 && b = 0 then

115

0

116

else a*b/(gcd a b)

117


118

(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and

119

[(a',b')] *)

120

let sum_rat (a,b) (a',b') =

121

if a = 0 && b = 0 then

122

(a',b')

123

else if a'=0 && b'=0 then

124

(a,b)

125

else

126

let lcm_bb' = lcm b b' in

127

(a*lcm_bb'/b+a'*lcm_bb'/b',lcm_bb')

128


129

let simplify_rat (a,b) =

130

let gcd = gcd a b in

131

if (gcd =0) then

132

(a,b)

133

else (a/gcd,b/gcd)

134


135

let max_rat (a,b) (a',b') =

136

let ratio_ab = (float_of_int a)/.(float_of_int b) in

137

let ratio_ab' = (float_of_int a')/.(float_of_int b') in

138

if ratio_ab > ratio_ab' then

139

(a,b)

140

else

141

(a',b')

142


143

(** [list_union l1 l2] returns the union of list [l1] and [l2]. The

144

result contains no duplicates. *)

145

let list_union l1 l2 =

146

let rec aux l acc =

147

match l with

148

 [] > acc

149

 x::tl >

150

if List.mem x acc then

151

aux tl acc

152

else

153

aux tl (x::acc)

154

in

155

let l1' = aux l1 [] in

156

aux l2 l1'

157


158

(** [hashtbl_add h1 h2] adds all the bindings in [h2] to [h1]. If the

159

intersection is not empty, it replaces the former binding *)

160

let hashtbl_add h1 h2 =

161

Hashtbl.iter (fun key value > Hashtbl.replace h1 key value) h2

162


163

let hashtbl_iterlast h f1 f2 =

164

let l = Hashtbl.length h in

165

ignore(

166

Hashtbl.fold

167

(fun k v cpt >

168

if cpt = l then

169

begin f2 k v; cpt+1 end

170

else

171

begin f1 k v; cpt+1 end)

172

h 1)

173


174

(** Match types variables to 'a, 'b, ..., for prettyprinting. Type

175

variables are identified by integers. *)

176

let tnames = ref ([]: (int * string) list)

177

let tname_counter = ref 0

178

(* Same for carriers *)

179

let crnames = ref ([]: (int * string) list)

180

let crname_counter = ref 0

181

(* Same for dimension *)

182

let dnames = ref ([]: (int * string) list)

183

let dname_counter = ref 0

184

(* Same for delays *)

185

let inames = ref ([]: (int * string) list)

186

let iname_counter = ref 0

187


188

let reset_names () =

189

tnames := []; tname_counter := 0; crnames := []; crname_counter := 0; dnames := []; dname_counter := 0; inames := []; iname_counter := 0

190


191

(* From OCaml compiler *)

192

let new_tname () =

193

let tname =

194

if !tname_counter < 26

195

then String.make 1 (Char.chr(97 + !tname_counter))

196

else String.make 1 (Char.chr(97 + !tname_counter mod 26)) ^

197

string_of_int(!tname_counter / 26) in

198

incr tname_counter;

199

tname

200


201

let new_crname () =

202

incr crname_counter;

203

Format.sprintf "c%i" (!crname_counter1)

204


205

let name_of_type id =

206

try List.assoc id !tnames with Not_found >

207

let name = new_tname () in

208

tnames := (id, name) :: !tnames;

209

name

210


211

let name_of_carrier id =

212

let pp_id =

213

try List.assoc id !crnames with Not_found >

214

let name = new_crname () in

215

crnames := (id,name) :: !crnames;

216

name

217

in

218

pp_id

219


220

let new_dname () =

221

incr dname_counter;

222

Format.sprintf "d%i" (!dname_counter1)

223


224

let name_of_dimension id =

225

try List.assoc id !dnames with Not_found >

226

let name = new_dname () in

227

dnames := (id, name) :: !dnames;

228

name

229


230

let new_iname () =

231

incr iname_counter;

232

Format.sprintf "t%i" (!iname_counter1)

233


234

let name_of_delay id =

235

try List.assoc id !inames with Not_found >

236

let name = new_iname () in

237

inames := (id, name) :: !inames;

238

name

239


240

open Format

241


242

let print_rat fmt (a,b) =

243

if b=1 then

244

Format.fprintf fmt "%i" a

245

else

246

if b < 0 then

247

Format.fprintf fmt "%i/%i" (a) (b)

248

else

249

Format.fprintf fmt "%i/%i" a b

250


251


252

(* Generic pretty printing *)

253


254

let pp_final_char_if_non_empty c l =

255

(fun fmt > match l with [] > ()  _ > Format.fprintf fmt "%(%)" c)

256


257

let pp_newline_if_non_empty l =

258

(fun fmt > match l with [] > ()  _ > Format.fprintf fmt "@,")

259


260

let fprintf_list ?(eol:('a, formatter, unit) format = "") ~sep:sep f fmt l =

261

let rec aux fmt = function

262

 [] > ()

263

 [e] > f fmt e

264

 x::r > Format.fprintf fmt "%a%(%)%a" f x sep aux r

265

in

266

match l with

267

 [] > ()

268

 _ > (

269

aux fmt l;

270

Format.fprintf fmt "%(%)" eol

271

)

272


273

let pp_list l pp_fun beg_str end_str sep_str =

274

if (beg_str="\n") then

275

print_newline ()

276

else

277

print_string beg_str;

278

let rec pp_l l =

279

match l with

280

 [] > ()

281

 [hd] >

282

pp_fun hd

283

 hd::tl >

284

pp_fun hd;

285

if (sep_str="\n") then

286

print_newline ()

287

else

288

print_string sep_str;

289

pp_l tl

290

in

291

pp_l l;

292

if (end_str="\n") then

293

print_newline ()

294

else

295

print_string end_str

296


297

let pp_array a pp_fun beg_str end_str sep_str =

298

if (beg_str="\n") then

299

print_newline ()

300

else

301

print_string beg_str;

302

let n = Array.length a in

303

if n > 0 then

304

begin

305

Array.iter (fun x > pp_fun x; print_string sep_str) (Array.sub a 0 (n1));

306

pp_fun a.(n1)

307

end;

308

if (end_str="\n") then

309

print_newline ()

310

else

311

print_string end_str

312


313

let pp_iset fmt t =

314

begin

315

Format.fprintf fmt "{@ ";

316

ISet.iter (fun s > Format.fprintf fmt "%s@ " s) t;

317

Format.fprintf fmt "}@."

318

end

319


320

let pp_imap pp_val fmt m =

321

begin

322

Format.fprintf fmt "@[{@ ";

323

IMap.iter (fun key v > Format.fprintf fmt "%s > %a@ " key pp_val v) m;

324

Format.fprintf fmt "}@ @]"

325

end

326


327

let pp_hashtbl t pp_fun beg_str end_str sep_str =

328

if (beg_str="\n") then

329

print_newline ()

330

else

331

print_string beg_str;

332

let pp_fun1 k v =

333

pp_fun k v;

334

if (sep_str="\n") then

335

print_newline ()

336

else

337

print_string sep_str

338

in

339

hashtbl_iterlast t pp_fun1 pp_fun;

340

if (end_str="\n") then

341

print_newline ()

342

else

343

print_string end_str

344


345

let pp_longident lid =

346

let pp_fun (nid, tag) =

347

print_string nid;

348

print_string "(";

349

print_int tag;

350

print_string ")"

351

in

352

pp_list lid pp_fun "" "." "."

353


354

let pp_date fmt tm =

355

Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i"

356

(tm.Unix.tm_year + 1900)

357

tm.Unix.tm_mon

358

tm.Unix.tm_mday

359

tm.Unix.tm_hour

360

tm.Unix.tm_min

361

tm.Unix.tm_sec

362


363

(* Used for uid in variables *)

364


365

let var_id_cpt = ref 0

366

let get_new_id () = incr var_id_cpt;!var_id_cpt

367


368


369

(* for lexing purposes *)

370


371

(* Update line number for location info *)

372

let incr_line lexbuf =

373

let pos = lexbuf.Lexing.lex_curr_p in

374

lexbuf.Lexing.lex_curr_p < { pos with

375

Lexing.pos_lnum = pos.Lexing.pos_lnum + 1;

376

Lexing.pos_bol = pos.Lexing.pos_cnum;

377

}

378


379


380

let last_tag = ref (1)

381

let new_tag () =

382

incr last_tag; !last_tag

383


384


385

module List =

386

struct

387

include List

388

let iteri2 f l1 l2 =

389

if List.length l1 <> List.length l2 then

390

raise (Invalid_argument "iteri2: lists have different lengths")

391

else

392

let rec run idx l1 l2 =

393

match l1, l2 with

394

 [], [] > ()

395

 hd1::tl1, hd2::tl2 > (

396

f idx hd1 hd2;

397

run (idx+1) tl1 tl2

398

)

399

 _ > assert false

400

in

401

run 0 l1 l2

402


403

let rec extract l fst last =

404

if last < fst then assert false else

405

match l, fst with

406

 hd::tl, 0 > if last = 0 then [] else hd::(extract tl 0 (last1))

407

 _::tl, _ > extract tl (fst1) (last1)

408

 [], 0 > if last=0 then [] else assert false (* List too short *)

409

 _ > assert false

410


411

end

412


413

let get_date () =

414

let tm = Unix.localtime (Unix.time ()) in

415

let fmt = Format.str_formatter in

416

pp_date fmt tm;

417

(* let open Unix in *)

418

(* let _ = *)

419

(* Format.fprintf fmt *)

420

(* "%i/%i/%i %ih%i:%i" *)

421

(* tm.tm_year *)

422

(* tm.tm_mon *)

423

(* tm.tm_mday *)

424

(* tm.tm_hour *)

425

(* tm.tm_min *)

426

(* tm.tm_sec *)

427

(* in *)

428

Format.flush_str_formatter ()

429


430


431


432

(* Local Variables: *)

433

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

434

(* End: *)

435

