MAJ terminée. Nous sommes passés en version 14.6.2 . Pour consulter les "releases notes" associées c'est ici :

https://about.gitlab.com/releases/2022/01/11/security-release-gitlab-14-6-2-released/
https://about.gitlab.com/releases/2022/01/04/gitlab-14-6-1-released/

grew_base.ml 15.6 KB
Newer Older
bguillaum's avatar
bguillaum committed
1
2
3
4
5
6
7
8
9
10
(**********************************************************************************)
(*    Libcaml-grew - a Graph Rewriting library dedicated to NLP applications      *)
(*                                                                                *)
(*    Copyright 2011-2013 Inria, Université de Lorraine                           *)
(*                                                                                *)
(*    Webpage: http://grew.loria.fr                                               *)
(*    License: CeCILL (see LICENSE folder or "http://www.cecill.info")            *)
(*    Authors: see AUTHORS file                                                   *)
(**********************************************************************************)

pj2m's avatar
pj2m committed
11
open Log
bguillaum's avatar
bguillaum committed
12
open Printf
pj2m's avatar
pj2m committed
13

bguillaum's avatar
bguillaum committed
14
15
module String_set = Set.Make (String)
module String_map = Map.Make (String)
pj2m's avatar
pj2m committed
16

bguillaum's avatar
bguillaum committed
17
18
module Int_set = Set.Make (struct type t = int let compare = Pervasives.compare end)
module Int_map = Map.Make (struct type t = int let compare = Pervasives.compare end)
19

bguillaum's avatar
bguillaum committed
20
21
22
23
(* ================================================================================ *)
module Loc = struct
  type t = string * int

bguillaum's avatar
bguillaum committed
24
25
26
27
28
  let file_line f l = (f,l)

  let file f = (f, -1)

  let to_string (file,line) = sprintf "[file: %s, line: %d]" (Filename.basename file) line
bguillaum's avatar
bguillaum committed
29
30
31
32
33
34
35
36
37
38
39
40
41

  let opt_set_line line = function
    | None -> None
    | Some (file,_) -> Some (file, line)
end (* module Loc *)

(* ================================================================================ *)
module Error = struct

  exception Build of (string * Loc.t option)
  exception Run of (string * Loc.t option)
  exception Bug of (string * Loc.t option)

bguillaum's avatar
Typos    
bguillaum committed
42
  let build_ ?loc message = raise (Build (message, loc))
bguillaum's avatar
bguillaum committed
43
44
45
46
47
48
49
50
  let build ?loc = Printf.ksprintf (build_ ?loc)

  let run_ ?loc message = raise (Run (message, loc))
  let run ?loc = Printf.ksprintf (run_ ?loc)

  let bug_ ?loc message = raise (Bug (message, loc))
  let bug ?loc = Printf.ksprintf (bug_ ?loc)
end (* module Error *)
51

bguillaum's avatar
bguillaum committed
52
53
54
55
56
(* ================================================================================ *)
module String_ = struct

  let to_float string =
    try float_of_string string
bguillaum's avatar
bguillaum committed
57
58
59
    with _ ->
      try float_of_string (Str.global_replace (Str.regexp "\\.") "," string)
      with _ -> Error.build "[String_.to_float] cannot convert '%s'" string
60

bguillaum's avatar
bguillaum committed
61
  let of_float float = Str.global_replace (Str.regexp ",") "." (sprintf "%g" float)
62

63
  let rm_first_char = function "" -> "" | s -> String.sub s 1 ((String.length s) - 1)
bguillaum's avatar
bguillaum committed
64
65
66
67
68
69

  let rm_peripheral_white s =
    s
    |> (Str.global_replace (Str.regexp "\\( \\|\t\\)*$") "")
    |> (Str.global_replace (Str.regexp "^\\( \\|\t\\)*") "")

bguillaum's avatar
bguillaum committed
70
end (* module String_ *)
71

bguillaum's avatar
bguillaum committed
72
73
74
75
76
77
78
79
(* ================================================================================ *)
module Dot = struct
  let to_png_file dot output_file =
    let temp_file_name,out_ch = Filename.open_temp_file ~mode:[Open_rdonly;Open_wronly;Open_text] "grewui_" ".dot" in
    fprintf out_ch "%s" dot;
    close_out out_ch;
    ignore(Sys.command(sprintf "dot -Tpng -o %s %s " output_file temp_file_name))
end (* module Dot *)
80

bguillaum's avatar
bguillaum committed
81
82
83
84
85
86
87
(* ================================================================================ *)
module File = struct
  let write data name =
    let out_ch = open_out name in
    fprintf out_ch "%s\n" data;
    close_out out_ch

bguillaum's avatar
bguillaum committed
88
  let read file =
bguillaum's avatar
bguillaum committed
89
    let in_ch = open_in file in
bguillaum's avatar
bguillaum committed
90
91
92
    (* if the input file contains an UTF-8 byte order mark (EF BB BF), skip 3 bytes, else get back to 0 *)
    (match input_byte in_ch with 0xEF -> seek_in in_ch 3 | _ -> seek_in in_ch 0);

bguillaum's avatar
bguillaum committed
93
94
95
96
97
98
99
100
    let rev_lines = ref [] in
    try
      while true do
        let line = input_line in_ch in
        if (Str.string_match (Str.regexp "^[ \t]*$") line 0) || (line.[0] = '%')
        then ()
        else rev_lines := line :: !rev_lines
      done; assert false
bguillaum's avatar
bguillaum committed
101
    with End_of_file ->
bguillaum's avatar
bguillaum committed
102
103
      close_in in_ch;
      List.rev !rev_lines
bguillaum's avatar
bguillaum committed
104

bguillaum's avatar
bguillaum committed
105
106
  (* [read_ln file] returns a list of couples (line_num, line). Blank lines and lines starting with '%' are ignored. *)
  let read_ln file =
bguillaum's avatar
bguillaum committed
107
    let in_ch = open_in file in
bguillaum's avatar
bguillaum committed
108
109
110
    (* if the input file contains an UTF-8 byte order mark (EF BB BF), skip 3 bytes, else get back to 0 *)
    (match input_byte in_ch with 0xEF -> seek_in in_ch 3 | _ -> seek_in in_ch 0);

bguillaum's avatar
bguillaum committed
111
112
113
114
115
116
117
118
119
120
    let cpt = ref 0 in
    let rev_lines = ref [] in
    try
      while true do
        let line = input_line in_ch in
        incr cpt;
        if (Str.string_match (Str.regexp "^[ \t]*$") line 0) || (line.[0] = '%')
        then ()
        else rev_lines := (!cpt, line) :: !rev_lines
      done; assert false
bguillaum's avatar
bguillaum committed
121
    with End_of_file ->
bguillaum's avatar
bguillaum committed
122
123
      close_in in_ch;
      List.rev !rev_lines
bguillaum's avatar
bguillaum committed
124
125
 end (* module File *)

bguillaum's avatar
bguillaum committed
126
(* ================================================================================ *)
pj2m's avatar
pj2m committed
127
128
129
module Array_ = struct
  let dicho_mem elt array =
    let rec loop low high =
bguillaum's avatar
bguillaum committed
130
      (if low > high
pj2m's avatar
pj2m committed
131
132
      then false
      else
133
134
135
136
        match (low+high)/2 with
        | middle when array.(middle) = elt -> true
        | middle when array.(middle) < elt -> loop (middle+1) high
        | middle -> loop low (middle - 1)
bguillaum's avatar
bguillaum committed
137
      ) in
pj2m's avatar
pj2m committed
138
139
140
141
142
143
144
145
146
    loop 0 ((Array.length array) - 1)

  (* dichotomic search in a sorted array *)
  let dicho_find elt array =
    let rec loop low high =
      (if low > high then raise Not_found);
      match (low+high)/2 with
      | middle when array.(middle) = elt -> middle
      | middle when array.(middle) < elt -> loop (middle+1) high
bguillaum's avatar
bguillaum committed
147
      | middle -> loop low (middle - 1) in
pj2m's avatar
pj2m committed
148
    loop 0 ((Array.length array) - 1)
bguillaum's avatar
bguillaum committed
149

pj2m's avatar
pj2m committed
150
151
152
153
154
155
  let dicho_find_assoc elt array =
    let rec loop low high =
      (if low > high then raise Not_found);
      match (low+high)/2 with
      | middle when fst array.(middle) = elt -> middle
      | middle when fst array.(middle) < elt -> loop (middle+1) high
bguillaum's avatar
bguillaum committed
156
      | middle -> loop low (middle - 1) in
pj2m's avatar
pj2m committed
157
    loop 0 ((Array.length array) - 1)
bguillaum's avatar
bguillaum committed
158
end (* module Array_ *)
pj2m's avatar
pj2m committed
159

bguillaum's avatar
bguillaum committed
160
(* ================================================================================ *)
pj2m's avatar
pj2m committed
161
module List_ = struct
bguillaum's avatar
bguillaum committed
162
163
164
165
166
  let rec set position elt = function
    | [] -> failwith "List_.set"
    | _::t when position = 0 -> elt::t
    | x::t -> x:: (set (position-1) elt t)

pj2m's avatar
pj2m committed
167
168
169
170
171
  let rec rm elt = function
    | [] -> raise Not_found
    | x::t when x=elt -> t
    | x::t -> x::(rm elt t)

bguillaum's avatar
bguillaum committed
172
  let pos x l =
bguillaum's avatar
bguillaum committed
173
174
175
176
177
178
    let rec loop i = function
    | [] -> None
    | h::t when h=x -> Some i
    | _::t -> loop (i+1) t in
    loop 0 l

pj2m's avatar
pj2m committed
179
180
181
182
183
184
185
  let rec opt = function
    | [] -> []
    | None :: t -> opt t
    | Some x :: t -> x :: (opt t)

  let rec opt_map f = function
    | [] -> []
bguillaum's avatar
bguillaum committed
186
    | x::t ->
187
188
189
        match f x with
        | None -> opt_map f t
        | Some r -> r :: (opt_map f t)
pj2m's avatar
pj2m committed
190
191
192
193
194

  let rec flat_map f = function
    | [] -> []
    | x::t -> (f x)@(flat_map f t)

bguillaum's avatar
bguillaum committed
195
196
  let iteri fct =
    let rec loop i = function
pj2m's avatar
pj2m committed
197
198
199
      | [] -> ()
      | h::t -> (fct i h); (loop (i+1) t) in
    loop 0
bguillaum's avatar
bguillaum committed
200
201
202

  let mapi fct =
    let rec loop i = function
pj2m's avatar
pj2m committed
203
204
205
206
      | [] -> []
      | h::t -> let head = fct i h in head :: (loop (i+1) t)
    in loop 0

bguillaum's avatar
bguillaum committed
207
208
  let opt_mapi fct =
    let rec loop i = function
209
210
211
212
213
214
215
      | [] -> []
      | h::t ->
        match fct i h with
          | None -> loop (i+1) t
          | Some res -> res :: (loop (i+1) t)
    in loop 0

pj2m's avatar
pj2m committed
216
  let foldi_left f init l =
bguillaum's avatar
bguillaum committed
217
218
    fst
      (List.fold_left
219
220
         (fun (acc,i) elt -> (f i acc elt, i+1))
         (init,0) l
pj2m's avatar
pj2m committed
221
222
223
224
225
226
      )

  let rec remove elt = function
    | [] -> raise Not_found
    | a::tail when a = elt -> tail
    | a::tail -> a::(remove elt tail)
227

pj2m's avatar
pj2m committed
228
229
230
  let to_string string_of_item sep = function
    | [] -> ""
    | h::t -> List.fold_left (fun acc elt -> acc ^ sep ^ (string_of_item elt)) (string_of_item h) t
231

pj2m's avatar
pj2m committed
232
233
  let rec sort_insert elt = function
    | [] -> [elt]
bguillaum's avatar
bguillaum committed
234
    | h::t when elt<h -> elt::h::t
pj2m's avatar
pj2m committed
235
236
237
238
239
240
    | h::t -> h::(sort_insert elt t)

  let rec sort_mem elt = function
    | [] -> false
    | h::_ when elt<h -> false
    | h::_ when elt=h -> true
241
    | h::t (* when elt>h *) -> sort_mem elt t
242
243
244
245
246

  let rec sort_assoc key = function
    | [] -> None
    | (k,_)::_ when key<k -> None
    | (k,_)::t when key>k -> sort_assoc key t
bguillaum's avatar
bguillaum committed
247
    | (_,v)::_ -> Some v
248
249
250
251
252
253
254

  let rec sort_remove_assoc key = function
    | [] -> []
    | (k,_)::_ as t when key<k -> t
    | (k,v)::t when key>k -> (k,v) :: (sort_remove_assoc key t)
    | (_,v)::t -> t

pj2m's avatar
pj2m committed
255
256
  exception Usort

bguillaum's avatar
bguillaum committed
257
  let rec usort_remove key = function
pj2m's avatar
pj2m committed
258
259
260
261
262
263
264
265
266
267
268
269
    | [] -> raise Not_found
    | x::t when key < x -> raise Not_found
    | x::t when key = x -> t
    | x::t -> x::(usort_remove key t)

  let usort_insert ?(compare=Pervasives.compare) elt l =
    let rec loop = function
      | [] -> [elt]
      | x::t when compare elt x < 0 -> elt :: x :: t
      | x::t when compare elt x > 0 -> x :: (loop t)
    | _ -> raise Usort in
    try Some (loop l) with Usort -> None
270

bguillaum's avatar
bguillaum committed
271
  let rec sort_disjoint l1 l2 =
pj2m's avatar
pj2m committed
272
273
274
275
    match (l1,l2) with
    | [], _ | _, [] -> true
    | h1::t1 , h2::t2 when h1<h2 -> sort_disjoint t1 l2
    | h1::t1 , h2::t2 when h1>h2 -> sort_disjoint l1 t2
bguillaum's avatar
bguillaum committed
276
    | _ -> false
277

bguillaum's avatar
bguillaum committed
278
  let sort_is_empty_inter l1 l2 =
pj2m's avatar
pj2m committed
279
280
281
282
283
    let rec loop = function
      | [], _ | _, [] -> true
      | x1::t1, x2::t2 when x1 < x2 -> loop (t1, x2::t2)
      | x1::t1, x2::t2 when x1 > x2 -> loop (x1::t1, t2)
      | x1::t1, x2::t2 -> false in
bguillaum's avatar
bguillaum committed
284
    loop (l1,l2)
pj2m's avatar
pj2m committed
285

bguillaum's avatar
bguillaum committed
286
  let sort_inter l1 l2 =
pj2m's avatar
pj2m committed
287
288
289
290
291
292
    let rec loop = function
      | [], _ | _, [] -> []
      | x1::t1, x2::t2 when x1 < x2 -> loop (t1, x2::t2)
      | x1::t1, x2::t2 when x1 > x2 -> loop (x1::t1, t2)
      | x1::t1, x2::t2 -> x1 :: loop (t1, t2) in
    loop (l1,l2)
bguillaum's avatar
bguillaum committed
293
294

  let sort_union l1 l2 =
bguillaum's avatar
bguillaum committed
295
296
297
298
299
300
301
302
    let rec loop = function
      | [], l | l, [] -> l
      | x1::t1, x2::t2 when x1 < x2 -> x1 :: loop (t1, x2::t2)
      | x1::t1, x2::t2 when x1 > x2 -> x2 :: loop (x1::t1, t2)
      | x1::t1, x2::t2 -> x1 :: loop (t1, t2) in
    loop (l1,l2)


pj2m's avatar
pj2m committed
303
  exception Not_disjoint
bguillaum's avatar
bguillaum committed
304
  let sort_disjoint_union ?(compare=Pervasives.compare) l1 l2 =
pj2m's avatar
pj2m committed
305
306
307
308
309
310
    let rec loop = function
      | [], l | l, [] -> l
      | x1::t1, x2::t2 when (compare x1 x2) < 0 -> x1 :: loop (t1, x2::t2)
      | x1::t1, x2::t2 when (compare x1  x2) > 0 -> x2 :: loop (x1::t1, t2)
      | _ -> raise Not_disjoint in
    loop (l1,l2)
bguillaum's avatar
bguillaum committed
311
312

  let sort_include l1 l2 =
pj2m's avatar
pj2m committed
313
314
315
316
317
318
319
    let rec loop = function
      | [], l -> true
      | l, [] -> false
      | x1::t1, x2::t2 when x1 < x2 -> false
      | x1::t1, x2::t2 when x1 > x2 -> loop (x1::t1, t2)
      | x1::t1, x2::t2 -> loop (t1, t2) in
    loop (l1,l2)
bguillaum's avatar
bguillaum committed
320
321

  let sort_included_diff l1 l2 =
pj2m's avatar
pj2m committed
322
323
324
325
326
327
328
329
    let rec loop = function
      | [], l -> failwith "[sort_included_diff] not included"
      | l, [] -> l
      | x1::t1, x2::t2 when x1 < x2 -> x1 :: loop (t1, x2::t2)
      | x1::t1, x2::t2 when x1 > x2 -> failwith "[sort_included_diff] not included"
      | x1::t1, x2::t2 -> loop (t1, t2) in
    loop (l1,l2)

bguillaum's avatar
bguillaum committed
330
  let sort_diff l1 l2 =
pj2m's avatar
pj2m committed
331
332
333
334
335
336
337
338
    let rec loop = function
      | [], l -> []
      | l, [] -> l
      | x1::t1, x2::t2 when x1 < x2 -> x1 :: loop (t1, x2::t2)
      | x1::t1, x2::t2 when x1 > x2 -> loop (x1::t1, t2)
      | x1::t1, x2::t2 -> loop (t1, t2) in
    loop (l1,l2)

339
  let foldi_left f init l =
bguillaum's avatar
bguillaum committed
340
341
    fst
      (List.fold_left
342
343
         (fun (acc,i) elt -> (f i acc elt, i+1))
         (init,0) l
344
      )
bguillaum's avatar
bguillaum committed
345
346
347
348
349
350
351
352

  let prev_next_iter fct list =
    let int_fct prev next elt = fct ?prev ?next elt in
    let rec loop prev = function
      | [] -> ()
      | [last] -> int_fct prev None last
      | head::snd::tail -> int_fct prev (Some snd) head; loop (Some head) (snd::tail)
    in loop None list
bguillaum's avatar
bguillaum committed
353
end (* module List_ *)
pj2m's avatar
pj2m committed
354

bguillaum's avatar
bguillaum committed
355
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
356
357
358
359
module type OrderedType = sig
  type t
  val compare: t -> t -> int
end (* module type OrderedType *)
360

bguillaum's avatar
bguillaum committed
361
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
362
363
module type S = sig
  type key
364

bguillaum's avatar
bguillaum committed
365
  type +'a t
366

bguillaum's avatar
bguillaum committed
367
  val empty: 'a t
368

bguillaum's avatar
bguillaum committed
369
370
  (* an empty list returned if the key is undefined *)
  val assoc: key -> 'a t -> 'a list
371

bguillaum's avatar
bguillaum committed
372
  val is_empty: 'a t -> bool
373

bguillaum's avatar
bguillaum committed
374
  val to_string: ('a -> string) -> 'a t -> string
375

bguillaum's avatar
bguillaum committed
376
  val iter: (key -> 'a -> unit) -> 'a t -> unit
377

bguillaum's avatar
bguillaum committed
378
  val add: key -> 'a -> 'a t -> 'a t option
379

bguillaum's avatar
bguillaum committed
380
  val fold: ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b
381

bguillaum's avatar
bguillaum committed
382
383
  (* raise Not_found if no (key,elt) *)
  val remove: key -> 'a -> 'a t -> 'a t
384

bguillaum's avatar
bguillaum committed
385
386
  (* raise Not_found if no (key,elt) *)
  val remove_key: key -> 'a t -> 'a t
387

bguillaum's avatar
bguillaum committed
388
389
  (* [mem key value t ] test if the couple (key, value) is in the massoc [t]. *)
  val mem: key -> 'a -> 'a t -> bool
390

bguillaum's avatar
bguillaum committed
391
392
  (* mem_key key t] tests is [key] is associated to at least one value in [t]. *)
  val mem_key: key -> 'a t -> bool
393

bguillaum's avatar
bguillaum committed
394
395
  exception Not_disjoint
  val disjoint_union: 'a t -> 'a t -> 'a t
396

bguillaum's avatar
bguillaum committed
397
398
  exception Duplicate
  val merge_key: key -> key -> 'a t -> 'a t
399

bguillaum's avatar
bguillaum committed
400
  val exists: (key -> 'a -> bool) -> 'a t -> bool
401

bguillaum's avatar
bguillaum committed
402
403
  val rename: (key * key) list -> 'a t -> 'a t
end (* module type S *)
404

bguillaum's avatar
bguillaum committed
405
(* ================================================================================ *)
406
407
408
409
410
411
412
413
414
415
416
module Massoc_make (Ord: OrderedType) = struct
  module M = Map.Make (Ord)

  type key = Ord.t

  type 'a t = ('a list) M.t

  let empty = M.empty

  let is_empty t = (t=empty)

bguillaum's avatar
bguillaum committed
417
418
  let assoc key t =
    try M.find key t
419
420
    with Not_found -> []

bguillaum's avatar
bguillaum committed
421
  let to_string _ _ = failwith "Not implemted"
422
423

  let iter fct t =
bguillaum's avatar
bguillaum committed
424
    M.iter
425
426
427
      (fun key list -> List.iter (fun elt -> fct key elt) list
      ) t

bguillaum's avatar
bguillaum committed
428
  let add key elt t =
429
430
    try
      let list = M.find key t in
bguillaum's avatar
bguillaum committed
431
      match List_.usort_insert elt list with
432
433
434
435
436
437
438
        | Some l -> Some (M.add key l t)
        | None -> None
    with Not_found -> Some (M.add key [elt] t)

  let fold fct init t =
    M.fold
      (fun key list acc ->
bguillaum's avatar
bguillaum committed
439
        List.fold_left
440
441
442
443
          (fun acc2 elt ->
            fct acc2 key elt)
          acc list)
      t init
bguillaum's avatar
bguillaum committed
444

445
446
447
448
449
450
  (* Not found raised in the value is not defined *)
  let remove key value t =
    match M.find key t with
      | [one] when one=value -> M.remove key t
      | old -> M.add key (List_.usort_remove value old) t

451
  let remove_key key t = M.remove key t
452
453
454
455
456
457
458
459
460
461

  let rec mem key value t =
    try List_.sort_mem value (M.find key t)
    with Not_found -> false

  let rec mem_key key t = M.mem key t

  exception Not_disjoint

  let disjoint_union t1 t2 =
bguillaum's avatar
bguillaum committed
462
    M.fold
463
      (fun key list acc ->
bguillaum's avatar
bguillaum committed
464
        try
465
466
467
468
469
470
471
472
          let old = M.find key acc in
          M.add key (List_.sort_disjoint_union list old) acc
        with
          | Not_found -> M.add key list acc
          | List_.Not_disjoint -> raise Not_disjoint
      ) t1 t2

  exception Duplicate
bguillaum's avatar
bguillaum committed
473

474
475
476
477
478
  let merge_key i j t =
    try
      let old_i = M.find i t in
      let old_j = try M.find j t with Not_found -> [] in
      M.add j (List_.sort_disjoint_union old_i old_j) (M.remove i t)
bguillaum's avatar
bguillaum committed
479
    with
480
481
482
      | Not_found -> (* no key i *) t
      | List_.Not_disjoint -> raise Duplicate

bguillaum's avatar
bguillaum committed
483
484
485
486
487
488
489
490
491
492
493
  exception True
  let exists fct t =
    try
      M.iter
        (fun key list ->
          if List.exists (fun elt -> fct key elt) list
          then raise True
        ) t;
      false
    with True -> true

494
495
496
497
498
499
  let rename mapping t =
    M.fold
      (fun key value acc ->
        let new_key = try List.assoc key mapping with Not_found -> key in
        M.add new_key value acc
      ) t M.empty
500
501
end (* module Massoc_make *)

bguillaum's avatar
bguillaum committed
502
(* ================================================================================ *)
pj2m's avatar
pj2m committed
503
504
505
506
507
508
509
510
511
512
513
module Id = struct
  type name = string

  type t = int

  type table = name array

  let build ?(loc:Loc.t option) string table =
    try Array_.dicho_find string table
    with Not_found -> Error.build ?loc "Identifier '%s' not found" string

bguillaum's avatar
bguillaum committed
514
  let build_opt string table =
pj2m's avatar
pj2m committed
515
516
    try Some (Array_.dicho_find string table)
    with Not_found -> None
bguillaum's avatar
bguillaum committed
517
end (* module Id *)
518

bguillaum's avatar
bguillaum committed
519
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
520
521
522
(* copy from leopar *)
module Timeout = struct
  exception Stop
523

bguillaum's avatar
bguillaum committed
524
525
  let counter = ref 0.
  let timeout = ref None
bguillaum's avatar
bguillaum committed
526

bguillaum's avatar
bguillaum committed
527
528
529
  let start () = counter := Unix.time ()

  let check () =
bguillaum's avatar
bguillaum committed
530
    match !timeout with
bguillaum's avatar
bguillaum committed
531
532
533
534
    | None -> ()
    | Some delay ->
        if Unix.time () -. !counter > delay
        then raise Stop
bguillaum's avatar
bguillaum committed
535
end (* module Timeout *)