X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=pa_bitmatch.ml;h=f7695823b7d0462a38c44f0a963c627b82544a4e;hb=d1e400223f83ce1a4b3ccafda79d882d77eab849;hp=83bb5d4988ab5ea539a4dcfa3b6b26825a829a4e;hpb=edd992287c4ee26b6a16d39927649c80ede7f860;p=ocaml-bitstring.git

diff --git a/pa_bitmatch.ml b/pa_bitmatch.ml
index 83bb5d4..f769582 100644
--- a/pa_bitmatch.ml
+++ b/pa_bitmatch.ml
@@ -32,25 +32,54 @@ open Ast
  *)
 let debug = false
 
-(* A field when used in a bitmatch (a pattern). *)
-type fpatt = {
-  fpatt : patt;				(* field matching pattern *)
-  fpc : fcommon;
-}
-(* A field when used in a BITSTRING constructor (an expression). *)
-and fexpr = {
-  fexpr : expr;				(* field value *)
-  fec : fcommon;
-}
-
-and fcommon = {
+(* Work out if an expression is an integer constant.
+ *
+ * Returns [Some i] if so (where i is the integer value), else [None].
+ *
+ * Fairly simplistic algorithm: we can only detect simple constant
+ * expressions such as [k], [k+c], [k-c] etc.
+ *)
+let rec expr_is_constant = function
+  | <:expr< $int:i$ >> ->		(* Literal integer constant. *)
+    Some (int_of_string i)
+  | <:expr< $a$ + $b$ >> ->		(* Addition of constants. *)
+    (match expr_is_constant a, expr_is_constant b with
+     | Some a, Some b -> Some (a+b)
+     | _ -> 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. *)
+
+(* Field.  In bitmatch (patterns) the type is [patt field].  In
+ * BITSTRING (constructor) the type is [expr field].
+ *)
+type 'a field = {
+  field : 'a;				(* field ('a is either patt or expr) *)
   flen : expr;				(* length in bits, may be non-const *)
-  endian : endian;			(* endianness *)
+  endian : Bitmatch.endian;		(* endianness *)
   signed : bool;			(* true if signed, false if unsigned *)
   t : t;				(* type *)
   _loc : Loc.t;				(* location in source code *)
+  printer : 'a -> string;		(* turn the field into a string *)
 }
-and endian = BigEndian | LittleEndian | NativeEndian
 and t = Int | String | Bitstring
 
 (* Generate a fresh, unique symbol each time called. *)
@@ -60,16 +89,8 @@ let gensym =
     incr i; let i = !i in
     sprintf "__pabitmatch_%s_%d" name i
 
-let rec parse_patt_field _loc fpatt flen qs =
-  let fpc = parse_field_common _loc flen qs in
-  { fpatt = fpatt; fpc = fpc }
-
-and parse_constr_field _loc fexpr flen qs =
-  let fec = parse_field_common _loc flen qs in
-  { fexpr = fexpr; fec = fec }
-
 (* Deal with the qualifiers which appear for a field of both types. *)
-and parse_field_common _loc flen qs =
+let parse_field _loc field flen qs printer =
   let endian, signed, t =
     match qs with
     | None -> (None, None, None)
@@ -81,21 +102,21 @@ and parse_field_common _loc flen qs =
 		if endian <> None then
 		  Loc.raise _loc (Failure "an endian flag has been set already")
 		else (
-		  let endian = Some BigEndian in
+		  let endian = Some Bitmatch.BigEndian in
 		  (endian, signed, t)
 		)
 	    | "littleendian" ->
 		if endian <> None then
 		  Loc.raise _loc (Failure "an endian flag has been set already")
 		else (
-		  let endian = Some LittleEndian in
+		  let endian = Some Bitmatch.LittleEndian in
 		  (endian, signed, t)
 		)
 	    | "nativeendian" ->
 		if endian <> None then
 		  Loc.raise _loc (Failure "an endian flag has been set already")
 		else (
-		  let endian = Some NativeEndian in
+		  let endian = Some Bitmatch.NativeEndian in
 		  (endian, signed, t)
 		)
 	    | "signed" ->
