Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / utils.ml @ ba2f9fa1

History | View | Annotate | Download (8.76 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
let desome x = match x with Some x -> x | None -> failwith "desome"
40

    
41
let option_map f o =
42
  match o with
43
  | None   -> None
44
  | Some e -> Some (f e)
45

    
46
let add_cons x l =
47
 if List.mem x l then l else x::l
48

    
49
let rec remove_duplicates l =
50
 match l with
51
 | [] -> []
52
 | t::q -> add_cons t (remove_duplicates q)
53

    
54
let position pred l =
55
  let rec pos p l =
56
    match l with
57
    | [] -> assert false
58
    | t::q -> if pred t then p else pos (p+1) q
59
  in pos 0 l
60

    
61
let rec duplicate x n =
62
 if n < 0 then [] else x :: duplicate x (n - 1)
63

    
64
let enumerate n =
65
  let rec aux i =
66
    if i >= n then [] else i :: aux (i+1)
67
  in aux 0
68

    
69
let rec repeat n f x =
70
 if n <= 0 then x else repeat (n-1) f (f x)
71

    
72
let transpose_list ll =
73
  let rec transpose ll =
74
    match ll with
75
    | []   -> []
76
    | [l]  -> List.map (fun el -> [el]) l
77
    | l::q -> List.map2 (fun el eq -> el::eq) l (transpose q)
78
  in match ll with
79
  | []   -> []
80
  | l::q -> let length_l = List.length l in
81
	    List.iter (fun l' -> let length_l' = List.length l'
82
				 in if length_l <> length_l' then raise (TransposeError (length_l, length_l'))) q;
83
	    transpose ll
84

    
85
let rec filter_upto p n l =
86
 if n = 0 then [] else
87
 match l with
88
 | [] -> []
89
 | t::q -> if p t then t :: filter_upto p (n-1) q else filter_upto p n q
90

    
91
(* Warning: bad complexity *)
92
let list_of_imap imap =
93
  IMap.fold (fun i v (il,vl) -> (i::il,v::vl)) imap ([],[])
94

    
95
(** [gcd a b] returns the greatest common divisor of [a] and [b]. *)
96
let rec gcd a b =
97
  if b = 0 then a
98
  else gcd b (a mod b)
99

    
100
(** [lcm a b] returns the least common multiple of [a] and [b]. *)
101
let lcm a b =
102
  if a = 0 && b = 0 then
103
    0
104
  else a*b/(gcd a b)
105

    
106
(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and
107
    [(a',b')] *)
108
let sum_rat (a,b) (a',b') =
109
  if a = 0 && b = 0 then
110
    (a',b')
111
  else if a'=0 && b'=0 then
112
    (a,b)
113
  else
114
    let lcm_bb' = lcm b b' in
115
    (a*lcm_bb'/b+a'*lcm_bb'/b',lcm_bb')
116

    
117
let simplify_rat (a,b) =
118
  let gcd = gcd a b in
119
  if (gcd =0) then
120
    (a,b)
121
  else (a/gcd,b/gcd)
122

    
123
let max_rat (a,b) (a',b') =
124
  let ratio_ab = (float_of_int a)/.(float_of_int b) in
125
  let ratio_ab' = (float_of_int a')/.(float_of_int b') in
126
  if ratio_ab > ratio_ab' then
127
    (a,b)
128
  else
129
    (a',b')
130

    
131
(** [list_union l1 l2] returns the union of list [l1] and [l2]. The
132
    result contains no duplicates. *)
133
let list_union l1 l2 =
134
  let rec aux l acc =
135
    match l with
136
    | [] -> acc
137
    | x::tl ->
138
        if List.mem x acc then
139
          aux tl acc
140
        else
141
          aux tl (x::acc)
142
  in
143
  let l1' = aux l1 [] in
144
  aux l2 l1'
145

    
146
(** [hashtbl_add h1 h2] adds all the bindings in [h2] to [h1]. If the
147
    intersection is not empty, it replaces the former binding *)
148
let hashtbl_add h1 h2 =
149
  Hashtbl.iter (fun key value -> Hashtbl.replace h1 key value) h2
150

    
151
let hashtbl_iterlast h f1 f2 =
152
  let l = Hashtbl.length h in
153
  ignore(
154
  Hashtbl.fold
155
    (fun k v cpt ->
156
      if cpt = l then
157
        begin f2 k v; cpt+1 end
158
      else
159
        begin f1 k v; cpt+1 end)
160
    h 1)
161

    
162
(** Match types variables to 'a, 'b, ..., for pretty-printing. Type
163
    variables are identified by integers. *)
164
let tnames = ref ([]: (int * string) list)
165
let tname_counter = ref 0
166
(* Same for carriers *)
167
let crnames = ref ([]: (int * string) list)
168
let crname_counter = ref 0
169
(* Same for dimension *)
170
let dnames = ref ([]: (int * string) list)
171
let dname_counter = ref 0
172
(* Same for delays *)
173
let inames = ref ([]: (int * string) list)
174
let iname_counter = ref 0
175

    
176
let reset_names () =
177
  tnames := []; tname_counter := 0; crnames := []; crname_counter := 0; dnames := []; dname_counter := 0; inames := []; iname_counter := 0
178

    
179
(* From OCaml compiler *)
180
let new_tname () =
181
  let tname =
182
    if !tname_counter < 26
183
    then String.make 1 (Char.chr(97 + !tname_counter))
184
    else String.make 1 (Char.chr(97 + !tname_counter mod 26)) ^
185
      string_of_int(!tname_counter / 26) in
186
  incr tname_counter;
187
  tname
188

    
189
let new_crname () =
190
  incr crname_counter;
191
  Format.sprintf "c%i" (!crname_counter-1)
192

    
193
let name_of_type id =
194
  try List.assoc id !tnames with Not_found ->
195
    let name = new_tname () in
196
    tnames := (id, name) :: !tnames;
197
    name
198

    
199
let name_of_carrier id =
200
  let pp_id =
201
    try List.assoc id !crnames with Not_found ->
202
      let name = new_crname () in
203
      crnames := (id,name) :: !crnames;
204
      name
205
  in
206
  pp_id
207

    
208
let new_dname () =
209
  incr dname_counter;
210
  Format.sprintf "d%i" (!dname_counter-1)
211

    
212
let name_of_dimension id =
213
  try List.assoc id !dnames with Not_found ->
214
    let name = new_dname () in
215
    dnames := (id, name) :: !dnames;
216
    name
217

    
218
let new_iname () =
219
  incr iname_counter;
220
  Format.sprintf "t%i" (!iname_counter-1)
221

    
222
let name_of_delay id =
223
  try List.assoc id !inames with Not_found ->
224
    let name = new_iname () in
225
    inames := (id, name) :: !inames;
226
    name
227

    
228
open Format
229

    
230
let print_rat fmt (a,b) =
231
  if b=1 then
232
    Format.fprintf fmt "%i" a
233
  else
234
    if b < 0 then
235
      Format.fprintf fmt "%i/%i" (-a) (-b)
236
    else
237
      Format.fprintf fmt "%i/%i" a b
238
	
239

    
240
(* Generic pretty printing *)
241

    
242
let pp_final_char_if_non_empty c l =
243
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c)
244

    
245
let pp_newline_if_non_empty l =
246
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "@,")
247

    
248
let rec fprintf_list ~sep:sep f fmt = function
249
  | []   -> ()
