X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=pa_bitmatch.ml;h=1e3225ca0e56f8affa1e1e6b9eed6065a8088fdb;hb=a7932dd74a91ebf54128bf5456e6a0054fc506c5;hp=b5e975867810643531ace0b1807f83d4a9872bf7;hpb=d4f8287a45c85630560cc88c67c9dba47ae05f35;p=ocaml-bitstring.git diff --git a/pa_bitmatch.ml b/pa_bitmatch.ml index b5e9758..1e3225c 100644 --- a/pa_bitmatch.ml +++ b/pa_bitmatch.ml @@ -15,7 +15,7 @@ * 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: pa_bitmatch.ml,v 1.7 2008-04-25 10:44:00 rjones Exp $ + * $Id$ *) open Printf @@ -30,21 +30,57 @@ open Ast * * If this is false then no extra debugging code is emitted. *) -let debug = true +let debug = false -type m = Fields of f list (* field ; field -> ... *) - | Bind of string option (* _ -> ... *) -and f = { - (* XXX fval should be a patt, not an expr *) - fval : expr; (* field binding or value *) +(* 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 | Bitstring +and t = Int | String | Bitstring (* Generate a fresh, unique symbol each time called. *) let gensym = @@ -53,8 +89,8 @@ let gensym = incr i; let i = !i in sprintf "__pabitmatch_%s_%d" name i -(* Deal with the qualifiers which appear for a field. *) -let parse_field _loc fval flen qs = +(* Deal with the qualifiers which appear for a field of both types. *) +let parse_field _loc field flen qs printer = let endian, signed, t = match qs with | None -> (None, None, None) @@ -66,21 +102,21 @@ let parse_field _loc fval flen qs = 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" -> @@ -104,6 +140,13 @@ let parse_field _loc fval flen qs = let t = Some Int in (endian, signed, t) ) + | "string" -> + if t <> None then + Loc.raise _loc (Failure "a type flag has been set already") + else ( + let t = Some String in + (endian, signed, t) + ) | "bitstring" -> if t <> None then Loc.raise _loc (Failure "a type flag has been set already") @@ -115,49 +158,52 @@ let parse_field _loc fval flen qs = Loc.raise _loc (Failure (s ^ ": unknown qualifier")) ) (None, None, None) qs in - (* If type is set to bitstring then endianness and signedness - * qualifiers are meaningless and must not be set. + (* If type is set to string or bitstring then endianness and + * signedness qualifiers are meaningless and must not be set. *) - if t = Some Bitstring && (endian <> None || signed <> None) then - Loc.raise _loc ( - Failure "bitstring type and endian or signed qualifiers cannot be mixed" - ); + if (t = Some Bitstring || t = Some String) + && (endian <> None || signed <> None) then + Loc.raise _loc ( + Failure "string types and endian or signed qualifiers cannot be mixed" + ); (* 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 { - fval = fval; + 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 string_of_field { fval = fval; flen = flen; +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 } = - let fval = - match fval with - | <:expr< $lid:id$ >> -> id - | _ -> "[expression]" in + _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 @@ -165,7 +211,7 @@ let string_of_field { fval = fval; flen = flen; let loc_char = Loc.start_off _loc - Loc.start_bol _loc in sprintf "%s : %s : %s, %s, %s @ (%S, %d, %d)" - fval flen t endian signed loc_fname loc_line loc_char + (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 = @@ -187,14 +233,12 @@ let output_constructor _loc fields = (* Convert each field to a simple bitstring-generating expression. *) let fields = List.map ( - fun {fval=fval; flen=flen; endian=endian; signed=signed; t=t} -> + 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 @@ -207,36 +251,42 @@ let output_constructor _loc fields = | (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 = @@ -253,7 +303,7 @@ let output_constructor _loc fields = exn_used := true; <:expr< - Bitmatch.$lid:construct_func$ $lid:buffer$ $fval$ $flen$ + Bitmatch.$lid:construct_func$ $lid:buffer$ $fexpr$ $flen$ $lid:exn$ >> @@ -273,7 +323,7 @@ let output_constructor _loc fields = <:expr< if $flen$ >= 1 && $flen$ <= 64 then - Bitmatch.$lid:construct_func$ $lid:buffer$ $fval$ $flen$ + Bitmatch.$lid:construct_func$ $lid:buffer$ $fexpr$ $flen$ $lid:exn$ else raise (Bitmatch.Construct_failure @@ -282,11 +332,68 @@ let output_constructor _loc fields = $int:loc_line$, $int:loc_char$)) >> + (* String, constant length > 0, must be a multiple of 8. *) + | String, Some i when i > 0 && i land 7 = 0 -> + let bs = gensym "bs" in + <:expr< + let $lid:bs$ = $fexpr$ in + if String.length $lid:bs$ = ($flen$ 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$)) + >> + + (* String, constant length -1, means variable length string + * with no checks. + *) + | String, Some (-1) -> + <:expr< Bitmatch.construct_string $lid:buffer$ $fexpr$ >> + + (* String, constant length = 0 is probably an error, and so is + * any other value. + *) + | String, Some _ -> + Loc.raise _loc (Failure "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, + * and matches the declared length. + *) + | 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. *) | Bitstring, Some i when i > 0 -> let bs = gensym "bs" in <:expr< - let $lid:bs$ = $fval$ in + let $lid:bs$ = $fexpr$ in if Bitmatch.bitstring_length $lid:bs$ = $flen$ then Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$ else @@ -300,9 +407,9 @@ let output_constructor _loc fields = * with no checks. *) | Bitstring, Some (-1) -> - <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fval$ >> + <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >> - (* Bitstring, constant length = 0 is probably an error, and so it + (* Bitstring, constant length = 0 is probably an error, and so is * any other value. *) | Bitstring, Some _ -> @@ -320,7 +427,7 @@ let output_constructor _loc fields = <:expr< let $lid:bslen$ = $flen$ in if $lid:bslen$ > 0 then ( - let $lid:bs$ = $fval$ in + let $lid:bs$ = $fexpr$ in if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ then Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$ else @@ -389,26 +496,14 @@ let output_bitmatch _loc bs cases = let rec output_field_extraction inner = function | [] -> inner | field :: fields -> - let {fval=fval; flen=flen; endian=endian; signed=signed; t=t} + let {field=fpatt; flen=flen; endian=endian; signed=signed; + t=t; _loc=_loc} = field in - (* Is fval a binding (an ident) or an expression? If it's - * a binding then we will generate a binding for this field. - * If it's an expression then we will test the field against - * the expression. - *) - let fval_is_ident = - match fval with - | <:expr< $lid:id$ >> -> Some id - | _ -> None 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 @@ -421,54 +516,48 @@ let output_bitmatch _loc bs cases = | (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 = - match t, fval_is_ident, flen_is_const with - (* Common case: int field, binding, constant flen *) - | Int, Some ident, Some i when i > 0 && i <= 64 -> - let extract_func = name_of_int_extract_const (i,endian,signed) 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$ - ) - >> - - (* Int field, not a binding, constant flen *) - | Int, None, Some i when i > 0 && i <= 64 -> + 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 let v = gensym "val" in <:expr< @@ -476,51 +565,88 @@ let output_bitmatch _loc bs cases = let $lid:v$, $lid:off$, $lid:len$ = Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$ $flen$ in - if $lid:v$ = $fval$ then ( - $inner$ - ) + match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> () ) >> - | Int, _, Some _ -> + | 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, Some ident, None -> + | Int, None -> let extract_func = name_of_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$ = + let $lid:v$, $lid:off$, $lid:len$ = Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$ $flen$ in - $inner$ + match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> () ) >> - | Int, None, None -> - let extract_func = name_of_int_extract (endian,signed) in - let v = gensym "val" in + (* String, constant flen > 0. *) + | String, Some i when i > 0 && i land 7 = 0 -> + let bs = gensym "bs" in <:expr< - if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then ( - let $lid:v$, $lid:off$, $lid:len$ = - Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$ + if $lid:len$ >= $flen$ then ( + let $lid:bs$, $lid:off$, $lid:len$ = + Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$ $flen$ in - if $lid:v$ = $fval$ then ( - $inner$ - ) + match Bitmatch.string_of_bitstring $lid:bs$ with + | $fpatt$ when true -> $inner$ + | _ -> () ) >> - (* Can't compare bitstrings at the moment. *) - | Bitstring, None, _ -> - Loc.raise _loc - (Failure "cannot compare a bitstring to a constant") + (* String, constant flen = -1, means consume all the + * rest of the input. + *) + | 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$ + | _ -> () + >> + + | String, Some _ -> + Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1") - (* Bitstring, constant flen >= 0. *) - | Bitstring, Some ident, Some i when i >= 0 -> + (* String field, non-const flen. We check the flen is > 0 + * and a multiple of 8 (-1 is not allowed here), at runtime. + *) + | 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. + *) + | 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 ( let $lid:ident$, $lid:off$, $lid:len$ = @@ -533,20 +659,34 @@ let output_bitmatch _loc bs cases = (* Bitstring, constant flen = -1, means consume all the * rest of the input. *) - | Bitstring, Some ident, Some i when i = -1 -> + | 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 _ -> + | 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, Some ident, None -> + | 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 && $flen$ <= $lid:len$ then ( let $lid:ident$, $lid:off$, $lid:len$ = @@ -579,61 +719,22 @@ let output_bitmatch _loc bs cases = (* 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. @@ -680,37 +781,46 @@ EXTEND Gram [ LIST0 [ q = LIDENT -> q ] SEP "," ] ]; - field: [ - [ fval = expr LEVEL "top"; ":"; 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 ] -> - parse_field _loc fval len qs + parse_field _loc fpatt len qs patt_printer ] ]; + (* Case inside bitmatch operator. *) match_case: [ - [ "_"; + [ "{"; + 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) ] - | [ fields = LIST0 field SEP ";"; - w = OPT [ "when"; e = expr -> e ]; "->"; - code = expr -> - (Fields fields, w, code) + ]; + + (* Field used in the BITSTRING constructor (an expression). *) + constr_field: [ + [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top"; + qs = OPT [ ":"; qs = qualifiers -> qs ] -> + parse_field _loc fexpr len qs expr_printer ] ]; (* '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 field SEP ";" -> + | [ "BITSTRING"; "{"; + fields = LIST0 constr_field SEP ";"; + "}" -> output_constructor _loc fields ] ];