Project

General

Profile

« Previous | Next » 

Revision ca7ff3f7

Added by Lélio Brun 7 months ago

reformatting

View differences:

src/utils/utils.ml
11 11

  
12 12
open Graph
13 13

  
14
type rat = int*int
14
type rat = int * int
15

  
15 16
type ident = string
17

  
16 18
type tag = int
19

  
17 20
type longident = (string * tag) list
18 21

  
19
exception TransposeError of int*int
22
exception TransposeError of int * int
20 23

  
21 24
(** General utility functions. *)
22 25
let create_hashtable size init =
......
24 27
  List.iter (fun (key, data) -> Hashtbl.add tbl key data) init;
25 28
  tbl
26 29

  
27
module IdentModule =
28
struct (* Node module *)
30
module IdentModule = struct
31
  (* Node module *)
29 32
  type t = ident
33

  
30 34
  let compare = compare
35

  
31 36
  let hash n = Hashtbl.hash n
37

  
32 38
  let equal n1 n2 = n1 = n2
33 39
end
34 40

  
35 41
module IMap = struct
36
  include Map.Make(IdentModule)
42
  include Map.Make (IdentModule)
43

  
37 44
  let union_l m1 m2 =
38
    merge (fun _ o1 o2 -> match o1, o2 with
39
        | None, None -> None
40
        | Some _, _ -> o1
41
        | _, Some _ -> o2) m1 m2
45
    merge
46
      (fun _ o1 o2 ->
47
        match o1, o2 with
48
        | None, None ->
49
          None
50
        | Some _, _ ->
51
          o1
52
        | _, Some _ ->
53
          o2)
54
      m1 m2
42 55
end
43 56

  
44
module ISet = Set.Make(IdentModule)
57
module ISet = Set.Make (IdentModule)
45 58
module IdentDepGraph = Imperative.Digraph.ConcreteBidirectional (IdentModule)
46
module TopologicalDepGraph = Topological.Make(IdentDepGraph)
47
module ComponentsDepGraph = Components.Make(IdentDepGraph) 
48
                           
59
module TopologicalDepGraph = Topological.Make (IdentDepGraph)
60
module ComponentsDepGraph = Components.Make (IdentDepGraph)
61

  
49 62
(*module DotGraph = Graphviz.Dot (IdentDepGraph)*)
50 63
module Bfs = Traverse.Bfs (IdentDepGraph)
51 64

  
52
            
53 65
exception DeSome
66

  
54 67
let desome x = match x with Some x -> x | None -> raise DeSome
55 68

  
56
let option_map f o =
57
  match o with
58
  | None   -> None
59
  | Some e -> Some (f e)
69
let option_map f o = match o with None -> None | Some e -> Some (f e)
60 70

  
61
let add_cons x l =
62
 if List.mem x l then l else x::l
71
let add_cons x l = if List.mem x l then l else x :: l
63 72

  
64 73
let rec remove_duplicates l =
65
 match l with
66
 | [] -> []
67
 | t::q -> add_cons t (remove_duplicates q)
74
  match l with [] -> [] | t :: q -> add_cons t (remove_duplicates q)
68 75

  
69 76
let position pred l =
70 77
  let rec pos p l =
71 78
    match l with
72
    | [] -> assert false
73
    | t::q -> if pred t then p else pos (p+1) q
74
  in pos 0 l
79
    | [] ->
80
      assert false
81
    | t :: q ->
82
      if pred t then p else pos (p + 1) q
83
  in
84
  pos 0 l
75 85

  
76 86
(* TODO: Lélio: why n+1? cf former def below *)
77 87
(* if n < 0 then [] else x :: duplicate x (n - 1) *)
78
let duplicate x n = List.init (n+1) (fun _ -> x)
88
let duplicate x n = List.init (n + 1) (fun _ -> x)
79 89

  
80 90
let enumerate n = List.init n (fun i -> i)
81 91

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

  
85 94
let transpose_list ll =
86 95
  let rec transpose ll =
87 96
    match ll with
88
    | []   -> []
89
    | [l]  -> List.map (fun el -> [el]) l
90
    | l::q -> List.map2 (fun el eq -> el::eq) l (transpose q)
91
  in match ll with
92
  | []   -> []
93
  | l::q -> let length_l = List.length l in
