## lustrec / src / utils.ml @ 2d179f5b

History | View | Annotate | Download (8.76 KB)

1 | a2d97a3e | ploc | (********************************************************************) |
---|---|---|---|

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 | 22fe1c93 | ploc | open Graph |

13 | |||

14 | type rat = int*int |
||

15 | type ident = string |
||

16 | type tag = int |
||

17 | type longident = (string * tag) list |
||

18 | |||

19 | b616fe7a | xthirioux | exception TransposeError of int*int |

20 | |||

21 | 22fe1c93 | ploc | (** 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 | e2380d4d | ploc | let desome x = match x with Some x -> x | None -> failwith "desome" |

40 | |||

41 | 22fe1c93 | ploc | let option_map f o = |

42 | match o with |
||

43 | | None -> None |
||

44 | | Some e -> Some (f e) |
||

45 | |||

46 | 45c13277 | xthirioux | let add_cons x l = |

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

48 | |||

49 | bb2ca5f4 | xthirioux | let rec remove_duplicates l = |

50 | match l with |
||

51 | | [] -> [] |
||

52 | 45c13277 | xthirioux | | t::q -> add_cons t (remove_duplicates q) |

53 | bb2ca5f4 | xthirioux | |

54 | 22fe1c93 | ploc | 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 (n-1) f (f x) |
||

71 | |||

72 | b616fe7a | xthirioux | 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 | 22fe1c93 | ploc | |

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 (n-1) 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 pretty-printing. 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_counter-1) |
||

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_counter-1) |
||

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_counter-1) |
||

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 (n-1)); |
||

286 | pp_fun a.(n-1) |
||

287 | end; |
||

288 | if (end_str="\n") then |
||

289 | print_newline () |
||

290 | else |
||

291 | print_string end_str |
||

292 | |||

293 | 8a183477 | xthirioux | 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 | 22fe1c93 | ploc | 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 | 5c1184ad | ploc | 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 | 22fe1c93 | ploc | |

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 | (* compile-command:"make -C .." *) |
||

365 | (* End: *) |