CCBitField now with printing, freezing, named fields

src/data/CCBitField.ml

@@ -3,6 +3,7 @@
 (** {1 Bit Field} *)
 
 exception TooManyFields
+exception Frozen
 
 let max_width = Sys.word_size - 2
 
@@ -24,21 +25,42 @@ module type BITFIELD = sig
   val width : _ field -> int
   (** Number of bits of the field *)
 
-  val bool : unit -> bool field
+  val name : _ field -> string
+  (** Informal name of the field *)
+
+  val bool : ?name:string -> unit -> bool field
   (** New field of type boo
+      @raise Frozen if [freeze ()] was called
       @raise TooManyFields if there is no room *)
 
-  val int2 : unit -> int field
+  val int2 : ?name:string -> unit -> int field
   (** New field of type 2-bits int
+      @raise Frozen if [freeze ()] was called
       @raise TooManyFields if there is no room *)
 
-  val int3 : unit -> int field
+  val int3 : ?name:string -> unit -> int field
   (** New field for 3-bits int
+      @raise Frozen if [freeze ()] was called
       @raise TooManyFields if there is no room *)
 
-  val int : width:int -> int field
+  val int : ?name:string -> width:int -> int field
   (** New field for [width] bits.
+      @raise Frozen if [freeze ()] was called
       @raise TooManyFields if there is no room *)
+
+  val freeze : unit -> unit
+  (** Prevent new fields from being added *)
+
+  val total_width : unit -> int
+  (** Current width of the bitfield *)
+
+  type any_field = AnyField : 'a field -> any_field
+
+  val iter_fields : (any_field -> unit) -> unit
+  (** Iterate on all currently present fields *)
+
+  val pp : Format.formatter -> t -> unit
+  (** Print the bitfield using the current list of fields *)
 end
 
 let rec all_bits_ acc w =
@@ -59,26 +81,46 @@ module Make(X : EMPTY) : BITFIELD = struct
 
   let empty = 0
 
-  let width_ = ref 0
+  type _ field_kind =
+    | Bool : bool field_kind
+    | Int : int field_kind
 
   type 'a field = {
-    start : int;
+    kind : 'a field_kind;
+    name : string;
     width : int;
     get : t -> 'a;
     set : 'a -> t -> t;
   }
 
+  type any_field = AnyField : 'a field -> any_field
+
+  let width_ = ref 0
+  let frozen_ = ref false
+  let fields_ = Queue.create()
+  let register_ f = Queue.push (AnyField f) fields_
+
   let get f x = f.get x
   let set f v x = f.set v x
   let width f = f.width
+  let name f = f.name
 
-  let bool () =
+  let make_field f =
+    if !width_ > max_width then raise TooManyFields;
+    if !frozen_ then raise Frozen;
+    register_ f;
+    f
+
+  let new_name_ () =
+    "field_" ^ string_of_int (Queue.length fields_)
+
+  let bool ?(name=new_name_()) () =
     let n = !width_ in
     incr width_;
-    if !width_ > max_width then raise TooManyFields;
     let mask = 1 lsl n in
-    {
+    make_field {
-      start=n;
+      kind = Bool;
+      name;
       width=1;
       get=(fun x -> (x land mask) <> 0);
       set=(fun b x ->
@@ -86,13 +128,13 @@ module Make(X : EMPTY) : BITFIELD = struct
       );
     }
 
-  let int2 () =
+  let int2 ?(name=new_name_()) () =
     let n = !width_ in
     width_ := n+2;
-    if !width_ > max_width then raise TooManyFields;
     let mask = 3 lsl n in
-    {
+    make_field {
-      start=n;
+      kind = Int;
+      name;
       width=2;
       get=(fun x -> (x land mask) lsr n);
       set=(fun v x ->
@@ -102,13 +144,13 @@ module Make(X : EMPTY) : BITFIELD = struct
       )
     }
 
-  let int3 () =
+  let int3 ?(name=new_name_()) () =
     let n = !width_ in
     width_ := n+3;
-    if !width_ > max_width then raise TooManyFields;
     let mask = 7 lsl n in
-    {
+    make_field {
-      start=n;
+      kind = Int;
+      name;
       width=3;
       get=(fun x -> (x land mask) lsr n);
       set=(fun v x ->
@@ -118,14 +160,14 @@ module Make(X : EMPTY) : BITFIELD = struct
       )
     }
 
-  let int ~width:w =
+  let int ?(name=new_name_()) ~width:w =
     let n = !width_ in
     width_ := n+w;
-    if !width_ > max_width then raise TooManyFields;
     let mask_unshifted = all_bits_ 0 w in
     let mask = mask_unshifted lsl n in
-    {
+    make_field {
-      start=n;
+      kind = Int;
+      name;
       width=w;
       get=(fun x -> (x land mask) lsr n);
       set=(fun v x ->
@@ -134,4 +176,25 @@ module Make(X : EMPTY) : BITFIELD = struct
         x lor (v lsl n)
       )
     }
+
+  let freeze () = frozen_ := true
+
+  let total_width () = !width_
+
+  let iter_fields f = Queue.iter f fields_
+
+  let pp out x =
+    let ppf = Format.fprintf in
+    ppf out "{@[<hv>";
+    Queue.iter
+      (fun (AnyField f) ->
+        match f.kind with
+        | Bool ->
+            let b = get f x in
+            ppf out "%s: %b,@ " f.name b
+        | Int ->
+            let i = get f x in
+            ppf out "%s: %ui@, " f.name i
+      ) fields_;
+    ppf out "@]}"
 end

src/data/CCBitField.mli

@@ -12,8 +12,14 @@
 exception TooManyFields
 (** Raised when too many fields are packed into one bitfield *)
 
+exception Frozen
+(** Raised when a frozen bitfield is modified *)
+
 module type EMPTY = sig end
 
+val max_width : int
+(** System-dependent maximum width for a bitfield *)
+
 (** {2 Bitfield Signature} *)
 module type BITFIELD = sig
   type t = private int
@@ -31,21 +37,42 @@ module type BITFIELD = sig
   val width : _ field -> int
   (** Number of bits of the field *)
 
-  val bool : unit -> bool field
+  val name : _ field -> string
+  (** Informal name of the field *)
+
+  val bool : ?name:string -> unit -> bool field
   (** New field of type boo
+      @raise Frozen if [freeze ()] was called
       @raise TooManyFields if there is no room *)
 
-  val int2 : unit -> int field
+  val int2 : ?name:string -> unit -> int field
   (** New field of type 2-bits int
+      @raise Frozen if [freeze ()] was called
       @raise TooManyFields if there is no room *)
 
-  val int3 : unit -> int field
+  val int3 : ?name:string -> unit -> int field
   (** New field for 3-bits int
+      @raise Frozen if [freeze ()] was called
       @raise TooManyFields if there is no room *)
 
-  val int : width:int -> int field
+  val int : ?name:string -> width:int -> int field
   (** New field for [width] bits.
+      @raise Frozen if [freeze ()] was called
       @raise TooManyFields if there is no room *)
+
+  val freeze : unit -> unit
+  (** Prevent new fields from being added *)
+
+  val total_width : unit -> int
+  (** Current width of the bitfield *)
+
+  type any_field = AnyField : 'a field -> any_field
+
+  val iter_fields : (any_field -> unit) -> unit
+  (** Iterate on all currently present fields *)
+
+  val pp : Format.formatter -> t -> unit
+  (** Print the bitfield using the current list of fields *)
 end
 
 (** Create a new bitfield type *)