lustrec / src / utils.ml @ e2068500
History  View  Annotate  Download (8.76 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 
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: *) 