Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / utils.ml @ 365d1b07

History | View | Annotate | Download (10.2 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 365d1b07 ploc
module IdentDepGraph = Graph.Imperative.Digraph.ConcreteBidirectional (IdentModule)
39
module TopologicalDepGraph = Topological.Make(IdentDepGraph)
40 22fe1c93 ploc
41 365d1b07 ploc
(*module DotGraph = Graphviz.Dot (IdentDepGraph)*)
42
module Bfs = Traverse.Bfs (IdentDepGraph)
43
44
            
45 04a63d25 xthirioux
exception DeSome
46
let desome x = match x with Some x -> x | None -> raise DeSome
47 e2380d4d ploc
48 22fe1c93 ploc
let option_map f o =
49
  match o with
50
  | None   -> None
51
  | Some e -> Some (f e)
52
53 45c13277 xthirioux
let add_cons x l =
54
 if List.mem x l then l else x::l
55
56 bb2ca5f4 xthirioux
let rec remove_duplicates l =
57
 match l with
58
 | [] -> []
59 45c13277 xthirioux
 | t::q -> add_cons t (remove_duplicates q)
60 bb2ca5f4 xthirioux
61 22fe1c93 ploc
let position pred l =
62
  let rec pos p l =
63
    match l with
64
    | [] -> assert false
65
    | t::q -> if pred t then p else pos (p+1) q
66
  in pos 0 l
67
68
let rec duplicate x n =
69
 if n < 0 then [] else x :: duplicate x (n - 1)
70
71
let enumerate n =
72
  let rec aux i =
73
    if i >= n then [] else i :: aux (i+1)
74
  in aux 0
75
76
let rec repeat n f x =
77
 if n <= 0 then x else repeat (n-1) f (f x)
78
79 b616fe7a xthirioux
let transpose_list ll =
80
  let rec transpose ll =
81
    match ll with
82
    | []   -> []
83
    | [l]  -> List.map (fun el -> [el]) l
84
    | l::q -> List.map2 (fun el eq -> el::eq) l (transpose q)
85
  in match ll with
86
  | []   -> []
87
  | l::q -> let length_l = List.length l in
88
	    List.iter (fun l' -> let length_l' = List.length l'
89
				 in if length_l <> length_l' then raise (TransposeError (length_l, length_l'))) q;
90
	    transpose ll
91 22fe1c93 ploc
92
let rec filter_upto p n l =
93
 if n = 0 then [] else
94
 match l with
95
 | [] -> []
96
 | t::q -> if p t then t :: filter_upto p (n-1) q else filter_upto p n q
97
98
(* Warning: bad complexity *)
99
let list_of_imap imap =
100
  IMap.fold (fun i v (il,vl) -> (i::il,v::vl)) imap ([],[])
101
102
(** [gcd a b] returns the greatest common divisor of [a] and [b]. *)
103
let rec gcd a b =
104
  if b = 0 then a
105
  else gcd b (a mod b)
106
107
(** [lcm a b] returns the least common multiple of [a] and [b]. *)
108
let lcm a b =
109
  if a = 0 && b = 0 then
110
    0
111
  else a*b/(gcd a b)
112
113
(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and
114
    [(a',b')] *)
115
let sum_rat (a,b) (a',b') =
116
  if a = 0 && b = 0 then
117
    (a',b')
118
  else if a'=0 && b'=0 then
119
    (a,b)
120
  else
121
    let lcm_bb' = lcm b b' in
