Attention une mise à jour du service Gitlab va être effectuée le mardi 18 janvier (et non lundi 17 comme annoncé précédemment) entre 18h00 et 18h30. Cette mise à jour va générer une interruption du service dont nous ne maîtrisons pas complètement la durée mais qui ne devrait pas excéder quelques minutes.

grew_base.ml 17.7 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
29
  let to_line (_,line) = line
bguillaum's avatar
bguillaum committed
30
31
32
33
34
35
36
37
38
39
40
41
42

  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
43
  let build_ ?loc message = raise (Build (message, loc))
bguillaum's avatar
bguillaum committed
44
45
46
47
48
49
50
51
  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 *)
52

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

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

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

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

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

71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86

  let rec match_star_re re s =
    let star_re = Str.full_split (Str.regexp "\\*+") re in
    let len = String.length s in
    let rec loop pos = function
      | [] -> pos = len

      | [Str.Delim "*"] -> true

      | Str.Text t :: tail ->
        if Str.string_match (Str.regexp_string t) s pos
        then loop (pos+(String.length t)) tail
        else false

      (* if the [re] ends with some text jump to the end and test for the text *)
      | [Str.Delim "*"; Str.Text t] ->
bguillaum's avatar
bguillaum committed
87
88
        (String.length t <= String.length s) &&
        (Str.string_match (Str.regexp_string t) s (len - (String.length t)))
89
90
91
92
93
94
95
96
97
98
99
100
101
102

      (* if the [re] required for some text [t],
         we consider the first occurence which is more general than other occurences *)
      | Str.Delim "*" :: Str.Text t :: tail ->
        begin
          try
          let new_pos = Str.search_forward (Str.regexp_string t) s pos in
            loop (new_pos+(String.length t)) tail
          with Not_found -> false
        end
      | _ -> Error.build "Ill formed regular expression \"%s\"" re
    in
    loop 0 star_re

bguillaum's avatar
bguillaum committed
103
end (* module String_ *)
104

bguillaum's avatar
bguillaum committed
105
106
107
108
109
110
111
112
(* ================================================================================ *)
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 *)
113

bguillaum's avatar
bguillaum committed
114
115
116
117
118
119
120
(* ================================================================================ *)
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
121
  let read file =
bguillaum's avatar
bguillaum committed
122
    let in_ch = open_in file in
