X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=pa_bitmatch.ml;h=b154a318cd1a410c3ed2e873c05e3bc27b495a31;hb=4853c75eb968f482dc8d9919cb56fc12fec8e3d2;hp=2c5a6deb81d39f759d2b6e6b8f61a0e624c03014;hpb=e3bd7e70911c1afb5ad31d2368ed94961a973f62;p=ocaml-bitstring.git diff --git a/pa_bitmatch.ml b/pa_bitmatch.ml index 2c5a6de..b154a31 100644 --- a/pa_bitmatch.ml +++ b/pa_bitmatch.ml @@ -1,5 +1,21 @@ (* Bitmatch syntax extension. - * $Id: pa_bitmatch.ml,v 1.1 2008-03-31 22:52:17 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: pa_bitmatch.ml,v 1.10 2008-04-25 12:55:39 rjones Exp $ *) open Printf @@ -8,17 +24,34 @@ open Camlp4.PreCast open Syntax open Ast -type m = Fields of f list (* field ; field -> ... *) - | Bind of string option (* _ -> ... *) -and f = { - ident : string; (* field name *) +(* 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 + +(* 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 = { flen : expr; (* length in bits, may be non-const *) endian : endian; (* endianness *) signed : bool; (* true if signed, false if unsigned *) t : t; (* type *) + _loc : Loc.t; (* location in source code *) } and endian = BigEndian | LittleEndian | NativeEndian -and t = Int | Bitstring +and t = Int | String | Bitstring (* Generate a fresh, unique symbol each time called. *) let gensym = @@ -27,8 +60,21 @@ 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 = +(* Heuristic test if a pattern is exhaustive. *) +let pattern_is_exhaustive = function + | <:patt< $lid:_$ >> -> true + | _ -> false + +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 endian, signed, t = match qs with | None -> (None, None, None) @@ -78,6 +124,13 @@ let output_field _loc name 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") @@ -89,13 +142,14 @@ let output_field _loc name 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 @@ -103,13 +157,315 @@ let output_field _loc name flen qs = let t = match t with None -> Int | Some t -> t in { - ident = name; flen = flen; endian = endian; signed = signed; t = t; + _loc = _loc; } +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 flen = + match flen with + | <:expr< $int:i$ >> -> i + | _ -> "[non-const-len]" in + let endian = 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 + +(* 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 {fexpr=fexpr; fec={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 name_of_int_construct_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. + *) + (* XXX The meaning of signed/unsigned breaks down at + * 31, 32, 63 and 64 bits. + *) + | (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" + 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" + 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 + *) + | Int, Some i when i > 0 && i <= 64 -> + let construct_func = + name_of_int_construct_const (i,endian,signed) in + exn_used := true; + + <:expr< + Bitmatch.$lid:construct_func$ $lid:buffer$ $fexpr$ $flen$ + $lid:exn$ + >> + + | 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 + *) + | Int, None -> + let construct_func = name_of_int_construct (endian,signed) in + exn_used := true; + + <:expr< + if $flen$ >= 1 && $flen$ <= 64 then + Bitmatch.$lid:construct_func$ $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. *) + | 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$ = $fexpr$ in + if Bitmatch.bitstring_length $lid:bs$ = $flen$ 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. + *) + | 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, 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. + *) + | 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. + *) + 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 * the list of cases to test against. @@ -130,8 +486,12 @@ let output_bitmatch _loc bs cases = *) 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=fpatt; fpc={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 = @@ -140,9 +500,16 @@ let output_bitmatch _loc bs cases = | _ -> 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. + *) + (* XXX The meaning of signed/unsigned breaks down at + * 31, 32, 63 and 64 bits. + *) | (1, _, _) -> "extract_bit" - | ((2|3|4|5|6|7), _, false) -> "extract_char_unsigned" - | ((2|3|4|5|6|7), _, true) -> "extract_char_signed" + | ((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" @@ -180,14 +547,25 @@ let output_bitmatch _loc bs cases = (* 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 - <: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$ - ) - >> + let v = gensym "val" in + if pattern_is_exhaustive fpatt then + <:expr< + if $lid:len$ >= $flen$ then ( + let $lid:v$, $lid:off$, $lid:len$ = + Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$ + $flen$ in + match $lid:v$ with $fpatt$ -> $inner$ + ) + >> + else + <:expr< + if $lid:len$ >= $flen$ then ( + let $lid:v$, $lid:off$, $lid:len$ = + Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$ + $flen$ in + match $lid:v$ with $fpatt$ -> $inner$ | _ -> () + ) + >> | Int, Some _ -> Loc.raise _loc (Failure "length of int field must be [1..64]") @@ -198,17 +576,116 @@ let output_bitmatch _loc bs cases = *) | Int, None -> let extract_func = name_of_int_extract (endian,signed) 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$ - ) - >> - - (* Bitstring, constant flen >= 0. *) + let v = gensym "val" in + if pattern_is_exhaustive fpatt then + <: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$ + $flen$ in + match $lid:v$ with $fpatt$ -> $inner$ + ) + >> + else + <: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$ + $flen$ in + match $lid:v$ with $fpatt$ -> $inner$ | _ -> () + ) + >> + + (* String, constant flen > 0. *) + | String, Some i when i > 0 && i land 7 = 0 -> + let bs = gensym "bs" in + if pattern_is_exhaustive fpatt then + <:expr< + if $lid:len$ >= $flen$ 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$ -> $inner$ + ) + >> + else + <:expr< + if $lid:len$ >= $flen$ 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$ -> $inner$ + | _ -> () + ) + >> + + (* String, constant flen = -1, means consume all the + * rest of the input. + *) + | String, Some i when i = -1 -> + let bs = gensym "bs" in + if pattern_is_exhaustive fpatt then + <: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$ -> $inner$ + >> + else + <: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$ -> $inner$ + | _ -> () + >> + + | 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. + *) + | String, None -> + let bs = gensym "bs" in + if pattern_is_exhaustive fpatt then + <: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$ -> $inner$ + ) + >> + else + <: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$ -> $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$ = @@ -222,6 +699,12 @@ let output_bitmatch _loc bs cases = * rest of the input. *) | Bitstring, Some i when i = -1 -> + let ident = + match fpatt with + | <:patt< $lid:ident$ >> -> ident + | _ -> + 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 @@ -235,8 +718,14 @@ let output_bitmatch _loc bs cases = * (-1 is not allowed here) at runtime. *) | Bitstring, None -> + let ident = + match fpatt with + | <:patt< $lid:ident$ >> -> ident + | _ -> + 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 @@ -245,71 +734,58 @@ let output_bitmatch _loc bs cases = >> in + (* Emit extra debugging code. *) + let expr = + if not debug then expr else ( + let field = string_of_patt_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 @@ -342,32 +818,48 @@ EXTEND Gram [ LIST0 [ q = LIDENT -> q ] 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 + parse_patt_field _loc fpatt len 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 ] -> + parse_constr_field _loc fexpr len 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