X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=pa_bitmatch.ml;h=98151a3746175885d66b6a998440b7b64dd84daf;hb=1be1a65d5fc5727d20e465bebaafcad263b87162;hp=3cea7f2ab65c7f2fd9838fa9611bc9cd522e6f2e;hpb=41b0cba3e1ce05c96c330d76200ca38e9c4bd3c2;p=ocaml-bitstring.git

diff --git a/pa_bitmatch.ml b/pa_bitmatch.ml
index 3cea7f2..98151a3 100644
--- a/pa_bitmatch.ml
+++ b/pa_bitmatch.ml
@@ -133,13 +133,55 @@ let parse_field _loc field qs =
 
   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 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
+  (* This function makes code to raise a Bitmatch.Construct_failure exception
+   * containing a message and the current _loc context.
+   * (Thanks to Bluestorm for suggesting this).
+   *)
+  let construct_failure _loc msg =
+    <:expr<
+      Bitmatch.Construct_failure
+        ($`str:msg$,
+	 $`str:Loc.file_name _loc$,
+	 $`int:Loc.start_line _loc$,
+	 $`int:Loc.start_off _loc - Loc.start_bol _loc$)
+    >>
+  in
+  let raise_construct_failure _loc msg =
+    <:expr< raise $construct_failure _loc msg$ >>
+  in
 
   (* Bitstrings are created like the 'Buffer' module (in fact, using
    * the Buffer module), by appending snippets to a growing buffer.
@@ -164,6 +206,8 @@ let output_constructor _loc fields =
       let _loc = P.get_location field in
       let offset = P.get_offset field in
 
+      let fail = locfail _loc 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
@@ -179,84 +223,10 @@ let output_constructor _loc fields =
        *)
       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
@@ -292,10 +262,7 @@ let output_constructor _loc fields =
 	      if $flen$ >= 1 && $flen$ <= 64 then
 		$construct_fn$ $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$))
+		$raise_construct_failure _loc "length of int field must be [1..64]"$
 	    >>
 
         (* String, constant length > 0, must be a multiple of 8. *)
@@ -307,10 +274,7 @@ let output_constructor _loc fields =
 	      if String.length $lid:bs$ = $`int:j$ 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$))
+		$raise_construct_failure _loc "length of string does not match declaration"$
 	    >>
 
 	(* String, constant length -1, means variable length string
@@ -340,20 +304,11 @@ let output_constructor _loc fields =
 		  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$))
+		    $raise_construct_failure _loc "length of string does not match declaration"$
 		) else
-		  raise (Bitmatch.Construct_failure
-			   ("length of string must be a multiple of 8",
-			    $str:loc_fname$,
-			    $int:loc_line$, $int:loc_char$))
+		  $raise_construct_failure _loc "length of string must be a multiple of 8"$
 	      ) else
-		raise (Bitmatch.Construct_failure
-			 ("length of string must be > 0",
-			  $str:loc_fname$,
-			  $int:loc_line$, $int:loc_char$))
+		$raise_construct_failure _loc "length of string must be > 0"$
 	    >>
 
         (* Bitstring, constant length >= 0. *)
@@ -364,10 +319,7 @@ let output_constructor _loc fields =
 	      if Bitmatch.bitstring_length $lid:bs$ = $`int:i$ 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$))
+		$raise_construct_failure _loc "length of bitstring does not match declaration"$
 	    >>
 
 	(* Bitstring, constant length -1, means variable length bitstring
@@ -394,15 +346,9 @@ let output_constructor _loc fields =
 		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$))
+		  $raise_construct_failure _loc "length of bitstring does not match declaration"$
 	      ) else
-		raise (Bitmatch.Construct_failure
-			 ("length of bitstring must be > 0",
-			  $str:loc_fname$,
-			  $int:loc_line$, $int:loc_char$))
+		$raise_construct_failure _loc "length of bitstring must be > 0"$
 	    >> in
       expr
   ) fields in
@@ -429,11 +375,8 @@ let output_constructor _loc fields =
 
   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$
+      let $lid:exn$ = $construct_failure _loc "value out of range"$ in
+      $expr$
     >>
   else
     expr
@@ -443,8 +386,6 @@ let output_constructor _loc fields =
  * the list of cases to test against.
  *)
 let output_bitmatch _loc bs cases =
-  let fail = locfail _loc in
-
   let data = gensym "data" and off = gensym "off" and len = gensym "len" in
   let result = gensym "result" in
 
@@ -469,89 +410,18 @@ let output_bitmatch _loc bs cases =
 	let _loc = P.get_location field in
 	let offset = P.get_offset field in
 
+	let fail = locfail _loc in
+
 	(* Is flen (field len) an integer constant?  If so, what is it?
 	 * This will be [Some i] if it's a constant or [None] if it's
 	 * non-constant or we couldn't determine.
 	 *)
 	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
@@ -921,7 +791,10 @@ let load_patterns_from_file _loc filename =
   let names = List.rev !names in
   List.iter (
     function
-    | name, P.Pattern patt -> add_named_pattern _loc name patt
+    | name, P.Pattern patt ->
+	if patt = [] then
+	  locfail _loc (sprintf "pattern %s: no fields" name);
+	add_named_pattern _loc name patt
     | _, P.Constructor _ -> () (* just ignore these for now *)
   ) names