X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=pa_bitmatch.ml;h=82818f6453c5b67c502bc5787c18aa9cfd119a78;hb=091a76c07b4ddd25c3459b7e6a9fd3e1245a57a7;hp=d8698e250e9aa1201b46975308725c9d05593a96;hpb=898a83cd362e47c189b66d055c240559a0bdd7a0;p=ocaml-bitstring.git diff --git a/pa_bitmatch.ml b/pa_bitmatch.ml index d8698e2..82818f6 100644 --- a/pa_bitmatch.ml +++ b/pa_bitmatch.ml @@ -24,6 +24,9 @@ open Camlp4.PreCast open Syntax open Ast +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. @@ -68,20 +71,6 @@ let rec expr_is_constant = function | _ -> 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 : 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 t = Int | String | Bitstring - (* Generate a fresh, unique symbol each time called. *) let gensym = let i = ref 1000 in @@ -90,128 +79,99 @@ let gensym = sprintf "__pabitmatch_%s_%d" name i (* Deal with the qualifiers which appear for a field of both types. *) -let parse_field _loc field flen qs printer = - let endian, signed, t = +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 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 endian = Some Bitmatch.BigEndian in - (endian, signed, t) + let field = P.set_endian field LittleEndian in + (true, signed_set, type_set, field) ) - | "littleendian" -> - 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 Bitmatch.LittleEndian in - (endian, signed, t) + let field = P.set_endian field NativeEndian in + (true, signed_set, type_set, field) ) - | "nativeendian" -> - if endian <> None then + | "endian", Some expr -> + if endian_set then Loc.raise _loc (Failure "an endian flag has been set already") else ( - let endian = Some Bitmatch.NativeEndian in - (endian, signed, t) + let field = P.set_endian_expr field expr in + (true, signed_set, type_set, field) ) - | "signed" -> - if signed <> None then + | "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" -> - if t <> None then + | "int", 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_int field in + (endian_set, signed_set, true, field) ) - | "string" -> - 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 String 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. *) - if (t = Some Bitstring || t = Some String) - && (endian <> None || signed <> None) then + 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" - ); - - (* Default endianness, signedness, type. *) - let endian = match endian with None -> Bitmatch.BigEndian | Some e -> e in - let signed = match signed with None -> false | Some s -> s in - let t = match t with None -> Int | Some t -> t in - - { - field = field; - flen = flen; - endian = endian; - signed = signed; - t = t; - _loc = _loc; - printer = printer; - } - -let string_of_t = function - | Int -> "int" - | String -> "string" - | Bitstring -> "bitstring" - -let patt_printer = function - | <:patt< $lid:id$ >> -> id - | _ -> "[pattern]" - -let expr_printer = function - | <:expr< $lid:id$ >> -> id - | _ -> "[expression]" - -let string_of_field { field = field; flen = flen; - endian = endian; signed = signed; t = t; - _loc = _loc; - printer = printer} = - let flen = - match expr_is_constant flen with - | Some i -> string_of_int i - | None -> "[non-const-len]" in - let endian = Bitmatch.string_of_endian endian in - let signed = if signed then "signed" else "unsigned" in - let t = string_of_t t in - let loc_fname = Loc.file_name _loc in - let loc_line = Loc.start_line _loc in - let loc_char = Loc.start_off _loc - Loc.start_bol _loc in + ) 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 - sprintf "%s : %s : %s, %s, %s @ (%S, %d, %d)" - (printer field) flen t endian signed loc_fname loc_line loc_char + field (* Generate the code for a constructor, ie. 'BITSTRING ...'. *) let output_constructor _loc fields = @@ -233,60 +193,96 @@ let output_constructor _loc fields = (* Convert each field to a simple bitstring-generating expression. *) let fields = List.map ( - fun {field=fexpr; flen=flen; endian=endian; signed=signed; - t=t; _loc=_loc} -> + 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 - 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. - *) + (* 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, _, _) -> "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, 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" + | (1, _, _) -> + <:expr> + | ((2|3|4|5|6|7|8), _, false) -> + <:expr> + | ((2|3|4|5|6|7|8), _, true) -> + <:expr> + | (i, P.ConstantEndian BigEndian, false) when i <= 31 -> + <:expr> + | (i, P.ConstantEndian BigEndian, true) when i <= 31 -> + <:expr> + | (i, P.ConstantEndian LittleEndian, false) when i <= 31 -> + <:expr> + | (i, P.ConstantEndian LittleEndian, true) when i <= 31 -> + <:expr> + | (i, P.ConstantEndian NativeEndian, false) when i <= 31 -> + <:expr> + | (i, P.ConstantEndian NativeEndian, true) when i <= 31 -> + <:expr> + | (i, P.EndianExpr expr, false) when i <= 31 -> + <:expr> + | (i, P.EndianExpr expr, true) when i <= 31 -> + <:expr> + | (32, P.ConstantEndian BigEndian, false) -> + <:expr> + | (32, P.ConstantEndian BigEndian, true) -> + <:expr> + | (32, P.ConstantEndian LittleEndian, false) -> + <:expr> + | (32, P.ConstantEndian LittleEndian, true) -> + <:expr> + | (32, P.ConstantEndian NativeEndian, false) -> + <:expr> + | (32, P.ConstantEndian NativeEndian, true) -> + <:expr> + | (32, P.EndianExpr expr, false) -> + <:expr> + | (32, P.EndianExpr expr, true) -> + <:expr> + | (_, P.ConstantEndian BigEndian, false) -> + <:expr> + | (_, P.ConstantEndian BigEndian, true) -> + <:expr> + | (_, P.ConstantEndian LittleEndian, false) -> + <:expr> + | (_, P.ConstantEndian LittleEndian, true) -> + <:expr> + | (_, P.ConstantEndian NativeEndian, false) -> + <:expr> + | (_, P.ConstantEndian NativeEndian, true) -> + <:expr> + | (_, P.EndianExpr expr, false) -> + <:expr> + | (_, P.EndianExpr expr, true) -> + <:expr> 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). - *) - | (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" + let int_construct = function + | (P.ConstantEndian BigEndian, false) -> + <:expr> + | (P.ConstantEndian BigEndian, true) -> + <:expr> + | (P.ConstantEndian LittleEndian, false) -> + <:expr> + | (P.ConstantEndian LittleEndian, true) -> + <:expr> + | (P.ConstantEndian NativeEndian, false) -> + <:expr> + | (P.ConstantEndian NativeEndian, true) -> + <:expr> + | (P.EndianExpr expr, false) -> + <:expr> + | (P.EndianExpr expr, true) -> + <:expr> in let expr = @@ -297,17 +293,15 @@ let output_constructor _loc fields = * 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 + | P.Int, Some i when i > 0 && i <= 64 -> + let construct_fn = int_construct_const (i,endian,signed) in exn_used := true; <:expr< - Bitmatch.$lid:construct_func$ $lid:buffer$ $fexpr$ $`int:i$ - $lid:exn$ + $construct_fn$ $lid:buffer$ $fexpr$ $`int:i$ $lid:exn$ >> - | Int, Some _ -> + | 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 @@ -317,14 +311,13 @@ let output_constructor _loc fields = * 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 + | P.Int, None -> + let construct_fn = 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$ + $construct_fn$ $lid:buffer$ $fexpr$ $flen$ $lid:exn$ else raise (Bitmatch.Construct_failure ("length of int field must be [1..64]", @@ -333,7 +326,7 @@ let output_constructor _loc fields = >> (* String, constant length > 0, must be a multiple of 8. *) - | String, Some i when i > 0 && i land 7 = 0 -> + | P.String, Some i when i > 0 && i land 7 = 0 -> let bs = gensym "bs" in let j = i lsr 3 in <:expr< @@ -350,20 +343,20 @@ let output_constructor _loc fields = (* String, constant length -1, means variable length string * with no checks. *) - | String, Some (-1) -> + | 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. *) - | String, Some _ -> + | P.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 -> + | P.String, None -> let bslen = gensym "bslen" in let bs = gensym "bs" in <:expr< @@ -391,7 +384,7 @@ let output_constructor _loc fields = >> (* Bitstring, constant length > 0. *) - | Bitstring, Some i when i > 0 -> + | P.Bitstring, Some i when i > 0 -> let bs = gensym "bs" in <:expr< let $lid:bs$ = $fexpr$ in @@ -407,13 +400,13 @@ let output_constructor _loc fields = (* Bitstring, constant length -1, means variable length bitstring * with no checks. *) - | Bitstring, Some (-1) -> + | 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, Some _ -> + | P.Bitstring, Some _ -> Loc.raise _loc (Failure "length of bitstring must be > 0 or the special value -1") @@ -422,7 +415,7 @@ let output_constructor _loc fields = * We check at runtime that the length is > 0 and matches * the declared length. *) - | Bitstring, None -> + | P.Bitstring, None -> let bslen = gensym "bslen" in let bs = gensym "bs" in <:expr< @@ -497,100 +490,130 @@ let output_bitmatch _loc bs cases = let rec output_field_extraction inner = function | [] -> inner | field :: fields -> - let {field=fpatt; flen=flen; endian=endian; signed=signed; - t=t; _loc=_loc} - = field in + 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 = expr_is_constant flen 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 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, 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" + | (1, _, _) -> + <:expr> + | ((2|3|4|5|6|7|8), _, false) -> + <:expr> + | ((2|3|4|5|6|7|8), _, true) -> + <:expr> + | (i, P.ConstantEndian BigEndian, false) when i <= 31 -> + <:expr> + | (i, P.ConstantEndian BigEndian, true) when i <= 31 -> + <:expr> + | (i, P.ConstantEndian LittleEndian, false) when i <= 31 -> + <:expr> + | (i, P.ConstantEndian LittleEndian, true) when i <= 31 -> + <:expr> + | (i, P.ConstantEndian NativeEndian, false) when i <= 31 -> + <:expr> + | (i, P.ConstantEndian NativeEndian, true) when i <= 31 -> + <:expr> + | (i, P.EndianExpr expr, false) when i <= 31 -> + <:expr> + | (i, P.EndianExpr expr, true) when i <= 31 -> + <:expr> + | (32, P.ConstantEndian BigEndian, false) -> + <:expr> + | (32, P.ConstantEndian BigEndian, true) -> + <:expr> + | (32, P.ConstantEndian LittleEndian, false) -> + <:expr> + | (32, P.ConstantEndian LittleEndian, true) -> + <:expr> + | (32, P.ConstantEndian NativeEndian, false) -> + <:expr> + | (32, P.ConstantEndian NativeEndian, true) -> + <:expr> + | (32, P.EndianExpr expr, false) -> + <:expr> + | (32, P.EndianExpr expr, true) -> + <:expr> + | (_, P.ConstantEndian BigEndian, false) -> + <:expr> + | (_, P.ConstantEndian BigEndian, true) -> + <:expr> + | (_, P.ConstantEndian LittleEndian, false) -> + <:expr> + | (_, P.ConstantEndian LittleEndian, true) -> + <:expr> + | (_, P.ConstantEndian NativeEndian, false) -> + <:expr> + | (_, P.ConstantEndian NativeEndian, true) -> + <:expr> + | (_, P.EndianExpr expr, false) -> + <:expr> + | (_, P.EndianExpr expr, true) -> + <: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). - *) - | (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" + let int_extract = function + | (P.ConstantEndian BigEndian, false) -> + <:expr> + | (P.ConstantEndian BigEndian, true) -> + <:expr> + | (P.ConstantEndian LittleEndian, false) -> + <:expr> + | (P.ConstantEndian LittleEndian, true) -> + <:expr> + | (P.ConstantEndian NativeEndian, false) -> + <:expr> + | (P.ConstantEndian NativeEndian, true) -> + <:expr> + | (P.EndianExpr expr, false) -> + <:expr> + | (P.EndianExpr expr, true) -> + <: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$ >= $`int:i$ then ( let $lid:v$, $lid:off$, $lid:len$ = - Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$ - $`int:i$ in + $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:v$, $lid:off$, $lid:len$ = - Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$ - $flen$ in + $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $flen$ in match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> () ) >> (* String, constant flen > 0. *) - | String, Some i when i > 0 && i land 7 = 0 -> + | P.String, Some i when i > 0 && i land 7 = 0 -> let bs = gensym "bs" in <:expr< if $lid:len$ >= $`int:i$ then ( @@ -606,7 +629,7 @@ let output_bitmatch _loc bs cases = (* String, constant flen = -1, means consume all the * rest of the input. *) - | String, Some i when i = -1 -> + | P.String, Some i when i = -1 -> let bs = gensym "bs" in <:expr< let $lid:bs$, $lid:off$, $lid:len$ = @@ -616,13 +639,13 @@ let output_bitmatch _loc bs cases = | _ -> () >> - | String, Some _ -> + | 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. *) - | String, None -> + | P.String, None -> let bs = gensym "bs" in <:expr< if $flen$ >= 0 && $flen$ <= $lid:len$ @@ -640,7 +663,7 @@ let output_bitmatch _loc bs cases = * At the moment all we can do is assign the bitstring to an * identifier. *) - | Bitstring, Some i when i >= 0 -> + | P.Bitstring, Some i when i >= 0 -> let ident = match fpatt with | <:patt< $lid:ident$ >> -> ident @@ -660,7 +683,7 @@ let output_bitmatch _loc bs cases = (* 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 @@ -674,13 +697,13 @@ let output_bitmatch _loc bs cases = $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 @@ -701,7 +724,7 @@ let output_bitmatch _loc bs cases = (* Emit extra debugging code. *) let expr = if not debug then expr else ( - let field = string_of_field field in + let field = P.string_of_field field in <:expr< if !Bitmatch.debug then ( @@ -778,15 +801,25 @@ let output_bitmatch _loc bs cases = 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 used in the bitmatch operator (a pattern). *) patt_field: [ [ fpatt = patt; ":"; len = expr LEVEL "top"; qs = OPT [ ":"; qs = qualifiers -> qs ] -> - parse_field _loc fpatt len qs patt_printer + 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 ] ]; @@ -806,7 +839,10 @@ EXTEND Gram constr_field: [ [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top"; qs = OPT [ ":"; qs = qualifiers -> qs ] -> - parse_field _loc fexpr len qs expr_printer + 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 ] ];