lustrec / lib / utils / utils.ml @ 9b0432bc
History  View  Annotate  Download (10.7 KB)
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 
[@@deriving show] 
16 
type ident = string 
17 
[@@deriving show] 
18 
type tag = int 
19 
[@@deriving show] 
20 
type longident = (string * tag) list 
21 
[@@deriving show] 
22  
23 
exception TransposeError of int*int 
24  
25 
(** General utility functions. *) 
26 
let create_hashtable size init = 
27 
let tbl = Hashtbl.create size in 
28 
List.iter (fun (key, data) > Hashtbl.add tbl key data) init; 
29 
tbl 
30  
31 
module IdentModule = 
32 
struct (* Node module *) 
33 
type t = ident 
34 
let compare = compare 
35 
let hash n = Hashtbl.hash n 
36 
let equal n1 n2 = n1 = n2 
37 
end 
38  
39 
module IMap = 
40 
struct 
41 
include Map.Make(IdentModule) 
42 
let elements m = fold (fun i n res > (i, n)::res) m [] 
43 
end 
44 

45 
module ISet = Set.Make(IdentModule) 
46 
module IdentDepGraph = Imperative.Digraph.ConcreteBidirectional (IdentModule) 
47 
module TopologicalDepGraph = Topological.Make(IdentDepGraph) 
48 
module ComponentsDepGraph = Components.Make(IdentDepGraph) 
49 

50 
(*module DotGraph = Graphviz.Dot (IdentDepGraph)*) 
51 
module Bfs = Traverse.Bfs (IdentDepGraph) 
52  
53 

54 
exception DeSome 
55 
let desome x = match x with Some x > x  None > raise DeSome 
56  
57 
let option_map f o = 
58 
match o with 
59 
 None > None 
60 
 Some e > Some (f e) 
61  
62 
let add_cons x l = 
63 
if List.mem x l then l else x::l 
64  
65 
let rec remove_duplicates l = 
66 
match l with 
67 
 [] > [] 
68 
 t::q > add_cons t (remove_duplicates q) 
69  
70 
let position pred l = 
71 
let rec pos p l = 
72 
match l with 
73 
 [] > assert false 
74 
 t::q > if pred t then p else pos (p+1) q 
75 
in pos 0 l 
76  
77 
let rec duplicate x n = 
78 
if n < 0 then [] else x :: duplicate x (n  1) 
79  
80 
let enumerate n = 
81 
let rec aux i = 
82 
if i >= n then [] else i :: aux (i+1) 
83 
in aux 0 
84  
85 
let rec repeat n f x = 
86 
if n <= 0 then x else repeat (n1) f (f x) 
87  
88 
let transpose_list ll = 
89 
let rec transpose ll = 
90 
match ll with 
91 
 [] > [] 
92 
 [l] > List.map (fun el > [el]) l 
93 
 l::q > List.map2 (fun el eq > el::eq) l (transpose q) 
94 
in match ll with 
95 
 [] > [] 
96 
 l::q > let length_l = List.length l in 
97 
List.iter (fun l' > let length_l' = List.length l' 
98 
in if length_l <> length_l' then raise (TransposeError (length_l, length_l'))) q; 
99 
transpose ll 
100  
101 
let rec filter_upto p n l = 
102 
if n = 0 then [] else 
103 
match l with 
104 
 [] > [] 
105 
 t::q > if p t then t :: filter_upto p (n1) q else filter_upto p n q 
