Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

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 (n-1) 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 (n-1) 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 pretty-printing. 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_counter-1)
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_counter-1)
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_counter-1)
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 (n-1));
310
      pp_fun a.(n-1)
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 (last-1))
411
      | _::tl, _ -> extract tl (fst-1) (last-1)
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
                           (* compile-command:"make -C .." *)
438
                           (* End: *)
439