From e90623aed74a64aa2f69ca6ea30e2a33e9851408 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 24 Aug 2015 16:00:53 +0200 Subject: [PATCH] update `CCBitField` to use first-class modules --- src/data/CCBitField.ml | 214 +++++++++++++++++++++++----------------- src/data/CCBitField.mli | 87 +++++++++------- 2 files changed, 173 insertions(+), 128 deletions(-) diff --git a/src/data/CCBitField.ml b/src/data/CCBitField.ml index a063e397..06475dd1 100644 --- a/src/data/CCBitField.ml +++ b/src/data/CCBitField.ml @@ -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 = - if !width_ > max_width then raise TooManyFields; - if !frozen_ then raise Frozen; - register_ f; - 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; + 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 -> - assert (x >= 0 && x < 8); - let x = x land (lnot mask) in - x lor (v lsl n) - ) - } + 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 -> - assert (x >= 0 && x <= mask_unshifted); - let x = x land (lnot mask) in - x lor (v lsl n) - ) - } + 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 "{@["; 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 diff --git a/src/data/CCBitField.mli b/src/data/CCBitField.mli index 0d7173a4..00734489 100644 --- a/src/data/CCBitField.mli +++ b/src/data/CCBitField.mli @@ -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'); () *)