122
    (a*lcm_bb'/b+a'*lcm_bb'/b',lcm_bb')
123
124
let simplify_rat (a,b) =
125
  let gcd = gcd a b in
126
  if (gcd =0) then
127
    (a,b)
128
  else (a/gcd,b/gcd)
129
130
let max_rat (a,b) (a',b') =
131
  let ratio_ab = (float_of_int a)/.(float_of_int b) in
132
  let ratio_ab' = (float_of_int a')/.(float_of_int b') in
133
  if ratio_ab > ratio_ab' then
134
    (a,b)
135
  else
136
    (a',b')
137
138
(** [list_union l1 l2] returns the union of list [l1] and [l2]. The
139
    result contains no duplicates. *)
140
let list_union l1 l2 =
141
  let rec aux l acc =
142
    match l with
143
    | [] -> acc
144
    | x::tl ->
145
        if List.mem x acc then
146
          aux tl acc
147
        else
148
          aux tl (x::acc)
149
  in
150
  let l1' = aux l1 [] in
151
  aux l2 l1'
152
153
(** [hashtbl_add h1 h2] adds all the bindings in [h2] to [h1]. If the
154
    intersection is not empty, it replaces the former binding *)
155
let hashtbl_add h1 h2 =
156
  Hashtbl.iter (fun key value -> Hashtbl.replace h1 key value) h2
157
158
let hashtbl_iterlast h f1 f2 =
159
  let l = Hashtbl.length h in
160
  ignore(
161
  Hashtbl.fold
162
    (fun k v cpt ->
163
      if cpt = l then
164
        begin f2 k v; cpt+1 end
165
      else
166
        begin f1 k v; cpt+1 end)
167
    h 1)
168
169
(** Match types variables to 'a, 'b, ..., for pretty-printing. Type
170
    variables are identified by integers. *)
171
let tnames = ref ([]: (int * string) list)
172
let tname_counter = ref 0
173
(* Same for carriers *)
174
let crnames = ref ([]: (int * string) list)
175
let crname_counter = ref 0
176
(* Same for dimension *)
177
let dnames = ref ([]: (int * string) list)
178
let dname_counter = ref 0
179
(* Same for delays *)
180
let inames = ref ([]: (int * string) list)
181
let iname_counter = ref 0
182
183
let reset_names () =
184
  tnames := []; tname_counter := 0; crnames := []; crname_counter := 0; dnames := []; dname_counter := 0; inames := []; iname_counter := 0
185
186
(* From OCaml compiler *)
187
let new_tname () =
188
  let tname =
189
    if !tname_counter < 26
190
    then String.make 1 (Char.chr(97 + !tname_counter))
191
    else String.make 1 (Char.chr(97 + !tname_counter mod 26)) ^
192
      string_of_int(!tname_counter / 26) in
193
  incr tname_counter;
194
  tname
195
196
let new_crname () =
197
  incr crname_counter;
198
  Format.sprintf "c%i" (!crname_counter-1)
199
200
let name_of_type id =
201
  try List.assoc id !tnames with Not_found ->
202
    let name = new_tname () in
203
    tnames := (id, name) :: !tnames;
204
    name
205
206
let name_of_carrier id =
207
  let pp_id =
208
    try List.assoc id !crnames with Not_found ->
209
      let name = new_crname () in
210
      crnames := (id,name) :: !crnames;
211
      name
212
  in
213
  pp_id
214
215
let new_dname () =
216
  incr dname_counter;
217
  Format.sprintf "d%i" (!dname_counter-1)
218
219
let name_of_dimension id =
220
  try List.assoc id !dnames with Not_found ->
221
    let name = new_dname () in
222
    dnames := (id, name) :: !dnames;
223
    name
224
225
let new_iname () =
226
  incr iname_counter;
227
  Format.sprintf "t%i" (!iname_counter-1)
228
229
let name_of_delay id =
230
  try List.assoc id !inames with Not_found ->
231
    let name = new_iname () in
232
    inames := (id, name) :: !inames;
233
    name
234
235
open Format
236
237
let print_rat fmt (a,b) =
238
  if b=1 then
239
    Format.fprintf fmt "%i" a
240
  else
241
    if b < 0 then
242
      Format.fprintf fmt "%i/%i" (-a) (-b)
243
    else
244
      Format.fprintf fmt "%i/%i" a b
245
	
246
247
(* Generic pretty printing *)
248
249
let pp_final_char_if_non_empty c l =
250
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c)
251
252
let pp_newline_if_non_empty l =
253
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "@,")
254
255
let rec fprintf_list ~sep:sep f fmt = function
256
  | []   -> ()
257
  | [e]  -> f fmt e
258
  | x::r -> Format.fprintf fmt "%a%(%)%a" f x sep (fprintf_list ~sep f) r
259
260
let pp_list l pp_fun beg_str end_str sep_str =
261
  if (beg_str="\n") then
262
    print_newline ()
263
  else
264
    print_string beg_str;
265
  let rec pp_l l =
266
    match l with
267
    | [] -> ()
268
    | [hd] -> 
269
        pp_fun hd
270
    | hd::tl ->
271
        pp_fun hd;
272
        if (sep_str="\n") then
273
          print_newline ()
274
        else
275
          print_string sep_str;
276
        pp_l tl
277
  in
278
  pp_l l;
279
  if (end_str="\n") then
280
    print_newline ()
281
  else
282
    print_string end_str
283
284
let pp_array a pp_fun beg_str end_str sep_str =
285
  if (beg_str="\n") then
286
    print_newline ()
287
  else
288
    print_string beg_str;
289
  let n = Array.length a in
290
  if n > 0 then
291
    begin
292
      Array.iter (fun x -> pp_fun x; print_string sep_str) (Array.sub a 0 (n-1));
293
      pp_fun a.(n-1)
294
    end;