94
    List.iter (fun l' -> let length_l' = List.length l'
95
                in if length_l <> length_l' then raise (TransposeError (length_l, length_l'))) q;
97
    | [] ->
98
      []
99
    | [ l ] ->
100
      List.map (fun el -> [ el ]) l
101
    | l :: q ->
102
      List.map2 (fun el eq -> el :: eq) l (transpose q)
103
  in
104
  match ll with
105
  | [] ->
106
    []
107
  | l :: q ->
108
    let length_l = List.length l in
109
    List.iter
110
      (fun l' ->
111
        let length_l' = List.length l' in
112
        if length_l <> length_l' then
113
          raise (TransposeError (length_l, length_l')))
114
      q;
96 115
    transpose ll
97 116

  
98 117
let rec filter_upto p n l =
99
 if n = 0 then [] else
100
 match l with
101
 | [] -> []
102
 | t::q -> if p t then t :: filter_upto p (n-1) q else filter_upto p n q
118
  if n = 0 then []
119
  else
120
    match l with
121
    | [] ->
122
      []
123
    | t :: q ->
124
      if p t then t :: filter_upto p (n - 1) q else filter_upto p n q
103 125

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

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

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

  
119
(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and
120
    [(a',b')] *)
121
let sum_rat (a,b) (a',b') =
122
  if a = 0 && b = 0 then
123
    (a',b')
124
  else if a'=0 && b'=0 then
125
    (a,b)
134
let lcm a b = if a = 0 && b = 0 then 0 else a * b / gcd a b
135

  
136
(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and [(a',b')] *)
137
let sum_rat (a, b) (a', b') =
138
  if a = 0 && b = 0 then a', b'
139
  else if a' = 0 && b' = 0 then a, b
126 140
  else
127 141
    let lcm_bb' = lcm b b' in
128
    (a*lcm_bb'/b+a'*lcm_bb'/b',lcm_bb')
142
    (a * lcm_bb' / b) + (a' * lcm_bb' / b'), lcm_bb'
129 143

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

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

  
144
(** [list_union l1 l2] returns the union of list [l1] and [l2]. The
145
    result contains no duplicates. *)
148
let max_rat (a, b) (a', b') =
149
  let ratio_ab = float_of_int a /. float_of_int b in
150
  let ratio_ab' = float_of_int a' /. float_of_int b' in
151
  if ratio_ab > ratio_ab' then a, b else a', b'
152

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

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

  
175
(** Match types variables to 'a, 'b, ..., for pretty-printing. Type
176
    variables are identified by integers. *)
177
let tnames = ref ([]: (int * string) list)
173
  ignore
174
    (Hashtbl.fold
175
       (fun k v cpt ->
176
         if cpt = l then (
177
           f2 k v;
178
           cpt + 1)
179
         else (
180
           f1 k v;
181
           cpt + 1))
182
       h 1)
183

  
184
(** Match types variables to 'a, 'b, ..., for pretty-printing. Type variables
185
    are identified by integers. *)
186
let tnames = ref ([] : (int * string) list)
187

  
178 188
let tname_counter = ref 0
189

  
179 190
(* Same for carriers *)
180
let crnames = ref ([]: (int * string) list)
191
let crnames = ref ([] : (int * string) list)
192

  
181 193
let crname_counter = ref 0
194

  
182 195
(* Same for dimension *)
183
let dnames = ref ([]: (int * string) list)
196
let dnames = ref ([] : (int * string) list)
197

  
184 198
let dname_counter = ref 0
199

  
185 200
(* Same for delays *)
186
let inames = ref ([]: (int * string) list)
201
let inames = ref ([] : (int * string) list)
202

  
187 203
let iname_counter = ref 0
188 204

  
189 205
let reset_names () =
......
199 215
(* From OCaml compiler *)
200 216
let new_tname () =
201 217
  let tname =
202
    if !tname_counter < 26
203
    then String.make 1 (Char.chr(97 + !tname_counter))
204
    else String.make 1 (Char.chr(97 + !tname_counter mod 26)) ^
205
      string_of_int(!tname_counter / 26) in
218
    if !tname_counter < 26 then String.make 1 (Char.chr (97 + !tname_counter))
219
    else
220
      String.make 1 (Char.chr (97 + (!tname_counter mod 26)))
221
      ^ string_of_int (!tname_counter / 26)
222
  in
206 223
  incr tname_counter;
207 224
  tname
208 225

  
209 226
let new_crname () =
210 227
  incr crname_counter;
211
  Format.sprintf "c%i" (!crname_counter-1)
228
  Format.sprintf "c%i" (!crname_counter - 1)
212 229

  
213 230
let name_of_type id =
214
  try List.assoc id !tnames with Not_found ->
231
  try List.assoc id !tnames
232
  with Not_found ->
215 233
    let name = new_tname () in
216 234
    tnames := (id, name) :: !tnames;
217 235
    name
218 236

  
219 237
let name_of_carrier id =
220 238
  let pp_id =
221
    try List.assoc id !crnames with Not_found ->
239
    try List.assoc id !crnames
240
    with Not_found ->
222 241
      let name = new_crname () in
223
      crnames := (id,name) :: !crnames;
242
      crnames := (id, name) :: !crnames;
224 243
      name
225 244
  in
226 245
  pp_id
227 246

  
228 247
let new_dname () =
229 248
  incr dname_counter;
230
  Format.sprintf "d%i" (!dname_counter-1)
249
  Format.sprintf "d%i" (!dname_counter - 1)
231 250

  
232 251
let name_of_dimension id =
233
  try List.assoc id !dnames with Not_found ->
252
  try List.assoc id !dnames
253
  with Not_found ->
234 254
    let name = new_dname () in
235 255
    dnames := (id, name) :: !dnames;
236 256
    name
237 257

  
238 258
let new_iname () =
239 259
  incr iname_counter;
240
  Format.sprintf "t%i" (!iname_counter-1)
260
  Format.sprintf "t%i" (!iname_counter - 1)
241 261

  
242 262
let name_of_delay id =
243
  try List.assoc id !inames with Not_found ->
263
  try List.assoc id !inames
264
  with Not_found ->
244 265
    let name = new_iname () in
245 266
    inames := (id, name) :: !inames;
246 267
    name
247 268

  
248 269
open Format
249 270

  
250
let print_rat fmt (a,b) =
251
  if b=1 then
252
    Format.fprintf fmt "%i" a
253
  else
254
    if b < 0 then
255
      Format.fprintf fmt "%i/%i" (-a) (-b)
256
    else
257
      Format.fprintf fmt "%i/%i" a b
258
	
271
let print_rat fmt (a, b) =
272
  if b = 1 then Format.fprintf fmt "%i" a
273
  else if b < 0 then Format.fprintf fmt "%i/%i" (-a) (-b)
274
  else Format.fprintf fmt "%i/%i" a b
259 275

  
260 276
(* Generic pretty printing *)
261 277

  
278
let pp_final_char_if_non_empty c l fmt =
279
  match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c
262 280

  
263
let pp_final_char_if_non_empty c l =
264
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c)
265

  
266
let pp_newline_if_non_empty l =
267
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "@,")
281
let pp_newline_if_non_empty l fmt =
282
  match l with [] -> () | _ -> Format.fprintf fmt "@,"
268 283

  
269 284
module Format = struct
270 285
  include Format
......
283 298
  let pp_print_endcut s fmt () = fprintf fmt "%s@," s
284 299

  
285 300
  let pp_print_opar fmt () = pp_print_string fmt "("
301

  
286 302
  let pp_print_cpar fmt () = pp_print_string fmt ")"
303

  
287 304
  let pp_print_obracket fmt () = pp_print_string fmt "["
305

  
288 306
  let pp_print_cbracket fmt () = pp_print_string fmt "]"
307

  
289 308
  let pp_print_obrace fmt () = pp_print_string fmt "{"
309

  
290 310
  let pp_print_cbrace fmt () = pp_print_string fmt "}"
311

  
291 312
  let pp_print_opar' fmt () = pp_print_string fmt "( "
313

  
292 314
  let pp_print_cpar' fmt () = pp_print_string fmt " )"
315

  
293 316
  let pp_print_obrace' fmt () = pp_print_string fmt "{ "
317

  
294 318
  let pp_print_cbrace' fmt () = pp_print_string fmt " }"
295 319

  
296 320
  let pp_print_comma fmt () = fprintf fmt ",@ "
321

  
297 322
  let pp_print_semicolon fmt () = fprintf fmt ";@ "
323

  
298 324
  let pp_print_comma' fmt () = fprintf fmt ","
325

  
299 326
  let pp_print_semicolon' fmt () = fprintf fmt ";"
300 327

  
301 328
  let pp_open_vbox0 fmt () = pp_open_vbox fmt 0
302 329

  
303
  let pp_print_list
304
      ?(pp_prologue=pp_print_nothing) ?(pp_epilogue=pp_print_nothing)
305
      ?(pp_op=pp_print_nothing) ?(pp_cl=pp_print_nothing)
306
      ?(pp_open_box=fun fmt () -> pp_open_box fmt 0)
307
      ?(pp_eol=pp_print_nothing)
308
      ?(pp_nil=pp_print_nothing)
309
      ?pp_sep pp_v fmt l =
330
  let pp_print_list ?(pp_prologue = pp_print_nothing)
331
      ?(pp_epilogue = pp_print_nothing) ?(pp_op = pp_print_nothing)
332
      ?(pp_cl = pp_print_nothing)
333
      ?(pp_open_box = fun fmt () -> pp_open_box fmt 0)
334
      ?(pp_eol = pp_print_nothing) ?(pp_nil = pp_print_nothing) ?pp_sep pp_v fmt
335
      l =
310 336
    fprintf fmt "%a%a%a%a%a@]%a%a"
311
      (fun fmt l -> if l <> [] then pp_prologue fmt ()) l
312
      pp_op ()
313
      pp_open_box ()
337
      (fun fmt l -> if l <> [] then pp_prologue fmt ())
338
      l pp_op () pp_open_box ()
314 339
      (fun fmt () ->
315
         if l = [] then pp_nil fmt () else pp_print_list ?pp_sep pp_v fmt l) ()
316
      (fun fmt l -> if l <> [] then pp_eol fmt ()) l
317
      pp_cl ()
318
      (fun fmt l -> if l <> [] then pp_epilogue fmt ()) l
340
        if l = [] then pp_nil fmt () else pp_print_list ?pp_sep pp_v fmt l)
341
      ()
342
      (fun fmt l -> if l <> [] then pp_eol fmt ())
343
      l pp_cl ()
344
      (fun fmt l -> if l <> [] then pp_epilogue fmt ())
345
      l
319 346

  
320 347
  let pp_comma_list = pp_print_list ~pp_sep:pp_print_comma
321 348

  
322
  let pp_print_list_i
323
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
324
      pp_v =
349
  let pp_print_list_i ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box
350
      ?pp_eol ?pp_sep pp_v =
325 351
    let i = ref 0 in
326
    pp_print_list
327
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
328
      (fun fmt x -> pp_v fmt !i x; incr i)
329

  
330
  let pp_print_list2
331
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
332
      pp_v fmt (l1, l2) =
333
    pp_print_list
334
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
335
      pp_v fmt (List.combine l1 l2)
336

  
337
  let pp_print_list_i2
338
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
339
      pp_v fmt (l1, l2) =
340
    pp_print_list_i
341
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
342
      (fun fmt i (x1, x2) -> pp_v fmt i x1 x2) fmt (List.combine l1 l2)
343

  
344
  let pp_print_parenthesized ?(pp_sep=pp_print_comma) =
345
    pp_print_list
346
      ~pp_op:pp_print_opar
347
      ~pp_cl:pp_print_cpar
348
      ~pp_sep
349

  
350
  let pp_print_bracketed ?(pp_sep=pp_print_comma) =
351
    pp_print_list
352
      ~pp_op:pp_print_obracket
353
      ~pp_cl:pp_print_cbracket
354
      ~pp_sep
355

  
356
  let pp_print_braced ?(pp_sep=pp_print_comma) =
357
    pp_print_list
358
      ~pp_op:pp_print_obrace
359
      ~pp_cl:pp_print_cbrace
360
      ~pp_sep
361

  
362
  let pp_print_braced' ?(pp_sep=pp_print_comma) =
363
    pp_print_list
364
      ~pp_op:pp_print_obrace'
365
      ~pp_cl:pp_print_cbrace'
366
      ~pp_sep
352
    pp_print_list ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol
353
      ?pp_sep (fun fmt x ->
354
        pp_v fmt !i x;
355
        incr i)
356

  
357
  let pp_print_list2 ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box
358
      ?pp_eol ?pp_sep pp_v fmt (l1, l2) =
359
    pp_print_list ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol
360
      ?pp_sep pp_v fmt (List.combine l1 l2)
361

  
362
  let pp_print_list_i2 ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box
363
      ?pp_eol ?pp_sep pp_v fmt (l1, l2) =
364
    pp_print_list_i ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol
365
      ?pp_sep
366
      (fun fmt i (x1, x2) -> pp_v fmt i x1 x2)
367
      fmt (List.combine l1 l2)
368

  
369
  let pp_print_parenthesized ?(pp_sep = pp_print_comma) =
370
    pp_print_list ~pp_op:pp_print_opar ~pp_cl:pp_print_cpar ~pp_sep
371

  
372
  let pp_print_bracketed ?(pp_sep = pp_print_comma) =
373
    pp_print_list ~pp_op:pp_print_obracket ~pp_cl:pp_print_cbracket ~pp_sep
374

  
375
  let pp_print_braced ?(pp_sep = pp_print_comma) =
376
    pp_print_list ~pp_op:pp_print_obrace ~pp_cl:pp_print_cbrace ~pp_sep
377

  
378
  let pp_print_braced' ?(pp_sep = pp_print_comma) =
379
    pp_print_list ~pp_op:pp_print_obrace' ~pp_cl:pp_print_cbrace' ~pp_sep
367 380
end
368 381

  
369
let fprintf_list ?(eol:('a, formatter, unit) format = "") ~sep:sep f fmt l =
382
let fprintf_list ?(eol : ('a, formatter, unit) format = "") ~sep f fmt l =
370 383
  Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "%(%)" sep) f fmt l);
371 384
  if l <> [] then Format.fprintf fmt "%(%)" eol
372 385

  
373 386
let pp_list l pp_fun beg_str end_str sep_str =
374
  if (beg_str="\n") then
375
    print_newline ()
376
  else
377
    print_string beg_str;
387
  if beg_str = "\n" then print_newline () else print_string beg_str;
378 388
  let rec pp_l l =
379 389
    match l with
380
    | [] -> ()
381
    | [hd] -> 
382
        pp_fun hd
383
    | hd::tl ->
384
        pp_fun hd;
385
        if (sep_str="\n") then
386
          print_newline ()
387
        else
388
          print_string sep_str;
389
        pp_l tl
390
    | [] ->
391
      ()
392
    | [ hd ] ->
393
      pp_fun hd
394
    | hd :: tl ->
395
      pp_fun hd;
396
      if sep_str = "\n" then print_newline () else print_string sep_str;
397
      pp_l tl
390 398
  in
391 399
  pp_l l;
392
  if (end_str="\n") then
393
    print_newline ()
394
  else
395
    print_string end_str
400
  if end_str = "\n" then print_newline () else print_string end_str
396 401

  
397 402
let pp_array a pp_fun beg_str end_str sep_str =
398
  if (beg_str="\n") then
399
    print_newline ()
400
  else
401
    print_string beg_str;
403
  if beg_str = "\n" then print_newline () else print_string beg_str;
402 404
  let n = Array.length a in
403
  if n > 0 then
404
    begin
405
      Array.iter (fun x -> pp_fun x; print_string sep_str) (Array.sub a 0 (n-1));
406
      pp_fun a.(n-1)
407
    end;
408
  if (end_str="\n") then
409
    print_newline ()
410
  else
411
    print_string end_str
405
  if n > 0 then (
406
    Array.iter
407
      (fun x ->
408
        pp_fun x;
409
        print_string sep_str)
410
      (Array.sub a 0 (n - 1));
411
    pp_fun a.(n - 1));
412
  if end_str = "\n" then print_newline () else print_string end_str
412 413

  
413 414
let pp_iset fmt t =
414 415
  Format.fprintf fmt "@[<hv 0>@[<hv 2>{";
415 416
  ISet.iter (fun s -> Format.fprintf fmt "@ %s" s) t;
416 417
  Format.fprintf fmt "@]@ }@]"
417 418

  
418
let pp_imap ?(comment="") pp_val fmt m =
419
let pp_imap ?(comment = "") pp_val fmt m =
419 420
  Format.fprintf fmt "@[<hv 0>@[<hv 2>{ %s" comment;
420 421
  IMap.iter (fun key v -> Format.fprintf fmt "@ %s -> %a" key pp_val v) m;
421 422
  Format.fprintf fmt "@]@ }@]"
422 423

  
423 424
let pp_hashtbl t pp_fun beg_str end_str sep_str =
424
  if (beg_str="\n") then
425
    print_newline ()
426
  else
427
    print_string beg_str;
425
  if beg_str = "\n" then print_newline () else print_string beg_str;
428 426
  let pp_fun1 k v =
429 427
    pp_fun k v;
430
    if (sep_str="\n") then
431
      print_newline ()
432
    else
433
      print_string sep_str
428
    if sep_str = "\n" then print_newline () else print_string sep_str
434 429
  in
435 430
  hashtbl_iterlast t pp_fun1 pp_fun;
436
  if (end_str="\n") then
437
    print_newline ()
438
  else
439
    print_string end_str
431
  if end_str = "\n" then print_newline () else print_string end_str
440 432

  
441 433
let pp_longident lid =
442 434
  let pp_fun (nid, tag) =
......
445 437
    print_int tag;
446 438
    print_string ")"
447 439
  in
448
  pp_list lid pp_fun "" "." "."  
440
  pp_list lid pp_fun "" "." "."
449 441

  
450 442
let pp_date fmt tm =
451 443
  let open Unix in
452
  Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i"
453
    (tm.tm_year + 1900)
454
    tm.tm_mon
455
    tm.tm_mday
456
    tm.tm_hour
457
    tm.tm_min
458
    tm.tm_sec
444
  Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i" (tm.tm_year + 1900) tm.tm_mon
445
    tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec
459 446

  
460 447
(* Used for uid in variables *)
461 448

  
462 449
let get_new_id =
463 450
  let var_id_cpt = ref 0 in
464
  fun () -> incr var_id_cpt; !var_id_cpt
451
  fun () ->
452
    incr var_id_cpt;
453
    !var_id_cpt
465 454

  
466 455
let new_tag =
467 456
  let last_tag = ref (-1) in
468
  fun () -> incr last_tag; !last_tag
469

  
457
  fun () ->
458
    incr last_tag;
459
    !last_tag
470 460

  
471 461
module List = struct
472
  include List 
462
  include List
463

  
473 464
  let iteri2 f l1 l2 =
474 465
    if List.length l1 <> List.length l2 then
475 466
      raise (Invalid_argument "iteri2: lists have different lengths")
476 467
    else
477 468
      let rec run idx l1 l2 =
478 469
        match l1, l2 with
479
        | [], [] -> ()
480
        | hd1::tl1, hd2::tl2 ->
470
        | [], [] ->
471
          ()
472
        | hd1 :: tl1, hd2 :: tl2 ->
481 473
          f idx hd1 hd2;
482
          run (idx+1) tl1 tl2
483
        | _ -> assert false
474
          run (idx + 1) tl1 tl2
475
        | _ ->
476
          assert false
484 477
      in
485 478
      run 0 l1 l2
486 479

  
487 480
  let rec extract l fst last =
488
    if last < fst then assert false else
481
    if last < fst then assert false
482
    else
489 483
      match l, fst with
490
      | hd::tl, 0 -> if last = 0 then [] else hd::(extract tl 0 (last-1))
491
      | _::tl, _ -> extract tl (fst-1) (last-1)
492
      | [], 0 -> if last=0 then [] else assert false (* List too short *)
493
      | _ -> assert false 
494

  
484
      | hd :: tl, 0 ->
485
        if last = 0 then [] else hd :: extract tl 0 (last - 1)
486
      | _ :: tl, _ ->
487
        extract tl (fst - 1) (last - 1)
488
      | [], 0 ->
489
        if last = 0 then [] else assert false (* List too short *)
490
      | _ ->
491
        assert false
495 492
end
496 493

  
497 494
let get_date () =
498
  let tm = Unix.localtime (Unix.time ()) in 
495
  let tm = Unix.localtime (Unix.time ()) in
499 496
  let fmt = Format.str_formatter in
500 497
  pp_date fmt tm;
501 498
  Format.flush_str_formatter ()

Also available in: Unified diff