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 = Map.Make(IdentModule)

36


37

module ISet = Set.Make(IdentModule)

38

module IdentDepGraph = Graph.Imperative.Digraph.ConcreteBidirectional (IdentModule)

39

module TopologicalDepGraph = Topological.Make(IdentDepGraph)

40


41

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

42

module Bfs = Traverse.Bfs (IdentDepGraph)

43


44


45

exception DeSome

46

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

47


48

let option_map f o =

49

match o with

50

 None > None

51

 Some e > Some (f e)

52


53

let add_cons x l =

54

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

55


56

let rec remove_duplicates l =

57

match l with

58

 [] > []

59

 t::q > add_cons t (remove_duplicates q)

60


61

let position pred l =

62

let rec pos p l =

63

match l with

64

 [] > assert false

65

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

66

in pos 0 l

67


68

let rec duplicate x n =

69

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

70


71

let enumerate n =

72

let rec aux i =

73

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

74

in aux 0

75


76

let rec repeat n f x =

77

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

78


79

let transpose_list ll =

80

let rec transpose ll =

81

match ll with

82

 [] > []

83

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

84

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

85

in match ll with

86

 [] > []

87

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

88

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

89

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

90

transpose ll

91


92

let rec filter_upto p n l =

93

if n = 0 then [] else

94

match l with

95

 [] > []

96

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

97


98

(* Warning: bad complexity *)

99

let list_of_imap imap =

100

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

101


102

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

103

let rec gcd a b =

104

if b = 0 then a

105

else gcd b (a mod b)

106


107

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

108

let lcm a b =

109

if a = 0 && b = 0 then

110

0

111

else a*b/(gcd a b)

112


113

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

114

[(a',b')] *)

115

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

116

if a = 0 && b = 0 then

117

(a',b')

118

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

119

(a,b)

120

else

121

let lcm_bb' = lcm b b' in

122

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

123


124

let simplify_rat (a,b) =

125

let gcd = gcd a b in

126

if (gcd =0) then

127

(a,b)

128

else (a/gcd,b/gcd)

129


130

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

131

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

132

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

133

if ratio_ab > ratio_ab' then

134

(a,b)

135

else

136

(a',b')

137


138

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

139

result contains no duplicates. *)

140

let list_union l1 l2 =

141

let rec aux l acc =

142

match l with

143

 [] > acc

144

 x::tl >

145

if List.mem x acc then

146

aux tl acc

147

else

148

aux tl (x::acc)

149

in

150

let l1' = aux l1 [] in

151

aux l2 l1'

152


153

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

154

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

155

let hashtbl_add h1 h2 =

156

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

157


158

let hashtbl_iterlast h f1 f2 =

159

let l = Hashtbl.length h in

160

ignore(

161

Hashtbl.fold

162

(fun k v cpt >

163

if cpt = l then

164

begin f2 k v; cpt+1 end

165

else

166

begin f1 k v; cpt+1 end)

167

h 1)

168


169

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

170

variables are identified by integers. *)

171

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

172

let tname_counter = ref 0

173

(* Same for carriers *)

174

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

175

let crname_counter = ref 0

176

(* Same for dimension *)

177

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

178

let dname_counter = ref 0

179

(* Same for delays *)

180

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

181

let iname_counter = ref 0

182


183

let reset_names () =

184

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

185


186

(* From OCaml compiler *)

187

let new_tname () =

188

let tname =

189

if !tname_counter < 26

190

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

191

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

192

string_of_int(!tname_counter / 26) in

193

incr tname_counter;

194

tname

195


196

let new_crname () =

197

incr crname_counter;

198

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

199


200

let name_of_type id =

201

try List.assoc id !tnames with Not_found >

202

let name = new_tname () in

203

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

204

name

205


206

let name_of_carrier id =

207

let pp_id =

208

try List.assoc id !crnames with Not_found >

209

let name = new_crname () in

210

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

211

name

212

in

213

pp_id

214


215

let new_dname () =

216

incr dname_counter;

217

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

218


219

let name_of_dimension id =

220

try List.assoc id !dnames with Not_found >

221

let name = new_dname () in

222

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

223

name

224


225

let new_iname () =

226

incr iname_counter;

227

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

228


229

let name_of_delay id =

230

try List.assoc id !inames with Not_found >

231

let name = new_iname () in

232

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

233

name

234


235

open Format

236


237

let print_rat fmt (a,b) =

238

if b=1 then

239

Format.fprintf fmt "%i" a

240