bguillaum's avatar
bguillaum committed
123
124
125
    (* 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
126
127
128
129
130
131
132
133
    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
134
    with End_of_file ->
bguillaum's avatar
bguillaum committed
135
136
      close_in in_ch;
      List.rev !rev_lines
bguillaum's avatar
bguillaum committed
137

bguillaum's avatar
bguillaum committed
138
139
  (* [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
140
    let in_ch = open_in file in
bguillaum's avatar
bguillaum committed
141
142
143
    (* 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
144
145
146
147
148
149
150
151
152
153
    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
154
    with End_of_file ->
bguillaum's avatar
bguillaum committed
155
156
      close_in in_ch;
      List.rev !rev_lines
bguillaum's avatar
bguillaum committed
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180

  let load file =
    let ch = open_in file in
    let buff = Buffer.create 32 in
    try
      while true do
        let next = input_line ch in 
        Printf.bprintf buff "%s\n" next
      done; assert false
    with End_of_file ->
      close_in ch;
      Buffer.contents buff

  exception Found of int
  let get_suffix file_name =
  let len = String.length file_name in
    try
      for i = len-1 downto 0 do
        if file_name.[i] = '.'
        then raise (Found i)
      done;
      None
    with
    | Found i -> Some (String.sub file_name i (len-i))
bguillaum's avatar
bguillaum committed
181
182
 end (* module File *)

bguillaum's avatar
bguillaum committed
183
(* ================================================================================ *)
pj2m's avatar
pj2m committed
184
185
186
module Array_ = struct
  let dicho_mem elt array =
    let rec loop low high =
bguillaum's avatar
bguillaum committed
187
      (if low > high
pj2m's avatar
pj2m committed
188
189
      then false
      else
190
191
192
193
        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
194
      ) in
pj2m's avatar
pj2m committed
195
196
197
198
199
200
201
202
203
    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
204
      | middle -> loop low (middle - 1) in
pj2m's avatar
pj2m committed
205
    loop 0 ((Array.length array) - 1)
bguillaum's avatar
bguillaum committed
206

pj2m's avatar
pj2m committed
207
208
209
210
211
212
  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
213
      | middle -> loop low (middle - 1) in
pj2m's avatar
pj2m committed
214
    loop 0 ((Array.length array) - 1)
bguillaum's avatar
bguillaum committed
215
end (* module Array_ *)
pj2m's avatar
pj2m committed
216

bguillaum's avatar
bguillaum committed
217
(* ================================================================================ *)
pj2m's avatar
pj2m committed
218
module List_ = struct
bguillaum's avatar
bguillaum committed
219
220
221
222
223
  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
224
225
226
227
228
  let rec rm elt = function
    | [] -> raise Not_found
    | x::t when x=elt -> t
    | x::t -> x::(rm elt t)

229
  let index x l =
bguillaum's avatar
bguillaum committed
230
231
232
233
234
235
    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
236
237
238
239
240
241
242
  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
243
    | x::t ->
244
245
246
        match f x with
        | None -> opt_map f t
        | Some r -> r :: (opt_map f t)
pj2m's avatar
pj2m committed
247

bguillaum's avatar
bguillaum committed
248
249
250
251
252
253
254
255
256
  let rec try_map exc fct = function
    | [] -> []
    | x::t -> let tail =  try_map exc fct t in
      try (fct x)::tail
      with e ->
        if e = exc
        then tail
        else raise e

pj2m's avatar
pj2m committed
257
258
259
260
  let rec flat_map f = function
    | [] -> []
    | x::t -> (f x)@(flat_map f t)

bguillaum's avatar
bguillaum committed
261
262
  let opt_mapi fct =
    let rec loop i = function
263
264
265
266
267
268
269
      | [] -> []
      | 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
270
  let foldi_left f init l =
bguillaum's avatar
bguillaum committed
271
272
    fst
      (List.fold_left
273
274
         (fun (acc,i) elt -> (f i acc elt, i+1))
         (init,0) l
pj2m's avatar
pj2m committed
275
276
277
278
279
280
      )

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

pj2m's avatar
pj2m committed
282
283
284
  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
285

pj2m's avatar
pj2m committed
286
287
  let rec sort_insert elt = function
    | [] -> [elt]
bguillaum's avatar
bguillaum committed
288
    | h::t when elt<h -> elt::h::t
pj2m's avatar
pj2m committed
289
290
291
292
293
294
    | h::t -> h::(sort_insert elt t)

  let rec sort_mem elt = function
    | [] -> false
    | h::_ when elt<h -> false
    | h::_ when elt=h -> true
295
    | h::t (* when elt>h *) -> sort_mem elt t
296
297
298
299
300

  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
301
    | (_,v)::_ -> Some v
302
303
304
305
306
307
308

  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
309
310
  exception Usort

bguillaum's avatar
bguillaum committed
311
  let rec usort_remove key = function
pj2m's avatar
pj2m committed
312
313
314
315
316
317
318
319
320
321
    | [] -> 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)
322
      | _ -> raise Usort in
pj2m's avatar
pj2m committed
323
    try Some (loop l) with Usort -> None
324

bguillaum's avatar
bguillaum committed
325
  let rec sort_disjoint l1 l2 =
pj2m's avatar
pj2m committed
326
327
328
329
    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
330
    | _ -> false
331

bguillaum's avatar
bguillaum committed
332
  let sort_is_empty_inter l1 l2 =
pj2m's avatar
pj2m committed
333
334
335
336
337
    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
338
    loop (l1,l2)
pj2m's avatar
pj2m committed
339

bguillaum's avatar
bguillaum committed
340
  let sort_inter l1 l2 =
pj2m's avatar
pj2m committed
341
342
343
344
345
346
    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
347
348

  let sort_union l1 l2 =
bguillaum's avatar
bguillaum committed
349
350
351
352
353
354
355
356
    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
357
  exception Not_disjoint
bguillaum's avatar
bguillaum committed
358
  let sort_disjoint_union ?(compare=Pervasives.compare) l1 l2 =
pj2m's avatar
pj2m committed
359
360
361
362
363
364
    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
365
366

  let sort_include l1 l2 =
pj2m's avatar
pj2m committed
367
368
369
370
371
372
373
    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
374
375

  let sort_included_diff l1 l2 =
pj2m's avatar
pj2m committed
376
377
378
379
380
381
382
383
    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
384
  let sort_diff l1 l2 =
pj2m's avatar
pj2m committed
385
386
387
388
389
390
391
392
    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)

bguillaum's avatar
bguillaum committed
393
394
395
396
397
398
399
  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
400
end (* module List_ *)
pj2m's avatar
pj2m committed
401

bguillaum's avatar
bguillaum committed
402
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
403
404
405
406
module type OrderedType = sig
  type t
  val compare: t -> t -> int
end (* module type OrderedType *)
407

bguillaum's avatar
bguillaum committed
408
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
409
410
module type S = sig
  type key
411

bguillaum's avatar
bguillaum committed
412
  type +'a t
413

bguillaum's avatar
bguillaum committed
414
  val empty: 'a t
415

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

bguillaum's avatar
bguillaum committed
419
  val is_empty: 'a t -> bool
420

bguillaum's avatar
bguillaum committed
421
  val to_string: ('a -> string) -> 'a t -> string
422

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

bguillaum's avatar
bguillaum committed
425
  val add: key -> 'a -> 'a t -> 'a t option
426

427
428
  val replace: key -> 'a list -> 'a t -> 'a t

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

bguillaum's avatar
bguillaum committed
431
432
  (* raise Not_found if no (key,elt) *)
  val remove: key -> 'a -> 'a t -> 'a t
433

bguillaum's avatar
bguillaum committed
434
435
  (* raise Not_found if no (key,elt) *)
  val remove_key: key -> 'a t -> 'a t
436

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

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

bguillaum's avatar
bguillaum committed
443
444
  exception Not_disjoint
  val disjoint_union: 'a t -> 'a t -> 'a t
445

bguillaum's avatar
bguillaum committed
446
447
  exception Duplicate
  val merge_key: key -> key -> 'a t -> 'a t
448

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

bguillaum's avatar
bguillaum committed
451
452
  val rename: (key * key) list -> 'a t -> 'a t
end (* module type S *)
453

bguillaum's avatar
bguillaum committed
454
(* ================================================================================ *)
455
456
457
458
459
460
461
462
463
464
465
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
466
467
  let assoc key t =
    try M.find key t
468
469
    with Not_found -> []

bguillaum's avatar
bguillaum committed
470
  let to_string _ _ = failwith "Not implemted"
471
472

  let iter fct t =
bguillaum's avatar
bguillaum committed
473
    M.iter
474
475
476
      (fun key list -> List.iter (fun elt -> fct key elt) list
      ) t

477
478
  let replace = M.add

bguillaum's avatar
bguillaum committed
479
  let add key elt t =
480
481
    try
      let list = M.find key t in
bguillaum's avatar
bguillaum committed
482
      match List_.usort_insert elt list with
483
484
485
486
487
488
489
        | 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
490
        List.fold_left
491
492
493
494
          (fun acc2 elt ->
            fct acc2 key elt)
          acc list)
      t init
bguillaum's avatar
bguillaum committed
495

496
497
498
499
500
501
  (* 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

502
  let remove_key key t = M.remove key t
503
504
505
506
507
508
509
510
511
512

  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
513
    M.fold
514
      (fun key list acc ->
bguillaum's avatar
bguillaum committed
515
        try
516
517
518
519
520
521
522
523
          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
524

525
526
527
528
529
  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
530
    with
531
532
533
      | Not_found -> (* no key i *) t
      | List_.Not_disjoint -> raise Duplicate

bguillaum's avatar
bguillaum committed
534
535
536
537
538
539
540
541
542
543
544
  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

545
546
547
548
549
550
  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
551
552
end (* module Massoc_make *)

bguillaum's avatar
bguillaum committed
553
(* ================================================================================ *)
pj2m's avatar
pj2m committed
554
555
556
module Id = struct
  type t = int

bguillaum's avatar
bguillaum committed
557
558
559
560
561
  type 'a gtable = 'a array * ('a -> string)

  let gbuild ?(loc:Loc.t option) key (table,conv) =
    try Array_.dicho_find key table
    with Not_found -> Error.build ?loc "Identifier '%s' not found" (conv key)
pj2m's avatar
pj2m committed
562

bguillaum's avatar
bguillaum committed
563
564
565
566
567
568
569
570
571
  let gbuild_opt key (table, _) =
    try Some (Array_.dicho_find key table)
    with Not_found -> None

  type name = string
  type table = string array
  let build ?(loc:Loc.t option) key table =
    try Array_.dicho_find key table
    with Not_found -> Error.build ?loc "Identifier '%s' not found" key
pj2m's avatar
pj2m committed
572

bguillaum's avatar
bguillaum committed
573
574
  let build_opt key table =
    try Some (Array_.dicho_find key table)
pj2m's avatar
pj2m committed
575
    with Not_found -> None
bguillaum's avatar
bguillaum committed
576
end (* module Id *)
577

bguillaum's avatar
bguillaum committed
578
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
579
580
581
(* copy from leopar *)
module Timeout = struct
  exception Stop
582

bguillaum's avatar
bguillaum committed
583
584
  let counter = ref 0.
  let timeout = ref None
bguillaum's avatar
bguillaum committed
585

bguillaum's avatar
bguillaum committed
586
587
588
  let start () = counter := Unix.time ()

  let check () =
bguillaum's avatar
bguillaum committed
589
    match !timeout with
bguillaum's avatar
bguillaum committed
590
591
592
593
    | None -> ()
    | Some delay ->
        if Unix.time () -. !counter > delay
        then raise Stop
bguillaum's avatar
bguillaum committed
594
end (* module Timeout *)
bguillaum's avatar
bguillaum committed
595
596
597
598

(* ================================================================================ *)
module Global = struct
  let current_file = ref "Not a file"
bguillaum's avatar
bguillaum committed
599
  let current_line = ref 1
bguillaum's avatar
bguillaum committed
600
  let label_flag = ref false
bguillaum's avatar
bguillaum committed
601
602
603

  let init file =
    current_file := file;
bguillaum's avatar
bguillaum committed
604
    current_line := 1;
bguillaum's avatar
bguillaum committed
605
    label_flag := false;
bguillaum's avatar
bguillaum committed
606
end