mirror of
https://github.com/c-cube/ocaml-containers.git
synced 2025-12-06 11:15:31 -05:00
rewrite CCBitField with a much simpler interface
This commit is contained in:
Simon Cruanes
parent
4f6bce60e5
commit
5a1a88d3f5
2 changed files with 89 additions and 280 deletions
|
|
@ -7,7 +7,58 @@ exception Frozen
|
|||
|
||||
let max_width = Sys.word_size - 2
|
||||
|
||||
module type EMPTY = sig end
|
||||
(*$R
|
||||
let module B = CCBitField.Make(struct end) in
|
||||
let x = B.mk_field () in
|
||||
let y = B.mk_field () in
|
||||
let z = B.mk_field () in
|
||||
|
||||
let f = B.empty |> B.set x true |> B.set y true in
|
||||
|
||||
assert_bool "z_false" (not (B.get z f)) ;
|
||||
|
||||
assert_bool "z_true" (f |> B.set z true |> B.get z);
|
||||
*)
|
||||
|
||||
(*$R
|
||||
let module B = CCBitField.Make(struct end) in
|
||||
let x = B.mk_field () in
|
||||
B.freeze();
|
||||
assert_bool "must raise"
|
||||
(try ignore (B.mk_field()); false with Frozen -> true);
|
||||
|
||||
*)
|
||||
|
||||
(*$R
|
||||
let module B = CCBitField.Make(struct end) in
|
||||
|
||||
let x = B.mk_field () in
|
||||
let y = B.mk_field () in
|
||||
let z = B.mk_field () in
|
||||
let u = B.mk_field () in
|
||||
B.freeze();
|
||||
|
||||
let f = B.empty
|
||||
|> B.set y true
|
||||
|> B.set z true
|
||||
in
|
||||
|
||||
assert_equal ~printer:CCInt.to_string 6 (f :> int) ;
|
||||
|
||||
assert_equal false (B.get x f) ;
|
||||
assert_equal true (B.get y f) ;
|
||||
assert_equal true (B.get z f);
|
||||
|
||||
let f' = B.set u true f in
|
||||
|
||||
assert_equal false (B.get x f') ;
|
||||
assert_equal true (B.get y f') ;
|
||||
assert_equal true (B.get z f');
|
||||
assert_equal true (B.get u f');
|
||||
|
||||
()
|
||||
*)
|
||||
|
||||
|
||||
module type S = sig
|
||||
type t = private int
|
||||
|
|
@ -17,49 +68,16 @@ module type S = sig
|
|||
val empty : t
|
||||
(** Empty bitfields (all bits 0) *)
|
||||
|
||||
type _ field_kind =
|
||||
| Bool : bool field_kind
|
||||
| Int : int field_kind
|
||||
type field
|
||||
|
||||
(** Field of type [value], with a given width and position within the
|
||||
bitfield type *)
|
||||
module type FIELD = sig
|
||||
type value
|
||||
(** Values contained in the field *)
|
||||
val get : field -> t -> bool
|
||||
(** Get the value of this field *)
|
||||
|
||||
val get : t -> value
|
||||
val set : field -> bool -> t -> t
|
||||
(** Set the value of this field *)
|
||||
|
||||
val set : value -> t -> t
|
||||
|
||||
val width : int
|
||||
|
||||
val name : string
|
||||
|
||||
val kind : value field_kind
|
||||
end
|
||||
|
||||
type 'a field = (module FIELD with type value = 'a)
|
||||
|
||||
val bool : ?name:string -> unit -> bool field
|
||||
(** New field of type bool
|
||||
@raise Frozen if [freeze ()] was called
|
||||
@raise TooManyFields if there is no room *)
|
||||
|
||||
val int2 : ?name:string -> unit -> int field
|
||||
(** New field of type 2-bits int (same as [int ~width:2])
|
||||
@raise Frozen if [freeze ()] was called
|
||||
@raise TooManyFields if there is no room *)
|
||||
|
||||
val int3 : ?name:string -> unit -> int field
|
||||
(** New field of type 3-bits int (same as [int ~width:3])
|
||||
@raise Frozen if [freeze ()] was called
|
||||
@raise TooManyFields if there is no room *)
|
||||
|
||||
val int : ?name:string -> width:int -> unit -> int field
|
||||
(** New field for [width] bits.
|
||||
@raise Frozen if [freeze ()] was called
|
||||
@raise Invalid_argument if width is not [<= 1]
|
||||
@raise TooManyFields if there is no room *)
|
||||
val mk_field : unit -> field
|
||||
(** Make a new field *)
|
||||
|
||||
val freeze : unit -> unit
|
||||
(** Prevent new fields from being added. From now on, creating
|
||||
|
|
@ -67,16 +85,9 @@ module type S = sig
|
|||
|
||||
val total_width : unit -> int
|
||||
(** Current width of the bitfield *)
|
||||
|
||||
type any_field = AnyField : (module FIELD with type value = 'a) * 'a field_kind -> 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
|
||||
|
||||
(* all bits from 0 to w-1 set to true *)
|
||||
let rec all_bits_ acc w =
|
||||
if w=0 then acc
|
||||
else
|
||||
|
|
@ -96,145 +107,29 @@ let get_then_incr n =
|
|||
incr n;
|
||||
x
|
||||
|
||||
let get_then_add n offset =
|
||||
let x = !n in
|
||||
n := !n + offset;
|
||||
x
|
||||
|
||||
module Make(X : EMPTY) : S = struct
|
||||
module Make(X : sig end) : S = struct
|
||||
type t = int
|
||||
|
||||
let empty = 0
|
||||
|
||||
type _ field_kind =
|
||||
| Bool : bool field_kind
|
||||
| Int : int field_kind
|
||||
|
||||
module type FIELD = sig
|
||||
type value
|
||||
(** Values contained in the field *)
|
||||
|
||||
val get : t -> value
|
||||
|
||||
val set : value -> t -> t
|
||||
|
||||
val width : int
|
||||
|
||||
val name : string
|
||||
|
||||
val kind : value field_kind
|
||||
end
|
||||
|
||||
type 'a field = (module FIELD with type value = 'a)
|
||||
|
||||
type any_field = AnyField : (module FIELD with type value = 'a) * 'a field_kind -> any_field
|
||||
|
||||
let width_ = ref 0
|
||||
let frozen_ = ref false
|
||||
let fields_ = Queue.create()
|
||||
let register_
|
||||
: type a. (module FIELD with type value = a) -> unit
|
||||
= fun f ->
|
||||
if !width_ > max_width then raise TooManyFields;
|
||||
if !frozen_ then raise Frozen;
|
||||
let (module F) = f in
|
||||
Queue.push (AnyField (f, F.kind)) fields_
|
||||
|
||||
let new_name_ () =
|
||||
"field_" ^ string_of_int (Queue.length fields_)
|
||||
type field = int (* a mask *)
|
||||
|
||||
let bool ?(name=new_name_()) () : bool field =
|
||||
let module B = struct
|
||||
type value = bool
|
||||
let n = get_then_incr width_
|
||||
let mask = 1 lsl n
|
||||
let name = name
|
||||
let width = 1
|
||||
let get x = (x land mask) <> 0
|
||||
let set b x =
|
||||
if b then x lor mask else x land (lnot mask)
|
||||
let kind = Bool
|
||||
end in
|
||||
let f = (module B : FIELD with type value = bool) in
|
||||
register_ f;
|
||||
f
|
||||
let get field x = (x land field) <> 0
|
||||
|
||||
let int2 ?(name=new_name_()) () =
|
||||
let module Int2 = struct
|
||||
type value = int
|
||||
let n = get_then_add width_ 2
|
||||
let name = name
|
||||
let mask = 3 lsl n
|
||||
let kind = Int
|
||||
let width=2
|
||||
let get x = (x land mask) lsr n
|
||||
let set v x =
|
||||
assert (x >= 0 && x < 4);
|
||||
let x = x land (lnot mask) in
|
||||
x lor (v lsl n)
|
||||
end in
|
||||
let f = (module Int2 : FIELD with type value = int) in
|
||||
register_ f;
|
||||
f
|
||||
let set field b x =
|
||||
if b then x lor field else x land (lnot field)
|
||||
|
||||
|
||||
let int3 ?(name=new_name_()) () =
|
||||
let module Int3 = struct
|
||||
type value = int
|
||||
let name = name
|
||||
let n = get_then_add width_ 3
|
||||
let mask = 7 lsl n
|
||||
let width = 3
|
||||
let kind = Int
|
||||
let get x = (x land mask) lsr n
|
||||
let set v x =
|
||||
assert (x >= 0 && x < 8);
|
||||
let x = x land (lnot mask) in
|
||||
x lor (v lsl n)
|
||||
end in
|
||||
let f = (module Int3 : FIELD with type value = int) in
|
||||
register_ f;
|
||||
f
|
||||
|
||||
let int ?(name=new_name_()) ~width:w () =
|
||||
let module F = struct
|
||||
type value = int
|
||||
let n = get_then_add width_ w
|
||||
let mask_unshifted = all_bits_ 0 w
|
||||
let mask = mask_unshifted lsl n
|
||||
let kind = Int
|
||||
let name = name
|
||||
let width = w
|
||||
let get x = (x land mask) lsr n
|
||||
let set v x =
|
||||
assert (x >= 0 && x <= mask_unshifted);
|
||||
let x = x land (lnot mask) in
|
||||
x lor (v lsl n)
|
||||
end in
|
||||
let f = (module F : FIELD with type value = int) in
|
||||
register_ f;
|
||||
f
|
||||
let mk_field () =
|
||||
if !frozen_ then raise Frozen;
|
||||
let n = get_then_incr width_ in
|
||||
if n > max_width then raise TooManyFields;
|
||||
let mask = 1 lsl n in
|
||||
mask
|
||||
|
||||
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>";
|
||||
let first=ref true in
|
||||
Queue.iter
|
||||
(fun (AnyField ((module F), kind)) ->
|
||||
if !first then first := false else ppf out ",@ ";
|
||||
match kind with
|
||||
| Bool ->
|
||||
let b = F.get x in
|
||||
ppf out "%s=%b" F.name b
|
||||
| Int ->
|
||||
let i = F.get x in
|
||||
ppf out "%s=%u" F.name i
|
||||
) fields_;
|
||||
ppf out "@]}"
|
||||
end
|
||||
|
|
|
|||
|
|
@ -6,28 +6,22 @@
|
|||
up to 30 or 62 bits (depending on the architecture) in
|
||||
a relatively type-safe way.
|
||||
|
||||
{[
|
||||
module B = CCBitField.Make(struct end);;
|
||||
{[
|
||||
module B = CCBitField.Make(struct end);;
|
||||
|
||||
#install_printer B.pp;;
|
||||
#install_printer B.pp;;
|
||||
|
||||
module X = (val B.int ~name:"x" ~width:3 ());;
|
||||
module Y = (val B.int ~name:"y" ~width:2 ());;
|
||||
module Z = (val B.bool ~name:"z" ());;
|
||||
let x = B.mk_field ()
|
||||
let y = B.mk_field ()
|
||||
let z = B.mk_field ()
|
||||
|
||||
let f = B.empty |> X.set 3 |> Y.set 1;;
|
||||
let f = B.empty |> B.set x true |> B.set y true;;
|
||||
|
||||
Z.get f ;;
|
||||
assert (not (B.get z f)) ;;
|
||||
|
||||
f |> Z.set true |> Z.get ;;
|
||||
assert (f |> B.set z true |> B.get z);;
|
||||
|
||||
Format.printf "f: %a@." B.pp f;;
|
||||
|
||||
]}
|
||||
|
||||
{b status: experimental}
|
||||
|
||||
@since 0.13
|
||||
]}
|
||||
*)
|
||||
|
||||
exception TooManyFields
|
||||
|
|
@ -36,9 +30,6 @@ exception TooManyFields
|
|||
exception Frozen
|
||||
(** Raised when a frozen bitfield is modified *)
|
||||
|
||||
module type EMPTY = sig end
|
||||
(** Used for generativity on versions of OCaml older than 4.02 *)
|
||||
|
||||
val max_width : int
|
||||
(** System-dependent maximum width for a bitfield, typically 30 or 62 *)
|
||||
|
||||
|
|
@ -51,49 +42,16 @@ module type S = sig
|
|||
val empty : t
|
||||
(** Empty bitfields (all bits 0) *)
|
||||
|
||||
type _ field_kind =
|
||||
| Bool : bool field_kind
|
||||
| Int : int field_kind
|
||||
type field
|
||||
|
||||
(** Field of type [value], with a given width and position within the
|
||||
bitfield type *)
|
||||
module type FIELD = sig
|
||||
type value
|
||||
(** Values contained in the field *)
|
||||
val get : field -> t -> bool
|
||||
(** Get the value of this field *)
|
||||
|
||||
val get : t -> value
|
||||
val set : field -> bool -> t -> t
|
||||
(** Set the value of this field *)
|
||||
|
||||
val set : value -> t -> t
|
||||
|
||||
val width : int
|
||||
|
||||
val name : string
|
||||
|
||||
val kind : value field_kind
|
||||
end
|
||||
|
||||
type 'a field = (module FIELD with type value = 'a)
|
||||
|
||||
val bool : ?name:string -> unit -> bool field
|
||||
(** New field of type bool
|
||||
@raise Frozen if [freeze ()] was called
|
||||
@raise TooManyFields if there is no room *)
|
||||
|
||||
val int2 : ?name:string -> unit -> int field
|
||||
(** New field of type 2-bits int (same as [int ~width:2])
|
||||
@raise Frozen if [freeze ()] was called
|
||||
@raise TooManyFields if there is no room *)
|
||||
|
||||
val int3 : ?name:string -> unit -> int field
|
||||
(** New field of type 3-bits int (same as [int ~width:3])
|
||||
@raise Frozen if [freeze ()] was called
|
||||
@raise TooManyFields if there is no room *)
|
||||
|
||||
val int : ?name:string -> width:int -> unit -> int field
|
||||
(** New field for [width] bits.
|
||||
@raise Frozen if [freeze ()] was called
|
||||
@raise Invalid_argument if width is not [<= 1]
|
||||
@raise TooManyFields if there is no room *)
|
||||
val mk_field : unit -> field
|
||||
(** Make a new field *)
|
||||
|
||||
val freeze : unit -> unit
|
||||
(** Prevent new fields from being added. From now on, creating
|
||||
|
|
@ -101,55 +59,11 @@ module type S = sig
|
|||
|
||||
val total_width : unit -> int
|
||||
(** Current width of the bitfield *)
|
||||
|
||||
type any_field = AnyField : (module FIELD with type value = 'a) * 'a field_kind -> 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 *)
|
||||
module Make(X : EMPTY) : S
|
||||
|
||||
(*$R
|
||||
let module B = CCBitField.Make(struct end) in
|
||||
|
||||
let module X = (val B.bool ()) in
|
||||
let module Y = (val B.int2 ()) in
|
||||
let module Z = (val B.bool ()) in
|
||||
let module U = (val B.int ~width:4 ()) in
|
||||
|
||||
assert_equal 2 Y.width ;
|
||||
assert_equal 4 U.width ;
|
||||
|
||||
let f = B.empty
|
||||
|> Y.set 3
|
||||
|> Z.set true
|
||||
in
|
||||
|
||||
assert_equal 14 (f :> int) ;
|
||||
|
||||
assert_equal false (X.get f) ;
|
||||
assert_equal 3 (Y.get f) ;
|
||||
assert_equal true (Z.get f);
|
||||
|
||||
let f' = U.set 13 f in
|
||||
|
||||
assert_equal false (X.get f') ;
|
||||
assert_equal 3 (Y.get f') ;
|
||||
assert_equal true (Z.get f');
|
||||
assert_equal 13 (U.get f');
|
||||
|
||||
()
|
||||
*)
|
||||
|
||||
module Make(X : sig end) : S
|
||||
|
||||
(**/**)
|
||||
|
||||
val all_bits_ : int -> int -> int
|
||||
(** Undocumented, do not use. Exposed for testing purpose *)
|
||||
|
||||
(**/**)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue