X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=pa_bitmatch.ml;h=1e3225ca0e56f8affa1e1e6b9eed6065a8088fdb;hb=a7932dd74a91ebf54128bf5456e6a0054fc506c5;hp=9d29340f6ca3fd60336e29f263fd845e3e194ee6;hpb=e87f0879fef8e32e7ae7f7103f420c1612f3863f;p=ocaml-bitstring.git

diff --git a/pa_bitmatch.ml b/pa_bitmatch.ml
index 9d29340..1e3225c 100644
--- a/pa_bitmatch.ml
+++ b/pa_bitmatch.ml
@@ -15,7 +15,7 @@
  * License along with this library; if not, write to the Free Software
  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  *
- * $Id: pa_bitmatch.ml,v 1.11 2008-04-25 14:57:11 rjones Exp $
+ * $Id$
  *)
 
 open Printf
@@ -68,25 +68,18 @@ let rec expr_is_constant = function
      | _ -> None)
   | _ -> None				(* Anything else is not constant. *)
 
-(* 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 = {
+(* 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. *)
@@ -96,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)
@@ -117,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" ->
@@ -183,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 expr_is_constant flen with
     | Some i -> string_of_int i
     | None -> "[non-const-len]" in
-  let endian = string_of_endian endian 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 =
@@ -258,8 +233,8 @@ 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.
        *)
@@ -276,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 =
@@ -515,8 +496,8 @@ 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
@@ -535,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 =
@@ -676,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
@@ -695,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
@@ -711,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 (
@@ -796,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
     ]
   ];
 
@@ -816,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
     ]
   ];