simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2025-12-06 19:25:28 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

rewrite CCBitField with a much simpler interface

Browse source
This commit is contained in:
Simon Cruanes 2016-11-03 21:32:00 +01:00
parent 4f6bce60e5
commit 5a1a88d3f5
2 changed files with 89 additions and 280 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

253
src/data/CCBitField.ml
View file

@ -7,7 +7,58 @@ exception Frozen
let max_width = Sys.word_size - 2 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 module type S = sig
type t = private int type t = private int
@ -17,49 +68,16 @@ module type S = sig
val empty : t val empty : t
(** Empty bitfields (all bits 0) *) (** Empty bitfields (all bits 0) *)
type _ field_kind = type field
| Bool : bool field_kind
| Int : int field_kind
(** Field of type [value], with a given width and position within the val get : field -> t -> bool
bitfield type *) (** Get the value of this field *)
module type FIELD = sig
type value
(** Values contained in the field *)
val get : t -> value val set : field -> bool -> t -> t
(** Set the value of this field *)
val set : value -> t -> t val mk_field : unit -> field
(** Make a new field *)
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 freeze : unit -> unit val freeze : unit -> unit
(** Prevent new fields from being added. From now on, creating (** Prevent new fields from being added. From now on, creating
@ -67,16 +85,9 @@ module type S = sig
val total_width : unit -> int val total_width : unit -> int
(** Current width of the bitfield *) (** 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 end
(* all bits from 0 to w-1 set to true *)
let rec all_bits_ acc w = let rec all_bits_ acc w =
if w=0 then acc if w=0 then acc
else else
@ -96,145 +107,29 @@ let get_then_incr n =
incr n; incr n;
x x
let get_then_add n offset = module Make(X : sig end) : S = struct
let x = !n in
n := !n + offset;
x
module Make(X : EMPTY) : S = struct
type t = int type t = int
let empty = 0 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 width_ = ref 0
let frozen_ = ref false let frozen_ = ref false
let fields_ = Queue.create()
let register_ type field = int (* a mask *)
: type a. (module FIELD with type value = a) -> unit
= fun f -> let get field x = (x land field) <> 0
if !width_ > max_width then raise TooManyFields;
let set field b x =
if b then x lor field else x land (lnot field)
let mk_field () =
if !frozen_ then raise Frozen; if !frozen_ then raise Frozen;
let (module F) = f in let n = get_then_incr width_ in
Queue.push (AnyField (f, F.kind)) fields_ if n > max_width then raise TooManyFields;
let mask = 1 lsl n in
let new_name_ () = mask
"field_" ^ string_of_int (Queue.length fields_)
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 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 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 freeze () = frozen_ := true let freeze () = frozen_ := true
let total_width () = !width_ 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 end

114
src/data/CCBitField.mli
View file

@ -11,23 +11,17 @@ module B = CCBitField.Make(struct end);;
#install_printer B.pp;; #install_printer B.pp;;
module X = (val B.int ~name:"x" ~width:3 ());; let x = B.mk_field ()
module Y = (val B.int ~name:"y" ~width:2 ());; let y = B.mk_field ()
module Z = (val B.bool ~name:"z" ());; 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 exception TooManyFields
@ -36,9 +30,6 @@ exception TooManyFields
exception Frozen exception Frozen
(** Raised when a frozen bitfield is modified *) (** 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 val max_width : int
(** System-dependent maximum width for a bitfield, typically 30 or 62 *) (** System-dependent maximum width for a bitfield, typically 30 or 62 *)
@ -51,49 +42,16 @@ module type S = sig
val empty : t val empty : t
(** Empty bitfields (all bits 0) *) (** Empty bitfields (all bits 0) *)
type _ field_kind = type field
| Bool : bool field_kind
| Int : int field_kind
(** Field of type [value], with a given width and position within the val get : field -> t -> bool
bitfield type *) (** Get the value of this field *)
module type FIELD = sig
type value
(** Values contained in the field *)
val get : t -> value val set : field -> bool -> t -> t
(** Set the value of this field *)
val set : value -> t -> t val mk_field : unit -> field
(** Make a new field *)
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 freeze : unit -> unit val freeze : unit -> unit
(** Prevent new fields from being added. From now on, creating (** Prevent new fields from being added. From now on, creating
@ -101,55 +59,11 @@ module type S = sig
val total_width : unit -> int val total_width : unit -> int
(** Current width of the bitfield *) (** 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 end
(** Create a new bitfield type *) (** Create a new bitfield type *)
module Make(X : EMPTY) : S module Make(X : sig end) : 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');
()
*)
(**/**) (**/**)
val all_bits_ : int -> int -> int val all_bits_ : int -> int -> int
(** Undocumented, do not use. Exposed for testing purpose *)
(**/**) (**/**)