viewcvs.cgi/misc/upool.ml

type 'a typed_int = int
external int: 'a typed_int -> int = "%identity"

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

  val dummy: t
  val min: t -> t -> t
  val mk: value -> t
  val value: t -> value

  val extract: unit -> value array
  val intract: value array -> unit

  val from_int: int -> t
end

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

module Make(X : Custom.T) = struct
  type token
  type value = X.t
  type t = token typed_int

  let min = min

  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 value h = 
    assert (h != dummy);
    try HInt.find pool h
    with Not_found -> assert false *)

  let value h = HInt.find pool h

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

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

  let from_int i = i
end
1	type 'a typed_int = int
2	external int: 'a typed_int -> int = "%identity"
3
4	module type S = sig
5	type token
6	type value
7	include Custom.T with type t = token typed_int
8	exception Not_unique of value * value
9
10	val dummy: t
11	val min: t -> t -> t
12	val mk: value -> t
13	val value: t -> value
14
15	val extract: unit -> value array
16	val intract: value array -> unit
17
18	val from_int: int -> t
19	end
20
21	module HInt = Hashtbl.Make(struct type t = int
22	let hash x = x
23	let equal x y = x==y end)
24
25	module Make(X : Custom.T) = struct
26	type token
27	type value = X.t
28	type t = token typed_int
29
30	let min = min
31
32	exception Not_unique of value * value
33	let compare (x:int) y = if (x=y) then 0 else if (x < y) then (-1) else 1
34	let hash x = x
35	let equal x y = x==y
36
37	let pool = HInt.create 1024
38	let dummy = max_int
39
40	let mk v =
41	let h = X.hash v in
42	if (h == dummy) then raise (Not_unique (v,v));
43	(try
44	let v' = HInt.find pool h in
45	if not (X.equal v v') then raise (Not_unique (v,v'));
46	with Not_found -> HInt.add pool h v);
47	h
48
49	(* let value h =
50	assert (h != dummy);
51	try HInt.find pool h
52	with Not_found -> assert false *)
53
54	let value h = HInt.find pool h
55
56	let extract () = Array.of_list (HInt.fold (fun _ v accu -> v::accu) pool [])
57	let intract = Array.iter (fun v -> ignore (mk v))
58
59	let check _ = ()
60	let dump ppf _ = ()
61
62	let from_int i = i
63	end