Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / utils.ml @ a703ed0c

History | View | Annotate | Download (10.2 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
module IdentDepGraph = Imperative.Digraph.ConcreteBidirectional (IdentModule)
39
module TopologicalDepGraph = Topological.Make(IdentDepGraph)
40
module ComponentsDepGraph = Components.Make(IdentDepGraph) 
41
                           
42
(*module DotGraph = Graphviz.Dot (IdentDepGraph)*)
43
module Bfs = Traverse.Bfs (IdentDepGraph)
44

    
45
            
46
exception DeSome
47
let desome x = match x with Some x -> x | None -> raise DeSome
48

    
49
let option_map f o =
50
  match o with
51
  | None   -> None
52
  | Some e -> Some (f e)
53

    
54
let add_cons x l =
55
 if List.mem x l then l else x::l
56

    
57
let rec remove_duplicates l =
58
 match l with
59
 | [] -> []
60
 | t::q -> add_cons t (remove_duplicates q)
61

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

    
69
let rec duplicate x n =
70
 if n < 0 then [] else x :: duplicate x (n - 1)
71

    
72
let enumerate n =
73
  let rec aux i =
74
    if i >= n then [] else i :: aux (i+1)
75
  in aux 0
76

    
77
let rec repeat n f x =
78
 if n <= 0 then x else repeat (n-1) f (f x)
79

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

    
93
let rec filter_upto p n l =
94
 if n = 0 then [] else
95
 match l with
96
 | [] -> []
97
 | t::q -> if p t then t :: filter_upto p (n-1) q else filter_upto p n q
98

    
99
(* Warning: bad complexity *)
100
let list_of_imap imap =
101
  IMap.fold (fun i v (il,vl) -> (i::il,v::vl)) imap ([],[])
102

    
103
(** [gcd a b] returns the greatest common divisor of [a] and [b]. *)
104
let rec gcd a b =
105
  if b = 0 then a
106
  else gcd b (a mod b)
107

    
108
(** [lcm a b] returns the least common multiple of [a] and [b]. *)
109
let lcm a b =
110
  if a = 0 && b = 0 then
111
    0
112
  else a*b/(gcd a b)
113

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

    
125
let simplify_rat (a,b) =
126
  let gcd = gcd a b in
127
  if (gcd =0) then
128
    (a,b)
129
  else (a/gcd,b/gcd)
130

    
131
let max_rat (a,b) (a',b') =
132
  let ratio_ab = (float_of_int a)/.(float_of_int b) in
133
  let ratio_ab' = (float_of_int a')/.(float_of_int b') in
134
  if ratio_ab > ratio_ab' then
135
    (a,b)
136
  else
137
    (a',b')
138

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

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

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

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

    
184
let reset_names () =
185
  tnames := []; tname_counter := 0; crnames := []; crname_counter := 0; dnames := []; dname_counter := 0; inames := []; iname_counter := 0
186

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

    
197
let new_crname () =
198
  incr crname_counter;
199
  Format.sprintf "c%i" (!crname_counter-1)
200

    
201
let name_of_type id =
202
  try List.assoc id !tnames with Not_found ->
203
    let name = new_tname () in
204
    tnames := (id, name) :: !tnames;
205
    name
206

    
207
let name_of_carrier id =
208
  let pp_id =
209
    try List.assoc id !crnames with Not_found ->
210
      let name = new_crname () in
211
      crnames := (id,name) :: !crnames;
212
      name
213
  in
214
  pp_id
215

    
216
let new_dname () =
217
  incr dname_counter;
218
  Format.sprintf "d%i" (!dname_counter-1)
219

    
220
let name_of_dimension id =
221
  try List.assoc id !dnames with Not_found ->
222
    let name = new_dname () in
223
    dnames := (id, name) :: !dnames;
224
    name
225

    
226
let new_iname () =
227
  incr iname_counter;
228
  Format.sprintf "t%i" (!iname_counter-1)
229

    
230
let name_of_delay id =
231
  try List.assoc id !inames with Not_found ->
232
    let name = new_iname () in
233
    inames := (id, name) :: !inames;
234
    name
235

    
236
open Format
237

    
238
let print_rat fmt (a,b) =
239
  if b=1 then
240
    Format.fprintf fmt "%i" a
241
  else
242
    if b < 0 then
243
      Format.fprintf fmt "%i/%i" (-a) (-b)
244
    else
245
      Format.fprintf fmt "%i/%i" a b
246
	
247

    
248
(* Generic pretty printing *)
249

    
250
let pp_final_char_if_non_empty c l =
251
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c)
252

    
253
let pp_newline_if_non_empty l =
254
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "@,")
255

    
256
let rec fprintf_list ~sep:sep f fmt = function
257
  | []   -> ()
258
  | [e]  -> f fmt e
259
  | x::r -> Format.fprintf fmt "%a%(%)%a" f x sep (fprintf_list ~sep f) r
260

    
261
let pp_list l pp_fun beg_str end_str sep_str =
262
  if (beg_str="\n") then
263
    print_newline ()
264
  else
265
    print_string beg_str;
266
  let rec pp_l l =
267
    match l with