@@ -147,60 +168,50 @@ and parse_field_common _loc flen qs =
       );
 
   (* Default endianness, signedness, type. *)
-  let endian = match endian with None -> BigEndian | Some e -> e in
+  let endian = match endian with None -> Bitmatch.BigEndian | Some e -> e in
   let signed = match signed with None -> false | Some s -> s in
   let t = match t with None -> Int | Some t -> t in
 
   {
+    field = field;
     flen = flen;
     endian = endian;
     signed = signed;
     t = t;
     _loc = _loc;
+    printer = printer;
   }
 
-let string_of_endian = function
-  | BigEndian -> "bigendian"
-  | LittleEndian -> "littleendian"
-  | NativeEndian -> "nativeendian"
-
 let string_of_t = function
   | Int -> "int"
   | String -> "string"
   | Bitstring -> "bitstring"
 
-let rec string_of_patt_field { fpatt = fpatt; fpc = fpc } =
-  let fpc = string_of_field_common fpc in
-  let fpatt =
-    match fpatt with
-    | <:patt< $lid:id$ >> -> id
-    | _ -> "[pattern]" in
-  fpatt ^ " : " ^ fpc
-
-and string_of_constr_field { fexpr = fexpr; fec = fec } =
-  let fec = string_of_field_common fec in
-  let fexpr =
-    match fexpr with
-    | <:expr< $lid:id$ >> -> id
-    | _ -> "[expression]" in
-  fexpr ^ " : " ^ fec
-
-and string_of_field_common { flen = flen;
-			     endian = endian; signed = signed; t = t;
-			     _loc = _loc } =
+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 flen with
-    | <:expr< $int:i$ >> -> i
-    | _ -> "[non-const-len]" in
-  let endian = string_of_endian endian in
+    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, %d, %d)"
-    flen t endian signed loc_fname loc_line loc_char
+  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 =
@@ -222,15 +233,12 @@ let output_constructor _loc fields =
 
   (* Convert each field to a simple bitstring-generating expression. *)
   let fields = List.map (
-    fun {fexpr=fexpr; fec={flen=flen; endian=endian; signed=signed;
-			   t=t; _loc=_loc}} ->
+    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 =
-	match flen with
-	| <:expr< $int:i$ >> -> Some (int_of_string i)
-	| _ -> None in
+      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
@@ -243,36 +251,42 @@ let output_constructor _loc fields =
 	| (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, BigEndian, false) when i <= 31 -> "construct_int_be_unsigned"
-	| (i, BigEndian, true) when i <= 31 -> "construct_int_be_signed"
-	| (i, LittleEndian, false) when i <= 31 -> "construct_int_le_unsigned"
-	| (i, LittleEndian, true) when i <= 31 -> "construct_int_le_signed"
-	| (i, NativeEndian, false) when i <= 31 -> "construct_int_ne_unsigned"
-	| (i, NativeEndian, true) when i <= 31 -> "construct_int_ne_signed"
-	| (32, BigEndian, false) -> "construct_int32_be_unsigned"
-	| (32, BigEndian, true) -> "construct_int32_be_signed"
-	| (32, LittleEndian, false) -> "construct_int32_le_unsigned"
-	| (32, LittleEndian, true) -> "construct_int32_le_signed"
-	| (32, NativeEndian, false) -> "construct_int32_ne_unsigned"
-	| (32, NativeEndian, true) -> "construct_int32_ne_signed"
-	| (_, BigEndian, false) -> "construct_int64_be_unsigned"
-	| (_, BigEndian, true) -> "construct_int64_be_signed"
-	| (_, LittleEndian, false) -> "construct_int64_le_unsigned"
-	| (_, LittleEndian, true) -> "construct_int64_le_signed"
-	| (_, NativeEndian, false) -> "construct_int64_ne_unsigned"
-	| (_, NativeEndian, true) -> "construct_int64_ne_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).
 	   *)
