mirror of
https://github.com/c-cube/ocaml-containers.git
synced 2025-12-06 11:15:31 -05:00
update CCBitField to use first-class modules
This commit is contained in:
Simon Cruanes
parent
25af289f96
commit
e90623aed7
2 changed files with 173 additions and 128 deletions
|
|
@ -17,21 +17,28 @@ module type S = sig
|
|||
val empty : t
|
||||
(** Empty bitfields (all bits 0) *)
|
||||
|
||||
type 'a field
|
||||
(** Field of type ['a], with a given width and position within the
|
||||
type _ field_kind =
|
||||
| Bool : bool field_kind
|
||||
| Int : int field_kind
|
||||
|
||||
(** 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 : 'a field -> t -> 'a
|
||||
(** Get a field of type ['a] *)
|
||||
val get : t -> value
|
||||
|
||||
val set : 'a field -> 'a -> t -> t
|
||||
(** Set a field of type ['a] *)
|
||||
val set : value -> t -> t
|
||||
|
||||
val width : _ field -> int
|
||||
(** Number of bits of the field *)
|
||||
val width : int
|
||||
|
||||
val name : _ field -> string
|
||||
(** Informal name of the field *)
|
||||
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
|
||||
|
|
@ -48,9 +55,10 @@ module type S = sig
|
|||
@raise Frozen if [freeze ()] was called
|
||||
@raise TooManyFields if there is no room *)
|
||||
|
||||
val int : ?name:string -> width:int -> int field
|
||||
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
|
||||
|
|
@ -60,7 +68,7 @@ module type S = sig
|
|||
val total_width : unit -> int
|
||||
(** Current width of the bitfield *)
|
||||
|
||||
type any_field = AnyField : 'a field -> any_field
|
||||
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 *)
|
||||
|
|
@ -82,6 +90,17 @@ let rec all_bits_ acc w =
|
|||
all_bits_ 0 4 = 15
|
||||
*)
|
||||
|
||||
(* increment and return previous value *)
|
||||
let get_then_incr n =
|
||||
let x = !n in
|
||||
incr n;
|
||||
x
|
||||
|
||||
let get_then_add n offset =
|
||||
let x = !n in
|
||||
n := !n + offset;
|
||||
x
|
||||
|
||||
module Make(X : EMPTY) : S = struct
|
||||
type t = int
|
||||
|
||||
|
|
@ -91,97 +110,110 @@ module Make(X : EMPTY) : S = struct
|
|||
| Bool : bool field_kind
|
||||
| Int : int field_kind
|
||||
|
||||
type 'a field = {
|
||||
kind : 'a field_kind;
|
||||
name : string;
|
||||
width : int;
|
||||
get : t -> 'a;
|
||||
set : 'a -> t -> t;
|
||||
}
|
||||
module type FIELD = sig
|
||||
type value
|
||||
(** Values contained in the field *)
|
||||
|
||||
type any_field = AnyField : 'a field -> any_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_ 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 make_field f =
|
||||
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;
|
||||
register_ f;
|
||||
f
|
||||
let (module F) = f in
|
||||
Queue.push (AnyField (f, F.kind)) fields_
|
||||
|
||||
let new_name_ () =
|
||||
"field_" ^ string_of_int (Queue.length fields_)
|
||||
|
||||
let bool ?(name=new_name_()) () =
|
||||
let n = !width_ in
|
||||
incr width_;
|
||||
let mask = 1 lsl n in
|
||||
make_field {
|
||||
kind = Bool;
|
||||
name;
|
||||
width=1;
|
||||
get=(fun x -> (x land mask) <> 0);
|
||||
set=(fun b x ->
|
||||
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 n = !width_ in
|
||||
width_ := n+2;
|
||||
let mask = 3 lsl n in
|
||||
make_field {
|
||||
kind = Int;
|
||||
name;
|
||||
width=2;
|
||||
get=(fun x -> (x land mask) lsr n);
|
||||
set=(fun v x ->
|
||||
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 n = !width_ in
|
||||
width_ := n+3;
|
||||
let mask = 7 lsl n in
|
||||
make_field {
|
||||
kind = Int;
|
||||
name;
|
||||
width=3;
|
||||
get=(fun x -> (x land mask) lsr n);
|
||||
set=(fun v x ->
|
||||
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 n = !width_ in
|
||||
width_ := n+w;
|
||||
let mask_unshifted = all_bits_ 0 w in
|
||||
let mask = mask_unshifted lsl n in
|
||||
make_field {
|
||||
kind = Int;
|
||||
name;
|
||||
width=w;
|
||||
get=(fun x -> (x land mask) lsr n);
|
||||
set=(fun v x ->
|
||||
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
|
||||
|
||||
|
|
@ -194,15 +226,15 @@ module Make(X : EMPTY) : S = struct
|
|||
ppf out "{@[<hv>";
|
||||
let first=ref true in
|
||||
Queue.iter
|
||||
(fun (AnyField f) ->
|
||||
(fun (AnyField ((module F), kind)) ->
|
||||
if !first then first := false else ppf out ",@ ";
|
||||
match f.kind with
|
||||
match kind with
|
||||
| Bool ->
|
||||
let b = get f x in
|
||||
ppf out "%s=%b" f.name b
|
||||
let b = F.get x in
|
||||
ppf out "%s=%b" F.name b
|
||||
| Int ->
|
||||
let i = get f x in
|
||||
ppf out "%s=%u" f.name i
|
||||
let i = F.get x in
|
||||
ppf out "%s=%u" F.name i
|
||||
) fields_;
|
||||
ppf out "@]}"
|
||||
end
|
||||
|
|
|
|||
|
|
@ -11,20 +11,24 @@ module B = CCBitField.Make(struct end);;
|
|||
|
||||
#install_printer B.pp;;
|
||||
|
||||
let x = B.int ~name:"x" ~width:3;;
|
||||
let y = B.int ~name:"y" ~width:2;;
|
||||
let z = B.bool ~name:"z" ();;
|
||||
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 f = B.(empty |> set x 3 |> set y 1);;
|
||||
let f = B.empty |> X.set 3 |> Y.set 1;;
|
||||
|
||||
B.get z f ;;
|
||||
Z.get f ;;
|
||||
|
||||
B.(f |> set z true |> get z) ;;
|
||||
f |> Z.set true |> Z.get ;;
|
||||
|
||||
Format.printf "f: %a@." B.pp f;;
|
||||
|
||||
]}
|
||||
|
||||
{b status: experimental}
|
||||
@since NEXT_RELEASE *)
|
||||
{b status: experimental}
|
||||
|
||||
@since NEXT_RELEASE
|
||||
*)
|
||||
|
||||
exception TooManyFields
|
||||
(** Raised when too many fields are packed into one bitfield *)
|
||||
|
|
@ -33,9 +37,10 @@ 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 *)
|
||||
(** System-dependent maximum width for a bitfield, typically 30 or 62 *)
|
||||
|
||||
(** {2 Bitfield Signature} *)
|
||||
module type S = sig
|
||||
|
|
@ -46,21 +51,28 @@ module type S = sig
|
|||
val empty : t
|
||||
(** Empty bitfields (all bits 0) *)
|
||||
|
||||
type 'a field
|
||||
(** Field of type ['a], with a given width and position within the
|
||||
type _ field_kind =
|
||||
| Bool : bool field_kind
|
||||
| Int : int field_kind
|
||||
|
||||
(** 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 : 'a field -> t -> 'a
|
||||
(** Get a field of type ['a] *)
|
||||
val get : t -> value
|
||||
|
||||
val set : 'a field -> 'a -> t -> t
|
||||
(** Set a field of type ['a] *)
|
||||
val set : value -> t -> t
|
||||
|
||||
val width : _ field -> int
|
||||
(** Number of bits of the field *)
|
||||
val width : int
|
||||
|
||||
val name : _ field -> string
|
||||
(** Informal name of the field *)
|
||||
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
|
||||
|
|
@ -77,9 +89,10 @@ module type S = sig
|
|||
@raise Frozen if [freeze ()] was called
|
||||
@raise TooManyFields if there is no room *)
|
||||
|
||||
val int : ?name:string -> width:int -> int field
|
||||
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
|
||||
|
|
@ -89,7 +102,7 @@ module type S = sig
|
|||
val total_width : unit -> int
|
||||
(** Current width of the bitfield *)
|
||||
|
||||
type any_field = AnyField : 'a field -> any_field
|
||||
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 *)
|
||||
|
|
@ -104,31 +117,31 @@ module Make(X : EMPTY) : S
|
|||
(*$R
|
||||
let module B = CCBitField.Make(struct end) in
|
||||
|
||||
let x = B.bool () in
|
||||
let y = B.int2 () in
|
||||
let z = B.bool () in
|
||||
let u = B.int 4 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 (B.width y) ;
|
||||
assert_equal 4 (B.width u) ;
|
||||
assert_equal 2 Y.width ;
|
||||
assert_equal 4 U.width ;
|
||||
|
||||
let f = B.empty
|
||||
|> B.set y 3
|
||||
|> B.set z true
|
||||
|> Y.set 3
|
||||
|> Z.set true
|
||||
in
|
||||
|
||||
assert_equal 14 (f :> int) ;
|
||||
|
||||
assert_equal false (B.get x f) ;
|
||||
assert_equal 3 (B.get y f) ;
|
||||
assert_equal true (B.get z f);
|
||||
assert_equal false (X.get f) ;
|
||||
assert_equal 3 (Y.get f) ;
|
||||
assert_equal true (Z.get f);
|
||||
|
||||
let f' = B.set u 13 f in
|
||||
let f' = U.set 13 f in
|
||||
|
||||
assert_equal false (B.get x f') ;
|
||||
assert_equal 3 (B.get y f') ;
|
||||
assert_equal true (B.get z f');
|
||||
assert_equal 13 (B.get u f');
|
||||
assert_equal false (X.get f') ;
|
||||
assert_equal 3 (Y.get f') ;
|
||||
assert_equal true (Z.get f');
|
||||
assert_equal 13 (U.get f');
|
||||
|
||||
()
|
||||
*)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue