+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
+
+ sprintf "%s : %s : %s, %s, %s @ (%S, %d, %d)"
+ (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 =
+ 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 {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 = 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.
+ *)
+ (* 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"
+ 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"
+ 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
+