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

exception DeSome

40

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

41


42

let option_map f o =

43

match o with

44

 None > None

45

 Some e > Some (f e)

46


47

let add_cons x l =

48

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

49


50

let rec remove_duplicates l =

51

match l with

52

 [] > []

53

 t::q > add_cons t (remove_duplicates q)

54


55

let position pred l =

56

let rec pos p l =

57

match l with

58

 [] > assert false

59

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

60

in pos 0 l

61


62

let rec duplicate x n =

63

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

64


65

let enumerate n =

66

let rec aux i =

67

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

68

in aux 0

69


70

let rec repeat n f x =

71

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

72


73

let transpose_list ll =

74

let rec transpose ll =

75

match ll with

76

 [] > []

77

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

78

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

79

in match ll with

80

 [] > []

81

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

82

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

83

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

84

transpose ll

85


86

let rec filter_upto p n l =

87

if n = 0 then [] else

88

match l with

89

 [] > []

90

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

91


92

(* Warning: bad complexity *)

93

let list_of_imap imap =

94

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

95


96

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

97

let rec gcd a b =

98

if b = 0 then a

99

else gcd b (a mod b)

100


101

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

102

let lcm a b =

103

if a = 0 && b = 0 then

104

0

105

else a*b/(gcd a b)

106


107

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

108

[(a',b')] *)

109

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

110

if a = 0 && b = 0 then

111

(a',b')

112

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

113

(a,b)

114

else

115

let lcm_bb' = lcm b b' in

116

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

117


118

let simplify_rat (a,b) =

119

let gcd = gcd a b in

120

if (gcd =0) then

121

(a,b)

122

else (a/gcd,b/gcd)

123


124

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

125

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

126

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

127

if ratio_ab > ratio_ab' then

128

(a,b)

129

else

130

(a',b')

131


132

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

133

result contains no duplicates. *)

134

let list_union l1 l2 =

135

let rec aux l acc =

136

match l with

137

 [] > acc

138

 x::tl >

139

if List.mem x acc then

140

aux tl acc

141

else

142

aux tl (x::acc)

143

in

144

let l1' = aux l1 [] in

145

aux l2 l1'

146


147

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

148

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

149

let hashtbl_add h1 h2 =

150

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

151


152

let hashtbl_iterlast h f1 f2 =

153

let l = Hashtbl.length h in

154

ignore(

155

Hashtbl.fold

156

(fun k v cpt >

157

if cpt = l then

158

begin f2 k v; cpt+1 end

159

else

160

begin f1 k v; cpt+1 end)

161

h 1)

162


163

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

164

variables are identified by integers. *)

165

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

166

let tname_counter = ref 0

167

(* Same for carriers *)

168

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

169

let crname_counter = ref 0

170

(* Same for dimension *)

171

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

172

let dname_counter = ref 0

173

(* Same for delays *)

174

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

175

let iname_counter = ref 0

176


177

let reset_names () =

178

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

179


180

(* From OCaml compiler *)

181

let new_tname () =

182

let tname =

183

if !tname_counter < 26

184

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

185

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

186

string_of_int(!tname_counter / 26) in

187

incr tname_counter;

188

tname

189


190

let new_crname () =

191

incr crname_counter;

192

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

193


194

let name_of_type id =

195

try List.assoc id !tnames with Not_found >

196

let name = new_tname () in

197

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

198

name

199


200

let name_of_carrier id =

201

let pp_id =

202

try List.assoc id !crnames with Not_found >

203

let name = new_crname () in

204

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

205

name

206

in

207

pp_id

208


209

let new_dname () =

210

incr dname_counter;

211

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

212


213

let name_of_dimension id =

214

try List.assoc id !dnames with Not_found >

215

let name = new_dname () in

216

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

217

name

218


219

let new_iname () =

220

incr iname_counter;

221

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

222


223

let name_of_delay id =

224

try List.assoc id !inames with Not_found >

225

let name = new_iname () in

226

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

227

name