295
  if (end_str="\n") then
296
    print_newline ()
297
  else
298
    print_string end_str
299
300 8a183477 xthirioux
let pp_iset fmt t =
301
  begin
302
    Format.fprintf fmt "{@ ";
303
    ISet.iter (fun s -> Format.fprintf fmt "%s@ " s) t;
304
    Format.fprintf fmt "}@."
305
  end
306
307 4d138e19 ploc
let pp_imap pp_val fmt m =
308
  begin
309
    Format.fprintf fmt "@[{@ ";
310
    IMap.iter (fun key v -> Format.fprintf fmt "%s -> %a@ " key pp_val v) m;
311
    Format.fprintf fmt "}@ @]"
312
  end
313
    
314 22fe1c93 ploc
let pp_hashtbl t pp_fun beg_str end_str sep_str =
315
  if (beg_str="\n") then
316
    print_newline ()
317
  else
318
    print_string beg_str;
319
  let pp_fun1 k v =
320
    pp_fun k v;
321
    if (sep_str="\n") then
322
      print_newline ()
323
    else
324
      print_string sep_str
325
  in
326
  hashtbl_iterlast t pp_fun1 pp_fun;
327
  if (end_str="\n") then
328
    print_newline ()
329
  else
330
    print_string end_str
331
332
let pp_longident lid =
333
  let pp_fun (nid, tag) =
334
    print_string nid;
335
    print_string "(";
336
    print_int tag;
337
    print_string ")"
338
  in
339
  pp_list lid pp_fun "" "." "."  
340
341 5c1184ad ploc
let pp_date fmt tm =
342 0f36882c xthirioux
  Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i"
343 5c1184ad ploc
    (tm.Unix.tm_year + 1900)
344
    tm.Unix.tm_mon
345
    tm.Unix.tm_mday
346
    tm.Unix.tm_hour
347
    tm.Unix.tm_min
348
    tm.Unix.tm_sec
349 22fe1c93 ploc
350
(* Used for uid in variables *)
351
352
let var_id_cpt = ref 0
353
let get_new_id () = incr var_id_cpt;!var_id_cpt
354
355
356
(* for lexing purposes *)
357
358
(* Update line number for location info *)
359
let incr_line lexbuf =
360
  let pos = lexbuf.Lexing.lex_curr_p in
361
  lexbuf.Lexing.lex_curr_p <- { pos with
362
    Lexing.pos_lnum = pos.Lexing.pos_lnum + 1;
363
    Lexing.pos_bol = pos.Lexing.pos_cnum;
364
  }
365
366
367
let last_tag = ref (-1)
368
let new_tag () =
369
  incr last_tag; !last_tag
370
371 6fa45cb6 ploc
372
module List =
373
struct
374
  include List 
375
  let iteri2 f l1 l2 =
376
    if List.length l1 <> List.length l2 then
377
      raise (Invalid_argument "iteri2: lists have different lengths")
378
    else
379
      let rec run idx l1 l2 =
380
	match l1, l2 with
381
	| [], [] -> ()
382
	| hd1::tl1, hd2::tl2 -> (
383
	  f idx hd1 hd2;
384
	  run (idx+1) tl1 tl2
385
	)
386
	| _ -> assert false
387
      in
388
      run 0 l1 l2
389 57d61d67 ploc
390
  let rec extract l fst last =
391
    if last < fst then assert false else
392
      match l, fst with
393
      | hd::tl, 0 -> if last = 0 then [] else hd::(extract tl 0 (last-1))
394
      | _::tl, _ -> extract tl (fst-1) (last-1)
395
      | [], 0 -> if last=0 then [] else assert false (* List too short *)
396
      | _ -> assert false 
397
		 
398 6fa45cb6 ploc
end
399
400 57d61d67 ploc
let get_date () =
401 7d77632f ploc
  let tm = Unix.localtime (Unix.time ()) in 
402 57d61d67 ploc
  let fmt = Format.str_formatter in
403 7d77632f ploc
  pp_date fmt tm;
404
  (* let open Unix in *)
405
  (* let _ = *)
406
  (*   Format.fprintf fmt *)
407
  (*     "%i/%i/%i %ih%i:%i" *)
408
  (*     tm.tm_year *)
409
  (*     tm.tm_mon *)
410
  (*     tm.tm_mday *)
411
  (*     tm.tm_hour *)
412
  (*     tm.tm_min *)
413
  (*     tm.tm_sec *)
414
  (* in *)
415 57d61d67 ploc
  Format.flush_str_formatter ()
416
417 22fe1c93 ploc
(* Local Variables: *)
418
(* compile-command:"make -C .." *)
419
(* End: *)