bitstring_persistent.ml

   1 (* Bitstring persistent patterns.
   2  * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public
   6  * License as published by the Free Software Foundation; either
   7  * version 2 of the License, or (at your option) any later version,
   8  * with the OCaml linking exception described in COPYING.LIB.
   9  *
  10  * This library is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13  * Lesser General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU Lesser General Public
  16  * License along with this library; if not, write to the Free Software
  17  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18  *
  19  * $Id$
  20  *)
  21
  22 open Printf
  23
  24 open Camlp4.PreCast
  25 open Syntax
  26 open Ast
  27
  28 type patt = Camlp4.PreCast.Syntax.Ast.patt
  29 type expr = Camlp4.PreCast.Syntax.Ast.expr
  30 type loc_t = Camlp4.PreCast.Syntax.Ast.Loc.t
  31
  32 (* Field.  In bitmatch (patterns) the type is [patt field].  In
  33  * BITSTRING (constructor) the type is [expr field].
  34  *)
  35 type 'a field = {
  36   field : 'a;                           (* field ('a is either patt or expr) *)
  37   flen : expr;                          (* length in bits, may be non-const *)
  38   endian : endian_expr;                 (* endianness *)
  39   signed : bool;                        (* true if signed, false if unsigned *)
  40   t : field_type;                       (* type *)
  41   _loc : Loc.t;                         (* location in source code *)
  42   offset : expr option;                 (* offset expression *)
  43   check : expr option;                  (* check expression [patterns only] *)
  44   bind : expr option;                   (* bind expression [patterns only] *)
  45   save_offset_to : patt option;         (* save_offset_to [patterns only] *)
  46 }
  47 and field_type = Int | String | Bitstring (* field type *)
  48 and endian_expr =
  49   | ConstantEndian of Bitstring.endian  (* a constant little/big/nativeendian *)
  50   | EndianExpr of expr                  (* an endian expression *)
  51
  52 type pattern = patt field list
  53
  54 type constructor = expr field list
  55
  56 type named = string * alt
  57 and alt =
  58   | Pattern of pattern
  59   | Constructor of constructor
  60
  61 (* Work out if an expression is an integer constant.
  62  *
  63  * Returns [Some i] if so (where i is the integer value), else [None].
  64  *
  65  * Fairly simplistic algorithm: we can only detect simple constant
  66  * expressions such as [k], [k+c], [k-c] etc.
  67  *)
  68 let rec expr_is_constant = function
  69   | <:expr< $int:i$ >> ->               (* Literal integer constant. *)
  70     Some (int_of_string i)
  71   | <:expr< $a$ + $b$ >> ->             (* Addition of constants. *)
  72     (match expr_is_constant a, expr_is_constant b with
  73      | Some a, Some b -> Some (a+b)
  74      | _ -> None)
  75   | <:expr< $a$ - $b$ >> ->             (* Subtraction. *)
  76     (match expr_is_constant a, expr_is_constant b with
  77      | Some a, Some b -> Some (a-b)
  78      | _ -> None)
  79   | <:expr< $a$ * $b$ >> ->             (* Multiplication. *)
  80     (match expr_is_constant a, expr_is_constant b with
  81      | Some a, Some b -> Some (a*b)
  82      | _ -> None)
  83   | <:expr< $a$ / $b$ >> ->             (* Division. *)
  84     (match expr_is_constant a, expr_is_constant b with
  85      | Some a, Some b -> Some (a/b)
  86      | _ -> None)
  87   | <:expr< $a$ lsl $b$ >> ->           (* Shift left. *)
  88     (match expr_is_constant a, expr_is_constant b with
  89      | Some a, Some b -> Some (a lsl b)
  90      | _ -> None)
  91   | <:expr< $a$ lsr $b$ >> ->           (* Shift right. *)
  92     (match expr_is_constant a, expr_is_constant b with
  93      | Some a, Some b -> Some (a lsr b)
  94      | _ -> None)
  95   | _ -> None                           (* Anything else is not constant. *)
  96
  97 let string_of_field_type = function
  98   | Int -> "int"
  99   | String -> "string"
 100   | Bitstring -> "bitstring"
 101
 102 let patt_printer = function
 103   | <:patt< $lid:id$ >> -> id
 104   | <:patt< _ >> -> "_"
 105   | _ -> "[pattern]"
 106
 107 let rec expr_printer = function
 108   | <:expr< $lid:id$ >> -> id
 109   | <:expr< $int:i$ >> -> i
 110   | <:expr< $lid:op$ $a$ $b$ >> ->
 111     sprintf "%s %s %s" op (expr_printer a) (expr_printer b)
 112   | _ -> "[expr]"
 113
 114 let _string_of_field { flen = flen;
 115                        endian = endian; signed = signed; t = t;
 116                        _loc = _loc;
 117                        offset = offset; check = check; bind = bind;
 118                        save_offset_to = save_offset_to } =
 119   let flen = expr_printer flen in
 120   let endian =
 121     match endian with
 122     | ConstantEndian endian -> Bitstring.string_of_endian endian
 123     | EndianExpr expr -> sprintf "endian(%s)" (expr_printer expr) in
 124   let signed = if signed then "signed" else "unsigned" in
 125   let t = string_of_field_type t in
 126
 127   let offset =
 128     match offset with
 129     | None -> ""
 130     | Some expr -> sprintf ", offset(%s)" (expr_printer expr) in
 131
 132   let check =
 133     match check with
 134     | None -> ""
 135     | Some expr -> sprintf ", check(%s)" (expr_printer expr) in
 136
 137   let bind =
 138     match bind with
 139     | None -> ""
 140     | Some expr -> sprintf ", bind(%s)" (expr_printer expr) in
 141
 142   let save_offset_to =
 143     match save_offset_to with
 144     | None -> ""
 145     | Some patt ->
 146         match patt with
 147         | <:patt< $lid:id$ >> -> sprintf ", save_offset_to(%s)" id
 148         | _ -> sprintf ", save_offset_to([patt])" in
 149
 150   let loc_fname = Loc.file_name _loc in
 151   let loc_line = Loc.start_line _loc in
 152   let loc_char = Loc.start_off _loc - Loc.start_bol _loc in
 153
 154   sprintf "%s : %s, %s, %s%s%s%s%s (* %S:%d %d *)"
 155     flen t endian signed offset check bind save_offset_to
 156     loc_fname loc_line loc_char
 157
 158 let rec string_of_pattern_field ({ field = patt } as field) =
 159   sprintf "%s : %s" (patt_printer patt) (_string_of_field field)
 160
 161 and string_of_constructor_field ({ field = expr } as field) =
 162   sprintf "%s : %s" (expr_printer expr) (_string_of_field field)
 163
 164 let string_of_pattern pattern =
 165   "{ " ^
 166     String.concat ";\n  " (List.map string_of_pattern_field pattern) ^
 167     " }\n"
 168
 169 let string_of_constructor constructor =
 170   "{ " ^
 171     String.concat ";\n  " (List.map string_of_constructor_field constructor) ^
 172     " }\n"
 173
 174 let named_to_channel chan n = Marshal.to_channel chan n []
 175
 176 let named_to_string n = Marshal.to_string n []
 177
 178 let named_to_buffer str ofs len n = Marshal.to_buffer str ofs len n []
 179
 180 let named_from_channel = Marshal.from_channel
 181
 182 let named_from_string = Marshal.from_string
 183
 184 let create_pattern_field _loc =
 185   {
 186     field = <:patt< _ >>;
 187     flen = <:expr< 32 >>;
 188     endian = ConstantEndian Bitstring.BigEndian;
 189     signed = false;
 190     t = Int;
 191     _loc = _loc;
 192     offset = None;
 193     check = None;
 194     bind = None;
 195     save_offset_to = None;
 196   }
 197
 198 let set_lident_patt field id =
 199   let _loc = field._loc in
 200   { field with field = <:patt< $lid:id$ >> }
 201 let set_int_patt field i =
 202   let _loc = field._loc in
 203   { field with field = <:patt< $`int:i$ >> }
 204 let set_string_patt field str =
 205   let _loc = field._loc in
 206   { field with field = <:patt< $str:str$ >> }
 207 let set_unbound_patt field =
 208   let _loc = field._loc in
 209   { field with field = <:patt< _ >> }
 210 let set_patt field patt = { field with field = patt }
 211 let set_length_int field flen =
 212   let _loc = field._loc in
 213   { field with flen = <:expr< $`int:flen$ >> }
 214 let set_length field flen = { field with flen = flen }
 215 let set_endian field endian = { field with endian = ConstantEndian endian }
 216 let set_endian_expr field expr = { field with endian = EndianExpr expr }
 217 let set_signed field signed = { field with signed = signed }
 218 let set_type_int field = { field with t = Int }
 219 let set_type_string field = { field with t = String }
 220 let set_type_bitstring field = { field with t = Bitstring }
 221 let set_location field loc = { field with _loc = loc }
 222 let set_offset_int field i =
 223   let _loc = field._loc in
 224   { field with offset = Some <:expr< $`int:i$ >> }
 225 let set_offset field expr = { field with offset = Some expr }
 226 let set_no_offset field = { field with offset = None }
 227 let set_check field expr = { field with check = Some expr }
 228 let set_no_check field = { field with check = None }
 229 let set_bind field expr = { field with bind = Some expr }
 230 let set_no_bind field = { field with bind = None }
 231 let set_save_offset_to field patt = { field with save_offset_to = Some patt }
 232 let set_save_offset_to_lident field id =
 233   let _loc = field._loc in
 234   { field with save_offset_to = Some <:patt< $lid:id$ >> }
 235 let set_no_save_offset_to field = { field with save_offset_to = None }
 236
 237 let create_constructor_field _loc =
 238   {
 239     field = <:expr< 0 >>;
 240     flen = <:expr< 32 >>;
 241     endian = ConstantEndian Bitstring.BigEndian;
 242     signed = false;
 243     t = Int;
 244     _loc = _loc;
 245     offset = None;
 246     check = None;
 247     bind = None;
 248     save_offset_to = None;
 249   }
 250
 251 let set_lident_expr field id =
 252   let _loc = field._loc in
 253   { field with field = <:expr< $lid:id$ >> }
 254 let set_int_expr field i =
 255   let _loc = field._loc in
 256   { field with field = <:expr< $`int:i$ >> }
 257 let set_string_expr field str =
 258   let _loc = field._loc in
 259   { field with field = <:expr< $str:str$ >> }
 260 let set_expr field expr =
 261   let _loc = field._loc in
 262   { field with field = expr }
 263
 264 let get_patt field = field.field
 265 let get_expr field = field.field
 266 let get_length field = field.flen
 267 let get_endian field = field.endian
 268 let get_signed field = field.signed
 269 let get_type field = field.t
 270 let get_location field = field._loc
 271 let get_offset field = field.offset
 272 let get_check field = field.check
 273 let get_bind field = field.bind
 274 let get_save_offset_to field = field.save_offset_to