Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / utils / utils.ml @ f4cba4b8

History | View | Annotate | Download (10.6 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 =
36
  struct
37
    include Map.Make(IdentModule)
38
    let elements m =  fold (fun i n res -> (i, n)::res) m [] 
39
  end
40
  
41
module ISet = Set.Make(IdentModule)
42
module IdentDepGraph = Imperative.Digraph.ConcreteBidirectional (IdentModule)
43
module TopologicalDepGraph = Topological.Make(IdentDepGraph)
44
module ComponentsDepGraph = Components.Make(IdentDepGraph) 
45
                           
46
(*module DotGraph = Graphviz.Dot (IdentDepGraph)*)
47
module Bfs = Traverse.Bfs (IdentDepGraph)
48

    
49
            
50
exception DeSome
51
let desome x = match x with Some x -> x | None -> raise DeSome
52

    
53
let option_map f o =
54
  match o with
55
  | None   -> None
56
  | Some e -> Some (f e)
57

    
58
let add_cons x l =
59
 if List.mem x l then l else x::l
60

    
61
let rec remove_duplicates l =
62
 match l with
63
 | [] -> []
64
 | t::q -> add_cons t (remove_duplicates q)
65

    
66
let position pred l =
67
  let rec pos p l =
68
    match l with
69
    | [] -> assert false
70
    | t::q -> if pred t then p else pos (p+1) q
71
  in pos 0 l
72

    
73
let rec duplicate x n =
74
 if n < 0 then [] else x :: duplicate x (n - 1)
75

    
76
let enumerate n =
77
  let rec aux i =
78
    if i >= n then [] else i :: aux (i+1)
79
  in aux 0
80

    
81
let rec repeat n f x =
82
 if n <= 0 then x else repeat (n-1) f (f x)
83

    
84
let transpose_list ll =
85
  let rec transpose ll =
86
    match ll with
87
    | []   -> []
88
    | [l]  -> List.map (fun el -> [el]) l
89
    | l::q -> List.map2 (fun el eq -> el::eq) l (transpose q)
90
  in match ll with
91
  | []   -> []
92
  | l::q -> let length_l = List.length l in
93
	    List.iter (fun l' -> let length_l' = List.length l'
94
				 in if length_l <> length_l' then raise (TransposeError (length_l, length_l'))) q;
95
	    transpose ll
96

    
97
let rec filter_upto p n l =
98
 if n = 0 then [] else
99
 match l with
100
 | [] -> []
101
 | t::q -> if p t then t :: filter_upto p (n-1) q else filter_upto p n q
102

    
103
(* Warning: bad complexity *)
104
let list_of_imap imap =
105
  IMap.fold (fun i v (il,vl) -> (i::il,v::vl)) imap ([],[])
106

    
107
(** [gcd a b] returns the greatest common divisor of [a] and [b]. *)
108
let rec gcd a b =
109
  if b = 0 then a
110
  else gcd b (a mod b)
111

    
112
(** [lcm a b] returns the least common multiple of [a] and [b]. *)
113
let lcm a b =
114
  if a = 0 && b = 0 then
115
    0
116
  else a*b/(gcd a b)
117

    
118
(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and
119
    [(a',b')] *)
120
let sum_rat (a,b) (a',b') =
121
  if a = 0 && b = 0 then
122
    (a',b')
123
  else if a'=0 && b'=0 then
124
    (a,b)
125
  else
126
    let lcm_bb' = lcm b b' in