228


229

open Format

230


231

let print_rat fmt (a,b) =

232

if b=1 then

233

Format.fprintf fmt "%i" a

234

else

235

if b < 0 then

236

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

237

else

238

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

239


240


241

(* Generic pretty printing *)

242


243

let pp_final_char_if_non_empty c l =

244

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

245


246

let pp_newline_if_non_empty l =

247

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

248


249

let rec fprintf_list ~sep:sep f fmt = function

250

 [] > ()

251

 [e] > f fmt e

252

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

253


254

let pp_list l pp_fun beg_str end_str sep_str =

255

if (beg_str="\n") then

256

print_newline ()

257

else

258

print_string beg_str;

259

let rec pp_l l =

260

match l with

261

 [] > ()

262

 [hd] >

263

pp_fun hd

264

 hd::tl >

265

pp_fun hd;

266

if (sep_str="\n") then

267

print_newline ()

268

else

269

print_string sep_str;

270

pp_l tl

271

in

272

pp_l l;

273

if (end_str="\n") then

274

print_newline ()

275

else

276

print_string end_str

277


278

let pp_array a pp_fun beg_str end_str sep_str =

279

if (beg_str="\n") then

280

print_newline ()

281

else

282

print_string beg_str;

283

let n = Array.length a in

284

if n > 0 then

285

begin

286

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

287

pp_fun a.(n1)

288

end;

289

if (end_str="\n") then

290

print_newline ()

291

else

292

print_string end_str

293


294

let pp_iset fmt t =

295

begin

296

Format.fprintf fmt "{@ ";

297

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

298

Format.fprintf fmt "}@."

299

end

300


301

let pp_imap pp_val fmt m =

302

begin

303

Format.fprintf fmt "@[{@ ";

304

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

305

Format.fprintf fmt "}@ @]"

306

end

307


308

let pp_hashtbl t pp_fun beg_str end_str sep_str =

309

if (beg_str="\n") then

310

print_newline ()

311

else

312

print_string beg_str;

313

let pp_fun1 k v =

314

pp_fun k v;

315

if (sep_str="\n") then

316

print_newline ()

317

else

318

print_string sep_str

319

in

320

hashtbl_iterlast t pp_fun1 pp_fun;

321

if (end_str="\n") then

322

print_newline ()

323

else

324

print_string end_str

325


326

let pp_longident lid =

327

let pp_fun (nid, tag) =

328

print_string nid;

329

print_string "(";

330

print_int tag;

331

print_string ")"

332

in

333

pp_list lid pp_fun "" "." "."

334


335

let pp_date fmt tm =

336

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

337

(tm.Unix.tm_year + 1900)

338

tm.Unix.tm_mon

339

tm.Unix.tm_mday

340

tm.Unix.tm_hour

341

tm.Unix.tm_min

342

tm.Unix.tm_sec

343


344

(* Used for uid in variables *)

345


346

let var_id_cpt = ref 0

347

let get_new_id () = incr var_id_cpt;!var_id_cpt

348


349


350

(* for lexing purposes *)

351


352

(* Update line number for location info *)

353

let incr_line lexbuf =

354

let pos = lexbuf.Lexing.lex_curr_p in

355

lexbuf.Lexing.lex_curr_p < { pos with

356

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

357

Lexing.pos_bol = pos.Lexing.pos_cnum;

358

}

359


360


361

let last_tag = ref (1)

362

let new_tag () =

363

incr last_tag; !last_tag

364


365


366

module List =

367

struct

368

include List

369

let iteri2 f l1 l2 =

370

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

371

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

372

else

373

let rec run idx l1 l2 =

374

match l1, l2 with

375

 [], [] > ()

376

 hd1::tl1, hd2::tl2 > (

377

f idx hd1 hd2;

378

run (idx+1) tl1 tl2

379

)

380

 _ > assert false

381

in

382

run 0 l1 l2

383

end

384


385


386

(* Local Variables: *)

387

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

388

(* End: *)
