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
21
22
23
24
end

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

25
module Make(X : Custom.T) = struct
26
27
28
29
  type token
  type value = X.t
  type t = token typed_int

30
31
  let min = min

32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
  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

49
(*  let value h = 
50
    assert (h != dummy);
51
52
    try HInt.find pool h
    with Not_found -> assert false *)
53

54
  let value h = HInt.find pool h
55

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

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

  let from_int i = i
63
end