127
    (a*lcm_bb'/b+a'*lcm_bb'/b',lcm_bb')
128

    
129
let simplify_rat (a,b) =
130
  let gcd = gcd a b in
131
  if (gcd =0) then
132
    (a,b)
133
  else (a/gcd,b/gcd)
134

    
135
let max_rat (a,b) (a',b') =
136
  let ratio_ab = (float_of_int a)/.(float_of_int b) in
137
  let ratio_ab' = (float_of_int a')/.(float_of_int b') in
138
  if ratio_ab > ratio_ab' then
139
    (a,b)
140
  else
141
    (a',b')
142

    
143
(** [list_union l1 l2] returns the union of list [l1] and [l2]. The
144
    result contains no duplicates. *)
145
let list_union l1 l2 =
146
  let rec aux l acc =
147
    match l with
148
    | [] -> acc
149
    | x::tl ->
150
        if List.mem x acc then
151
          aux tl acc
152
        else
153
          aux tl (x::acc)
154
  in
155
  let l1' = aux l1 [] in
156
  aux l2 l1'
157

    
158
(** [hashtbl_add h1 h2] adds all the bindings in [h2] to [h1]. If the
159
    intersection is not empty, it replaces the former binding *)
160
let hashtbl_add h1 h2 =
161
  Hashtbl.iter (fun key value -> Hashtbl.replace h1 key value) h2
162

    
163
let hashtbl_iterlast h f1 f2 =
164
  let l = Hashtbl.length h in
165
  ignore(
166
  Hashtbl.fold
167
    (fun k v cpt ->
168
      if cpt = l then
169
        begin f2 k v; cpt+1 end
170
      else
171
        begin f1 k v; cpt+1 end)
172
    h 1)
173

    
174
(** Match types variables to 'a, 'b, ..., for pretty-printing. Type
175
    variables are identified by integers. *)
176
let tnames = ref ([]: (int * string) list)
177
let tname_counter = ref 0
178
(* Same for carriers *)
179
let crnames = ref ([]: (int * string) list)
180
let crname_counter = ref 0
181
(* Same for dimension *)
182
let dnames = ref ([]: (int * string) list)
183
let dname_counter = ref 0
184
(* Same for delays *)
185
let inames = ref ([]: (int * string) list)
186
let iname_counter = ref 0
187

    
188
let reset_names () =
189
  tnames := []; tname_counter := 0; crnames := []; crname_counter := 0; dnames := []; dname_counter := 0; inames := []; iname_counter := 0
190

    
191
(* From OCaml compiler *)
192
let new_tname () =
193
  let tname =
194
    if !tname_counter < 26
195
    then String.make 1 (Char.chr(97 + !tname_counter))
196
    else String.make 1 (Char.chr(97 + !tname_counter mod 26)) ^
197
      string_of_int(!tname_counter / 26) in
198
  incr tname_counter;
199
  tname
200

    
201
let new_crname () =
202
  incr crname_counter;
203
  Format.sprintf "c%i" (!crname_counter-1)
204

    
205
let name_of_type id =
206
  try List.assoc id !tnames with Not_found ->
207
    let name = new_tname () in
208
    tnames := (id, name) :: !tnames;
209
    name
210

    
211
let name_of_carrier id =
212
  let pp_id =
213
    try List.assoc id !crnames with Not_found ->
214
      let name = new_crname () in
215
      crnames := (id,name) :: !crnames;
216
      name
217
  in
218
  pp_id
219

    
220
let new_dname () =
221
  incr dname_counter;
222
  Format.sprintf "d%i" (!dname_counter-1)
223

    
224
let name_of_dimension id =
225
  try List.assoc id !dnames with Not_found ->
226
    let name = new_dname () in
227
    dnames := (id, name) :: !dnames;
228
    name
229

    
230
let new_iname () =
231
  incr iname_counter;
232
  Format.sprintf "t%i" (!iname_counter-1)
233

    
234
let name_of_delay id =
235
  try List.assoc id !inames with Not_found ->
236
    let name = new_iname () in
237
    inames := (id, name) :: !inames;
238
    name
239

    
240
open Format
241

    
242
let print_rat fmt (a,b) =
243
  if b=1 then
244
    Format.fprintf fmt "%i" a
245
  else
246
    if b < 0 then
247
      Format.fprintf fmt "%i/%i" (-a) (-b)
248
    else
249
      Format.fprintf fmt "%i/%i" a b
250
	
251

    
252
(* Generic pretty printing *)
253

    
254
let pp_final_char_if_non_empty c l =
255
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c)
256

    
257
let pp_newline_if_non_empty l =
258
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "@,")
259

    
260
let fprintf_list ?(eol:('a, formatter, unit) Pervasives.format = "") ~sep:sep f fmt l =
261
  let rec aux fmt = function
262
  | []   -> ()
263
  | [e]  -> f fmt e
264
  | x::r -> Format.fprintf fmt "%a%(%)%a" f x sep aux r
265
  in
266
  match l with
267
  | [] -> ()
268
  | _ -> (
269
    aux fmt l;
270
    Format.fprintf fmt "%(%)" eol
271
  )                 
272
   
273
let pp_list l pp_fun beg_str end_str sep_str =
274
  if (beg_str="\n") then
275
    print_newline ()
276
  else
277
    print_string beg_str;
278
  let rec pp_l l =
279
    match l with
280
    | [] -> ()
281
    | [hd] -> 
282
        pp_fun hd
283
    | hd::tl ->
284
        pp_fun hd;
285
        if (sep_str="\n") then
286
          print_newline ()
287
        else
288
          print_string sep_str;
289
        pp_l tl
290
  in
291
  pp_l l;
292
  if (end_str="\n") then
293
    print_newline ()
294
  else
295
    print_string end_str
296

    
297
let pp_array a 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 n = Array.length a in
303
  if n > 0 then
304
    begin
305
      Array.iter (fun x -> pp_fun x; print_string sep_str) (Array.sub a 0 (n-1));
306
      pp_fun a.(n-1)
307
    end;
308
  if (end_str="\n") then
309
    print_newline ()
310
  else
311
    print_string end_str
312

    
313
let pp_iset fmt t =
314
  begin
315
    Format.fprintf fmt "{@ ";
316
    ISet.iter (fun s -> Format.fprintf fmt "%s@ " s) t;
317
    Format.fprintf fmt "}@."
318
  end
319

    
320
let pp_imap pp_val fmt m =
321
  begin
322
    Format.fprintf fmt "@[{@ ";
323
    IMap.iter (fun key v -> Format.fprintf fmt "%s -> %a@ " key pp_val v) m;
324
    Format.fprintf fmt "}@ @]"
325
  end
326
    
327
let pp_hashtbl t pp_fun beg_str end_str sep_str =
328
  if (beg_str="\n") then
329
    print_newline ()
330
  else
331
    print_string beg_str;
332
  let pp_fun1 k v =
333
    pp_fun k v;
334
    if (sep_str="\n") then
335
      print_newline ()
336
    else
337
      print_string sep_str
338
  in
339
  hashtbl_iterlast t pp_fun1 pp_fun;
340
  if (end_str="\n") then
341
    print_newline ()
342
  else
343
    print_string end_str
344

    
345
let pp_longident lid =
346
  let pp_fun (nid, tag) =
347
    print_string nid;
348
    print_string "(";
349
    print_int tag;
350
    print_string ")"
351
  in
352
  pp_list lid pp_fun "" "." "."  
353

    
354
let pp_date fmt tm =
355
  Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i"
356
    (tm.Unix.tm_year + 1900)
357
    tm.Unix.tm_mon
358
    tm.Unix.tm_mday
359
    tm.Unix.tm_hour
360
    tm.Unix.tm_min
361
    tm.Unix.tm_sec
362

    
363
(* Used for uid in variables *)
364

    
365
let var_id_cpt = ref 0
366
let get_new_id () = incr var_id_cpt;!var_id_cpt
367

    
368

    
369
(* for lexing purposes *)
370

    
371
(* Update line number for location info *)
372
let incr_line lexbuf =
373
  let pos = lexbuf.Lexing.lex_curr_p in
374
  lexbuf.Lexing.lex_curr_p <- { pos with
375
    Lexing.pos_lnum = pos.Lexing.pos_lnum + 1;
376
    Lexing.pos_bol = pos.Lexing.pos_cnum;
377
  }
378

    
379

    
380
let last_tag = ref (-1)
381
let new_tag () =
382
  incr last_tag; !last_tag
383

    
384

    
385
module List =
386
struct
387
  include List 
388
  let iteri2 f l1 l2 =
389
    if List.length l1 <> List.length l2 then
390
      raise (Invalid_argument "iteri2: lists have different lengths")
391
    else
392
      let rec run idx l1 l2 =
393
	match l1, l2 with
394
	| [], [] -> ()
395
	| hd1::tl1, hd2::tl2 -> (
396
	  f idx hd1 hd2;
397
	  run (idx+1) tl1 tl2
398
	)
399
	| _ -> assert false
400
      in
401
      run 0 l1 l2
402

    
403
  let rec extract l fst last =
404
    if last < fst then assert false else
405
      match l, fst with
406
      | hd::tl, 0 -> if last = 0 then [] else hd::(extract tl 0 (last-1))
407
      | _::tl, _ -> extract tl (fst-1) (last-1)
408
      | [], 0 -> if last=0 then [] else assert false (* List too short *)
409
      | _ -> assert false 
410
		 
411
end
412

    
413
let get_date () =
414
  let tm = Unix.localtime (Unix.time ()) in 
415
  let fmt = Format.str_formatter in
416
  pp_date fmt tm;
417
  (* let open Unix in *)
418
  (* let _ = *)
419
  (*   Format.fprintf fmt *)
420
  (*     "%i/%i/%i %ih%i:%i" *)
421
  (*     tm.tm_year *)
422
  (*     tm.tm_mon *)
423
  (*     tm.tm_mday *)
424
  (*     tm.tm_hour *)
425
  (*     tm.tm_min *)
426
  (*     tm.tm_sec *)
427
  (* in *)
428
  Format.flush_str_formatter ()
429

    
430

    
431
                           
432
                           (* Local Variables: *)
433
                           (* compile-command:"make -C .." *)
434
                           (* End: *)
435