*)
let debug = false
-(* A field when used in a bitmatch (a pattern). *)
-type fpatt = {
- fpatt : patt; (* field matching pattern *)
- fpc : fcommon;
-}
-(* A field when used in a BITSTRING constructor (an expression). *)
-and fexpr = {
- fexpr : expr; (* field value *)
- fec : fcommon;
-}
-
-and fcommon = {
+(* Work out if an expression is an integer constant.
+ *
+ * Returns [Some i] if so (where i is the integer value), else [None].
+ *
+ * Fairly simplistic algorithm: we can only detect simple constant
+ * expressions such as [k], [k+c], [k-c] etc.
+ *)
+let rec expr_is_constant = function
+ | <:expr< $int:i$ >> -> (* Literal integer constant. *)
+ Some (int_of_string i)
+ | <:expr< $a$ + $b$ >> -> (* Addition of constants. *)
+ (match expr_is_constant a, expr_is_constant b with
+ | Some a, Some b -> Some (a+b)
+ | _ -> None)
+ | <:expr< $a$ - $b$ >> -> (* Subtraction. *)
+ (match expr_is_constant a, expr_is_constant b with
+ | Some a, Some b -> Some (a-b)
+ | _ -> None)
+ | <:expr< $a$ * $b$ >> -> (* Multiplication. *)
+ (match expr_is_constant a, expr_is_constant b with
+ | Some a, Some b -> Some (a*b)
+ | _ -> None)
+ | <:expr< $a$ / $b$ >> -> (* Division. *)
+ (match expr_is_constant a, expr_is_constant b with
+ | Some a, Some b -> Some (a/b)
+ | _ -> None)
+ | <:expr< $a$ lsl $b$ >> -> (* Shift left. *)
+ (match expr_is_constant a, expr_is_constant b with
+ | Some a, Some b -> Some (a lsl b)
+ | _ -> None)
+ | <:expr< $a$ lsr $b$ >> -> (* Shift right. *)
+ (match expr_is_constant a, expr_is_constant b with
+ | Some a, Some b -> Some (a lsr b)
+ | _ -> None)
+ | _ -> None (* Anything else is not constant. *)
+
+(* Field. In bitmatch (patterns) the type is [patt field]. In
+ * BITSTRING (constructor) the type is [expr field].
+ *)
+type 'a field = {
+ field : 'a; (* field ('a is either patt or expr) *)
flen : expr; (* length in bits, may be non-const *)
- endian : endian; (* endianness *)
+ endian : Bitmatch.endian; (* endianness *)
signed : bool; (* true if signed, false if unsigned *)
t : t; (* type *)
_loc : Loc.t; (* location in source code *)
+ printer : 'a -> string; (* turn the field into a string *)
}
-and endian = BigEndian | LittleEndian | NativeEndian
and t = Int | String | Bitstring
(* Generate a fresh, unique symbol each time called. *)
incr i; let i = !i in
sprintf "__pabitmatch_%s_%d" name i
-let rec parse_patt_field _loc fpatt flen qs =
- let fpc = parse_field_common _loc flen qs in
- { fpatt = fpatt; fpc = fpc }
-
-and parse_constr_field _loc fexpr flen qs =
- let fec = parse_field_common _loc flen qs in
- { fexpr = fexpr; fec = fec }
-
(* Deal with the qualifiers which appear for a field of both types. *)
-and parse_field_common _loc flen qs =
+let parse_field _loc field flen qs printer =
let endian, signed, t =
match qs with
| None -> (None, None, None)
if endian <> None then
Loc.raise _loc (Failure "an endian flag has been set already")
else (
- let endian = Some BigEndian in
+ let endian = Some Bitmatch.BigEndian in
(endian, signed, t)
)
| "littleendian" ->
if endian <> None then
Loc.raise _loc (Failure "an endian flag has been set already")
else (
- let endian = Some LittleEndian in
+ let endian = Some Bitmatch.LittleEndian in
(endian, signed, t)
)
| "nativeendian" ->
if endian <> None then
Loc.raise _loc (Failure "an endian flag has been set already")
else (
- let endian = Some NativeEndian in
+ let endian = Some Bitmatch.NativeEndian in
(endian, signed, t)
)
| "signed" ->
);
(* Default endianness, signedness, type. *)
- let endian = match endian with None -> BigEndian | Some e -> e in
+ let endian = match endian with None -> Bitmatch.BigEndian | Some e -> e in
let signed = match signed with None -> false | Some s -> s in
let t = match t with None -> Int | Some t -> t in
{
+ field = field;
flen = flen;
endian = endian;
signed = signed;
t = t;
_loc = _loc;
+ printer = printer;
}
-let string_of_endian = function
- | BigEndian -> "bigendian"
- | LittleEndian -> "littleendian"
- | NativeEndian -> "nativeendian"
-
let string_of_t = function
| Int -> "int"
| String -> "string"
| Bitstring -> "bitstring"
-let rec string_of_patt_field { fpatt = fpatt; fpc = fpc } =
- let fpc = string_of_field_common fpc in
- let fpatt =
- match fpatt with
- | <:patt< $lid:id$ >> -> id
- | _ -> "[pattern]" in
- fpatt ^ " : " ^ fpc
-
-and string_of_constr_field { fexpr = fexpr; fec = fec } =
- let fec = string_of_field_common fec in
- let fexpr =
- match fexpr with
- | <:expr< $lid:id$ >> -> id
- | _ -> "[expression]" in
- fexpr ^ " : " ^ fec
-
-and string_of_field_common { flen = flen;
- endian = endian; signed = signed; t = t;
- _loc = _loc } =
+let patt_printer = function
+ | <:patt< $lid:id$ >> -> id
+ | _ -> "[pattern]"
+
+let expr_printer = function
+ | <:expr< $lid:id$ >> -> id
+ | _ -> "[expression]"
+
+let string_of_field { field = field; flen = flen;
+ endian = endian; signed = signed; t = t;
+ _loc = _loc;
+ printer = printer} =
let flen =
- match flen with
- | <:expr< $int:i$ >> -> i
- | _ -> "[non-const-len]" in
- let endian = string_of_endian endian in
+ match expr_is_constant flen with
+ | Some i -> string_of_int i
+ | None -> "[non-const-len]" in
+ let endian = Bitmatch.string_of_endian endian in
let signed = if signed then "signed" else "unsigned" in
let t = string_of_t t in
let loc_fname = Loc.file_name _loc in
let loc_line = Loc.start_line _loc in
let loc_char = Loc.start_off _loc - Loc.start_bol _loc in
- sprintf "%s : %s, %s, %s @ (%S, %d, %d)"
- flen t endian signed loc_fname loc_line loc_char
+ sprintf "%s : %s : %s, %s, %s @ (%S, %d, %d)"
+ (printer field) flen t endian signed loc_fname loc_line loc_char
(* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
let output_constructor _loc fields =
(* Convert each field to a simple bitstring-generating expression. *)
let fields = List.map (
- fun {fexpr=fexpr; fec={flen=flen; endian=endian; signed=signed;
- t=t; _loc=_loc}} ->
+ fun {field=fexpr; flen=flen; endian=endian; signed=signed;
+ t=t; _loc=_loc} ->
(* Is flen an integer constant? If so, what is it? This
* is very simple-minded and only detects simple constants.
*)
- let flen_is_const =
- match flen with
- | <:expr< $int:i$ >> -> Some (int_of_string i)
- | _ -> None in
+ let flen_is_const = expr_is_constant flen in
let name_of_int_construct_const = function
(* XXX As an enhancement we should allow a 64-bit-only
| (1, _, _) -> "construct_bit"
| ((2|3|4|5|6|7|8), _, false) -> "construct_char_unsigned"
| ((2|3|4|5|6|7|8), _, true) -> "construct_char_signed"
- | (i, BigEndian, false) when i <= 31 -> "construct_int_be_unsigned"
- | (i, BigEndian, true) when i <= 31 -> "construct_int_be_signed"
- | (i, LittleEndian, false) when i <= 31 -> "construct_int_le_unsigned"
- | (i, LittleEndian, true) when i <= 31 -> "construct_int_le_signed"
- | (i, NativeEndian, false) when i <= 31 -> "construct_int_ne_unsigned"
- | (i, NativeEndian, true) when i <= 31 -> "construct_int_ne_signed"
- | (32, BigEndian, false) -> "construct_int32_be_unsigned"
- | (32, BigEndian, true) -> "construct_int32_be_signed"
- | (32, LittleEndian, false) -> "construct_int32_le_unsigned"
- | (32, LittleEndian, true) -> "construct_int32_le_signed"
- | (32, NativeEndian, false) -> "construct_int32_ne_unsigned"
- | (32, NativeEndian, true) -> "construct_int32_ne_signed"
- | (_, BigEndian, false) -> "construct_int64_be_unsigned"
- | (_, BigEndian, true) -> "construct_int64_be_signed"
- | (_, LittleEndian, false) -> "construct_int64_le_unsigned"
- | (_, LittleEndian, true) -> "construct_int64_le_signed"
- | (_, NativeEndian, false) -> "construct_int64_ne_unsigned"
- | (_, NativeEndian, true) -> "construct_int64_ne_signed"
+ | (i, Bitmatch.BigEndian, false) when i <= 31 ->
+ "construct_int_be_unsigned"
+ | (i, Bitmatch.BigEndian, true) when i <= 31 ->
+ "construct_int_be_signed"
+ | (i, Bitmatch.LittleEndian, false) when i <= 31 ->
+ "construct_int_le_unsigned"
+ | (i, Bitmatch.LittleEndian, true) when i <= 31 ->
+ "construct_int_le_signed"
+ | (i, Bitmatch.NativeEndian, false) when i <= 31 ->
+ "construct_int_ne_unsigned"
+ | (i, Bitmatch.NativeEndian, true) when i <= 31 ->
+ "construct_int_ne_signed"
+ | (32, Bitmatch.BigEndian, false) -> "construct_int32_be_unsigned"
+ | (32, Bitmatch.BigEndian, true) -> "construct_int32_be_signed"
+ | (32, Bitmatch.LittleEndian, false) -> "construct_int32_le_unsigned"
+ | (32, Bitmatch.LittleEndian, true) -> "construct_int32_le_signed"
+ | (32, Bitmatch.NativeEndian, false) -> "construct_int32_ne_unsigned"
+ | (32, Bitmatch.NativeEndian, true) -> "construct_int32_ne_signed"
+ | (_, Bitmatch.BigEndian, false) -> "construct_int64_be_unsigned"
+ | (_, Bitmatch.BigEndian, true) -> "construct_int64_be_signed"
+ | (_, Bitmatch.LittleEndian, false) -> "construct_int64_le_unsigned"
+ | (_, Bitmatch.LittleEndian, true) -> "construct_int64_le_signed"
+ | (_, Bitmatch.NativeEndian, false) -> "construct_int64_ne_unsigned"
+ | (_, Bitmatch.NativeEndian, true) -> "construct_int64_ne_signed"
in
let name_of_int_construct = function
(* XXX As an enhancement we should allow users to
* specify that a field length can fit into a char/int/int32
* (of course, this would have to be checked at runtime).
*)
- | (BigEndian, false) -> "construct_int64_be_unsigned"
- | (BigEndian, true) -> "construct_int64_be_signed"
- | (LittleEndian, false) -> "construct_int64_le_unsigned"
- | (LittleEndian, true) -> "construct_int64_le_signed"
- | (NativeEndian, false) -> "construct_int64_ne_unsigned"
- | (NativeEndian, true) -> "construct_int64_ne_signed"
+ | (Bitmatch.BigEndian, false) -> "construct_int64_be_unsigned"
+ | (Bitmatch.BigEndian, true) -> "construct_int64_be_signed"
+ | (Bitmatch.LittleEndian, false) -> "construct_int64_le_unsigned"
+ | (Bitmatch.LittleEndian, true) -> "construct_int64_le_signed"
+ | (Bitmatch.NativeEndian, false) -> "construct_int64_ne_unsigned"
+ | (Bitmatch.NativeEndian, true) -> "construct_int64_ne_signed"
in
let expr =
let rec output_field_extraction inner = function
| [] -> inner
| field :: fields ->
- let {fpatt=fpatt; fpc={flen=flen; endian=endian; signed=signed;
- t=t; _loc=_loc}}
+ let {field=fpatt; flen=flen; endian=endian; signed=signed;
+ t=t; _loc=_loc}
= field in
(* Is flen an integer constant? If so, what is it? This
* is very simple-minded and only detects simple constants.
*)
- let flen_is_const =
- match flen with
- | <:expr< $int:i$ >> -> Some (int_of_string i)
- | _ -> None in
+ let flen_is_const = expr_is_constant flen in
let name_of_int_extract_const = function
(* XXX As an enhancement we should allow a 64-bit-only
| (1, _, _) -> "extract_bit"
| ((2|3|4|5|6|7|8), _, false) -> "extract_char_unsigned"
| ((2|3|4|5|6|7|8), _, true) -> "extract_char_signed"
- | (i, BigEndian, false) when i <= 31 -> "extract_int_be_unsigned"
- | (i, BigEndian, true) when i <= 31 -> "extract_int_be_signed"
- | (i, LittleEndian, false) when i <= 31 -> "extract_int_le_unsigned"
- | (i, LittleEndian, true) when i <= 31 -> "extract_int_le_signed"
- | (i, NativeEndian, false) when i <= 31 -> "extract_int_ne_unsigned"
- | (i, NativeEndian, true) when i <= 31 -> "extract_int_ne_signed"
- | (32, BigEndian, false) -> "extract_int32_be_unsigned"
- | (32, BigEndian, true) -> "extract_int32_be_signed"
- | (32, LittleEndian, false) -> "extract_int32_le_unsigned"
- | (32, LittleEndian, true) -> "extract_int32_le_signed"
- | (32, NativeEndian, false) -> "extract_int32_ne_unsigned"
- | (32, NativeEndian, true) -> "extract_int32_ne_signed"
- | (_, BigEndian, false) -> "extract_int64_be_unsigned"
- | (_, BigEndian, true) -> "extract_int64_be_signed"
- | (_, LittleEndian, false) -> "extract_int64_le_unsigned"
- | (_, LittleEndian, true) -> "extract_int64_le_signed"
- | (_, NativeEndian, false) -> "extract_int64_ne_unsigned"
- | (_, NativeEndian, true) -> "extract_int64_ne_signed"
+ | (i, Bitmatch.BigEndian, false) when i <= 31 ->
+ "extract_int_be_unsigned"
+ | (i, Bitmatch.BigEndian, true) when i <= 31 ->
+ "extract_int_be_signed"
+ | (i, Bitmatch.LittleEndian, false) when i <= 31 ->
+ "extract_int_le_unsigned"
+ | (i, Bitmatch.LittleEndian, true) when i <= 31 ->
+ "extract_int_le_signed"
+ | (i, Bitmatch.NativeEndian, false) when i <= 31 ->
+ "extract_int_ne_unsigned"
+ | (i, Bitmatch.NativeEndian, true) when i <= 31 ->
+ "extract_int_ne_signed"
+ | (32, Bitmatch.BigEndian, false) -> "extract_int32_be_unsigned"
+ | (32, Bitmatch.BigEndian, true) -> "extract_int32_be_signed"
+ | (32, Bitmatch.LittleEndian, false) -> "extract_int32_le_unsigned"
+ | (32, Bitmatch.LittleEndian, true) -> "extract_int32_le_signed"
+ | (32, Bitmatch.NativeEndian, false) -> "extract_int32_ne_unsigned"
+ | (32, Bitmatch.NativeEndian, true) -> "extract_int32_ne_signed"
+ | (_, Bitmatch.BigEndian, false) -> "extract_int64_be_unsigned"
+ | (_, Bitmatch.BigEndian, true) -> "extract_int64_be_signed"
+ | (_, Bitmatch.LittleEndian, false) -> "extract_int64_le_unsigned"
+ | (_, Bitmatch.LittleEndian, true) -> "extract_int64_le_signed"
+ | (_, Bitmatch.NativeEndian, false) -> "extract_int64_ne_unsigned"
+ | (_, Bitmatch.NativeEndian, true) -> "extract_int64_ne_signed"
in
let name_of_int_extract = function
(* XXX As an enhancement we should allow users to
* specify that a field length can fit into a char/int/int32
* (of course, this would have to be checked at runtime).
*)
- | (BigEndian, false) -> "extract_int64_be_unsigned"
- | (BigEndian, true) -> "extract_int64_be_signed"
- | (LittleEndian, false) -> "extract_int64_le_unsigned"
- | (LittleEndian, true) -> "extract_int64_le_signed"
- | (NativeEndian, false) -> "extract_int64_ne_unsigned"
- | (NativeEndian, true) -> "extract_int64_ne_signed"
+ | (Bitmatch.BigEndian, false) -> "extract_int64_be_unsigned"
+ | (Bitmatch.BigEndian, true) -> "extract_int64_be_signed"
+ | (Bitmatch.LittleEndian, false) -> "extract_int64_le_unsigned"
+ | (Bitmatch.LittleEndian, true) -> "extract_int64_le_signed"
+ | (Bitmatch.NativeEndian, false) -> "extract_int64_ne_unsigned"
+ | (Bitmatch.NativeEndian, true) -> "extract_int64_ne_signed"
in
let expr =
let ident =
match fpatt with
| <:patt< $lid:ident$ >> -> ident
+ | <:patt< _ >> -> "_"
| _ ->
Loc.raise _loc
(Failure "cannot compare a bitstring to a constant") in
let ident =
match fpatt with
| <:patt< $lid:ident$ >> -> ident
+ | <:patt< _ >> -> "_"
| _ ->
Loc.raise _loc
(Failure "cannot compare a bitstring to a constant") in
(* Emit extra debugging code. *)
let expr =
if not debug then expr else (
- let field = string_of_patt_field field in
+ let field = string_of_field field in
<:expr<
if !Bitmatch.debug then (
patt_field: [
[ fpatt = patt; ":"; len = expr LEVEL "top";
qs = OPT [ ":"; qs = qualifiers -> qs ] ->
- parse_patt_field _loc fpatt len qs
+ parse_field _loc fpatt len qs patt_printer
]
];
constr_field: [
[ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
qs = OPT [ ":"; qs = qualifiers -> qs ] ->
- parse_constr_field _loc fexpr len qs
+ parse_field _loc fexpr len qs expr_printer
]
];
git.annexia.org / ocaml-bitstring.git / blobdiff