Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / utils.ml @ b38ffff3

History | View | Annotate | Download (8.74 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 rec remove_duplicates l =
47
 match l with
48
 | [] -> []
49
 | t::q -> if List.mem t q then remove_duplicates q else t :: remove_duplicates q
50

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

    
58
let rec duplicate x n =
59
 if n < 0 then [] else x :: duplicate x (n - 1)
60

    
61
let enumerate n =
62
  let rec aux i =
63
    if i >= n then [] else i :: aux (i+1)
64
  in aux 0
65

    
66
let rec repeat n f x =
67
 if n <= 0 then x else repeat (n-1) f (f x)
68

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

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

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

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

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

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

    
114
let simplify_rat (a,b) =
115
  let gcd = gcd a b in
116
  if (gcd =0) then
117
    (a,b)
118
  else (a/gcd,b/gcd)
119

    
120
let max_rat (a,b) (a',b') =
121
  let ratio_ab = (float_of_int a)/.(float_of_int b) in
122
  let ratio_ab' = (float_of_int a')/.(float_of_int b') in
123
  if ratio_ab > ratio_ab' then
124
    (a,b)
125
  else
126
    (a',b')
127

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

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

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

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

    
173
let reset_names () =
174
  tnames := []; tname_counter := 0; crnames := []; crname_counter := 0; dnames := []; dname_counter := 0; inames := []; iname_counter := 0
175

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

    
186
let new_crname () =
187
  incr crname_counter;
188
  Format.sprintf "c%i" (!crname_counter-1)
189

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

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

    
205
let new_dname () =
206
  incr dname_counter;
207
  Format.sprintf "d%i" (!dname_counter-1)
208

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

    
215
let new_iname () =
216
  incr iname_counter;
217
  Format.sprintf "t%i" (!iname_counter-1)
218

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

    
225
open Format
226

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

    
237
(* Generic pretty printing *)
238

    
239
let pp_final_char_if_non_empty c l =
240
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c)
241

    
242
let pp_newline_if_non_empty l =
243
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "@,")
244

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

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

    
274
let pp_array a pp_fun beg_str end_str sep_str =
275
  if (beg_str="\n") then
276
    print_newline ()
277
  else
278
    print_string beg_str;
279
  let n = Array.length a in
280
  if n > 0 then
281
    begin
282
      Array.iter (fun x -> pp_fun x; print_string sep_str) (Array.sub a 0 (n-1));
283
      pp_fun a.(n-1)
284
    end;
285
  if (end_str="\n") then
286
    print_newline ()
287
  else
288
    print_string end_str
289

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

    
297
let pp_hashtbl t 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 pp_fun1 k v =
303
    pp_fun k v;
304
    if (sep_str="\n") then
305
      print_newline ()
306
    else
307
      print_string sep_str
308
  in
309
  hashtbl_iterlast t pp_fun1 pp_fun;
310
  if (end_str="\n") then
311
    print_newline ()
312
  else
313
    print_string end_str
314

    
315
let pp_longident lid =
316
  let pp_fun (nid, tag) =
317
    print_string nid;
318
    print_string "(";
319
    print_int tag;
320
    print_string ")"
321
  in
322
  pp_list lid pp_fun "" "." "."  
323

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

    
333
(* Used for uid in variables *)
334

    
335
let var_id_cpt = ref 0
336
let get_new_id () = incr var_id_cpt;!var_id_cpt
337

    
338

    
339
let track_exception () =
340
 if !Options.track_exceptions
341
 then (Printexc.print_backtrace stdout; flush stdout)
342
 else ()
343

    
344

    
345
(* for lexing purposes *)
346

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

    
355

    
356
let last_tag = ref (-1)
357
let new_tag () =
358
  incr last_tag; !last_tag
359

    
360
(* Local Variables: *)
361
(* compile-command:"make -C .." *)
362
(* End: *)