else

241

if b < 0 then

242

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

243

else

244

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

245


246


247

(* Generic pretty printing *)

248


249

let pp_final_char_if_non_empty c l =

250

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

251


252

let pp_newline_if_non_empty l =

253

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

254


255

let rec fprintf_list ~sep:sep f fmt = function

256

 [] > ()

257

 [e] > f fmt e

258

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

259


260

let pp_list l pp_fun beg_str end_str sep_str =

261

if (beg_str="\n") then

262

print_newline ()

263

else

264

print_string beg_str;

265

let rec pp_l l =

266

match l with

267

 [] > ()

268

 [hd] >

269

pp_fun hd

270

 hd::tl >

271

pp_fun hd;

272

if (sep_str="\n") then

273

print_newline ()

274

else

275

print_string sep_str;

276

pp_l tl

277

in

278

pp_l l;

279

if (end_str="\n") then

280

print_newline ()

281

else

282

print_string end_str

283


284

let pp_array a pp_fun beg_str end_str sep_str =

285

if (beg_str="\n") then

286

print_newline ()

287

else

288

print_string beg_str;

289

let n = Array.length a in

290

if n > 0 then

291

begin

292

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

293

pp_fun a.(n1)

294

end;

295

if (end_str="\n") then

296

print_newline ()

297

else

298

print_string end_str

299


300

let pp_iset fmt t =

301

begin

302

Format.fprintf fmt "{@ ";

303

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

304

Format.fprintf fmt "}@."

305

end

306


307

let pp_imap pp_val fmt m =

308

begin

309

Format.fprintf fmt "@[{@ ";

310

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

311

Format.fprintf fmt "}@ @]"

312

end

313


314

let pp_hashtbl t pp_fun beg_str end_str sep_str =

315

if (beg_str="\n") then

316

print_newline ()

317

else

318

print_string beg_str;

319

let pp_fun1 k v =

320

pp_fun k v;

321

if (sep_str="\n") then

322

print_newline ()

323

else

324

print_string sep_str

325

in

326

hashtbl_iterlast t pp_fun1 pp_fun;

327

if (end_str="\n") then

328

print_newline ()

329

else

330

print_string end_str

331


332

let pp_longident lid =

333

let pp_fun (nid, tag) =

334

print_string nid;

335

print_string "(";

336

print_int tag;

337

print_string ")"

338

in

339

pp_list lid pp_fun "" "." "."

340


341

let pp_date fmt tm =

342

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

343

(tm.Unix.tm_year + 1900)

344

tm.Unix.tm_mon

345

tm.Unix.tm_mday

346

tm.Unix.tm_hour

347

tm.Unix.tm_min

348

tm.Unix.tm_sec

349


350

(* Used for uid in variables *)

351


352

let var_id_cpt = ref 0

353

let get_new_id () = incr var_id_cpt;!var_id_cpt

354


355


356

(* for lexing purposes *)

357


358

(* Update line number for location info *)

359

let incr_line lexbuf =

360

let pos = lexbuf.Lexing.lex_curr_p in

361

lexbuf.Lexing.lex_curr_p < { pos with

362

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

363

Lexing.pos_bol = pos.Lexing.pos_cnum;

364

}

365


366


367

let last_tag = ref (1)

368

let new_tag () =

369

incr last_tag; !last_tag

370


371


372

module List =

373

struct

374

include List

375

let iteri2 f l1 l2 =

376

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

377

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

378

else

379

let rec run idx l1 l2 =

380

match l1, l2 with

381

 [], [] > ()

382

 hd1::tl1, hd2::tl2 > (

383

f idx hd1 hd2;

384

run (idx+1) tl1 tl2

385

)

386

 _ > assert false

387

in

388

run 0 l1 l2

389


390

let rec extract l fst last =

391

if last < fst then assert false else

392

match l, fst with

393

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

394

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

395

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

396

 _ > assert false

397


398

end

399


400

let get_date () =

401

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

402

let fmt = Format.str_formatter in

403

pp_date fmt tm;

404

(* let open Unix in *)

405

(* let _ = *)

406

(* Format.fprintf fmt *)

407

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

408

(* tm.tm_year *)

409

(* tm.tm_mon *)

410

(* tm.tm_mday *)

411

(* tm.tm_hour *)

412

(* tm.tm_min *)

413

(* tm.tm_sec *)

414

(* in *)

415

Format.flush_str_formatter ()

416


417

(* Local Variables: *)

418

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

419

(* End: *)