268
    | [] -> ()
269
    | [hd] -> 
270
        pp_fun hd
271
    | hd::tl ->
272
        pp_fun hd;
273
        if (sep_str="\n") then
274
          print_newline ()
275
        else
276
          print_string sep_str;
277
        pp_l tl
278
  in
279
  pp_l l;
280
  if (end_str="\n") then
281
    print_newline ()
282
  else
283
    print_string end_str
284

    
285
let pp_array a pp_fun beg_str end_str sep_str =
286
  if (beg_str="\n") then
287
    print_newline ()
288
  else
289
    print_string beg_str;
290
  let n = Array.length a in
291
  if n > 0 then
292
    begin
293
      Array.iter (fun x -> pp_fun x; print_string sep_str) (Array.sub a 0 (n-1));
294
      pp_fun a.(n-1)
295
    end;
296
  if (end_str="\n") then
297
    print_newline ()
298
  else
299
    print_string end_str
300

    
301
let pp_iset fmt t =
302
  begin
303
    Format.fprintf fmt "{@ ";
304
    ISet.iter (fun s -> Format.fprintf fmt "%s@ " s) t;
305
    Format.fprintf fmt "}@."
306
  end
307

    
308
let pp_imap pp_val fmt m =
309
  begin
310
    Format.fprintf fmt "@[{@ ";
311
    IMap.iter (fun key v -> Format.fprintf fmt "%s -> %a@ " key pp_val v) m;
312
    Format.fprintf fmt "}@ @]"
313
  end
314
    
315
let pp_hashtbl t pp_fun beg_str end_str sep_str =
316
  if (beg_str="\n") then
317
    print_newline ()
318
  else
319
    print_string beg_str;
320
  let pp_fun1 k v =
321
    pp_fun k v;
322
    if (sep_str="\n") then
323
      print_newline ()
324
    else
325
      print_string sep_str
326
  in
327
  hashtbl_iterlast t pp_fun1 pp_fun;
328
  if (end_str="\n") then
329
    print_newline ()
330
  else
331
    print_string end_str
332

    
333
let pp_longident lid =
334
  let pp_fun (nid, tag) =
335
    print_string nid;
336
    print_string "(";
337
    print_int tag;
338
    print_string ")"
339
  in
340
  pp_list lid pp_fun "" "." "."  
341

    
342
let pp_date fmt tm =
343
  Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i"
344
    (tm.Unix.tm_year + 1900)
345
    tm.Unix.tm_mon
346
    tm.Unix.tm_mday
347
    tm.Unix.tm_hour
348
    tm.Unix.tm_min
349
    tm.Unix.tm_sec
350

    
351
(* Used for uid in variables *)
352

    
353
let var_id_cpt = ref 0
354
let get_new_id () = incr var_id_cpt;!var_id_cpt
355

    
356

    
357
(* for lexing purposes *)
358

    
359
(* Update line number for location info *)
360
let incr_line lexbuf =
361
  let pos = lexbuf.Lexing.lex_curr_p in
362
  lexbuf.Lexing.lex_curr_p <- { pos with
363
    Lexing.pos_lnum = pos.Lexing.pos_lnum + 1;
364
    Lexing.pos_bol = pos.Lexing.pos_cnum;
365
  }
366

    
367

    
368
let last_tag = ref (-1)
369
let new_tag () =
370
  incr last_tag; !last_tag
371

    
372

    
373
module List =
374
struct
375
  include List 
376
  let iteri2 f l1 l2 =
377
    if List.length l1 <> List.length l2 then
378
      raise (Invalid_argument "iteri2: lists have different lengths")
379
    else
380
      let rec run idx l1 l2 =
381
	match l1, l2 with
382
	| [], [] -> ()
383
	| hd1::tl1, hd2::tl2 -> (
384
	  f idx hd1 hd2;
385
	  run (idx+1) tl1 tl2
386
	)
387
	| _ -> assert false
388
      in
389
      run 0 l1 l2
390

    
391
  let rec extract l fst last =
392
    if last < fst then assert false else
393
      match l, fst with
394
      | hd::tl, 0 -> if last = 0 then [] else hd::(extract tl 0 (last-1))
395
      | _::tl, _ -> extract tl (fst-1) (last-1)
396
      | [], 0 -> if last=0 then [] else assert false (* List too short *)
397
      | _ -> assert false 
398
		 
399
end
400

    
401
let get_date () =
402
  let tm = Unix.localtime (Unix.time ()) in 
403
  let fmt = Format.str_formatter in
404
  pp_date fmt tm;
405
  (* let open Unix in *)
406
  (* let _ = *)
407
  (*   Format.fprintf fmt *)
408
  (*     "%i/%i/%i %ih%i:%i" *)
409
  (*     tm.tm_year *)
410
  (*     tm.tm_mon *)
411
  (*     tm.tm_mday *)
412
  (*     tm.tm_hour *)
413
  (*     tm.tm_min *)
414
  (*     tm.tm_sec *)
415
  (* in *)
416
  Format.flush_str_formatter ()
417

    
418
(* Local Variables: *)
419
(* compile-command:"make -C .." *)
420
(* End: *)