diff --git a/src/data/CCBitField.ml b/src/data/CCBitField.ml index e1727112..99c46ef2 100644 --- a/src/data/CCBitField.ml +++ b/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 - { - start=n; + make_field { + 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 - { - start=n; + make_field { + 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 - { - start=n; + make_field { + 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 - { - start=n; + make_field { + 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 "{@["; + 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 diff --git a/src/data/CCBitField.mli b/src/data/CCBitField.mli index e3b073bf..3c441afe 100644 --- a/src/data/CCBitField.mli +++ b/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 *)