(* Bitmatch syntax extension.
- * $Id: pa_bitmatch.ml,v 1.2 2008-04-01 08:56:43 rjones Exp $
+ * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ *
+ * $Id$
*)
open Printf
open Syntax
open Ast
-type m = Fields of f list (* field ; field -> ... *)
- | Bind of string option (* _ -> ... *)
-and f = {
- ident : string; (* field name *)
- flen : expr; (* length in bits, may be non-const *)
- endian : endian; (* endianness *)
- signed : bool; (* true if signed, false if unsigned *)
- t : t; (* type *)
-}
-and endian = BigEndian | LittleEndian | NativeEndian
-and t = Int | Bitstring
+open Bitmatch
+module P = Bitmatch_persistent
+
+(* If this is true then we emit some debugging code which can
+ * be useful to tell what is happening during matches. You
+ * also need to do 'Bitmatch.debug := true' in your main program.
+ *
+ * If this is false then no extra debugging code is emitted.
+ *)
+let debug = false
+
+(* 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. *)
(* Generate a fresh, unique symbol each time called. *)
let gensym =
incr i; let i = !i in
sprintf "__pabitmatch_%s_%d" name i
-(* Deal with the qualifiers which appear for a field. *)
-let output_field _loc name flen qs =
- let endian, signed, t =
+(* 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 =
match qs with
- | None -> (None, None, None)
+ | None -> (false, false, false, field)
| Some qs ->
List.fold_left (
- fun (endian, signed, t) q ->
- match q with
- | "bigendian" ->
- if endian <> None then
+ 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 endian = Some BigEndian in
- (endian, signed, t)
+ let field = P.set_endian field BigEndian in
+ (true, signed_set, type_set, field)
)
- | "littleendian" ->
- if endian <> None then
+ | "littleendian", None ->
+ if endian_set then
Loc.raise _loc (Failure "an endian flag has been set already")
else (
- let endian = Some LittleEndian in
- (endian, signed, t)
+ let field = P.set_endian field LittleEndian in
+ (true, signed_set, type_set, field)
)
- | "nativeendian" ->
- if endian <> None then
+ | "nativeendian", None ->
+ if endian_set then
Loc.raise _loc (Failure "an endian flag has been set already")
else (
- let endian = Some NativeEndian in
- (endian, signed, t)
+ let field = P.set_endian field NativeEndian in
+ (true, signed_set, type_set, field)
)
- | "signed" ->
- if signed <> None then
+ | "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 signed = Some true in
- (endian, signed, t)
+ let field = P.set_signed field true in
+ (endian_set, true, type_set, field)
)
- | "unsigned" ->
- if signed <> None then
+ | "unsigned", None ->
+ if signed_set then
Loc.raise _loc (Failure "a signed flag has been set already")
else (
- let signed = Some false in
- (endian, signed, t)
+ 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)
)
- | "int" ->
- if t <> None then
+ | "string", None ->
+ if type_set then
Loc.raise _loc (Failure "a type flag has been set already")
else (
- let t = Some Int in
- (endian, signed, t)
+ let field = P.set_type_string field in
+ (endian_set, signed_set, true, field)
)
- | "bitstring" ->
- if t <> None then
+ | "bitstring", None ->
+ if type_set then
Loc.raise _loc (Failure "a type flag has been set already")
else (
- let t = Some Bitstring in
- (endian, signed, t)
+ let field = P.set_type_bitstring field in
+ (endian_set, signed_set, true, field)
)
- | s ->
- Loc.raise _loc (Failure (s ^ ": unknown qualifier"))
- ) (None, None, None) qs in
+ | 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
+
+ (* 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
+
+ (* Default endianness, signedness, type if not set already. *)
+ let field = if endian_set then field else P.set_endian field BigEndian in
+ let field = if signed_set then field else P.set_signed field false in
+ let field = if type_set then field else P.set_type_int field in
+
+ field
+
+(* 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
+
+ (* Bitstrings are created like the 'Buffer' module (in fact, using
+ * the Buffer module), by appending snippets to a growing buffer.
+ * This is reasonably efficient and avoids a lot of garbage.
+ *)
+ let buffer = gensym "buffer" in
+
+ (* General exception which is raised inside the constructor functions
+ * when an int expression is out of range at runtime.
+ *)
+ let exn = gensym "exn" in
+ let exn_used = ref false in
+
+ (* Convert each field to a simple bitstring-generating expression. *)
+ let fields = List.map (
+ fun field ->
+ let fexpr = P.get_expr field in
+ let flen = P.get_length field in
+ let endian = P.get_endian field in
+ let signed = P.get_signed field in
+ let t = P.get_type field in
+ let _loc = P.get_location 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 = 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 expr =
+ match t, flen_is_const with
+ (* Common case: int field, constant flen.
+ *
+ * Range checks are done inside the construction function
+ * because that's a lot simpler w.r.t. types. It might
+ * be better to move them here. XXX
+ *)
+ | P.Int, Some i when i > 0 && i <= 64 ->
+ let construct_fn = int_construct_const (i,endian,signed) in
+ exn_used := true;
+
+ <:expr<
+ $construct_fn$ $lid:buffer$ $fexpr$ $`int:i$ $lid:exn$
+ >>
+
+ | P.Int, Some _ ->
+ Loc.raise _loc (Failure "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].
+ *
+ * Range checks are done inside the construction function
+ * because that's a lot simpler w.r.t. types. It might
+ * be better to move them here. XXX
+ *)
+ | P.Int, None ->
+ let construct_fn = int_construct (endian,signed) in
+ exn_used := true;
+
+ <:expr<
+ 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$))
+ >>
+
+ (* String, constant length > 0, must be a multiple of 8. *)
+ | P.String, Some i when i > 0 && i land 7 = 0 ->
+ let bs = gensym "bs" in
+ let j = i lsr 3 in
+ <:expr<
+ let $lid:bs$ = $fexpr$ in
+ 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$))
+ >>
+
+ (* String, constant length -1, means variable length string
+ * with no checks.
+ *)
+ | P.String, Some (-1) ->
+ <:expr< Bitmatch.construct_string $lid:buffer$ $fexpr$ >>
+
+ (* String, constant length = 0 is probably an error, and so is
+ * 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")
- (* If type is set to bitstring then endianness and signedness
- * qualifiers are meaningless and must not be set.
+ (* String, non-constant length.
+ * We check at runtime that the length is > 0, a multiple of 8,
+ * and matches the declared length.
+ *)
+ | P.String, None ->
+ let bslen = gensym "bslen" in
+ let bs = gensym "bs" in
+ <:expr<
+ let $lid:bslen$ = $flen$ in
+ if $lid:bslen$ > 0 then (
+ if $lid:bslen$ land 7 = 0 then (
+ let $lid:bs$ = $fexpr$ in
+ 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$))
+ ) else
+ raise (Bitmatch.Construct_failure
+ ("length of string must be a multiple of 8",
+ $str:loc_fname$,
+ $int:loc_line$, $int:loc_char$))
+ ) else
+ raise (Bitmatch.Construct_failure
+ ("length of string must be > 0",
+ $str:loc_fname$,
+ $int:loc_line$, $int:loc_char$))
+ >>
+
+ (* 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$))
+ >>
+
+ (* Bitstring, constant length -1, means variable length bitstring
+ * with no checks.
+ *)
+ | 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.
+ *)
+ | P.Bitstring, Some _ ->
+ Loc.raise _loc
+ (Failure
+ "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
+ * the declared length.
+ *)
+ | P.Bitstring, None ->
+ let bslen = gensym "bslen" in
+ let bs = gensym "bs" in
+ <:expr<
+ let $lid:bslen$ = $flen$ in
+ 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$))
+ ) else
+ raise (Bitmatch.Construct_failure
+ ("length of bitstring must be > 0",
+ $str:loc_fname$,
+ $int:loc_line$, $int:loc_char$))
+ >> in
+ expr
+ ) fields in
+
+ (* Create the final bitstring. Start by creating an empty buffer
+ * and then evaluate each expression above in turn which will
+ * append some more to the bitstring buffer. Finally extract
+ * the bitstring.
+ *
+ * XXX We almost have enough information to be able to guess
+ * a good initial size for the buffer.
*)
- if t = Some Bitstring && (endian <> None || signed <> None) then
- Loc.raise _loc (
- Failure "bitstring type and endian or signed qualifiers cannot be mixed"
- );
-
- (* Default endianness, signedness, type. *)
- let endian = match endian with None -> 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
-
- {
- ident = name;
- flen = flen;
- endian = endian;
- signed = signed;
- t = t;
- }
+ let fields =
+ match fields with
+ | [] -> <:expr< [] >>
+ | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in
+
+ let expr =
+ <:expr<
+ let $lid:buffer$ = Bitmatch.Buffer.create () in
+ $fields$;
+ Bitmatch.Buffer.contents $lid:buffer$
+ >> 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$
+ >>
+ else
+ expr
(* Generate the code for a bitmatch statement. '_loc' is the
* location, 'bs' is the bitstring parameter, 'cases' are
*)
let rec output_field_extraction inner = function
| [] -> inner
- | {ident=ident; flen=flen; endian=endian; signed=signed; t=t} :: fields ->
- (* If length an integer constant? If so, what is it? This
+ | field :: fields ->
+ let fpatt = P.get_patt field in
+ let flen = P.get_length field in
+ let endian = P.get_endian field in
+ let signed = P.get_signed field in
+ let t = P.get_type field in
+ let _loc = P.get_location 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 name_of_int_extract_const = function
- (* XXX As an enhancement we should allow a 64-bit-only
- * mode which lets us use 'int' up to 63 bits and won't
- * compile on 32-bit platforms.
- *)
+ 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, _, _) -> "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"
+ | (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 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"
+ 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 expr =
match t, flen_is_const with
(* Common case: int field, constant flen *)
- | Int, Some i when i > 0 && i <= 64 ->
- let extract_func = name_of_int_extract_const (i,endian,signed) in
+ | P.Int, Some i when i > 0 && i <= 64 ->
+ let extract_fn = int_extract_const (i,endian,signed) in
+ let v = gensym "val" in
<:expr<
- if $lid:len$ >= $flen$ then (
- let $lid:ident$, $lid:off$, $lid:len$ =
- Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
- $flen$ in
- $inner$
+ if $lid:len$ >= $`int:i$ then (
+ let $lid:v$, $lid:off$, $lid:len$ =
+ $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ in
+ match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
)
>>
- | Int, Some _ ->
+ | P.Int, Some _ ->
Loc.raise _loc (Failure "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
* (not an error).
*)
- | Int, None ->
- let extract_func = name_of_int_extract (endian,signed) in
+ | P.Int, None ->
+ let extract_fn = int_extract (endian,signed) in
+ let v = gensym "val" in
<:expr<
- if $flen$ >= 1 && $flen$ <= 64 && $flen$ >= $lid:len$ then (
- let $lid:ident$, $lid:off$, $lid:len$ =
- Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
- $flen$ in
- $inner$
+ if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
+ let $lid:v$, $lid:off$, $lid:len$ =
+ $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $flen$ in
+ match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
)
>>
- (* Bitstring, constant flen >= 0. *)
- | Bitstring, Some i when i >= 0 ->
+ (* String, constant flen > 0. *)
+ | P.String, Some i when i > 0 && i land 7 = 0 ->
+ let bs = gensym "bs" in
+ <:expr<
+ if $lid:len$ >= $`int:i$ then (
+ let $lid:bs$, $lid:off$, $lid:len$ =
+ Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
+ $`int:i$ in
+ match Bitmatch.string_of_bitstring $lid:bs$ with
+ | $fpatt$ when true -> $inner$
+ | _ -> ()
+ )
+ >>
+
+ (* String, constant flen = -1, means consume all the
+ * rest of the input.
+ *)
+ | P.String, Some i when i = -1 ->
+ let bs = gensym "bs" in
+ <:expr<
+ let $lid:bs$, $lid:off$, $lid:len$ =
+ Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
+ match Bitmatch.string_of_bitstring $lid:bs$ with
+ | $fpatt$ when true -> $inner$
+ | _ -> ()
+ >>
+
+ | P.String, Some _ ->
+ Loc.raise _loc (Failure "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.
+ *)
+ | P.String, None ->
+ let bs = gensym "bs" in
+ <:expr<
+ if $flen$ >= 0 && $flen$ <= $lid:len$
+ && $flen$ land 7 = 0 then (
+ let $lid:bs$, $lid:off$, $lid:len$ =
+ Bitmatch.extract_bitstring
+ $lid:data$ $lid:off$ $lid:len$ $flen$ in
+ match Bitmatch.string_of_bitstring $lid:bs$ with
+ | $fpatt$ when true -> $inner$
+ | _ -> ()
+ )
+ >>
+
+ (* Bitstring, constant flen >= 0.
+ * At the moment all we can do is assign the bitstring to an
+ * identifier.
+ *)
+ | P.Bitstring, Some i when i >= 0 ->
+ let ident =
+ match fpatt with
+ | <:patt< $lid:ident$ >> -> ident
+ | <:patt< _ >> -> "_"
+ | _ ->
+ Loc.raise _loc
+ (Failure "cannot compare a bitstring to a constant") in
<:expr<
- if $lid:len$ >= $flen$ then (
+ if $lid:len$ >= $`int:i$ then (
let $lid:ident$, $lid:off$, $lid:len$ =
Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
- $flen$ in
+ $`int:i$ in
$inner$
)
>>
(* Bitstring, constant flen = -1, means consume all the
* rest of the input.
*)
- | Bitstring, Some i when i = -1 ->
+ | P.Bitstring, Some i when i = -1 ->
+ let ident =
+ match fpatt with
+ | <:patt< $lid:ident$ >> -> ident
+ | <:patt< _ >> -> "_"
+ | _ ->
+ Loc.raise _loc
+ (Failure "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
$inner$
>>
- | Bitstring, Some _ ->
+ | P.Bitstring, Some _ ->
Loc.raise _loc (Failure "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.
*)
- | Bitstring, None ->
+ | P.Bitstring, None ->
+ let ident =
+ match fpatt with
+ | <:patt< $lid:ident$ >> -> ident
+ | <:patt< _ >> -> "_"
+ | _ ->
+ Loc.raise _loc
+ (Failure "cannot compare a bitstring to a constant") in
<:expr<
- if $flen$ >= 0 && $lid:len$ >= $flen$ then (
+ if $flen$ >= 0 && $flen$ <= $lid:len$ then (
let $lid:ident$, $lid:off$, $lid:len$ =
Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
$flen$ in
>>
in
+ (* Emit extra debugging code. *)
+ let expr =
+ if not debug then expr else (
+ let field = P.string_of_field field in
+
+ <:expr<
+ if !Bitmatch.debug then (
+ Printf.eprintf "PA_BITMATCH: TEST:\n";
+ Printf.eprintf " %s\n" $str:field$;
+ Printf.eprintf " off %d len %d\n%!" $lid:off$ $lid:len$;
+ (*Bitmatch.hexdump_bitstring stderr
+ ($lid:data$,$lid:off$,$lid:len$);*)
+ );
+ $expr$
+ >>
+ ) in
+
output_field_extraction expr fields
in
(* Convert each case in the match. *)
let cases = List.map (
- function
- (* field : len ; field : len when .. -> ..*)
- | (Fields fields, Some whenclause, code) ->
- let inner =
- <:expr<
- if $whenclause$ then (
- $lid:result$ := Some ($code$);
- raise Exit
- )
- >> in
- output_field_extraction inner (List.rev fields)
-
- (* field : len ; field : len -> ... *)
- | (Fields fields, None, code) ->
- let inner =
- <:expr<
- $lid:result$ := Some ($code$);
- raise Exit
- >> in
- output_field_extraction inner (List.rev fields)
-
- (* _ as name when ... -> ... *)
- | (Bind (Some name), Some whenclause, code) ->
- <:expr<
- let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
- if $whenclause$ then (
- $lid:result$ := Some ($code$);
- raise Exit
- )
- >>
-
- (* _ as name -> ... *)
- | (Bind (Some name), None, code) ->
- <:expr<
- let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
- $lid:result$ := Some ($code$);
- raise Exit
- >>
-
- (* _ when ... -> ... *)
- | (Bind None, Some whenclause, code) ->
- <:expr<
- if $whenclause$ then (
- $lid:result$ := Some ($code$);
- raise Exit
- )
- >>
-
- (* _ -> ... *)
- | (Bind None, None, code) ->
- <:expr<
- $lid:result$ := Some ($code$);
- raise Exit
- >>
-
+ fun (fields, bind, whenclause, code) ->
+ let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
+ let inner =
+ match whenclause with
+ | Some whenclause ->
+ <:expr< if $whenclause$ then $inner$ >>
+ | None -> inner in
+ let inner =
+ match bind with
+ | Some name ->
+ <:expr<
+ let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
+ $inner$
+ >>
+ | None -> inner in
+ output_field_extraction inner (List.rev fields)
) cases in
+ (* Join them into a single expression.
+ *
+ * Don't do it with a normal fold_right because that leaves
+ * 'raise Exit; ()' at the end which causes a compiler warning.
+ * Hence a bit of complexity here.
+ *
+ * Note that the number of cases is always >= 1 so List.hd is safe.
+ *)
+ let cases = List.rev cases in
let cases =
- List.fold_right (fun case base -> <:expr< $case$ ; $base$ >>)
- cases <:expr< () >> in
+ List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
+ (List.hd cases) (List.tl cases) in
(* The final code just wraps the list of cases in a
* try/with construct so that each case is tried in
EXTEND Gram
GLOBAL: expr;
+ (* Qualifiers are a list of identifiers ("string", "bigendian", etc.)
+ * followed by an optional expression (used in certain cases). Note
+ * that we are careful not to declare any explicit reserved words.
+ *)
qualifiers: [
- [ LIST0 [ q = LIDENT -> q ] SEP "," ]
+ [ LIST0
+ [ q = LIDENT;
+ e = OPT [ "("; e = expr; ")" -> e ] -> (q, e) ]
+ SEP "," ]
];
- field: [
- [ name = LIDENT; ":"; len = expr LEVEL "top";
+ (* Field used in the bitmatch operator (a pattern). *)
+ patt_field: [
+ [ fpatt = patt; ":"; len = expr LEVEL "top";
qs = OPT [ ":"; qs = qualifiers -> qs ] ->
- output_field _loc name len qs
+ let field = P.create_pattern_field _loc in
+ let field = P.set_patt field fpatt in
+ let field = P.set_length field len in
+ parse_field _loc field qs
]
];
+ (* Case inside bitmatch operator. *)
match_case: [
- [ fields = LIST0 field SEP ";";
- w = OPT [ "when"; e = expr -> e ]; "->";
- code = expr ->
- (Fields fields, w, code)
- ]
- | [ "_";
+ [ "{";
+ fields = LIST0 patt_field SEP ";";
+ "}";
bind = OPT [ "as"; name = LIDENT -> name ];
- w = OPT [ "when"; e = expr -> e ]; "->";
+ whenclause = OPT [ "when"; e = expr -> e ]; "->";
code = expr ->
- (Bind bind, w, code)
+ (fields, bind, whenclause, code)
]
];
+ (* Field used in the BITSTRING constructor (an expression). *)
+ constr_field: [
+ [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
+ qs = OPT [ ":"; qs = qualifiers -> qs ] ->
+ let field = P.create_constructor_field _loc in
+ let field = P.set_expr field fexpr in
+ let field = P.set_length field len in
+ parse_field _loc field qs
+ ]
+ ];
+
+ (* 'bitmatch' expressions. *)
expr: LEVEL ";" [
- [ "bitmatch"; bs = expr; "with"; OPT "|";
+ [ "bitmatch";
+ bs = expr; "with"; OPT "|";
cases = LIST1 match_case SEP "|" ->
output_bitmatch _loc bs cases
]
+
+ (* Constructor. *)
+ | [ "BITSTRING"; "{";
+ fields = LIST0 constr_field SEP ";";
+ "}" ->
+ output_constructor _loc fields
+ ]
];
END
git.annexia.org / ocaml-bitstring.git / blobdiff