X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=pa_bitmatch.ml;h=c05ffde9890d774bf2823f126584d706c34ead38;hb=63a72ad59065a9b19bca1636a17098ad12c5e652;hp=2008b8ad5ff133976a134b7d0b392e8cee5e4266;hpb=bd83aa0f6033669913546ae50f9fd257420b94f8;p=ocaml-bitstring.git

diff --git a/pa_bitmatch.ml b/pa_bitmatch.ml
index 2008b8a..c05ffde 100644
--- a/pa_bitmatch.ml
+++ b/pa_bitmatch.ml
@@ -4,7 +4,8 @@
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public
  * License as published by the Free Software Foundation; either
- * version 2 of the License, or (at your option) any later version.
+ * version 2 of the License, or (at your option) any later version,
+ * with the OCaml linking exception described in COPYING.LIB.
  *
  * This library is distributed in the hope that it will be useful,
  * but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -38,6 +39,8 @@ let debug = false
 (* Hashtable storing named persistent patterns. *)
 let pattern_hash : (string, P.pattern) Hashtbl.t = Hashtbl.create 13
 
+let locfail _loc msg = Loc.raise _loc (Failure msg)
+
 (* Work out if an expression is an integer constant.
  *
  * Returns [Some i] if so (where i is the integer value), else [None].
@@ -46,33 +49,18 @@ let pattern_hash : (string, P.pattern) Hashtbl.t = Hashtbl.create 13
  * 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. *)