-	| (BigEndian, false) -> "construct_int64_be_unsigned"
-	| (BigEndian, true) -> "construct_int64_be_signed"
-	| (LittleEndian, false) -> "construct_int64_le_unsigned"
-	| (LittleEndian, true) -> "construct_int64_le_signed"
-	| (NativeEndian, false) -> "construct_int64_ne_unsigned"
-	| (NativeEndian, true) -> "construct_int64_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 expr =
@@ -482,17 +496,14 @@ let output_bitmatch _loc bs cases =
   let rec output_field_extraction inner = function
     | [] -> inner
     | field :: fields ->
-	let {fpatt=fpatt; fpc={flen=flen; endian=endian; signed=signed;
-			       t=t; _loc=_loc}}
+	let {field=fpatt; flen=flen; endian=endian; signed=signed;
+	     t=t; _loc=_loc}
 	    = field in
 
 	(* Is flen an integer constant?  If so, what is it?  This
 	 * is very simple-minded and only detects simple constants.
 	 *)
-	let flen_is_const =
-	  match flen with
-	  | <:expr< $int:i$ >> -> Some (int_of_string i)
-	  | _ -> None in
+	let flen_is_const = expr_is_constant flen in
 
 	let name_of_int_extract_const = function
 	    (* XXX As an enhancement we should allow a 64-bit-only
@@ -505,36 +516,42 @@ let output_bitmatch _loc bs cases =
 	  | (1, _, _) -> "extract_bit"
 	  | ((2|3|4|5|6|7|8), _, false) -> "extract_char_unsigned"
 	  | ((2|3|4|5|6|7|8), _, true) -> "extract_char_signed"
-	  | (i, BigEndian, false) when i <= 31 -> "extract_int_be_unsigned"
-	  | (i, BigEndian, true) when i <= 31 -> "extract_int_be_signed"
-	  | (i, LittleEndian, false) when i <= 31 -> "extract_int_le_unsigned"
-	  | (i, LittleEndian, true) when i <= 31 -> "extract_int_le_signed"
-	  | (i, NativeEndian, false) when i <= 31 -> "extract_int_ne_unsigned"
-	  | (i, NativeEndian, true) when i <= 31 -> "extract_int_ne_signed"
-	  | (32, BigEndian, false) -> "extract_int32_be_unsigned"
-	  | (32, BigEndian, true) -> "extract_int32_be_signed"
-	  | (32, LittleEndian, false) -> "extract_int32_le_unsigned"
-	  | (32, LittleEndian, true) -> "extract_int32_le_signed"
-	  | (32, NativeEndian, false) -> "extract_int32_ne_unsigned"
-	  | (32, NativeEndian, true) -> "extract_int32_ne_signed"
-	  | (_, BigEndian, false) -> "extract_int64_be_unsigned"
-	  | (_, BigEndian, true) -> "extract_int64_be_signed"
-	  | (_, LittleEndian, false) -> "extract_int64_le_unsigned"
-	  | (_, LittleEndian, true) -> "extract_int64_le_signed"
-	  | (_, NativeEndian, false) -> "extract_int64_ne_unsigned"
-	  | (_, NativeEndian, true) -> "extract_int64_ne_signed"
+	  | (i, Bitmatch.BigEndian, false) when i <= 31 ->
+	      "extract_int_be_unsigned"
+	  | (i, Bitmatch.BigEndian, true) when i <= 31 ->
+	      "extract_int_be_signed"
+	  | (i, Bitmatch.LittleEndian, false) when i <= 31 ->
+	      "extract_int_le_unsigned"
+	  | (i, Bitmatch.LittleEndian, true) when i <= 31 ->
+	      "extract_int_le_signed"
+	  | (i, Bitmatch.NativeEndian, false) when i <= 31 ->
+	      "extract_int_ne_unsigned"
+	  | (i, Bitmatch.NativeEndian, true) when i <= 31 ->
+	      "extract_int_ne_signed"
+	  | (32, Bitmatch.BigEndian, false) -> "extract_int32_be_unsigned"
+	  | (32, Bitmatch.BigEndian, true) -> "extract_int32_be_signed"
+	  | (32, Bitmatch.LittleEndian, false) -> "extract_int32_le_unsigned"
+	  | (32, Bitmatch.LittleEndian, true) -> "extract_int32_le_signed"
+	  | (32, Bitmatch.NativeEndian, false) -> "extract_int32_ne_unsigned"
+	  | (32, Bitmatch.NativeEndian, true) -> "extract_int32_ne_signed"
+	  | (_, Bitmatch.BigEndian, false) -> "extract_int64_be_unsigned"
+	  | (_, Bitmatch.BigEndian, true) -> "extract_int64_be_signed"
+	  | (_, Bitmatch.LittleEndian, false) -> "extract_int64_le_unsigned"
+	  | (_, Bitmatch.LittleEndian, true) -> "extract_int64_le_signed"
+	  | (_, Bitmatch.NativeEndian, false) -> "extract_int64_ne_unsigned"
+	  | (_, Bitmatch.NativeEndian, true) -> "extract_int64_ne_signed"
 	in
 	let name_of_int_extract = 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).
 	     *)
