Merge branch 'local-ocamlbuild' into local-trunk

[SXSI/xpathcomp.git] / src / custom.ml

diff --git a/src/custom.ml b/src/custom.ml
new file mode 100644 (file)
index 0000000..a71f32a
--- /dev/null
+++ b/src/custom.ml
@@ -0,0 +1,138 @@
+(* also taken from CDuce misc/custom.ml 
+   this module should always be included not referenced with Open
+*)
+
+module Dummy = 
+struct
+  let dump _ _ = failwith "dump not implemented"
+  let check _ = failwith "check not implemented"
+  let equal  _ _ = failwith "equal not implemented"
+  let hash _ = failwith "hash not implemented"
+  let compare _ _ = failwith "compare not implemented"
+  let print _ _ = failwith "print not implemented"
+end
+
+(* Some of this borrowed from Jean-Christophe Filliâtre :
+   http://www.lri.fr/~filliatr/ftp/ocaml/ds/bitset.ml.html
+*)
+
+module IntSet : Set.S with type elt = int= 
+struct
+  let max = Sys.word_size - 2
+  type t = int
+  type elt = int
+
+  let empty = 0
+  let full = -1
+  let is_empty x = x == 0
+  let mem e s = ((1 lsl e) land s) != 0
+  let add e s = (1 lsl e) lor s
+  let singleton e = (1 lsl e)
+  let union = (lor)
+  let inter = (land)
+  let diff a b = a land (lnot b)
+  let remove e s = (lnot (1 lsl e) land s)
+  let compare = (-)
+  let equal = (==)
+  let subset a b = a land (lnot b) == 0
+  let cardinal s = 
+    let rec loop n s =
+      if s == 0 then n else loop (succ n) (s - (s land (-s)))
+    in
+  loop 0 s
+(* inverse of bit i = 1 lsl i i.e. tib i = log_2(i) *)
+let log2 = Array.create 255 0
+let () = for i = 0 to 7 do log2.(1 lsl i) <- i done
+
+(* assumption: x is a power of 2 *)
+let tib32 x =
+  if x land 0xFFFF == 0 then 
+    let x = x lsr 16 in
+    if x land 0xFF == 0 then 24 + log2.(x lsr 8) else 16 + log2.(x)
+  else 
+    if x land 0xFF == 0 then 8 + log2.(x lsr 8) else log2.(x)
+
+let ffffffff = (0xffff lsl 16) lor 0xffff
+let tib64 x = 
+  if x land ffffffff == 0 then 32 + tib32 (x lsr 32) else tib32 x
+
+let tib = 
+  match Sys.word_size with 32 -> tib32 | 64 -> tib64 | _ -> assert false
+
+let min_elt s = 
+  if s == 0 then raise Not_found; 
+  tib (s land (-s))
+
+let choose = min_elt
+
+(* TODO: improve? *)
+let max_elt s =
+  if s == 0 then raise Not_found;
+  let rec loop i =
+    if s land i != 0 then tib i 
+    else if i = 1 then raise Not_found else loop (i lsr 1)
+  in
+  loop min_int
+
+let rec elements s =
+  if s == 0 then [] else let i = s land (-s) in tib i :: elements (s - i)
+
+let rec iter f s =
+  if s != 0 then let i = s land (-s) in f (tib i); iter f (s - i)
+
+let rec fold f s acc =
+  if s == 0 then acc else let i = s land (-s) in fold f (s - i) (f (tib i) acc)
+
+let rec for_all p s =
+  s == 0 || let i = s land (-s) in p (tib i) && for_all p (s - i)
+
+let rec exists p s =
+  s != 0 && let i = s land (-s) in p (tib i) || exists p (s - i)
+
+let rec filter p s =
+  if s == 0 then 
+    0 
+  else 
+    let i = s land (-s) in 
+    let s = filter p (s - i) in
+    if p (tib i) then s + i else s
+
+let rec partition p s =
+   if s == 0 then 
+    0, 0
+  else 
+    let i = s land (-s) in 
+    let st,sf = partition p (s - i) in
+    if p (tib i) then st + i, sf else st, sf + i
+
+let split i s =
+  let bi = 1 lsl i in
+  s land (bi - 1), s land bi != 0, s land (-1 lsl (i+1))
+end
+
+
+module Bool  = 
+struct
+  module Make (X : Sigs.T) (Y : Sigs.T) : 
+    Sigs.T with type t = X.t*Y.t =
+  struct
+    module Fst = X
+    module Snd = Y
+    type t = X.t*Y.t
+    let dump ppf (x,y) = 
+      X.dump ppf x;
+      Y.dump ppf y
+       
+    let check (x,y) = X.check x; Y.check y 
+    let equal  (x,y) (z,t) = 
+      X.equal x z && Y.equal y t
+    let hash (x,y) = (X.hash x) + 4093 * Y.hash y
+    let compare (x,y) (z,t) = 
+      let r = X.compare x z in
+       if r == 0 
+       then Y.compare y t 
+       else r
+         
+    let print _ _ = failwith "compare not implemented"
+  end
+end