1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 2002 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 (* Consistency tables: for checking consistency of module CRCs *)
17
18 open Misc
19
20 module Make (Module_name : sig
21 type t
22 module Set : Set.S with type elt = t
23 module Map : Map.S with type key = t
24 module Tbl : Hashtbl.S with type key = t
25 val compare : t -> t -> int
26 end) = struct
27 type t = (Digest.t * filepath) Module_name.Tbl.t
28
29 let create () = Module_name.Tbl.create 13
30
31 let clear = Module_name.Tbl.clear
32
33 exception Inconsistency of Module_name.t * filepath * filepath
34
35 exception Not_available of Module_name.t
36
37 let check tbl name crc source =
38 try
39 let (old_crc, old_source) = Module_name.Tbl.find tbl name in
40 if crc <> old_crc then raise(Inconsistency(name, source, old_source))
41 with Not_found ->
42 Module_name.Tbl.add tbl name (crc, source)
43
44 let check_noadd tbl name crc source =
45 try
46 let (old_crc, old_source) = Module_name.Tbl.find tbl name in
47 if crc <> old_crc then raise(Inconsistency(name, source, old_source))
48 with Not_found ->
49 raise (Not_available name)
50
51 let set tbl name crc source = Module_name.Tbl.add tbl name (crc, source)
52
53 let source tbl name = snd (Module_name.Tbl.find tbl name)
54
55 let extract l tbl =
56 let l = List.sort_uniq Module_name.compare l in
57 List.fold_left
58 (fun assc name ->
59 try
60 let (crc, _) = Module_name.Tbl.find tbl name in
61 (name, Some crc) :: assc
62 with Not_found ->
63 (name, None) :: assc)
64 [] l
65
66 let extract_map mod_names tbl =
67 Module_name.Set.fold
68 (fun name result ->
69 try
70 let (crc, _) = Module_name.Tbl.find tbl name in
71 Module_name.Map.add name (Some crc) result
72 with Not_found ->
73 Module_name.Map.add name None result)
74 mod_names
75 Module_name.Map.empty
76
77 let filter p tbl =
78 let to_remove = ref [] in
79 Module_name.Tbl.iter
80 (fun name _ ->
81 if not (p name) then to_remove := name :: !to_remove)
82 tbl;
83 List.iter
84 (fun name ->
85 while Module_name.Tbl.mem tbl name do
86 Module_name.Tbl.remove tbl name
87 done)
88 !to_remove
89 end
90