-	  | (BigEndian, false) -> "extract_int64_be_unsigned"
-	  | (BigEndian, true) -> "extract_int64_be_signed"
-	  | (LittleEndian, false) -> "extract_int64_le_unsigned"
-	  | (LittleEndian, true) -> "extract_int64_le_signed"
-	  | (NativeEndian, false) -> "extract_int64_ne_unsigned"
-	  | (NativeEndian, true) -> "extract_int64_ne_signed"
+	  | (Bitmatch.BigEndian, false) -> "extract_int64_be_unsigned"
+	  | (Bitmatch.BigEndian, true) -> "extract_int64_be_signed"
+	  | (Bitmatch.LittleEndian, false) -> "extract_int64_le_unsigned"
+	  | (Bitmatch.LittleEndian, true) -> "extract_int64_le_signed"
+	  | (Bitmatch.NativeEndian, false) -> "extract_int64_ne_unsigned"
+	  | (Bitmatch.NativeEndian, true) -> "extract_int64_ne_signed"
 	in
 
 	let expr =
@@ -646,6 +663,7 @@ let output_bitmatch _loc bs cases =
 	      let ident =
 		match fpatt with
 		| <:patt< $lid:ident$ >> -> ident
+		| <:patt< _ >> -> "_"
 		| _ ->
 		    Loc.raise _loc
 		      (Failure "cannot compare a bitstring to a constant") in
@@ -665,6 +683,7 @@ let output_bitmatch _loc bs cases =
 	      let ident =
 		match fpatt with
 		| <:patt< $lid:ident$ >> -> ident
+		| <:patt< _ >> -> "_"
 		| _ ->
 		    Loc.raise _loc
 		      (Failure "cannot compare a bitstring to a constant") in
@@ -681,7 +700,7 @@ let output_bitmatch _loc bs cases =
 	(* Emit extra debugging code. *)
 	let expr =
 	  if not debug then expr else (
-	    let field = string_of_patt_field field in
+	    let field = string_of_field field in
 
 	    <:expr<
 	      if !Bitmatch.debug then (
@@ -766,7 +785,7 @@ EXTEND Gram
   patt_field: [
     [ fpatt = patt; ":"; len = expr LEVEL "top";
       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
-	parse_patt_field _loc fpatt len qs
+	parse_field _loc fpatt len qs patt_printer
     ]
   ];
 
@@ -786,7 +805,7 @@ EXTEND Gram
   constr_field: [
     [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
-	parse_constr_field _loc fexpr len qs
+	parse_field _loc fexpr len qs expr_printer
     ]
   ];