* 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.
+ * version 2 of the License, or (at your option) any later version,
+ * with the OCaml linking exception described in COPYING.LIB.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
(* 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
+ (* This function makes code to raise a Bitmatch.Construct_failure exception
+ * containing a message and the current _loc context.
+ * (Thanks to Bluestorm for suggesting this).
+ *)
+ let construct_failure _loc msg =
+ <:expr<
+ Bitmatch.Construct_failure
+ ($`str:msg$,
+ $`str:Loc.file_name _loc$,
+ $`int:Loc.start_line _loc$,
+ $`int:Loc.start_off _loc - Loc.start_bol _loc$)
+ >>
+ in
+ let raise_construct_failure _loc msg =
+ <:expr< raise $construct_failure _loc msg$ >>
+ in
(* Bitstrings are created like the 'Buffer' module (in fact, using
* the Buffer module), by appending snippets to a growing buffer.
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$))
+ $raise_construct_failure _loc "length of int field must be [1..64]"$
>>
(* String, constant length > 0, must be a multiple of 8. *)
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$))
+ $raise_construct_failure _loc "length of string does not match declaration"$
>>
(* String, constant length -1, means variable length string
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$))
+ $raise_construct_failure _loc "length of string does not match declaration"$
) else
- raise (Bitmatch.Construct_failure
- ("length of string must be a multiple of 8",
- $str:loc_fname$,
- $int:loc_line$, $int:loc_char$))
+ $raise_construct_failure _loc "length of string must be a multiple of 8"$
) else
- raise (Bitmatch.Construct_failure
- ("length of string must be > 0",
- $str:loc_fname$,
- $int:loc_line$, $int:loc_char$))
+ $raise_construct_failure _loc "length of string must be > 0"$
>>
(* Bitstring, constant length >= 0. *)
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$))
+ $raise_construct_failure _loc "length of bitstring does not match declaration"$
>>
(* Bitstring, constant length -1, means variable length bitstring
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$))
+ $raise_construct_failure _loc "length of bitstring does not match declaration"$
) else
- raise (Bitmatch.Construct_failure
- ("length of bitstring must be > 0",
- $str:loc_fname$,
- $int:loc_line$, $int:loc_char$))
+ $raise_construct_failure _loc "length of bitstring must be > 0"$
>> in
expr
) fields 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$
+ let $lid:exn$ = $construct_failure _loc "value out of range"$ in
+ $expr$
>>
else
expr
* the list of cases to test against.
*)
let output_bitmatch _loc bs cases =
- let data = gensym "data" and off = gensym "off" and len = gensym "len" in
- let result = gensym "result" in
+ (* These symbols are used through the generated code to record our
+ * current position within the bitstring:
+ *
+ * data - original bitstring data (string, never changes)
+ *
+ * off - current offset within data (int, increments as we move through
+ * the bitstring)
+ * len - current remaining length within data (int, decrements as
+ * we move through the bitstring)
+ *
+ * original_off - saved offset at the start of the match (never changes)
+ * original_len - saved length at the start of the match (never changes)
+ *)
+ let data = gensym "data"
+ and off = gensym "off"
+ and len = gensym "len"
+ and original_off = gensym "original_off"
+ and original_len = gensym "original_len"
+ (* This is where the result will be stored (a reference). *)
+ and result = gensym "result" in
(* This generates the field extraction code for each
* field in a single case. There must be enough remaining data
* As we go through the fields, symbols 'data', 'off' and 'len'
* track our position and remaining length in the bitstring.
*
- * The whole thing is a lot of nested 'if' statements. Code
- * is generated from the inner-most (last) field outwards.
+ * The whole thing is a lot of nested 'if'/'match' statements.
+ * Code is generated from the inner-most (last) field outwards.
*)
let rec output_field_extraction inner = function
| [] -> inner
| _ ->
let move = gensym "move" in
<:expr<
- let $lid:move$ = $offset_expr$ - $lid:off$ in
+ let $lid:move$ =
+ $offset_expr$ - ($lid:off$ - $lid:original_off$) in
if $lid:move$ >= 0 then (
let $lid:off$ = $lid:off$ + $lid:move$ in
let $lid:len$ = $lid:len$ - $lid:move$ in
let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
<:expr<
- let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
+ (* Note we save the original offset/length at the start of the match
+ * in 'original_off'/'original_len' symbols. 'data' never changes.
+ *)
+ let ($lid:data$, $lid:original_off$, $lid:original_len$) = $bs$ in
+ let $lid:off$ = $lid:original_off$ and $lid:len$ = $lid:original_len$ in
let $lid:result$ = ref None in
(try
$cases$
let names = List.rev !names in
List.iter (
function
- | name, P.Pattern patt -> add_named_pattern _loc name patt
+ | name, P.Pattern patt ->
+ if patt = [] then
+ locfail _loc (sprintf "pattern %s: no fields" name);
+ add_named_pattern _loc name patt
| _, P.Constructor _ -> () (* just ignore these for now *)
) names
git.annexia.org / ocaml-bitstring.git / blobdiff