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