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


39

let desome x = match x with Some x > x  None > failwith "desome"

40


41

let option_map f o =

42

match o with

43

 None > None

44

 Some e > Some (f e)

45


46

let add_cons x l =

47

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

48


49

let rec remove_duplicates l =

50

match l with

51

 [] > []

52

 t::q > add_cons t (remove_duplicates q)

53


54

let position pred l =

55

let rec pos p l =

56

match l with

57

 [] > assert false

58

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

59

in pos 0 l

60


61

let rec duplicate x n =

62

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

63


64

let enumerate n =

65

let rec aux i =

66

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

67

in aux 0

68


69

let rec repeat n f x =

70

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

71


72

let transpose_list ll =

73

let rec transpose ll =

74

match ll with

75

 [] > []

76

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

77

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

78

in match ll with

79

 [] > []

80

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

81

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

82

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

83

transpose ll

84


85

let rec filter_upto p n l =

86

if n = 0 then [] else

87

match l with

88

 [] > []

89

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

90


91

(* Warning: bad complexity *)

92

let list_of_imap imap =

93

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

94


95

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

96

let rec gcd a b =

97

if b = 0 then a

98

else gcd b (a mod b)

99


100

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

101

let lcm a b =

102

if a = 0 && b = 0 then

103

0

104

else a*b/(gcd a b)

105


106

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

107

[(a',b')] *)

108

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

109

if a = 0 && b = 0 then

110

(a',b')

111

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

112

(a,b)

113

else

114

let lcm_bb' = lcm b b' in

115

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

116


117

let simplify_rat (a,b) =

118

let gcd = gcd a b in

119

if (gcd =0) then

120

(a,b)

121

else (a/gcd,b/gcd)

122


123

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

124

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

125

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

126

if ratio_ab > ratio_ab' then

127

(a,b)

128

else

129

(a',b')

130


131

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

132

result contains no duplicates. *)

133

let list_union l1 l2 =

134

let rec aux l acc =

135

match l with

136

 [] > acc

137

 x::tl >

138

if List.mem x acc then

139

aux tl acc

140

else

141

aux tl (x::acc)

142

in

143

let l1' = aux l1 [] in

144

aux l2 l1'

145


146

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

147

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

148

let hashtbl_add h1 h2 =

149

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

150


151

let hashtbl_iterlast h f1 f2 =

152

let l = Hashtbl.length h in

153

ignore(

154

Hashtbl.fold

155

(fun k v cpt >

156

if cpt = l then

157

begin f2 k v; cpt+1 end

158

else

159

begin f1 k v; cpt+1 end)

160

h 1)

161


162

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

163

variables are identified by integers. *)

164

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

165

let tname_counter = ref 0

166

(* Same for carriers *)

167

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

168

let crname_counter = ref 0

169

(* Same for dimension *)

170

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

171

let dname_counter = ref 0

172

(* Same for delays *)

173

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

174

let iname_counter = ref 0

175


176

let reset_names () =

177

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

178


179

(* From OCaml compiler *)

180

let new_tname () =

181

let tname =

182

if !tname_counter < 26

183

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

184

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

185

string_of_int(!tname_counter / 26) in

186

incr tname_counter;

187

tname

188


189

let new_crname () =

190

incr crname_counter;

191

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

192


193

let name_of_type id =

194

try List.assoc id !tnames with Not_found >

195

let name = new_tname () in

196

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

197

name

198


199

let name_of_carrier id =

200

let pp_id =

201

try List.assoc id !crnames with Not_found >

202

let name = new_crname () in

203

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

204

name

205

in

206

pp_id

207


208

let new_dname () =

209

incr dname_counter;

210

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

211


212

let name_of_dimension id =

213

try List.assoc id !dnames with Not_found >

214

let name = new_dname () in

215

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

216

name

217


218

let new_iname () =

219

incr iname_counter;

220

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

221


222

let name_of_delay id =

223

try List.assoc id !inames with Not_found >

224

let name = new_iname () in

225

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

226

name

227


228

open Format

229


230

let print_rat fmt (a,b) =

231

if b=1 then

232

Format.fprintf fmt "%i" a

233

else

234

if b < 0 then

235

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

236

else

237

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

238


239


240

(* Generic pretty printing *)

241


242

let pp_final_char_if_non_empty c l =

243

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

244


245

let pp_newline_if_non_empty l =

246

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

247


248

let rec fprintf_list ~sep:sep f fmt = function

249

 [] > ()

250

 [e] > f fmt e

251

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

252


253

let pp_list l pp_fun beg_str end_str sep_str =

254

if (beg_str="\n") then

255

print_newline ()

256

else

257

print_string beg_str;

258

let rec pp_l l =

259

match l with

260

 [] > ()

261

 [hd] >

262

pp_fun hd

263

 hd::tl >

264

pp_fun hd;

265

if (sep_str="\n") then

266

print_newline ()

267

else

268

print_string sep_str;

269

pp_l tl

270

in

271

pp_l l;

272

if (end_str="\n") then

273

print_newline ()

274

else

275

print_string end_str

276


277

let pp_array a pp_fun beg_str end_str sep_str =

278

if (beg_str="\n") then

279

print_newline ()

280

else

281

print_string beg_str;

282

let n = Array.length a in

283

if n > 0 then

284

begin

285

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

286

pp_fun a.(n1)

287

end;

288

if (end_str="\n") then

289

print_newline ()

290

else

291

print_string end_str

292


293

let pp_iset fmt t =

294

begin

295

Format.fprintf fmt "{@ ";

296

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

297

Format.fprintf fmt "}@."

298

end

299


300

let pp_hashtbl t pp_fun beg_str end_str sep_str =

301

if (beg_str="\n") then

302

print_newline ()

303

else

304

print_string beg_str;

305

let pp_fun1 k v =

306

pp_fun k v;

307

if (sep_str="\n") then

308

print_newline ()

309

else

310

print_string sep_str

311

in

312

hashtbl_iterlast t pp_fun1 pp_fun;

313

if (end_str="\n") then

314

print_newline ()

315

else

316

print_string end_str

317


318

let pp_longident lid =

319

let pp_fun (nid, tag) =

320

print_string nid;

321

print_string "(";

322

print_int tag;

323

print_string ")"

324

in

325

pp_list lid pp_fun "" "." "."

326


327

let pp_date fmt tm =

328

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

329

(tm.Unix.tm_year + 1900)

330

tm.Unix.tm_mon

331

tm.Unix.tm_mday

332

tm.Unix.tm_hour

333

tm.Unix.tm_min

334

tm.Unix.tm_sec

335


336

(* Used for uid in variables *)

337


338

let var_id_cpt = ref 0

339

let get_new_id () = incr var_id_cpt;!var_id_cpt

340


341


342

let track_exception () =

343

if !Options.track_exceptions

344

then (Printexc.print_backtrace stdout; flush stdout)

345

else ()

346


347


348

(* for lexing purposes *)

349


350

(* Update line number for location info *)

351

let incr_line lexbuf =

352

let pos = lexbuf.Lexing.lex_curr_p in

353

lexbuf.Lexing.lex_curr_p < { pos with

354

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

355

Lexing.pos_bol = pos.Lexing.pos_cnum;

356

}

357


358


359

let last_tag = ref (1)

360

let new_tag () =

361

incr last_tag; !last_tag

362


363

(* Local Variables: *)

364

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

365

(* End: *)
