upool.ml 1.21 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
type 'a typed_int = int
external int: 'a typed_int -> int = "%identity"

module type S = sig
  type token
  type value
  type t = token typed_int
  exception Not_unique of value * value

  val dummy: t
  val mk: value -> t
  val get: t -> value
  val compare: t -> t -> int
  val hash: t -> int
  val equal: t -> t -> bool

  val extract: unit -> value list
  val intract: value list -> unit
end

module HInt = Hashtbl.Make(struct type t = int
				  let hash x = x
				  let equal x y = x==y end)

module Make(X : Hashtbl.HashedType) = struct
  type token
  type value = X.t
  type t = token typed_int

  exception Not_unique of value * value
  let compare (x:int) y = if (x=y) then 0 else if (x < y) then (-1) else 1
  let hash x = x
  let equal x y = x==y

  let pool = HInt.create 1024
  let dummy = max_int

  let mk v =
    let h = X.hash v in
    if (h == dummy) then raise (Not_unique (v,v));
    (try 
       let v' = HInt.find pool h in 
       if not (X.equal v v') then raise (Not_unique (v,v'));
     with Not_found -> HInt.add pool h v);
    h

  let get h = 
    assert (h != dummy);
    HInt.find pool h

  let extract () = HInt.fold (fun _ v accu -> v::accu) pool []
  let intract = List.iter (fun v -> ignore (mk v))
end