(* Hashtable storing named persistent patterns. *)
let pattern_hash : (string, P.pattern) Hashtbl.t = Hashtbl.create 13
+let locfail _loc msg = Loc.raise _loc (Failure msg)
+
(* Work out if an expression is an integer constant.
*
* Returns [Some i] if so (where i is the integer value), else [None].
* expressions such as [k], [k+c], [k-c] etc.
*)
let rec expr_is_constant = function
- | <:expr< $int:i$ >> -> (* Literal integer constant. *)
+ | <: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. *)
+ | <:expr< $lid:op$ $a$ $b$ >> ->
(match expr_is_constant a, expr_is_constant b with
- | Some a, Some b -> Some (a lsl b)
+ | Some a, Some b -> (* Integer binary operations. *)
+ let ops = ["+", (+); "-", (-); "*", ( * ); "/", (/);
+ "land", (land); "lor", (lor); "lxor", (lxor);
+ "lsl", (lsl); "lsr", (lsr); "asr", (asr);
+ "mod", (mod)] in
+ (try Some ((List.assoc op ops) a b) with Not_found -> None)
| _ -> 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. *)
+ | _ -> None
(* Generate a fresh, unique symbol each time called. *)
let gensym =
(* Deal with the qualifiers which appear for a field of both types. *)
let parse_field _loc field qs =
- let endian_set, signed_set, type_set, field =
+ let fail = locfail _loc in
+
+ let endian_set, signed_set, type_set, offset_set, field =
match qs with
- | None -> (false, false, false, field)
+ | None -> (false, false, false, false, field)
| Some qs ->
- List.fold_left (
- fun (endian_set, signed_set, type_set, field) qual_expr ->
- match qual_expr with
- | "bigendian", None ->
- if endian_set then
- Loc.raise _loc (Failure "an endian flag has been set already")
- else (
- let field = P.set_endian field BigEndian in
- (true, signed_set, type_set, field)
- )
- | "littleendian", None ->
- if endian_set then
- Loc.raise _loc (Failure "an endian flag has been set already")
- else (
- let field = P.set_endian field LittleEndian in
- (true, signed_set, type_set, field)
- )
- | "nativeendian", None ->
- if endian_set then
- Loc.raise _loc (Failure "an endian flag has been set already")
- else (
- let field = P.set_endian field NativeEndian in
- (true, signed_set, type_set, field)
- )
- | "endian", Some expr ->
- if endian_set then
- Loc.raise _loc (Failure "an endian flag has been set already")
- else (
- let field = P.set_endian_expr field expr in
- (true, signed_set, type_set, field)
- )
- | "signed", None ->
- if signed_set then
- Loc.raise _loc (Failure "a signed flag has been set already")
- else (
- let field = P.set_signed field true in
- (endian_set, true, type_set, field)
- )
- | "unsigned", None ->
- if signed_set then
- Loc.raise _loc (Failure "a signed flag has been set already")
- else (
- let field = P.set_signed field false in
- (endian_set, true, type_set, field)
- )
- | "int", None ->
- if type_set then
- Loc.raise _loc (Failure "a type flag has been set already")
- else (
- let field = P.set_type_int field in
- (endian_set, signed_set, true, field)
- )
- | "string", None ->
- if type_set then
- Loc.raise _loc (Failure "a type flag has been set already")
- else (
- let field = P.set_type_string field in
- (endian_set, signed_set, true, field)
- )
- | "bitstring", None ->
- if type_set then
- Loc.raise _loc (Failure "a type flag has been set already")
- else (
- let field = P.set_type_bitstring field in
- (endian_set, signed_set, true, field)
- )
- | s, Some _ ->
- Loc.raise _loc (Failure (s ^ ": unknown qualifier, or qualifier should not be followed by an expression"))
- | s, None ->
- Loc.raise _loc (Failure (s ^ ": unknown qualifier, or qualifier should be followed by an expression"))
- ) (false, false, false, field) qs in
+ let check already_set msg = if already_set then fail msg in
+ let apply_qualifier
+ (endian_set, signed_set, type_set, offset_set, field) =
+ function
+ | "endian", Some expr ->
+ check endian_set "an endian flag has been set already";
+ let field = P.set_endian_expr field expr in
+ (true, signed_set, type_set, offset_set, field)
+ | "endian", None ->
+ fail "qualifier 'endian' should be followed by an expression"
+ | "offset", Some expr ->
+ check offset_set "an offset has been set already";
+ let field = P.set_offset field expr in
+ (endian_set, signed_set, type_set, true, field)
+ | "offset", None ->
+ fail "qualifier 'offset' should be followed by an expression"
+ | s, Some _ ->
+ fail (s ^ ": unknown qualifier, or qualifier should not be followed by an expression")
+ | qual, None ->
+ let endian_quals = ["bigendian", BigEndian;
+ "littleendian", LittleEndian;
+ "nativeendian", NativeEndian] in
+ let sign_quals = ["signed", true; "unsigned", false] in
+ let type_quals = ["int", P.set_type_int;
+ "string", P.set_type_string;
+ "bitstring", P.set_type_bitstring] in
+ if List.mem_assoc qual endian_quals then (
+ check endian_set "an endian flag has been set already";
+ let field = P.set_endian field (List.assoc qual endian_quals) in
+ (true, signed_set, type_set, offset_set, field)
+ ) else if List.mem_assoc qual sign_quals then (
+ check signed_set "a signed flag has been set already";
+ let field = P.set_signed field (List.assoc qual sign_quals) in
+ (endian_set, true, type_set, offset_set, field)
+ ) else if List.mem_assoc qual type_quals then (
+ check type_set "a type flag has been set already";
+ let field = List.assoc qual type_quals field in
+ (endian_set, signed_set, true, offset_set, field)
+ ) else
+ fail (qual ^ ": unknown qualifier, or qualifier should be followed by an expression") in
+ List.fold_left apply_qualifier (false, false, false, false, field) qs in
(* If type is set to string or bitstring then endianness and
* signedness qualifiers are meaningless and must not be set.
let () =
let t = P.get_type field in
if (t = P.Bitstring || t = P.String) && (endian_set || signed_set) then
- Loc.raise _loc (
- Failure "string types and endian or signed qualifiers cannot be mixed"
- ) in
+ fail "string types and endian or signed qualifiers cannot be mixed" in
(* Default endianness, signedness, type if not set already. *)
let field = if endian_set then field else P.set_endian field BigEndian in
field
+(* Choose the right constructor function. *)
+let build_bitmatch_call _loc funcname length endian signed =
+ match length, endian, signed with
+ (* XXX The meaning of signed/unsigned breaks down at
+ * 31, 32, 63 and 64 bits.
+ *)
+ | (Some 1, _, _) -> <:expr<Bitmatch.$lid:funcname ^ "_bit"$ >>
+ | (Some (2|3|4|5|6|7|8), _, sign) ->
+ let call = Printf.sprintf "%s_char_%s"
+ funcname (if sign then "signed" else "unsigned") in
+ <:expr< Bitmatch.$lid:call$ >>
+ | (len, endian, signed) ->
+ let t = match len with
+ | Some i when i <= 31 -> "int"
+ | Some 32 -> "int32"
+ | _ -> "int64" in
+ let sign = if signed then "signed" else "unsigned" in
+ match endian with
+ | P.ConstantEndian constant ->
+ let endianness = match constant with
+ | BigEndian -> "be"
+ | LittleEndian -> "le"
+ | NativeEndian -> "ne" in
+ let call = Printf.sprintf "%s_%s_%s_%s"
+ funcname t endianness sign in
+ <:expr< Bitmatch.$lid:call$ >>
+ | P.EndianExpr expr ->
+ let call = Printf.sprintf "%s_%s_%s_%s"
+ funcname t "ee" sign in
+ <:expr< Bitmatch.$lid:call$ $expr$ >>
+
(* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
let output_constructor _loc fields =
- let loc_fname = Loc.file_name _loc in
- let loc_line = string_of_int (Loc.start_line _loc) in
- let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
+ (* This function makes code to raise a Bitmatch.Construct_failure exception
+ * containing a message and the current _loc context.
+ * (Thanks to Bluestorm for suggesting this).
+ *)
+ let construct_failure _loc msg =
+ <:expr<
+ Bitmatch.Construct_failure
+ ($`str:msg$,
+ $`str:Loc.file_name _loc$,
+ $`int:Loc.start_line _loc$,
+ $`int:Loc.start_off _loc - Loc.start_bol _loc$)
+ >>
+ in
+ let raise_construct_failure _loc msg =
+ <:expr< raise $construct_failure _loc msg$ >>
+ in
(* Bitstrings are created like the 'Buffer' module (in fact, using
* the Buffer module), by appending snippets to a growing buffer.
let signed = P.get_signed field in
let t = P.get_type field in
let _loc = P.get_location field in
+ let offset = P.get_offset field in
+
+ let fail = locfail _loc in
+
+ (* offset() not supported in constructors. Implementation of
+ * forward-only offsets is fairly straightforward: we would
+ * need to just calculate the length of padding here and add
+ * it to what has been constructed. For general offsets,
+ * including going backwards, that would require a rethink in
+ * how we construct bitstrings.
+ *)
+ if offset <> None then
+ fail "offset expressions are not supported in BITSTRING constructors";
(* Is flen an integer constant? If so, what is it? This
* is very simple-minded and only detects simple constants.
*)
let flen_is_const = expr_is_constant flen in
- (* Choose the right constructor function. *)
- let int_construct_const = function
- (* XXX The meaning of signed/unsigned breaks down at
- * 31, 32, 63 and 64 bits.
- *)
- | (1, _, _) ->
- <:expr<Bitmatch.construct_bit>>
- | ((2|3|4|5|6|7|8), _, false) ->
- <:expr<Bitmatch.construct_char_unsigned>>
- | ((2|3|4|5|6|7|8), _, true) ->
- <:expr<Bitmatch.construct_char_signed>>
- | (i, P.ConstantEndian BigEndian, false) when i <= 31 ->
- <:expr<Bitmatch.construct_int_be_unsigned>>
- | (i, P.ConstantEndian BigEndian, true) when i <= 31 ->
- <:expr<Bitmatch.construct_int_be_signed>>
- | (i, P.ConstantEndian LittleEndian, false) when i <= 31 ->
- <:expr<Bitmatch.construct_int_le_unsigned>>
- | (i, P.ConstantEndian LittleEndian, true) when i <= 31 ->
- <:expr<Bitmatch.construct_int_le_signed>>
- | (i, P.ConstantEndian NativeEndian, false) when i <= 31 ->
- <:expr<Bitmatch.construct_int_ne_unsigned>>
- | (i, P.ConstantEndian NativeEndian, true) when i <= 31 ->
- <:expr<Bitmatch.construct_int_ne_signed>>
- | (i, P.EndianExpr expr, false) when i <= 31 ->
- <:expr<Bitmatch.construct_int_ee_unsigned $expr$>>
- | (i, P.EndianExpr expr, true) when i <= 31 ->
- <:expr<Bitmatch.construct_int_ee_signed $expr$>>
- | (32, P.ConstantEndian BigEndian, false) ->
- <:expr<Bitmatch.construct_int32_be_unsigned>>
- | (32, P.ConstantEndian BigEndian, true) ->
- <:expr<Bitmatch.construct_int32_be_signed>>
- | (32, P.ConstantEndian LittleEndian, false) ->
- <:expr<Bitmatch.construct_int32_le_unsigned>>
- | (32, P.ConstantEndian LittleEndian, true) ->
- <:expr<Bitmatch.construct_int32_le_signed>>
- | (32, P.ConstantEndian NativeEndian, false) ->
- <:expr<Bitmatch.construct_int32_ne_unsigned>>
- | (32, P.ConstantEndian NativeEndian, true) ->
- <:expr<Bitmatch.construct_int32_ne_signed>>
- | (32, P.EndianExpr expr, false) ->
- <:expr<Bitmatch.construct_int32_ee_unsigned $expr$>>
- | (32, P.EndianExpr expr, true) ->
- <:expr<Bitmatch.construct_int32_ee_signed $expr$>>
- | (_, P.ConstantEndian BigEndian, false) ->
- <:expr<Bitmatch.construct_int64_be_unsigned>>
- | (_, P.ConstantEndian BigEndian, true) ->
- <:expr<Bitmatch.construct_int64_be_signed>>
- | (_, P.ConstantEndian LittleEndian, false) ->
- <:expr<Bitmatch.construct_int64_le_unsigned>>
- | (_, P.ConstantEndian LittleEndian, true) ->
- <:expr<Bitmatch.construct_int64_le_signed>>
- | (_, P.ConstantEndian NativeEndian, false) ->
- <:expr<Bitmatch.construct_int64_ne_unsigned>>
- | (_, P.ConstantEndian NativeEndian, true) ->
- <:expr<Bitmatch.construct_int64_ne_signed>>
- | (_, P.EndianExpr expr, false) ->
- <:expr<Bitmatch.construct_int64_ee_unsigned $expr$>>
- | (_, P.EndianExpr expr, true) ->
- <:expr<Bitmatch.construct_int64_ee_signed $expr$>>
- in
- let int_construct = function
- | (P.ConstantEndian BigEndian, false) ->
- <:expr<Bitmatch.construct_int64_be_unsigned>>
- | (P.ConstantEndian BigEndian, true) ->
- <:expr<Bitmatch.construct_int64_be_signed>>
- | (P.ConstantEndian LittleEndian, false) ->
- <:expr<Bitmatch.construct_int64_le_unsigned>>
- | (P.ConstantEndian LittleEndian, true) ->
- <:expr<Bitmatch.construct_int64_le_signed>>
- | (P.ConstantEndian NativeEndian, false) ->
- <:expr<Bitmatch.construct_int64_ne_unsigned>>
- | (P.ConstantEndian NativeEndian, true) ->
- <:expr<Bitmatch.construct_int64_ne_signed>>
- | (P.EndianExpr expr, false) ->
- <:expr<Bitmatch.construct_int64_ee_unsigned $expr$>>
- | (P.EndianExpr expr, true) ->
- <:expr<Bitmatch.construct_int64_ee_signed $expr$>>
- in
+ let int_construct_const (i, endian, signed) =
+ build_bitmatch_call _loc "construct" (Some i) endian signed in
+ let int_construct (endian, signed) =
+ build_bitmatch_call _loc "construct" None endian signed in
let expr =
match t, flen_is_const with
>>
| P.Int, Some _ ->
- Loc.raise _loc (Failure "length of int field must be [1..64]")
+ fail "length of int field must be [1..64]"
(* Int field, non-constant length. We need to perform a runtime
* test to ensure the length is [1..64].
if $flen$ >= 1 && $flen$ <= 64 then
$construct_fn$ $lid:buffer$ $fexpr$ $flen$ $lid:exn$
else
- raise (Bitmatch.Construct_failure
- ("length of int field must be [1..64]",
- $str:loc_fname$,
- $int:loc_line$, $int:loc_char$))
+ $raise_construct_failure _loc "length of int field must be [1..64]"$
>>
(* String, constant length > 0, must be a multiple of 8. *)
if String.length $lid:bs$ = $`int:j$ then
Bitmatch.construct_string $lid:buffer$ $lid:bs$
else
- raise (Bitmatch.Construct_failure
- ("length of string does not match declaration",
- $str:loc_fname$,
- $int:loc_line$, $int:loc_char$))
+ $raise_construct_failure _loc "length of string does not match declaration"$
>>
(* String, constant length -1, means variable length string
* any other value.
*)
| P.String, Some _ ->
- Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
+ fail "length of string must be > 0 and a multiple of 8, or the special value -1"
(* String, non-constant length.
* We check at runtime that the length is > 0, a multiple of 8,
if String.length $lid:bs$ = ($lid:bslen$ lsr 3) then
Bitmatch.construct_string $lid:buffer$ $lid:bs$
else
- raise (Bitmatch.Construct_failure
- ("length of string does not match declaration",
- $str:loc_fname$,
- $int:loc_line$, $int:loc_char$))
+ $raise_construct_failure _loc "length of string does not match declaration"$
) else
- raise (Bitmatch.Construct_failure
- ("length of string must be a multiple of 8",
- $str:loc_fname$,
- $int:loc_line$, $int:loc_char$))
+ $raise_construct_failure _loc "length of string must be a multiple of 8"$
) else
- raise (Bitmatch.Construct_failure
- ("length of string must be > 0",
- $str:loc_fname$,
- $int:loc_line$, $int:loc_char$))
+ $raise_construct_failure _loc "length of string must be > 0"$
>>
- (* Bitstring, constant length > 0. *)
- | P.Bitstring, Some i when i > 0 ->
+ (* Bitstring, constant length >= 0. *)
+ | P.Bitstring, Some i when i >= 0 ->
let bs = gensym "bs" in
<:expr<
let $lid:bs$ = $fexpr$ in
if Bitmatch.bitstring_length $lid:bs$ = $`int:i$ then
Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
else
- raise (Bitmatch.Construct_failure
- ("length of bitstring does not match declaration",
- $str:loc_fname$,
- $int:loc_line$, $int:loc_char$))
+ $raise_construct_failure _loc "length of bitstring does not match declaration"$
>>
(* Bitstring, constant length -1, means variable length bitstring
| P.Bitstring, Some (-1) ->
<:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >>
- (* Bitstring, constant length = 0 is probably an error, and so is
- * any other value.
- *)
+ (* Bitstring, constant length < -1 is an error. *)
| P.Bitstring, Some _ ->
- Loc.raise _loc
- (Failure
- "length of bitstring must be > 0 or the special value -1")
+ fail "length of bitstring must be >= 0 or the special value -1"
(* Bitstring, non-constant length.
- * We check at runtime that the length is > 0 and matches
+ * We check at runtime that the length is >= 0 and matches
* the declared length.
*)
| P.Bitstring, None ->
let bs = gensym "bs" in
<:expr<
let $lid:bslen$ = $flen$ in
- if $lid:bslen$ > 0 then (
+ if $lid:bslen$ >= 0 then (
let $lid:bs$ = $fexpr$ in
if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ then
Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
else
- raise (Bitmatch.Construct_failure
- ("length of bitstring does not match declaration",
- $str:loc_fname$,
- $int:loc_line$, $int:loc_char$))
+ $raise_construct_failure _loc "length of bitstring does not match declaration"$
) else
- raise (Bitmatch.Construct_failure
- ("length of bitstring must be > 0",
- $str:loc_fname$,
- $int:loc_line$, $int:loc_char$))
+ $raise_construct_failure _loc "length of bitstring must be > 0"$
>> in
expr
) fields in
if !exn_used then
<:expr<
- let $lid:exn$ =
- Bitmatch.Construct_failure ("value out of range",
- $str:loc_fname$,
- $int:loc_line$, $int:loc_char$) in
- $expr$
+ let $lid:exn$ = $construct_failure _loc "value out of range"$ in
+ $expr$
>>
else
expr
let result = gensym "result" in
(* This generates the field extraction code for each
- * field a single case. Each field must be wider than
- * the minimum permitted for the type and there must be
- * enough remaining data in the bitstring to satisfy it.
+ * field in a single case. There must be enough remaining data
+ * in the bitstring to satisfy the field.
+ *
* As we go through the fields, symbols 'data', 'off' and 'len'
* track our position and remaining length in the bitstring.
*
let signed = P.get_signed field in
let t = P.get_type field in
let _loc = P.get_location field in
+ let offset = P.get_offset field in
+
+ let fail = locfail _loc in
- (* Is flen an integer constant? If so, what is it? This
- * is very simple-minded and only detects simple constants.
+ (* Is flen (field len) an integer constant? If so, what is it?
+ * This will be [Some i] if it's a constant or [None] if it's
+ * non-constant or we couldn't determine.
*)
let flen_is_const = expr_is_constant flen in
- let int_extract_const = function
- (* XXX The meaning of signed/unsigned breaks down at
- * 31, 32, 63 and 64 bits.
- *)
- | (1, _, _) ->
- <:expr<Bitmatch.extract_bit>>
- | ((2|3|4|5|6|7|8), _, false) ->
- <:expr<Bitmatch.extract_char_unsigned>>
- | ((2|3|4|5|6|7|8), _, true) ->
- <:expr<Bitmatch.extract_char_signed>>
- | (i, P.ConstantEndian BigEndian, false) when i <= 31 ->
- <:expr<Bitmatch.extract_int_be_unsigned>>
- | (i, P.ConstantEndian BigEndian, true) when i <= 31 ->
- <:expr<Bitmatch.extract_int_be_signed>>
- | (i, P.ConstantEndian LittleEndian, false) when i <= 31 ->
- <:expr<Bitmatch.extract_int_le_unsigned>>
- | (i, P.ConstantEndian LittleEndian, true) when i <= 31 ->
- <:expr<Bitmatch.extract_int_le_signed>>
- | (i, P.ConstantEndian NativeEndian, false) when i <= 31 ->
- <:expr<Bitmatch.extract_int_ne_unsigned>>
- | (i, P.ConstantEndian NativeEndian, true) when i <= 31 ->
- <:expr<Bitmatch.extract_int_ne_signed>>
- | (i, P.EndianExpr expr, false) when i <= 31 ->
- <:expr<Bitmatch.extract_int_ee_unsigned $expr$>>
- | (i, P.EndianExpr expr, true) when i <= 31 ->
- <:expr<Bitmatch.extract_int_ee_signed $expr$>>
- | (32, P.ConstantEndian BigEndian, false) ->
- <:expr<Bitmatch.extract_int32_be_unsigned>>
- | (32, P.ConstantEndian BigEndian, true) ->
- <:expr<Bitmatch.extract_int32_be_signed>>
- | (32, P.ConstantEndian LittleEndian, false) ->
- <:expr<Bitmatch.extract_int32_le_unsigned>>
- | (32, P.ConstantEndian LittleEndian, true) ->
- <:expr<Bitmatch.extract_int32_le_signed>>
- | (32, P.ConstantEndian NativeEndian, false) ->
- <:expr<Bitmatch.extract_int32_ne_unsigned>>
- | (32, P.ConstantEndian NativeEndian, true) ->
- <:expr<Bitmatch.extract_int32_ne_signed>>
- | (32, P.EndianExpr expr, false) ->
- <:expr<Bitmatch.extract_int32_ee_unsigned $expr$>>
- | (32, P.EndianExpr expr, true) ->
- <:expr<Bitmatch.extract_int32_ee_signed $expr$>>
- | (_, P.ConstantEndian BigEndian, false) ->
- <:expr<Bitmatch.extract_int64_be_unsigned>>
- | (_, P.ConstantEndian BigEndian, true) ->
- <:expr<Bitmatch.extract_int64_be_signed>>
- | (_, P.ConstantEndian LittleEndian, false) ->
- <:expr<Bitmatch.extract_int64_le_unsigned>>
- | (_, P.ConstantEndian LittleEndian, true) ->
- <:expr<Bitmatch.extract_int64_le_signed>>
- | (_, P.ConstantEndian NativeEndian, false) ->
- <:expr<Bitmatch.extract_int64_ne_unsigned>>
- | (_, P.ConstantEndian NativeEndian, true) ->
- <:expr<Bitmatch.extract_int64_ne_signed>>
- | (_, P.EndianExpr expr, false) ->
- <:expr<Bitmatch.extract_int64_ee_unsigned $expr$>>
- | (_, P.EndianExpr expr, true) ->
- <:expr<Bitmatch.extract_int64_ee_signed $expr$>>
- in
- let int_extract = function
- | (P.ConstantEndian BigEndian, false) ->
- <:expr<Bitmatch.extract_int64_be_unsigned>>
- | (P.ConstantEndian BigEndian, true) ->
- <:expr<Bitmatch.extract_int64_be_signed>>
- | (P.ConstantEndian LittleEndian, false) ->
- <:expr<Bitmatch.extract_int64_le_unsigned>>
- | (P.ConstantEndian LittleEndian, true) ->
- <:expr<Bitmatch.extract_int64_le_signed>>
- | (P.ConstantEndian NativeEndian, false) ->
- <:expr<Bitmatch.extract_int64_ne_unsigned>>
- | (P.ConstantEndian NativeEndian, true) ->
- <:expr<Bitmatch.extract_int64_ne_signed>>
- | (P.EndianExpr expr, false) ->
- <:expr<Bitmatch.extract_int64_ee_unsigned $expr$>>
- | (P.EndianExpr expr, true) ->
- <:expr<Bitmatch.extract_int64_ee_signed $expr$>>
- in
+ let int_extract_const (i, endian, signed) =
+ build_bitmatch_call _loc "extract" (Some i) endian signed in
+ let int_extract (endian, signed) =
+ build_bitmatch_call _loc "extract" None endian signed in
let expr =
match t, flen_is_const with
>>
| P.Int, Some _ ->
- Loc.raise _loc (Failure "length of int field must be [1..64]")
+ fail "length of int field must be [1..64]"
(* Int field, non-const flen. We have to test the range of
* the field at runtime. If outside the range it's a no-match
>>
| P.String, Some _ ->
- Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
+ fail "length of string must be > 0 and a multiple of 8, or the special value -1"
(* String field, non-const flen. We check the flen is > 0
* and a multiple of 8 (-1 is not allowed here), at runtime.
| <:patt< $lid:ident$ >> -> ident
| <:patt< _ >> -> "_"
| _ ->
- Loc.raise _loc
- (Failure "cannot compare a bitstring to a constant") in
+ fail "cannot compare a bitstring to a constant" in
<:expr<
if $lid:len$ >= $`int:i$ then (
let $lid:ident$, $lid:off$, $lid:len$ =
| <:patt< $lid:ident$ >> -> ident
| <:patt< _ >> -> "_"
| _ ->
- Loc.raise _loc
- (Failure "cannot compare a bitstring to a constant") in
+ fail "cannot compare a bitstring to a constant" in
<:expr<
let $lid:ident$, $lid:off$, $lid:len$ =
Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
>>
| P.Bitstring, Some _ ->
- Loc.raise _loc (Failure "length of bitstring must be >= 0 or the special value -1")
+ fail "length of bitstring must be >= 0 or the special value -1"
(* Bitstring field, non-const flen. We check the flen is >= 0
* (-1 is not allowed here) at runtime.
| <:patt< $lid:ident$ >> -> ident
| <:patt< _ >> -> "_"
| _ ->
- Loc.raise _loc
- (Failure "cannot compare a bitstring to a constant") in
+ fail "cannot compare a bitstring to a constant" in
<:expr<
if $flen$ >= 0 && $flen$ <= $lid:len$ then (
let $lid:ident$, $lid:off$, $lid:len$ =
>>
in
+ (* Computed offset: only offsets forward are supported.
+ *
+ * We try hard to optimize this based on what we know. Are
+ * we at a predictable offset now? (Look at the outer 'fields'
+ * list and see if they all have constant field length starting
+ * at some constant offset). Is this offset constant?
+ *
+ * Based on this we can do a lot of the computation at
+ * compile time, or defer it to runtime only if necessary.
+ *
+ * In all cases, the off and len fields get updated.
+ *)
+ let expr =
+ match offset with
+ | None -> expr (* common case: there was no offset expression *)
+ | Some offset_expr ->
+ (* This will be [Some i] if offset is a constant expression
+ * or [None] if it's a non-constant.
+ *)
+ let requested_offset = expr_is_constant offset_expr in
+
+ (* This will be [Some i] if our current offset is known
+ * at compile time, or [None] if we can't determine it.
+ *)
+ let current_offset =
+ let has_constant_offset field =
+ match P.get_offset field with
+ | None -> false
+ | Some expr ->
+ match expr_is_constant expr with
+ | None -> false
+ | Some i -> true
+ in
+ let get_constant_offset field =
+ match P.get_offset field with
+ | None -> assert false
+ | Some expr ->
+ match expr_is_constant expr with
+ | None -> assert false
+ | Some i -> i
+ in
+
+ let has_constant_len field =
+ match expr_is_constant (P.get_length field) with
+ | None -> false
+ | Some i when i > 0 -> true
+ | Some _ -> false
+ in
+ let get_constant_len field =
+ match expr_is_constant (P.get_length field) with
+ | None -> assert false
+ | Some i when i > 0 -> i
+ | Some _ -> assert false
+ in
+
+ let rec loop = function
+ (* first field has constant offset 0 *)
+ | [] -> Some 0
+ (* field with constant offset & length *)
+ | field :: _
+ when has_constant_offset field &&
+ has_constant_len field ->
+ Some (get_constant_offset field + get_constant_len field)
+ (* field with no offset & constant length *)
+ | field :: fields
+ when P.get_offset field = None &&
+ has_constant_len field ->
+ (match loop fields with
+ | None -> None
+ | Some offset -> Some (offset + get_constant_len field))
+ (* else, can't work out the offset *)
+ | _ -> None
+ in
+ loop fields in
+
+ (* Look at the current offset and requested offset cases and
+ * determine what code to generate.
+ *)
+ match current_offset, requested_offset with
+ (* This is the good case: both the current offset and
+ * the requested offset are constant, so we can remove
+ * almost all the runtime checks.
+ *)
+ | Some current_offset, Some requested_offset ->
+ let move = requested_offset - current_offset in
+ if move < 0 then
+ fail (sprintf "requested offset is less than the current offset (%d < %d)" requested_offset current_offset);
+ (* Add some code to move the offset and length by a
+ * constant amount, and a runtime test that len >= 0
+ * (XXX possibly the runtime test is unnecessary?)
+ *)
+ <:expr<
+ let $lid:off$ = $lid:off$ + $`int:move$ in
+ let $lid:len$ = $lid:len$ - $`int:move$ in
+ if $lid:len$ >= 0 then $expr$
+ >>
+ (* In any other case, we need to use runtime checks.
+ *
+ * XXX It's not clear if a backwards move detected at runtime
+ * is merely a match failure, or a runtime error. At the
+ * moment it's just a match failure since bitmatch generally
+ * doesn't raise runtime errors.
+ *)
+ | _ ->
+ let move = gensym "move" in
+ <:expr<
+ let $lid:move$ = $offset_expr$ - $lid:off$ in
+ if $lid:move$ >= 0 then (
+ let $lid:off$ = $lid:off$ + $lid:move$ in
+ let $lid:len$ = $lid:len$ - $lid:move$ in
+ if $lid:len$ >= 0 then $expr$
+ )
+ >> in (* end of computed offset code *)
+
(* Emit extra debugging code. *)
let expr =
if not debug then expr else (
- let field = P.string_of_field field in
+ let field = P.string_of_pattern_field field in
<:expr<
if !Bitmatch.debug then (
let expand_named_pattern _loc name =
try Hashtbl.find pattern_hash name
with Not_found ->
- Loc.raise _loc (Failure (sprintf "named pattern not found: %s" name))
+ locfail _loc (sprintf "named pattern not found: %s" name)
(* Add named patterns from a file. See the documentation on the
* directory search path in bitmatch_persistent.mli
let names = List.rev !names in
List.iter (
function
- | name, P.Pattern patt -> add_named_pattern _loc name patt
+ | name, P.Pattern patt ->
+ if patt = [] then
+ locfail _loc (sprintf "pattern %s: no fields" name);
+ add_named_pattern _loc name patt
| _, P.Constructor _ -> () (* just ignore these for now *)
) names
git.annexia.org / ocaml-bitstring.git / blobdiff