+ | s, Some _ ->
+ fail (s ^ ": unknown qualifier, or qualifier should not be followed by an expression")
+ | s, None ->
+ fail (s ^ ": unknown qualifier, or qualifier should be followed by an expression")
+ ) (false, 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.
+ *)
+ let () =
+ let t = P.get_type field in
+ if (t = P.Bitstring || t = P.String) && (endian_set || signed_set) then
+ fail "string types and endian or signed qualifiers cannot be mixed" 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
+
+ field
+
+(* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
+let output_constructor _loc fields =
+ let fail = locfail _loc in
+
+ 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 ->
+ 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
+ let offset = P.get_offset field in
+
+ (* offset() not supported in constructors. Implementation of
+ * forward-only offsets is fairly straightforward: we would
+ * need to just calculate the length of padding here and add
+ * it to what has been constructed. For general offsets,
+ * including going backwards, that would require a rethink in
+ * how we construct bitstrings.
+ *)
+ if offset <> None then
+ fail "offset expressions are not supported in BITSTRING constructors";
+
+ (* 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
+
+ (* 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, _, _) ->
+ <:expr<Bitmatch.construct_bit>>
+ | ((2|3|4|5|6|7|8), _, false) ->
+ <:expr<Bitmatch.construct_char_unsigned>>
+ | ((2|3|4|5|6|7|8), _, true) ->
+ <:expr<Bitmatch.construct_char_signed>>
+ | (i, P.ConstantEndian BigEndian, false) when i <= 31 ->
+ <:expr<Bitmatch.construct_int_be_unsigned>>
+ | (i, P.ConstantEndian BigEndian, true) when i <= 31 ->
+ <:expr<Bitmatch.construct_int_be_signed>>
+ | (i, P.ConstantEndian LittleEndian, false) when i <= 31 ->
+ <:expr<Bitmatch.construct_int_le_unsigned>>
+ | (i, P.ConstantEndian LittleEndian, true) when i <= 31 ->
+ <:expr<Bitmatch.construct_int_le_signed>>
+ | (i, P.ConstantEndian NativeEndian, false) when i <= 31 ->
+ <:expr<Bitmatch.construct_int_ne_unsigned>>
+ | (i, P.ConstantEndian NativeEndian, true) when i <= 31 ->
+ <:expr<Bitmatch.construct_int_ne_signed>>
+ | (i, P.EndianExpr expr, false) when i <= 31 ->
+ <:expr<Bitmatch.construct_int_ee_unsigned $expr$>>
+ | (i, P.EndianExpr expr, true) when i <= 31 ->
+ <:expr<Bitmatch.construct_int_ee_signed $expr$>>
+ | (32, P.ConstantEndian BigEndian, false) ->
+ <:expr<Bitmatch.construct_int32_be_unsigned>>
+ | (32, P.ConstantEndian BigEndian, true) ->
+ <:expr<Bitmatch.construct_int32_be_signed>>
+ | (32, P.ConstantEndian LittleEndian, false) ->
+ <:expr<Bitmatch.construct_int32_le_unsigned>>
+ | (32, P.ConstantEndian LittleEndian, true) ->
+ <:expr<Bitmatch.construct_int32_le_signed>>
+ | (32, P.ConstantEndian NativeEndian, false) ->
+ <:expr<Bitmatch.construct_int32_ne_unsigned>>
+ | (32, P.ConstantEndian NativeEndian, true) ->
+ <:expr<Bitmatch.construct_int32_ne_signed>>
+ | (32, P.EndianExpr expr, false) ->
+ <:expr<Bitmatch.construct_int32_ee_unsigned $expr$>>
+ | (32, P.EndianExpr expr, true) ->
+ <:expr<Bitmatch.construct_int32_ee_signed $expr$>>
+ | (_, P.ConstantEndian BigEndian, false) ->
+ <:expr<Bitmatch.construct_int64_be_unsigned>>
+ | (_, P.ConstantEndian BigEndian, true) ->
+ <:expr<Bitmatch.construct_int64_be_signed>>
+ | (_, P.ConstantEndian LittleEndian, false) ->
+ <:expr<Bitmatch.construct_int64_le_unsigned>>
+ | (_, P.ConstantEndian LittleEndian, true) ->
+ <:expr<Bitmatch.construct_int64_le_signed>>
+ | (_, P.ConstantEndian NativeEndian, false) ->
+ <:expr<Bitmatch.construct_int64_ne_unsigned>>
+ | (_, P.ConstantEndian NativeEndian, true) ->
+ <:expr<Bitmatch.construct_int64_ne_signed>>
+ | (_, P.EndianExpr expr, false) ->
+ <:expr<Bitmatch.construct_int64_ee_unsigned $expr$>>
+ | (_, P.EndianExpr expr, true) ->
+ <:expr<Bitmatch.construct_int64_ee_signed $expr$>>
+ in
+ let int_construct = function
+ | (P.ConstantEndian BigEndian, false) ->
+ <:expr<Bitmatch.construct_int64_be_unsigned>>
+ | (P.ConstantEndian BigEndian, true) ->
+ <:expr<Bitmatch.construct_int64_be_signed>>
+ | (P.ConstantEndian LittleEndian, false) ->
+ <:expr<Bitmatch.construct_int64_le_unsigned>>
+ | (P.ConstantEndian LittleEndian, true) ->
+ <:expr<Bitmatch.construct_int64_le_signed>>
+ | (P.ConstantEndian NativeEndian, false) ->
+ <:expr<Bitmatch.construct_int64_ne_unsigned>>
+ | (P.ConstantEndian NativeEndian, true) ->
+ <:expr<Bitmatch.construct_int64_ne_signed>>
+ | (P.EndianExpr expr, false) ->
+ <:expr<Bitmatch.construct_int64_ee_unsigned $expr$>>
+ | (P.EndianExpr expr, true) ->
+ <:expr<Bitmatch.construct_int64_ee_signed $expr$>>
+ in