upool.ml 1.37 KB
Newer Older
1 2 3 4 5 6
type 'a typed_int = int
external int: 'a typed_int -> int = "%identity"

module type S = sig
  type token
  type value
7
  include Custom.T with type t = token typed_int
8 9 10
  exception Not_unique of value * value

  val dummy: t
11
  val min: t -> t -> t
12
  val mk: value -> t
13
  val value: t -> value
14

15 16
  val extract: unit -> value array
  val intract: value array -> unit
17 18

  val from_int: int -> t
19 20
end

21 22 23 24 25 26
module HInt = 
  Hashtbl.Make(struct
    type t = int
    let hash x = x
    let equal x y = x==y 
end)
27

28
module Make(X : Custom.T) = struct
29 30 31 32
  type token
  type value = X.t
  type t = token typed_int

33 34
  let min = min

35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
  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

52
(*  let value h = 
53
    assert (h != dummy);
54 55
    try HInt.find pool h
    with Not_found -> assert false *)
56

57
  let value h = HInt.find pool h
58

59 60
  let extract () = Array.of_list (HInt.fold (fun _ v accu -> v::accu) pool [])
  let intract = Array.iter (fun v -> ignore (mk v))
61 62 63

  let check _ = ()
  let dump ppf _ = ()
64 65

  let from_int i = i
66
end