-    (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. *)
+  | <:expr< $lid:op$ $a$ $b$ >> ->
     (match expr_is_constant a, expr_is_constant b with
-     | Some a, Some b -> Some (a lsr 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)
-  | _ -> None				(* Anything else is not constant. *)
+  | _ -> None
 
 (* Generate a fresh, unique symbol each time called. *)
 let gensym =
@@ -83,88 +71,53 @@ let gensym =
 
 (* Deal with the qualifiers which appear for a field of both types. *)
 let parse_field _loc field qs =
+  let fail = locfail _loc in
+
   let endian_set, signed_set, type_set, offset_set, field =
     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
-		  Loc.raise _loc (Failure "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
-		  Loc.raise _loc (Failure "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
-		  Loc.raise _loc (Failure "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
-		  Loc.raise _loc (Failure "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
-		  Loc.raise _loc (Failure "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
-		  Loc.raise _loc (Failure "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
-		  Loc.raise _loc (Failure "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
-		  Loc.raise _loc (Failure "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
-		  Loc.raise _loc (Failure "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
-		  Loc.raise _loc (Failure "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 _ ->
-		Loc.raise _loc (Failure (s ^ ": unknown qualifier, or qualifier should not be followed by an expression"))
-	    | s, None ->
-		Loc.raise _loc (Failure (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.
@@ -172,9 +125,7 @@ let parse_field _loc field qs =
   let () =
     let t = P.get_type field in
     if (t = P.Bitstring || t = P.String) && (endian_set || signed_set) then
-      Loc.raise _loc (
-	Failure "string types and endian or signed qualifiers cannot be mixed"
-      ) in
+      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
@@ -183,11 +134,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 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.
@@ -212,6 +207,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
@@ -219,93 +216,18 @@ let output_constructor _loc fields =
        * including going backwards, that would require a rethink in
        * how we construct bitstrings.
        *)
-      if offset <> None then (
-	Loc.raise _loc (Failure "offset expressions are not supported in BITSTRING constructors")
-      );
+      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
+      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
@@ -324,7 +246,7 @@ let output_constructor _loc fields =
 	    >>
 
 	| P.Int, Some _ ->
-	    Loc.raise _loc (Failure "length of int field must be [1..64]")
+	    fail "length of int field must be [1..64]"
 
 	(* Int field, non-constant length.  We need to perform a runtime
 	 * test to ensure the length is [1..64].
@@ -341,10 +263,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. *)
@@ -356,10 +275,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
@@ -372,7 +288,7 @@ let output_constructor _loc fields =
 	 * any other value.
 	 *)
 	| P.String, Some _ ->
-	    Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
+	    fail "length of string must be > 0 and a multiple of 8, or the special value -1"
 
 	(* String, non-constant length.
 	 * We check at runtime that the length is > 0, a multiple of 8,
@@ -389,20 +305,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. *)
@@ -413,10 +320,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
@@ -427,9 +331,7 @@ let output_constructor _loc fields =
 
 	(* Bitstring, constant length < -1 is an error. *)
 	| P.Bitstring, Some _ ->
-	    Loc.raise _loc
-	      (Failure
-		 "length of bitstring must be >= 0 or the special value -1")
+	    fail "length of bitstring must be >= 0 or the special value -1"
 
 	(* Bitstring, non-constant length.
 	 * We check at runtime that the length is >= 0 and matches
@@ -445,15 +347,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
@@ -480,11 +376,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
@@ -494,8 +387,26 @@ let output_constructor _loc fields =
  * the list of cases to test against.
  *)
 let output_bitmatch _loc bs cases =
-  let data = gensym "data" and off = gensym "off" and len = gensym "len" in
-  let result = gensym "result" in
+  (* These symbols are used through the generated code to record our
+   * current position within the bitstring:
+   *
+   *   data - original bitstring data (string, never changes)
+   *
+   *   off  - current offset within data (int, increments as we move through
+   *            the bitstring)
+   *   len  - current remaining length within data (int, decrements as
+   *            we move through the bitstring)
+   *
+   *   original_off - saved offset at the start of the match (never changes)
+   *   original_len - saved length at the start of the match (never changes)
+   *)
+  let data = gensym "data"
+  and off = gensym "off"
+  and len = gensym "len"
+  and original_off = gensym "original_off"
+  and original_len = gensym "original_len"
+  (* This is where the result will be stored (a reference). *)
+  and result = gensym "result" in
 
   (* This generates the field extraction code for each
    * field in a single case.  There must be enough remaining data
@@ -504,8 +415,8 @@ let output_bitmatch _loc bs cases =
    * As we go through the fields, symbols 'data', 'off' and 'len'
    * track our position and remaining length in the bitstring.
    *
-   * The whole thing is a lot of nested 'if' statements. Code
-   * is generated from the inner-most (last) field outwards.
+   * The whole thing is a lot of nested 'if'/'match' statements.
+   * Code is generated from the inner-most (last) field outwards.
    *)
   let rec output_field_extraction inner = function
     | [] -> inner
@@ -518,89 +429,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
@@ -617,7 +457,7 @@ let output_bitmatch _loc bs cases =
 	      >>
 
 	  | P.Int, Some _ ->
-	      Loc.raise _loc (Failure "length of int field must be [1..64]")
+	      fail "length of int field must be [1..64]"
 
 	  (* Int field, non-const flen.  We have to test the range of
 	   * the field at runtime.  If outside the range it's a no-match
@@ -662,7 +502,7 @@ let output_bitmatch _loc bs cases =
 	      >>
 
 	  | P.String, Some _ ->
-	      Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
+	      fail "length of string must be > 0 and a multiple of 8, or the special value -1"
 
 	  (* String field, non-const flen.  We check the flen is > 0
 	   * and a multiple of 8 (-1 is not allowed here), at runtime.
@@ -691,8 +531,7 @@ let output_bitmatch _loc bs cases =
 		| <:patt< $lid:ident$ >> -> ident
 		| <:patt< _ >> -> "_"
 		| _ ->
-		    Loc.raise _loc
-		      (Failure "cannot compare a bitstring to a constant") in
+		    fail "cannot compare a bitstring to a constant" in
 	      <:expr<
 		if $lid:len$ >= $`int:i$ then (
 		  let $lid:ident$, $lid:off$, $lid:len$ =
@@ -711,8 +550,7 @@ let output_bitmatch _loc bs cases =
 		| <:patt< $lid:ident$ >> -> ident
 		| <:patt< _ >> -> "_"
 		| _ ->
-		    Loc.raise _loc
-		      (Failure "cannot compare a bitstring to a constant") in
+		    fail "cannot compare a bitstring to a constant" in
 	      <:expr<
 		let $lid:ident$, $lid:off$, $lid:len$ =
 		  Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
@@ -720,7 +558,7 @@ let output_bitmatch _loc bs cases =
 	      >>
 
 	  | P.Bitstring, Some _ ->
-	      Loc.raise _loc (Failure "length of bitstring must be >= 0 or the special value -1")
+	      fail "length of bitstring must be >= 0 or the special value -1"
 
 	  (* Bitstring field, non-const flen.  We check the flen is >= 0
 	   * (-1 is not allowed here) at runtime.
@@ -731,8 +569,7 @@ let output_bitmatch _loc bs cases =
 		| <:patt< $lid:ident$ >> -> ident
 		| <:patt< _ >> -> "_"
 		| _ ->
-		    Loc.raise _loc
-		      (Failure "cannot compare a bitstring to a constant") in
+		    fail "cannot compare a bitstring to a constant" in
 	      <:expr<
 		if $flen$ >= 0 && $flen$ <= $lid:len$ then (
 		  let $lid:ident$, $lid:off$, $lid:len$ =
@@ -829,7 +666,7 @@ let output_bitmatch _loc bs cases =
 	      | Some current_offset, Some requested_offset ->
 		  let move = requested_offset - current_offset in
 		  if move < 0 then
-		    Loc.raise _loc (Failure (sprintf "requested offset is less than the current offset (%d < %d)" requested_offset current_offset));
+		    fail (sprintf "requested offset is less than the current offset (%d < %d)" requested_offset current_offset);
 		  (* Add some code to move the offset and length by a
 		   * constant amount, and a runtime test that len >= 0
 		   * (XXX possibly the runtime test is unnecessary?)
@@ -849,7 +686,8 @@ let output_bitmatch _loc bs cases =
 	      | _ ->
 		  let move = gensym "move" in
 		  <:expr<
-		    let $lid:move$ = $offset_expr$ - $lid:off$ in
+		    let $lid:move$ =
+		      $offset_expr$ - ($lid:off$ - $lid:original_off$) in
 		    if $lid:move$ >= 0 then (
 		      let $lid:off$ = $lid:off$ + $lid:move$ in
 		      let $lid:len$ = $lid:len$ - $lid:move$ in
@@ -923,7 +761,11 @@ let output_bitmatch _loc bs cases =
   let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
 
   <:expr<
-    let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
+    (* Note we save the original offset/length at the start of the match
+     * in 'original_off'/'original_len' symbols.  'data' never changes.
+     *)
+    let ($lid:data$, $lid:original_off$, $lid:original_len$) = $bs$ in
+    let $lid:off$ = $lid:original_off$ and $lid:len$ = $lid:original_len$ in
     let $lid:result$ = ref None in
     (try
       $cases$
@@ -942,7 +784,7 @@ let add_named_pattern _loc name pattern =
 let expand_named_pattern _loc name =
   try Hashtbl.find pattern_hash name
   with Not_found ->
-    Loc.raise _loc (Failure (sprintf "named pattern not found: %s" name))
+    locfail _loc (sprintf "named pattern not found: %s" name)
 
 (* Add named patterns from a file.  See the documentation on the
  * directory search path in bitmatch_persistent.mli
@@ -973,7 +815,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