From 99fb2f84db01cf89f0d8280339e1010bca434265 Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Tue, 11 Aug 2015 20:26:47 +0200
Subject: [PATCH] add `CCBitField`, a safe abstraction for bitfields of < 62
 bits

---
 _oasis                  |  2 +-
 src/data/CCBitField.ml  | 80 +++++++++++++++++++++++++++++++++++++++++
 src/data/CCBitField.mli | 63 ++++++++++++++++++++++++++++++++
 3 files changed, 144 insertions(+), 1 deletion(-)
 create mode 100644 src/data/CCBitField.ml
 create mode 100644 src/data/CCBitField.mli

diff --git a/_oasis b/_oasis
index 93411ced..ef866ff4 100644
--- a/_oasis
+++ b/_oasis
@@ -84,7 +84,7 @@ Library "containers_data"
   Modules:          CCMultiMap, CCMultiSet, CCTrie, CCFlatHashtbl, CCCache,
                     CCPersistentHashtbl, CCDeque, CCFQueue, CCBV, CCMixtbl,
                     CCMixmap, CCRingBuffer, CCIntMap, CCPersistentArray,
-                    CCMixset, CCHashconsedSet, CCGraph, CCHashSet
+                    CCMixset, CCHashconsedSet, CCGraph, CCHashSet, CCBitField
   BuildDepends:     bytes
   FindlibParent:    containers
   FindlibName:      data
diff --git a/src/data/CCBitField.ml b/src/data/CCBitField.ml
new file mode 100644
index 00000000..cca955c0
--- /dev/null
+++ b/src/data/CCBitField.ml
@@ -0,0 +1,80 @@
+(* This file is free software, part of containers. See file "license" for more details. *)
+
+(** {1 Bit Field} *)
+
+exception TooManyFields
+
+let max_width = Sys.word_size - 2
+
+module type EMPTY = sig end
+
+module type BITFIELD = sig
+  type t = private int
+
+  val empty : t
+
+  type 'a field
+
+  val get : 'a field -> t -> 'a
+  (** Get a field of type ['a] *)
+
+  val set : 'a field -> 'a -> t -> t
+  (** Set a field of type ['a] *)
+
+  val width : _ field -> int
+  (** Number of bits of the field *)
+
+  val bool : unit -> bool field
+  (** New field of type bool *)
+
+  val int2 : unit -> int field
+  (** New field of type 2-bits int *)
+end
+
+module Make(X : EMPTY) : BITFIELD = struct
+  type t = int
+
+  let empty = 0
+
+  let width_ = ref 0
+
+  type 'a field = {
+    start : int;
+    width : int;
+    get : t -> 'a;
+    set : 'a -> t -> t;
+  }
+
+  let get f x = f.get x
+  let set f v x = f.set v x
+  let width f = f.width
+
+  let bool () =
+    let n = !width_ in
+    incr width_;
+    if !width_ > max_width then raise TooManyFields;
+    let mask = 1 lsl n in
+    {
+      start=n;
+      width=1;
+      get=(fun x -> (x land mask) <> 0);
+      set=(fun b x ->
+        if b then x lor mask else x land (lnot mask)
+      );
+    }
+
+  let int2 () =
+    let n = !width_ in
+    width_ := n+2;
+    if !width_ > max_width then raise TooManyFields;
+    let mask = 3 lsl n in
+    {
+      start=n;
+      width=2;
+      get=(fun x -> (x land mask) lsr n);
+      set=(fun v x ->
+        let x = x land (lnot mask) in
+        x lor (v lsl n)
+      )
+    }
+end
diff --git a/src/data/CCBitField.mli b/src/data/CCBitField.mli
new file mode 100644
index 00000000..9097c39d
--- /dev/null
+++ b/src/data/CCBitField.mli
@@ -0,0 +1,63 @@
+(* This file is free software, part of containers. See file "license" for more details. *)
+
+(** {1 Bit Field}
+
+  This module defines efficient bitfields
+  up to 30 or 62 bits (depending on the architecture) in
+  a relatively type-safe way.
+
+  {b status: experimental}
+  @since NEXT_RELEASE *)
+
+module type EMPTY = sig end
+
+(** {2 Bitfield Signature} *)
+module type BITFIELD = sig
+  type t = private int
+
+  val empty : t
+
+  type 'a field
+
+  val get : 'a field -> t -> 'a
+  (** Get a field of type ['a] *)
+
+  val set : 'a field -> 'a -> t -> t
+  (** Set a field of type ['a] *)
+
+  val width : _ field -> int
+  (** Number of bits of the field *)
+
+  val bool : unit -> bool field
+  (** New field of type bool *)
+
+  val int2 : unit -> int field
+  (** New field of type 2-bits int *)
+end
+
+(** Create a new bitfield type
+ 
+Example:
+
+{[
+  module B = CCBitField.Make(struct end);;
+
+  let x = B.bool ();;
+  let y = B.int2 ();;
+  let z = B.bool ();;
+
+  B.width y ;; (* = 2 *)
+
+  let f = B.empty
+  |> B.set y 3
+  |> B.set z true ;;
+  (* = 14 *)
+
+  B.get x f ;; (* false *)
+  B.get y f ;; (* 3 *)
+  B.get z f ;; (* true *)
+
+]}
+ 
+ *)
+module Make(X : EMPTY) : BITFIELD