106  
107 
(* Warning: bad complexity *) 
108 
let list_of_imap imap = 
109 
IMap.fold (fun i v (il,vl) > (i::il,v::vl)) imap ([],[]) 
110  
111 
(** [gcd a b] returns the greatest common divisor of [a] and [b]. *) 
112 
let rec gcd a b = 
113 
if b = 0 then a 
114 
else gcd b (a mod b) 
115  
116 
(** [lcm a b] returns the least common multiple of [a] and [b]. *) 
117 
let lcm a b = 
118 
if a = 0 && b = 0 then 
119 
0 
120 
else a*b/(gcd a b) 
121  
122 
(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and 
123 
[(a',b')] *) 
124 
let sum_rat (a,b) (a',b') = 
125 
if a = 0 && b = 0 then 
126 
(a',b') 
127 
else if a'=0 && b'=0 then 
128 
(a,b) 
129 
else 
130 
let lcm_bb' = lcm b b' in 
131 
(a*lcm_bb'/b+a'*lcm_bb'/b',lcm_bb') 
132  
133 
let simplify_rat (a,b) = 
134 
let gcd = gcd a b in 
135 
if (gcd =0) then 
136 
(a,b) 
137 
else (a/gcd,b/gcd) 
138  
139 
let max_rat (a,b) (a',b') = 
140 
let ratio_ab = (float_of_int a)/.(float_of_int b) in 
141 
let ratio_ab' = (float_of_int a')/.(float_of_int b') in 
142 
if ratio_ab > ratio_ab' then 
143 
(a,b) 
144 
else 
145 
(a',b') 
146  
147 
(** [list_union l1 l2] returns the union of list [l1] and [l2]. The 
148 
result contains no duplicates. *) 
149 
let list_union l1 l2 = 
150 
let rec aux l acc = 
151 
match l with 
152 
 [] > acc 
153 
 x::tl > 
154 
if List.mem x acc then 
155 
aux tl acc 
156 
else 
157 
aux tl (x::acc) 
158 
in 
159 
let l1' = aux l1 [] in 
160 
aux l2 l1' 
161  
162 
(** [hashtbl_add h1 h2] adds all the bindings in [h2] to [h1]. If the 
163 
intersection is not empty, it replaces the former binding *) 
164 
let hashtbl_add h1 h2 = 
165 
Hashtbl.iter (fun key value > Hashtbl.replace h1 key value) h2 
166  
167 
let hashtbl_iterlast h f1 f2 = 
168 
let l = Hashtbl.length h in 
169 
ignore( 
170 
Hashtbl.fold 
171 
(fun k v cpt > 
172 
if cpt = l then 
173 
begin f2 k v; cpt+1 end 
174 
else 
175 
begin f1 k v; cpt+1 end) 
176 
h 1) 
177  
178 
(** Match types variables to 'a, 'b, ..., for prettyprinting. Type 
179 
variables are identified by integers. *) 
180 
let tnames = ref ([]: (int * string) list) 
181 
let tname_counter = ref 0 
182 
(* Same for carriers *) 
183 
let crnames = ref ([]: (int * string) list) 
184 
let crname_counter = ref 0 
185 
(* Same for dimension *) 
186 
let dnames = ref ([]: (int * string) list) 
187 
let dname_counter = ref 0 
188 
(* Same for delays *) 
189 
let inames = ref ([]: (int * string) list) 
190 
let iname_counter = ref 0 
191  
192 
let reset_names () = 
193 
tnames := []; tname_counter := 0; crnames := []; crname_counter := 0; dnames := []; dname_counter := 0; inames := []; iname_counter := 0 
194  
195 
(* From OCaml compiler *) 
196 
let new_tname () = 
197 
let tname = 
198 
if !tname_counter < 26 
199 
then String.make 1 (Char.chr(97 + !tname_counter)) 
200 
else String.make 1 (Char.chr(97 + !tname_counter mod 26)) ^ 
201 
string_of_int(!tname_counter / 26) in 
202 
incr tname_counter; 
203 
tname 
204  
205 
let new_crname () = 
206 
incr crname_counter; 
207 
Format.sprintf "c%i" (!crname_counter1) 
208  
209 
let name_of_type id = 
210 
try List.assoc id !tnames with Not_found > 
211 
let name = new_tname () in 
212 
tnames := (id, name) :: !tnames; 
213 
name 
214  
215 
let name_of_carrier id = 
216 
let pp_id = 
217 
try List.assoc id !crnames with Not_found > 
218 
let name = new_crname () in 
219 
crnames := (id,name) :: !crnames; 
220 
name 
221 
in 
222 
pp_id 
223  
224 
let new_dname () = 
225 
incr dname_counter; 
226 
Format.sprintf "d%i" (!dname_counter1) 
227  
228 
let name_of_dimension id = 
229 
try List.assoc id !dnames with Not_found > 
230 
let name = new_dname () in 
231 
dnames := (id, name) :: !dnames; 
232 
name 
233  
234 
let new_iname () = 
235 
incr iname_counter; 
236 
Format.sprintf "t%i" (!iname_counter1) 
237  
238 
let name_of_delay id = 
239 
try List.assoc id !inames with Not_found > 
240 
let name = new_iname () in 
241 
inames := (id, name) :: !inames; 
242 
name 
243  
244 
open Format 
245  
246 
let print_rat fmt (a,b) = 
247 
if b=1 then 
248 
Format.fprintf fmt "%i" a 
249 
else 
250 
if b < 0 then 
251 
Format.fprintf fmt "%i/%i" (a) (b) 
252 
else 
253 
Format.fprintf fmt "%i/%i" a b 
254 

255  
256 
(* Generic pretty printing *) 
257  
258 
let pp_final_char_if_non_empty c l = 
259 
(fun fmt > match l with [] > ()  _ > Format.fprintf fmt "%(%)" c) 
260  
261 
let pp_newline_if_non_empty l = 
262 
(fun fmt > match l with [] > ()  _ > Format.fprintf fmt "@,") 
263  
264 
let fprintf_list ?(eol:('a, formatter, unit) format = "") ~sep:sep f fmt l = 
265 
let rec aux fmt = function 
266 
 [] > () 
267 
 [e] > f fmt e 
268 
 x::r > Format.fprintf fmt "%a%(%)%a" f x sep aux r 
269 
in 
270 
match l with 
271 
 [] > () 
272 
 _ > ( 
273 
aux fmt l; 
274 
Format.fprintf fmt "%(%)" eol 
275 
) 
276 

277 
let pp_list l 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 rec pp_l l = 
283 
match l with 
284 
 [] > () 
285 
 [hd] > 
286 
pp_fun hd 
287 
 hd::tl > 
288 
pp_fun hd; 
289 
if (sep_str="\n") then 
290 
print_newline () 
291 
else 
292 
print_string sep_str; 
293 
pp_l tl 
294 
in 
295 
pp_l l; 
296 
if (end_str="\n") then 
297 
print_newline () 
298 
else 
299 
print_string end_str 
300  
301 
let pp_array a pp_fun beg_str end_str sep_str = 
302 
if (beg_str="\n") then 
303 
print_newline () 
304 
else 
305 
print_string beg_str; 
306 
let n = Array.length a in 
307 
if n > 0 then 
308 
begin 
309 
Array.iter (fun x > pp_fun x; print_string sep_str) (Array.sub a 0 (n1)); 
310 
pp_fun a.(n1) 
311 
end; 
312 
if (end_str="\n") then 
313 
print_newline () 
314 
else 
315 
print_string end_str 
316  
317 
let pp_iset fmt t = 
318 
begin 
319 
Format.fprintf fmt "{@ "; 
320 
ISet.iter (fun s > Format.fprintf fmt "%s@ " s) t; 
321 
Format.fprintf fmt "}@." 
322 
end 
323  
324 
let pp_imap pp_val fmt m = 
325 
begin 
326 
Format.fprintf fmt "@[{@ "; 
327 
IMap.iter (fun key v > Format.fprintf fmt "%s > %a@ " key pp_val v) m; 
328 
Format.fprintf fmt "}@ @]" 
329 
end 
330 

331 
let pp_hashtbl t pp_fun beg_str end_str sep_str = 
332 
if (beg_str="\n") then 
333 
print_newline () 
334 
else 
335 
print_string beg_str; 
336 
let pp_fun1 k v = 
337 
pp_fun k v; 
338 
if (sep_str="\n") then 
339 
print_newline () 
340 
else 
341 
print_string sep_str 
342 
in 
343 
hashtbl_iterlast t pp_fun1 pp_fun; 
344 
if (end_str="\n") then 
345 
print_newline () 
346 
else 
347 
print_string end_str 
348  
349 
let pp_longident lid = 
350 
let pp_fun (nid, tag) = 
351 
print_string nid; 
352 
print_string "("; 
353 
print_int tag; 
354 
print_string ")" 
355 
in 
356 
pp_list lid pp_fun "" "." "." 
357  
358 
let pp_date fmt tm = 
359 
Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i" 
360 
(tm.Unix.tm_year + 1900) 
361 
tm.Unix.tm_mon 
362 
tm.Unix.tm_mday 
363 
tm.Unix.tm_hour 
364 
tm.Unix.tm_min 
365 
tm.Unix.tm_sec 
366  
367 
(* Used for uid in variables *) 
368  
369 
let var_id_cpt = ref 0 
370 
let get_new_id () = incr var_id_cpt;!var_id_cpt 
371  
372  
373 
(* for lexing purposes *) 
374  
375 
(* Update line number for location info *) 
376 
let incr_line lexbuf = 
377 
let pos = lexbuf.Lexing.lex_curr_p in 
378 
lexbuf.Lexing.lex_curr_p < { pos with 
379 
Lexing.pos_lnum = pos.Lexing.pos_lnum + 1; 
380 
Lexing.pos_bol = pos.Lexing.pos_cnum; 
381 
} 
382  
383  
384 
let last_tag = ref (1) 
385 
let new_tag () = 
386 
incr last_tag; !last_tag 
387  
388  
389 
module List = 
390 
struct 
391 
include List 
392 
let iteri2 f l1 l2 = 
393 
if List.length l1 <> List.length l2 then 
394 
raise (Invalid_argument "iteri2: lists have different lengths") 
395 
else 
396 
let rec run idx l1 l2 = 
397 
match l1, l2 with 
398 
 [], [] > () 
399 
 hd1::tl1, hd2::tl2 > ( 
400 
f idx hd1 hd2; 
401 
run (idx+1) tl1 tl2 
402 
) 
403 
 _ > assert false 
404 
in 
405 
run 0 l1 l2 
406  
407 
let rec extract l fst last = 
408 
if last < fst then assert false else 
409 
match l, fst with 
410 
 hd::tl, 0 > if last = 0 then [] else hd::(extract tl 0 (last1)) 
411 
 _::tl, _ > extract tl (fst1) (last1) 
412 
 [], 0 > if last=0 then [] else assert false (* List too short *) 
413 
 _ > assert false 
414 

415 
end 
416  
417 
let get_date () = 
418 
let tm = Unix.localtime (Unix.time ()) in 
419 
let fmt = Format.str_formatter in 
420 
pp_date fmt tm; 
421 
(* let open Unix in *) 
422 
(* let _ = *) 
423 
(* Format.fprintf fmt *) 
424 
(* "%i/%i/%i %ih%i:%i" *) 
425 
(* tm.tm_year *) 
426 
(* tm.tm_mon *) 
427 
(* tm.tm_mday *) 
428 
(* tm.tm_hour *) 
429 
(* tm.tm_min *) 
430 
(* tm.tm_sec *) 
431 
(* in *) 
432 
Format.flush_str_formatter () 
433  
434  
435 

436 
(* Local Variables: *) 
437 
(* compilecommand:"make C .." *) 
438 
(* End: *) 
439 
