lustrec / src / utils.ml @ 990210f3
History  View  Annotate  Download (9.21 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 
exception DeSome 
40 
let desome x = match x with Some x > x  None > raise DeSome 
41  
42 
let option_map f o = 
43 
match o with 
44 
 None > None 
45 
 Some e > Some (f e) 
46  
47 
let add_cons x l = 
48 
if List.mem x l then l else x::l 
49  
50 
let rec remove_duplicates l = 
51 
match l with 
52 
 [] > [] 
53 
 t::q > add_cons t (remove_duplicates q) 
54  
55 
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 (n1) f (f x) 
72  
73 
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  
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 (n1) 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 prettyprinting. 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_counter1) 
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_counter1) 
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_counter1) 
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 (n1)); 
287 
pp_fun a.(n1) 
288 
end; 
289 
if (end_str="\n") then 
290 
print_newline () 
291 
else 
292 
print_string end_str 
293  
294 
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 
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 
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 
let pp_date fmt tm = 
336 
Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i" 
337 
(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  
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  
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 
(* Local Variables: *) 
387 
(* compilecommand:"make C .." *) 
388 
(* End: *) 