From: Richard W.M. Jones Date: Thu, 17 Jul 2008 11:56:05 +0000 (+0000) Subject: Implement check() and bind() qualifiers. X-Git-Url: http://git.annexia.org/?a=commitdiff_plain;h=e7ab5952e9a51128b17ff2a054f2cfb9bb3baba4;p=ocaml-bitstring.git Implement check() and bind() qualifiers. - Previously check() was called when(). --- diff --git a/bitmatch.mli b/bitmatch.mli index fbecf8a..800cadd 100644 --- a/bitmatch.mli +++ b/bitmatch.mli @@ -446,24 +446,29 @@ bitmatch bits with Note that moving the offset backwards, and moving the offset in [BITSTRING] constructors, are both not supported at present. - {3 When-qualifiers} + {3 Check expressions} - You can add a [when(expr)] qualifier to bitmatch patterns. - If the expression evaluates to false then the current match case fails. + You can add a [check(expr)] qualifier to bitmatch patterns. + If the expression evaluates to false then the current match case + fails to match (in other words, we fall through to the next + match case - there is no error). For example: {[ bitmatch bits with -| { field : 16 : when (field > 100) } -> ... +| { field : 16 : check (field > 100) } -> ... ]} - Note the difference between a when-qualifier and a when-clause + Note the difference between a check expression and a when-clause is that the when-clause is evaluated after all the fields have - been matched. On the other hand a when-qualifier is evaluated + been matched. On the other hand a check expression is evaluated after the individual field has been matched, which means it is - potentially more efficient (if the when-qualifier fails then + potentially more efficient (if the check expression fails then we don't waste any time matching later fields). + We wanted to use the notation [when(expr)] here, but because + [when] is a reserved word we could not do this. + {3 Bind expressions} A bind expression is used to change the value of a matched @@ -488,22 +493,22 @@ bitmatch bits with (* remaining fields *) ]} - {3 Order of evaluation of when() and bind()} + {3 Order of evaluation of check() and bind()} - The choice is arbitrary, but we have chosen that when-qualifiers + The choice is arbitrary, but we have chosen that check expressions are evaluated first, and bind expressions are evaluated after. This means that the result of bind() is {i not} available in - the when-qualifier. + the check expression. - Note that this rule applies whatever order the when() and bind() - appear in the source code. + Note that this rule applies regardless of the order of check() + and bind() in the source code. {3 save_offset_to} Use [save_offset_to(variable)] to save the current bit offset within the match to a variable (strictly speaking, to a pattern). - This variable is then made available in any [when()] and [bind()] + This variable is then made available in any [check()] and [bind()] clauses in the current field, {i and} to any later fields, and to the code after the [->]. diff --git a/bitmatch_persistent.ml b/bitmatch_persistent.ml index 3413800..c848e36 100644 --- a/bitmatch_persistent.ml +++ b/bitmatch_persistent.ml @@ -40,7 +40,7 @@ type 'a field = { t : field_type; (* type *) _loc : Loc.t; (* location in source code *) offset : expr option; (* offset expression *) - when_ : expr option; (* when qualifier [patterns only] *) + check : expr option; (* check expression [patterns only] *) bind : expr option; (* bind expression [patterns only] *) save_offset_to : patt option; (* save_offset_to [patterns only] *) } @@ -112,7 +112,7 @@ let expr_printer = function let _string_of_field { flen = flen; endian = endian; signed = signed; t = t; _loc = _loc; - offset = offset; when_ = when_; bind = bind; + offset = offset; check = check; bind = bind; save_offset_to = save_offset_to } = let flen = match expr_is_constant flen with @@ -133,10 +133,10 @@ let _string_of_field { flen = flen; | Some i -> sprintf ", offset(%d)" i | None -> sprintf ", offset([expr])" in - let when_ = - match when_ with + let check = + match check with | None -> "" - | Some expr -> sprintf ", when([expr])" in + | Some expr -> sprintf ", check([expr])" in let bind = match bind with @@ -156,7 +156,7 @@ let _string_of_field { flen = flen; let loc_char = Loc.start_off _loc - Loc.start_bol _loc in sprintf "%s : %s, %s, %s%s%s%s%s (* %S:%d %d *)" - flen t endian signed offset when_ bind save_offset_to + flen t endian signed offset check bind save_offset_to loc_fname loc_line loc_char let rec string_of_pattern_field ({ field = patt } as field) = @@ -194,7 +194,7 @@ let create_pattern_field _loc = t = Int; _loc = _loc; offset = None; - when_ = None; + check = None; bind = None; save_offset_to = None; } @@ -228,8 +228,8 @@ let set_offset_int field i = { field with offset = Some <:expr< $`int:i$ >> } let set_offset field expr = { field with offset = Some expr } let set_no_offset field = { field with offset = None } -let set_when field expr = { field with when_ = Some expr } -let set_no_when field = { field with when_ = None } +let set_check field expr = { field with check = Some expr } +let set_no_check field = { field with check = None } let set_bind field expr = { field with bind = Some expr } let set_no_bind field = { field with bind = None } let set_save_offset_to field patt = { field with save_offset_to = Some patt } @@ -247,7 +247,7 @@ let create_constructor_field _loc = t = Int; _loc = _loc; offset = None; - when_ = None; + check = None; bind = None; save_offset_to = None; } @@ -273,6 +273,6 @@ let get_signed field = field.signed let get_type field = field.t let get_location field = field._loc let get_offset field = field.offset -let get_when field = field.when_ +let get_check field = field.check let get_bind field = field.bind let get_save_offset_to field = field.save_offset_to diff --git a/bitmatch_persistent.mli b/bitmatch_persistent.mli index 7374632..9c12d99 100644 --- a/bitmatch_persistent.mli +++ b/bitmatch_persistent.mli @@ -441,11 +441,11 @@ val set_no_offset : 'a field -> 'a field follow the previous field, or if it is the first field will be at offset zero. *) -val set_when : 'a field -> expr -> 'a field -(** Set the when-expression for a field to the given expression. *) +val set_check : 'a field -> expr -> 'a field +(** Set the check expression for a field to the given expression. *) -val set_no_when : 'a field -> 'a field -(** Remove the when-expression from a field. *) +val set_no_check : 'a field -> 'a field +(** Remove the check expression from a field. *) val set_bind : 'a field -> expr -> 'a field (** Set the bind-expression for a field to the given expression. *) @@ -529,8 +529,8 @@ val get_location : 'a field -> loc_t val get_offset : 'a field -> expr option (** Get the offset expression of a field, or [None] if there is none. *) -val get_when : 'a field -> expr option -(** Get the when expression of a field, or [None] if there is none. *) +val get_check : 'a field -> expr option +(** Get the check expression of a field, or [None] if there is none. *) val get_bind : 'a field -> expr option (** Get the bind expression of a field, or [None] if there is none. *) diff --git a/pa_bitmatch.ml b/pa_bitmatch.ml index 58290ca..d7f28ff 100644 --- a/pa_bitmatch.ml +++ b/pa_bitmatch.ml @@ -72,12 +72,12 @@ let gensym = (* Used to keep track of which qualifiers we've seen in parse_field. *) type whatset_t = { endian_set : bool; signed_set : bool; type_set : bool; - offset_set : bool; when_set : bool; bind_set : bool; + offset_set : bool; check_set : bool; bind_set : bool; save_offset_to_set : bool; } let noneset = { endian_set = false; signed_set = false; type_set = false; - offset_set = false; when_set = false; bind_set = false; + offset_set = false; check_set = false; bind_set = false; save_offset_to_set = false } @@ -104,12 +104,12 @@ let parse_field _loc field qs = { whatset with offset_set = true }, field | "offset", None -> fail "qualifier 'offset' should be followed by an expression" - | "when", Some expr -> - check whatset.when_set "a when-qualifier has been set already"; - let field = P.set_when field expr in - { whatset with when_set = true }, field - | "when", None -> - fail "qualifier 'when' should be followed by an expression" + | "check", Some expr -> + check whatset.check_set "a check-qualifier has been set already"; + let field = P.set_check field expr in + { whatset with check_set = true }, field + | "check", None -> + fail "qualifier 'check' should be followed by an expression" | "bind", Some expr -> check whatset.bind_set "a bind expression has been set already"; let field = P.set_bind field expr in @@ -247,7 +247,7 @@ let output_constructor _loc fields = let fail = locfail _loc in - (* offset(), when(), bind(), save_offset_to() not supported in + (* offset(), check(), bind(), save_offset_to() not supported in * constructors. * * Implementation of forward-only offsets is fairly @@ -258,8 +258,8 @@ let output_constructor _loc fields = *) if P.get_offset field <> None then fail "offset expressions are not supported in BITSTRING constructors"; - if P.get_when field <> None then - fail "when expressions are not supported in BITSTRING constructors"; + if P.get_check field <> None then + fail "check expressions are not supported in BITSTRING constructors"; if P.get_bind field <> None then fail "bind expressions are not supported in BITSTRING constructors"; if P.get_save_offset_to field <> None then @@ -482,6 +482,29 @@ let output_bitmatch _loc bs cases = *) let flen_is_const = expr_is_constant flen in + (* Surround the inner expression by check and bind clauses, so: + * if $check$ then + * let $bind...$ in + * $inner$ + * where the check and bind are switched on only if they are + * present in the field. (In the common case when neither + * clause is present, expr = inner). Note the order of the + * check & bind is visible to the user and defined in the + * documentation, so it must not change. + *) + let expr = inner in + let expr = + match P.get_bind field with + | None -> expr + | Some bind_expr -> + <:expr< let $fpatt$ = $bind_expr$ in $expr$ >> in + let expr = + match P.get_check field with + | None -> expr + | Some check_expr -> + <:expr< if $check_expr$ then $expr$ >> in + + (* Now build the code which matches a field. *) let int_extract_const (i, endian, signed) = build_bitmatch_call _loc "extract" (Some i) endian signed in let int_extract (endian, signed) = @@ -497,7 +520,7 @@ let output_bitmatch _loc bs cases = 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$ | _ -> () + match $lid:v$ with $fpatt$ when true -> $expr$ | _ -> () ) >> @@ -515,7 +538,7 @@ let output_bitmatch _loc bs cases = 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$ | _ -> () + match $lid:v$ with $fpatt$ when true -> $expr$ | _ -> () ) >> @@ -528,7 +551,7 @@ let output_bitmatch _loc bs cases = Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$ $`int:i$ in match Bitmatch.string_of_bitstring $lid:bs$ with - | $fpatt$ when true -> $inner$ + | $fpatt$ when true -> $expr$ | _ -> () ) >> @@ -542,7 +565,7 @@ let output_bitmatch _loc bs cases = 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$ + | $fpatt$ when true -> $expr$ | _ -> () >> @@ -561,7 +584,7 @@ let output_bitmatch _loc bs cases = Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$ $flen$ in match Bitmatch.string_of_bitstring $lid:bs$ with - | $fpatt$ when true -> $inner$ + | $fpatt$ when true -> $expr$ | _ -> () ) >> @@ -582,7 +605,7 @@ let output_bitmatch _loc bs cases = let $lid:ident$, $lid:off$, $lid:len$ = Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$ $`int:i$ in - $inner$ + $expr$ ) >> @@ -599,7 +622,7 @@ let output_bitmatch _loc bs cases = <:expr< let $lid:ident$, $lid:off$, $lid:len$ = Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in - $inner$ + $expr$ >> | P.Bitstring, Some _ -> @@ -620,7 +643,7 @@ let output_bitmatch _loc bs cases = let $lid:ident$, $lid:off$, $lid:len$ = Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$ $flen$ in - $inner$ + $expr$ ) >> in diff --git a/tests/70_check_and_bind.ml b/tests/70_check_and_bind.ml new file mode 100644 index 0000000..14ad836 --- /dev/null +++ b/tests/70_check_and_bind.ml @@ -0,0 +1,17 @@ +(* Test check() and bind(). + * $Id$ + *) + +open Printf +open Bitmatch + +let bits = (BITSTRING { 101 : 16; 202 : 16 }) + +let () = + bitmatch bits with + | { i : 16 : check (i > 100), bind (i*4); + j : 16 : check (j > 200) } -> + if i <> 404 || j <> 202 then + failwith (sprintf "70_check_and_bind: failed: %d %d" i j) + | { _ } -> + failwith "70_check_and_bind: match failed"