Usable version:

[tatoo.git] / src / hcons.ml

diff --git a/src/hcons.ml b/src/hcons.ml
new file mode 100644 (file)
index 0000000..d421d03
--- /dev/null
+++ b/src/hcons.ml
@@ -0,0 +1,96 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                               TAToo                                 *)
+(*                                                                     *)
+(*                     Kim Nguyen, LRI UMR8623                         *)
+(*                   Université Paris-Sud & CNRS                       *)
+(*                                                                     *)
+(*  Copyright 2010-2012 Université Paris-Sud and Centre National de la *)
+(*  Recherche Scientifique. All rights reserved.  This file is         *)
+(*  distributed under the terms of the GNU Lesser General Public       *)
+(*  License, with the special exception on linking described in file   *)
+(*  ../LICENSE.                                                        *)
+(*                                                                     *)
+(***********************************************************************)
+
+module type Abstract =
+  sig
+    type data
+    type t
+    val make : data -> t
+    val node : t -> data
+    val hash : t -> int
+    val uid : t -> Uid.t
+    val equal : t -> t -> bool
+    val init : unit -> unit
+  end
+
+type 'a node = { id   : Uid.t;
+                 key  : int;
+                 node : 'a }
+module type S =
+sig
+  type data
+  type t = private { id   : Uid.t;
+                     key  : int;
+                     node : data }
+  include Abstract with type data := data and type t := t
+end
+
+module type TableBuilder =
+  functor
+    (H : Sigs.HashedType) ->
+      Sigs.HashSet with type data = H.t
+
+module Builder (TB : TableBuilder) (H : Sigs.HashedType) =
+struct
+  type data = H.t
+  type t = { id   : Uid.t;
+             key  : int;
+             node : data }
+  let uid_make = ref (Uid.make_maker())
+  let node t = t.node
+  let uid t = t.id
+  let hash t = t.key
+  let equal t1 t2 = t1 == t2
+  module HN =
+  struct
+    type _t = t
+    type t = _t
+    let hash = hash
+    let equal x y = x == y || H.equal x.node y.node
+  end
+  module T = TB(HN)
+
+  let pool = T.create 101
+  let init () =
+    T.clear pool;
+    uid_make := Uid.make_maker ()
+
+  let make x =
+    let cell = { id = Uid.dummy; key = H.hash x; node = x } in
+    try
+      T.find pool cell
+    with
+    | Not_found ->
+      let cell = { cell with id = !uid_make(); } in
+      T.add pool cell;
+      cell
+end
+
+module Make = Builder (Utils.HashSet)
+module Weak = Builder (Weak.Make)
+
+module PosInt =
+struct
+  type data = int
+  type t = int
+  let make v =
+    if v < 0 then raise (Invalid_argument "Hcons.PosInt.make")
+    else v
+  let node v = v
+  let hash v = v
+  let uid v = Uid.of_int v
+  let equal x y = x == y
+  let init () = ()
+end