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

236  
237 
(* Generic pretty printing *) 
238  
239 
let pp_final_char_if_non_empty c l = 
240 
(fun fmt > match l with [] > ()  _ > Format.fprintf fmt "%(%)" c) 
241  
242 
let pp_newline_if_non_empty l = 
243 
(fun fmt > match l with [] > ()  _ > Format.fprintf fmt "@,") 
244  
245 
let rec fprintf_list ~sep:sep f fmt = function 
246 
 [] > () 
247 
 [e] > f fmt e 
248 
 x::r > Format.fprintf fmt "%a%(%)%a" f x sep (fprintf_list ~sep f) r 
249  
250 
let pp_list l pp_fun beg_str end_str sep_str = 
251 
if (beg_str="\n") then 
252 
print_newline () 
253 
else 
254 
print_string beg_str; 
255 
let rec pp_l l = 
256 
match l with 
257 
 [] > () 
258 
 [hd] > 
259 
pp_fun hd 
260 
 hd::tl > 
261 
pp_fun hd; 
262 
if (sep_str="\n") then 
263 
print_newline () 
264 
else 
265 
print_string sep_str; 
266 
pp_l tl 
267 
in 
268 
pp_l l; 
269 
if (end_str="\n") then 
270 
print_newline () 
271 
else 
272 
print_string end_str 
273  
274 
let pp_array a pp_fun beg_str end_str sep_str = 
275 
if (beg_str="\n") then 
276 
print_newline () 
277 
else 
278 
print_string beg_str; 
279 
let n = Array.length a in 
280 
if n > 0 then 
281 
begin 
282 
Array.iter (fun x > pp_fun x; print_string sep_str) (Array.sub a 0 (n1)); 
283 
pp_fun a.(n1) 
284 
end; 
285 
if (end_str="\n") then 
286 
print_newline () 
287 
else 
288 
print_string end_str 
289  
290 
let pp_iset fmt t = 
291 
begin 
292 
Format.fprintf fmt "{@ "; 
293 
ISet.iter (fun s > Format.fprintf fmt "%s@ " s) t; 
294 
Format.fprintf fmt "}@." 
295 
end 
296  
297 
let pp_hashtbl t pp_fun beg_str end_str sep_str = 
298 
if (beg_str="\n") then 
299 
print_newline () 
300 
else 
301 
print_string beg_str; 
302 
let pp_fun1 k v = 
303 
pp_fun k v; 
304 
if (sep_str="\n") then 
305 
print_newline () 
306 
else 
307 
print_string sep_str 
308 
in 
309 
hashtbl_iterlast t pp_fun1 pp_fun; 
310 
if (end_str="\n") then 
311 
print_newline () 
312 
else 
313 
print_string end_str 
314  
315 
let pp_longident lid = 
316 
let pp_fun (nid, tag) = 
317 
print_string nid; 
318 
print_string "("; 
319 
print_int tag; 
320 
print_string ")" 
321 
in 
322 
pp_list lid pp_fun "" "." "." 
323  
324 
let pp_date fmt tm = 
325 
Format.fprintf fmt "%i/%i/%i, %i:%i:%i" 
326 
(tm.Unix.tm_year + 1900) 
327 
tm.Unix.tm_mon 
328 
tm.Unix.tm_mday 
329 
tm.Unix.tm_hour 
330 
tm.Unix.tm_min 
331 
tm.Unix.tm_sec 
332  
333 
(* Used for uid in variables *) 
334  
335 
let var_id_cpt = ref 0 
336 
let get_new_id () = incr var_id_cpt;!var_id_cpt 
337  
338  
339 
let track_exception () = 
340 
if !Options.track_exceptions 
341 
then (Printexc.print_backtrace stdout; flush stdout) 
342 
else () 
343  
344  
345 
(* for lexing purposes *) 
346  
347 
(* Update line number for location info *) 
348 
let incr_line lexbuf = 
349 
let pos = lexbuf.Lexing.lex_curr_p in 
350 
lexbuf.Lexing.lex_curr_p < { pos with 
351 
Lexing.pos_lnum = pos.Lexing.pos_lnum + 1; 
352 
Lexing.pos_bol = pos.Lexing.pos_cnum; 
353 
} 
354  
355  
356 
let last_tag = ref (1) 
357 
let new_tag () = 
358 
incr last_tag; !last_tag 
359  
360 
(* Local Variables: *) 
361 
(* compilecommand:"make C .." *) 
362 
(* End: *) 