Project

General

Profile

Download (9.83 KB) Statistics
| Branch: | Tag: | Revision:
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
exception DeSome
40
let desome x = match x with Some x -> x | None -> raise DeSome
41

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    
229
open Format
230

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

    
241
(* Generic pretty printing *)
242

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

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

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

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

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

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

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

    
326
let pp_longident lid =
327
  let pp_fun (nid, tag) =
328
    print_string nid;
329
    print_string "(";
330
    print_int tag;
331
    print_string ")"
332
  in
333
  pp_list lid pp_fun "" "." "."  
334

    
335
let pp_date fmt tm =
336
  Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i"
337
    (tm.Unix.tm_year + 1900)
338
    tm.Unix.tm_mon
339
    tm.Unix.tm_mday
340
    tm.Unix.tm_hour
341
    tm.Unix.tm_min
342
    tm.Unix.tm_sec
343

    
344
(* Used for uid in variables *)
345

    
346
let var_id_cpt = ref 0
347
let get_new_id () = incr var_id_cpt;!var_id_cpt
348

    
349

    
350
(* for lexing purposes *)
351

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

    
360

    
361
let last_tag = ref (-1)
362
let new_tag () =
363
  incr last_tag; !last_tag
364

    
365

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

    
384
  let rec extract l fst last =
385
    if last < fst then assert false else
386
      match l, fst with
387
      | hd::tl, 0 -> if last = 0 then [] else hd::(extract tl 0 (last-1))
388
      | _::tl, _ -> extract tl (fst-1) (last-1)
389
      | [], 0 -> if last=0 then [] else assert false (* List too short *)
390
      | _ -> assert false 
391
		 
392
end
393

    
394
let get_date () =
395
  let tm = Unix.localtime (Unix.time ()) in
396
  let fmt = Format.str_formatter in
397
  let open Unix in
398
  let _ =
399
    Format.fprintf fmt
400
      "%i/%i/%i %ih%i:%i"
401
      tm.tm_year
402
      tm.tm_mon
403
      tm.tm_mday
404
      tm.tm_hour
405
      tm.tm_min
406
      tm.tm_sec
407
  in
408
  Format.flush_str_formatter ()
409

    
410
(* Local Variables: *)
411
(* compile-command:"make -C .." *)
412
(* End: *)
(73-73/77)