* expressions such as [k], [k+c], [k-c] etc.
*)
let rec expr_is_constant = function
- | <:expr< $int:i$ >> -> (* Literal integer constant. *)
+ | <:expr< $int:i$ >> -> (* Literal integer constant. *)
Some (int_of_string i)
- | <:expr< $a$ + $b$ >> -> (* Addition of constants. *)
+ | <:expr< $lid:op$ $a$ $b$ >> ->
(match expr_is_constant a, expr_is_constant b with
- | Some a, Some b -> Some (a+b)
+ | Some a, Some b -> (* Integer binary operations. *)
+ let ops = ["+", (+); "-", (-); "*", ( * ); "/", (/);
+ "land", (land); "lor", (lor); "lxor", (lxor);
+ "lsl", (lsl); "lsr", (lsr); "asr", (asr);
+ "mod", (mod)] in
+ (try Some ((List.assoc op ops) a b) with Not_found -> None)
| _ -> None)
- | <:expr< $a$ - $b$ >> -> (* Subtraction. *)
- (match expr_is_constant a, expr_is_constant b with
- | Some a, Some b -> Some (a-b)
- | _ -> None)
- | <:expr< $a$ * $b$ >> -> (* Multiplication. *)
- (match expr_is_constant a, expr_is_constant b with
- | Some a, Some b -> Some (a*b)
- | _ -> None)
- | <:expr< $a$ / $b$ >> -> (* Division. *)
- (match expr_is_constant a, expr_is_constant b with
- | Some a, Some b -> Some (a/b)
- | _ -> None)
- | <:expr< $a$ lsl $b$ >> -> (* Shift left. *)
- (match expr_is_constant a, expr_is_constant b with
- | Some a, Some b -> Some (a lsl b)
- | _ -> None)
- | <:expr< $a$ lsr $b$ >> -> (* Shift right. *)
- (match expr_is_constant a, expr_is_constant b with
- | Some a, Some b -> Some (a lsr b)
- | _ -> None)
- | _ -> None (* Anything else is not constant. *)
+ | _ -> None
(* Generate a fresh, unique symbol each time called. *)
let gensym =
match qs with
| None -> (false, false, false, false, field)
| Some qs ->
- List.fold_left (
- fun (endian_set, signed_set, type_set, offset_set, field) qual_expr ->
- match qual_expr with
- | "bigendian", None ->
- if endian_set then
- fail "an endian flag has been set already"
- else (
- let field = P.set_endian field BigEndian in
- (true, signed_set, type_set, offset_set, field)
- )
- | "littleendian", None ->
- if endian_set then
- fail "an endian flag has been set already"
- else (
- let field = P.set_endian field LittleEndian in
- (true, signed_set, type_set, offset_set, field)
- )
- | "nativeendian", None ->
- if endian_set then
- fail "an endian flag has been set already"
- else (
- let field = P.set_endian field NativeEndian in
- (true, signed_set, type_set, offset_set, field)
- )
- | "endian", Some expr ->
- if endian_set then
- fail "an endian flag has been set already"
- else (
- let field = P.set_endian_expr field expr in
- (true, signed_set, type_set, offset_set, field)
- )
- | "signed", None ->
- if signed_set then
- fail "a signed flag has been set already"
- else (
- let field = P.set_signed field true in
- (endian_set, true, type_set, offset_set, field)
- )
- | "unsigned", None ->
- if signed_set then
- fail "a signed flag has been set already"
- else (
- let field = P.set_signed field false in
- (endian_set, true, type_set, offset_set, field)
- )
- | "int", None ->
- if type_set then
- fail "a type flag has been set already"
- else (
- let field = P.set_type_int field in
- (endian_set, signed_set, true, offset_set, field)
- )
- | "string", None ->
- if type_set then
- fail "a type flag has been set already"
- else (
- let field = P.set_type_string field in
- (endian_set, signed_set, true, offset_set, field)
- )
- | "bitstring", None ->
- if type_set then
- fail "a type flag has been set already"
- else (
- let field = P.set_type_bitstring field in
- (endian_set, signed_set, true, offset_set, field)
- )
- | "offset", Some expr ->
- if offset_set then
- fail "an offset has been set already"
- else (
- let field = P.set_offset field expr in
- (endian_set, signed_set, type_set, true, field)
- )
- | 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
+ let check already_set msg = if already_set then fail msg in
+ let apply_qualifier
+ (endian_set, signed_set, type_set, offset_set, field) =
+ function
+ | "endian", Some expr ->
+ check endian_set "an endian flag has been set already";
+ let field = P.set_endian_expr field expr in
+ (true, signed_set, type_set, offset_set, field)
+ | "endian", None ->
+ fail "qualifier 'endian' should be followed by an expression"
+ | "offset", Some expr ->
+ check offset_set "an offset has been set already";
+ let field = P.set_offset field expr in
+ (endian_set, signed_set, type_set, true, field)
+ | "offset", None ->
+ fail "qualifier 'offset' should be followed by an expression"
+ | s, Some _ ->
+ fail (s ^ ": unknown qualifier, or qualifier should not be followed by an expression")
+ | qual, None ->
+ let endian_quals = ["bigendian", BigEndian;
+ "littleendian", LittleEndian;
+ "nativeendian", NativeEndian] in
+ let sign_quals = ["signed", true; "unsigned", false] in
+ let type_quals = ["int", P.set_type_int;
+ "string", P.set_type_string;
+ "bitstring", P.set_type_bitstring] in
+ if List.mem_assoc qual endian_quals then (
+ check endian_set "an endian flag has been set already";
+ let field = P.set_endian field (List.assoc qual endian_quals) in
+ (true, signed_set, type_set, offset_set, field)
+ ) else if List.mem_assoc qual sign_quals then (
+ check signed_set "a signed flag has been set already";
+ let field = P.set_signed field (List.assoc qual sign_quals) in
+ (endian_set, true, type_set, offset_set, field)
+ ) else if List.mem_assoc qual type_quals then (
+ check type_set "a type flag has been set already";
+ let field = List.assoc qual type_quals field in
+ (endian_set, signed_set, true, offset_set, field)
+ ) else
+ fail (qual ^ ": unknown qualifier, or qualifier should be followed by an expression") in
+ List.fold_left apply_qualifier (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.
field
+(* Choose the right constructor function. *)
+let build_bitmatch_call _loc funcname length endian signed =
+ match length, endian, signed with
+ (* XXX The meaning of signed/unsigned breaks down at
+ * 31, 32, 63 and 64 bits.
+ *)
+ | (Some 1, _, _) -> <:expr<Bitmatch.$lid:funcname ^ "_bit"$ >>
+ | (Some (2|3|4|5|6|7|8), _, sign) ->
+ let call = Printf.sprintf "%s_char_%s"
+ funcname (if sign then "signed" else "unsigned") in
+ <:expr< Bitmatch.$lid:call$ >>
+ | (len, endian, signed) ->
+ let t = match len with
+ | Some i when i <= 31 -> "int"
+ | Some 32 -> "int32"
+ | _ -> "int64" in
+ let sign = if signed then "signed" else "unsigned" in
+ match endian with
+ | P.ConstantEndian constant ->
+ let endianness = match constant with
+ | BigEndian -> "be"
+ | LittleEndian -> "le"
+ | NativeEndian -> "ne" in
+ let call = Printf.sprintf "%s_%s_%s_%s"
+ funcname t endianness sign in
+ <:expr< Bitmatch.$lid:call$ >>
+ | P.EndianExpr expr ->
+ let call = Printf.sprintf "%s_%s_%s_%s"
+ funcname t "ee" sign in
+ <:expr< Bitmatch.$lid:call$ $expr$ >>
+
(* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
let output_constructor _loc fields =
let fail = locfail _loc in
*)
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
+ let int_construct_const (i, endian, signed) =
+ build_bitmatch_call _loc "construct" (Some i) endian signed in
+ let int_construct (endian, signed) =
+ build_bitmatch_call _loc "construct" None endian signed in
let expr =
match t, flen_is_const with
*)
let flen_is_const = expr_is_constant flen in
- let int_extract_const = function
- (* XXX The meaning of signed/unsigned breaks down at
- * 31, 32, 63 and 64 bits.
- *)
- | (1, _, _) ->
- <:expr<Bitmatch.extract_bit>>
- | ((2|3|4|5|6|7|8), _, false) ->
- <:expr<Bitmatch.extract_char_unsigned>>
- | ((2|3|4|5|6|7|8), _, true) ->
- <:expr<Bitmatch.extract_char_signed>>
- | (i, P.ConstantEndian BigEndian, false) when i <= 31 ->
- <:expr<Bitmatch.extract_int_be_unsigned>>
- | (i, P.ConstantEndian BigEndian, true) when i <= 31 ->
- <:expr<Bitmatch.extract_int_be_signed>>
- | (i, P.ConstantEndian LittleEndian, false) when i <= 31 ->
- <:expr<Bitmatch.extract_int_le_unsigned>>
- | (i, P.ConstantEndian LittleEndian, true) when i <= 31 ->
- <:expr<Bitmatch.extract_int_le_signed>>
- | (i, P.ConstantEndian NativeEndian, false) when i <= 31 ->
- <:expr<Bitmatch.extract_int_ne_unsigned>>
- | (i, P.ConstantEndian NativeEndian, true) when i <= 31 ->
- <:expr<Bitmatch.extract_int_ne_signed>>
- | (i, P.EndianExpr expr, false) when i <= 31 ->
- <:expr<Bitmatch.extract_int_ee_unsigned $expr$>>
- | (i, P.EndianExpr expr, true) when i <= 31 ->
- <:expr<Bitmatch.extract_int_ee_signed $expr$>>
- | (32, P.ConstantEndian BigEndian, false) ->
- <:expr<Bitmatch.extract_int32_be_unsigned>>
- | (32, P.ConstantEndian BigEndian, true) ->
- <:expr<Bitmatch.extract_int32_be_signed>>
- | (32, P.ConstantEndian LittleEndian, false) ->
- <:expr<Bitmatch.extract_int32_le_unsigned>>
- | (32, P.ConstantEndian LittleEndian, true) ->
- <:expr<Bitmatch.extract_int32_le_signed>>
- | (32, P.ConstantEndian NativeEndian, false) ->
- <:expr<Bitmatch.extract_int32_ne_unsigned>>
- | (32, P.ConstantEndian NativeEndian, true) ->
- <:expr<Bitmatch.extract_int32_ne_signed>>
- | (32, P.EndianExpr expr, false) ->
- <:expr<Bitmatch.extract_int32_ee_unsigned $expr$>>
- | (32, P.EndianExpr expr, true) ->
- <:expr<Bitmatch.extract_int32_ee_signed $expr$>>
- | (_, P.ConstantEndian BigEndian, false) ->
- <:expr<Bitmatch.extract_int64_be_unsigned>>
- | (_, P.ConstantEndian BigEndian, true) ->
- <:expr<Bitmatch.extract_int64_be_signed>>
- | (_, P.ConstantEndian LittleEndian, false) ->
- <:expr<Bitmatch.extract_int64_le_unsigned>>
- | (_, P.ConstantEndian LittleEndian, true) ->
- <:expr<Bitmatch.extract_int64_le_signed>>
- | (_, P.ConstantEndian NativeEndian, false) ->
- <:expr<Bitmatch.extract_int64_ne_unsigned>>
- | (_, P.ConstantEndian NativeEndian, true) ->
- <:expr<Bitmatch.extract_int64_ne_signed>>
- | (_, P.EndianExpr expr, false) ->
- <:expr<Bitmatch.extract_int64_ee_unsigned $expr$>>
- | (_, P.EndianExpr expr, true) ->
- <:expr<Bitmatch.extract_int64_ee_signed $expr$>>
- in
- let int_extract = function
- | (P.ConstantEndian BigEndian, false) ->
- <:expr<Bitmatch.extract_int64_be_unsigned>>
- | (P.ConstantEndian BigEndian, true) ->
- <:expr<Bitmatch.extract_int64_be_signed>>
- | (P.ConstantEndian LittleEndian, false) ->
- <:expr<Bitmatch.extract_int64_le_unsigned>>
- | (P.ConstantEndian LittleEndian, true) ->
- <:expr<Bitmatch.extract_int64_le_signed>>
- | (P.ConstantEndian NativeEndian, false) ->
- <:expr<Bitmatch.extract_int64_ne_unsigned>>
- | (P.ConstantEndian NativeEndian, true) ->
- <:expr<Bitmatch.extract_int64_ne_signed>>
- | (P.EndianExpr expr, false) ->
- <:expr<Bitmatch.extract_int64_ee_unsigned $expr$>>
- | (P.EndianExpr expr, true) ->
- <:expr<Bitmatch.extract_int64_ee_signed $expr$>>
- in
+ let int_extract_const (i, endian, signed) =
+ build_bitmatch_call _loc "extract" (Some i) endian signed in
+ let int_extract (endian, signed) =
+ build_bitmatch_call _loc "extract" None endian signed in
let expr =
match t, flen_is_const with
git.annexia.org / ocaml-bitstring.git / blobdiff