250
  | [e]  -> f fmt e
251
  | x::r -> Format.fprintf fmt "%a%(%)%a" f x sep (fprintf_list ~sep f) r
252

    
253
let pp_list l pp_fun beg_str end_str sep_str =
254
  if (beg_str="\n") then
255
    print_newline ()
256
  else
257
    print_string beg_str;
258
  let rec pp_l l =
259
    match l with
260
    | [] -> ()
261
    | [hd] -> 
262
        pp_fun hd
263
    | hd::tl ->
264
        pp_fun hd;
265
        if (sep_str="\n") then
266
          print_newline ()
267
        else
268
          print_string sep_str;
269
        pp_l tl
270
  in
271
  pp_l l;
272
  if (end_str="\n") then
273
    print_newline ()
274
  else
275
    print_string end_str
276

    
277
let pp_array a 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 n = Array.length a in
283
  if n > 0 then
284
    begin
285
      Array.iter (fun x -> pp_fun x; print_string sep_str) (Array.sub a 0 (n-1));
286
      pp_fun a.(n-1)
287
    end;
288
  if (end_str="\n") then
289
    print_newline ()
290
  else
291
    print_string end_str
292

    
293
let pp_iset fmt t =
294
  begin
295
    Format.fprintf fmt "{@ ";
296
    ISet.iter (fun s -> Format.fprintf fmt "%s@ " s) t;
297
    Format.fprintf fmt "}@."
298
  end
299

    
300
let pp_hashtbl t pp_fun beg_str end_str sep_str =
301
  if (beg_str="\n") then
302
    print_newline ()
303
  else
304
    print_string beg_str;
305
  let pp_fun1 k v =
306
    pp_fun k v;
307
    if (sep_str="\n") then
308
      print_newline ()
309
    else
310
      print_string sep_str
311
  in
312
  hashtbl_iterlast t pp_fun1 pp_fun;
313
  if (end_str="\n") then
314
    print_newline ()
315
  else
316
    print_string end_str
317

    
318
let pp_longident lid =
319
  let pp_fun (nid, tag) =
320
    print_string nid;
321
    print_string "(";
322
    print_int tag;
323
    print_string ")"
324
  in
325
  pp_list lid pp_fun "" "." "."  
326

    
327
let pp_date fmt tm =
328
  Format.fprintf fmt "%i/%i/%i, %i:%i:%i"
329
    (tm.Unix.tm_year + 1900)
330
    tm.Unix.tm_mon
331
    tm.Unix.tm_mday
332
    tm.Unix.tm_hour
333
    tm.Unix.tm_min
334
    tm.Unix.tm_sec
335

    
336
(* Used for uid in variables *)
337

    
338
let var_id_cpt = ref 0
339
let get_new_id () = incr var_id_cpt;!var_id_cpt
340

    
341

    
342
let track_exception () =
343
 if !Options.track_exceptions
344
 then (Printexc.print_backtrace stdout; flush stdout)
345
 else ()
346

    
347

    
348
(* for lexing purposes *)
349

    
350
(* Update line number for location info *)
351
let incr_line lexbuf =
352
  let pos = lexbuf.Lexing.lex_curr_p in
353
  lexbuf.Lexing.lex_curr_p <- { pos with
354
    Lexing.pos_lnum = pos.Lexing.pos_lnum + 1;
355
    Lexing.pos_bol = pos.Lexing.pos_cnum;
356
  }
357

    
358

    
359
let last_tag = ref (-1)
360
let new_tag () =
361
  incr last_tag; !last_tag
362

    
363
(* Local Variables: *)
364
(* compile-command:"make -C .." *)
365
(* End: *)