## lustrec / src / utils.ml @ 8f0e9f74

History | View | Annotate | Download (9.21 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 | 4d138e19 | ploc | |

37 | 22fe1c93 | ploc | module ISet = Set.Make(IdentModule) |

38 | |||

39 | 04a63d25 | xthirioux | exception DeSome |

40 | let desome x = match x with Some x -> x | None -> raise DeSome |
||

41 | e2380d4d | ploc | |

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

43 | match o with |
||

44 | | None -> None |
||

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

46 | |||

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

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

49 | |||

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

51 | match l with |
||

52 | | [] -> [] |
||

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

54 | bb2ca5f4 | xthirioux | |

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

72 | |||

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

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

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

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

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

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

288 | end; |
||

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

290 | print_newline () |
||

291 | else |
||

292 | print_string end_str |
||

293 | |||

294 | 8a183477 | xthirioux | 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 | 4d138e19 | ploc | 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 | 22fe1c93 | ploc | 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 | 5c1184ad | ploc | let pp_date fmt tm = |

336 | 0f36882c | xthirioux | Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i" |

337 | 5c1184ad | ploc | (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 | 22fe1c93 | ploc | |

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 | 6fa45cb6 | ploc | |

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 | 22fe1c93 | ploc | (* Local Variables: *) |

387 | (* compile-command:"make -C .." *) |
||

388 | (* End: *) |