Implement dropbits, takebits, subbitstring.

[ocaml-bitstring.git] / bitmatch_persistent.ml

diff --git a/bitmatch_persistent.ml b/bitmatch_persistent.ml
index 8ad07d9..2b1b524 100644 (file)
--- a/bitmatch_persistent.ml
+++ b/bitmatch_persistent.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,7 +39,7 @@ type 'a field = {
   signed : bool;                       (* true if signed, false if unsigned *)
   t : field_type;                      (* type *)
   _loc : Loc.t;                                (* location in source code *)
-  printer : 'a -> string;              (* turn the field into a string *)
+  offset : expr option;                        (* offset expression *)
 }
 and field_type = Int | String | Bitstring (* field type *)
 and endian_expr =
@@ -49,6 +50,11 @@ type pattern = patt field list
 
 type constructor = expr field list
 
+type named = string * alt
+and alt =
+  | Pattern of pattern
+  | Constructor of constructor
+
 (* Work out if an expression is an integer constant.
  *
  * Returns [Some i] if so (where i is the integer value), else [None].
@@ -100,10 +106,10 @@ let expr_printer = function
   | <:expr< $int:i$ >> -> i
   | _ -> "[expression]"
 
-let string_of_field { field = field; flen = flen;
-                     endian = endian; signed = signed; t = t;
-                     _loc = _loc;
-                     printer = printer} =
+let _string_of_field { flen = flen;
+                      endian = endian; signed = signed; t = t;
+                      _loc = _loc;
+                      offset = offset } =
   let flen =
     match expr_is_constant flen with
     | Some i -> string_of_int i
@@ -111,38 +117,50 @@ let string_of_field { field = field; flen = flen;
   let endian =
     match endian with
     | ConstantEndian endian -> Bitmatch.string_of_endian endian
-    | EndianExpr _ -> "endian [expr]" in
+    | EndianExpr _ -> "endian([expr])" in
   let signed = if signed then "signed" else "unsigned" in
   let t = string_of_field_type t in
+
+  let offset =
+    match offset with
+    | None -> ""
+    | Some expr ->
+       match expr_is_constant expr with
+       | Some i -> sprintf ", offset(%d)" i
+       | None -> sprintf ", offset([expr])" 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 @ (%S, %d, %d)"
-    (printer field) flen t endian signed loc_fname loc_line loc_char
+  sprintf "%s : %s, %s, %s%s (* %S:%d %d *)"
+    flen t endian signed offset loc_fname loc_line loc_char
+
+let rec string_of_pattern_field ({ field = patt } as field) =
+  sprintf "%s : %s" (patt_printer patt) (_string_of_field field)
+
+and string_of_constructor_field ({ field = expr } as field) =
+  sprintf "%s : %s" (expr_printer expr) (_string_of_field field)
 
 let string_of_pattern pattern =
-  "{ " ^ String.concat "; " (List.map string_of_field pattern) ^ " }"
+  "{ " ^
+    String.concat ";\n  " (List.map string_of_pattern_field pattern) ^
+    " }\n"
 
 let string_of_constructor constructor =
-  "{ " ^ String.concat "; " (List.map string_of_field constructor) ^ " }"
+  "{ " ^
+    String.concat ";\n  " (List.map string_of_constructor_field constructor) ^
+    " }\n"
 
-let pattern_to_channel chan patt = Marshal.to_channel chan patt []
-let constructor_to_channel chan cons = Marshal.to_channel chan cons []
+let named_to_channel chan n = Marshal.to_channel chan n []
 
-let pattern_to_string patt = Marshal.to_string patt []
-let constructor_to_string cons = Marshal.to_string cons []
+let named_to_string n = Marshal.to_string n []
 
-let pattern_to_buffer str ofs len patt =
-  Marshal.to_buffer str ofs len patt []
-let constructor_to_buffer str ofs len cons =
-  Marshal.to_buffer str ofs len cons []
+let named_to_buffer str ofs len n = Marshal.to_buffer str ofs len n []
 
-let pattern_from_channel = Marshal.from_channel
-let constructor_from_channel = Marshal.from_channel
+let named_from_channel = Marshal.from_channel
 
-let pattern_from_string = Marshal.from_string
-let constructor_from_string = Marshal.from_string
+let named_from_string = Marshal.from_string
 
 let create_pattern_field _loc =
   {
@@ -152,7 +170,7 @@ let create_pattern_field _loc =
     signed = false;
     t = Int;
     _loc = _loc;
-    printer = patt_printer;
+    offset = None;
   }
 
 let set_lident_patt field id =
@@ -179,6 +197,11 @@ let set_type_int field = { field with t = Int }
 let set_type_string field = { field with t = String }
 let set_type_bitstring field = { field with t = Bitstring }
 let set_location field loc = { field with _loc = loc }
+let set_offset_int field i =
+  let _loc = field._loc in
+  { field with offset = Some <:expr< $`int:i$ >> }
+let set_offset field expr = { field with offset = Some expr }
+let set_no_offset field = { field with offset = None }
 
 let create_constructor_field _loc =
   {
@@ -188,7 +211,7 @@ let create_constructor_field _loc =
     signed = false;
     t = Int;
     _loc = _loc;
-    printer = expr_printer;
+    offset = None;
   }
 
 let set_lident_expr field id =
@@ -211,3 +234,4 @@ let get_endian field = field.endian
 let get_signed field = field.signed
 let get_type field = field.t
 let get_location field = field._loc
+let get_offset field = field.offset