bitmatch_persistent.ml

   1 (* Bitmatch 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 }
  44 and field_type = Int | String | Bitstring (* field type *)
  45 and endian_expr =
  46   | ConstantEndian of Bitmatch.endian   (* a constant little/big/nativeendian *)
  47   | EndianExpr of expr                  (* an endian expression *)
  48
  49 type pattern = patt field list
  50
  51 type constructor = expr field list
  52
  53 type named = string * alt
  54 and alt =
  55   | Pattern of pattern
  56   | Constructor of constructor
  57
  58 (* Work out if an expression is an integer constant.
  59  *
  60  * Returns [Some i] if so (where i is the integer value), else [None].
  61  *
  62  * Fairly simplistic algorithm: we can only detect simple constant
  63  * expressions such as [k], [k+c], [k-c] etc.
  64  *)
  65 let rec expr_is_constant = function
  66   | <:expr< $int:i$ >> ->               (* Literal integer constant. *)
  67     Some (int_of_string i)
  68   | <:expr< $a$ + $b$ >> ->             (* Addition of constants. *)
  69     (match expr_is_constant a, expr_is_constant b with
  70      | Some a, Some b -> Some (a+b)
  71      | _ -> None)
  72   | <:expr< $a$ - $b$ >> ->             (* Subtraction. *)
  73     (match expr_is_constant a, expr_is_constant b with
  74      | Some a, Some b -> Some (a-b)
  75      | _ -> None)
  76   | <:expr< $a$ * $b$ >> ->             (* Multiplication. *)
  77     (match expr_is_constant a, expr_is_constant b with
  78      | Some a, Some b -> Some (a*b)
  79      | _ -> None)
  80   | <:expr< $a$ / $b$ >> ->             (* Division. *)
  81     (match expr_is_constant a, expr_is_constant b with
  82      | Some a, Some b -> Some (a/b)
  83      | _ -> None)
  84   | <:expr< $a$ lsl $b$ >> ->           (* Shift left. *)
  85     (match expr_is_constant a, expr_is_constant b with
  86      | Some a, Some b -> Some (a lsl b)
  87      | _ -> None)
  88   | <:expr< $a$ lsr $b$ >> ->           (* Shift right. *)
  89     (match expr_is_constant a, expr_is_constant b with
  90      | Some a, Some b -> Some (a lsr b)
  91      | _ -> None)
  92   | _ -> None                           (* Anything else is not constant. *)
  93
  94 let string_of_field_type = function
  95   | Int -> "int"
  96   | String -> "string"
  97   | Bitstring -> "bitstring"
  98
  99 let patt_printer = function
 100   | <:patt< $lid:id$ >> -> id
 101   | <:patt< _ >> -> "_"
 102   | _ -> "[pattern]"
 103
 104 let expr_printer = function
 105   | <:expr< $lid:id$ >> -> id
 106   | <:expr< $int:i$ >> -> i
 107   | _ -> "[expression]"
 108
 109 let _string_of_field { flen = flen;
 110                        endian = endian; signed = signed; t = t;
 111                        _loc = _loc;
 112                        offset = offset } =
 113   let flen =
 114     match expr_is_constant flen with
 115     | Some i -> string_of_int i
 116     | None -> "[non-const-len]" in
 117   let endian =
 118     match endian with
 119     | ConstantEndian endian -> Bitmatch.string_of_endian endian
 120     | EndianExpr _ -> "endian([expr])" in
 121   let signed = if signed then "signed" else "unsigned" in
 122   let t = string_of_field_type t in
 123
 124   let offset =
 125     match offset with
 126     | None -> ""
 127     | Some expr ->
 128         match expr_is_constant expr with
 129         | Some i -> sprintf ", offset(%d)" i
 130         | None -> sprintf ", offset([expr])" in
 131
 132   let loc_fname = Loc.file_name _loc in
 133   let loc_line = Loc.start_line _loc in
 134   let loc_char = Loc.start_off _loc - Loc.start_bol _loc in
 135
 136   sprintf "%s : %s, %s, %s%s (* %S:%d %d *)"
 137     flen t endian signed offset loc_fname loc_line loc_char
 138
 139 let rec string_of_pattern_field ({ field = patt } as field) =
 140   sprintf "%s : %s" (patt_printer patt) (_string_of_field field)
 141
 142 and string_of_constructor_field ({ field = expr } as field) =
 143   sprintf "%s : %s" (expr_printer expr) (_string_of_field field)
 144
 145 let string_of_pattern pattern =
 146   "{ " ^
 147     String.concat ";\n  " (List.map string_of_pattern_field pattern) ^
 148     " }\n"
 149
 150 let string_of_constructor constructor =
 151   "{ " ^
 152     String.concat ";\n  " (List.map string_of_constructor_field constructor) ^
 153     " }\n"
 154
 155 let named_to_channel chan n = Marshal.to_channel chan n []
 156
 157 let named_to_string n = Marshal.to_string n []
 158
 159 let named_to_buffer str ofs len n = Marshal.to_buffer str ofs len n []
 160
 161 let named_from_channel = Marshal.from_channel
 162
 163 let named_from_string = Marshal.from_string
 164
 165 let create_pattern_field _loc =
 166   {
 167     field = <:patt< _ >>;
 168     flen = <:expr< 32 >>;
 169     endian = ConstantEndian Bitmatch.BigEndian;
 170     signed = false;
 171     t = Int;
 172     _loc = _loc;
 173     offset = None;
 174   }
 175
 176 let set_lident_patt field id =
 177   let _loc = field._loc in
 178   { field with field = <:patt< $lid:id$ >> }
 179 let set_int_patt field i =
 180   let _loc = field._loc in
 181   { field with field = <:patt< $`int:i$ >> }
 182 let set_string_patt field str =
 183   let _loc = field._loc in
 184   { field with field = <:patt< $str:str$ >> }
 185 let set_unbound_patt field =
 186   let _loc = field._loc in
 187   { field with field = <:patt< _ >> }
 188 let set_patt field patt = { field with field = patt }
 189 let set_length_int field flen =
 190   let _loc = field._loc in
 191   { field with flen = <:expr< $`int:flen$ >> }
 192 let set_length field flen = { field with flen = flen }
 193 let set_endian field endian = { field with endian = ConstantEndian endian }
 194 let set_endian_expr field expr = { field with endian = EndianExpr expr }
 195 let set_signed field signed = { field with signed = signed }
 196 let set_type_int field = { field with t = Int }
 197 let set_type_string field = { field with t = String }
 198 let set_type_bitstring field = { field with t = Bitstring }
 199 let set_location field loc = { field with _loc = loc }
 200 let set_offset_int field i =
 201   let _loc = field._loc in
 202   { field with offset = Some <:expr< $`int:i$ >> }
 203 let set_offset field expr = { field with offset = Some expr }
 204 let set_no_offset field = { field with offset = None }
 205
 206 let create_constructor_field _loc =
 207   {
 208     field = <:expr< 0 >>;
 209     flen = <:expr< 32 >>;
 210     endian = ConstantEndian Bitmatch.BigEndian;
 211     signed = false;
 212     t = Int;
 213     _loc = _loc;
 214     offset = None;
 215   }
 216
 217 let set_lident_expr field id =
 218   let _loc = field._loc in
 219   { field with field = <:expr< $lid:id$ >> }
 220 let set_int_expr field i =
 221   let _loc = field._loc in
 222   { field with field = <:expr< $`int:i$ >> }
 223 let set_string_expr field str =
 224   let _loc = field._loc in
 225   { field with field = <:expr< $str:str$ >> }
 226 let set_expr field expr =
 227   let _loc = field._loc in
 228   { field with field = expr }
 229
 230 let get_patt field = field.field
 231 let get_expr field = field.field
 232 let get_length field = field.flen
 233 let get_endian field = field.endian
 234 let get_signed field = field.signed
 235 let get_type field = field.t
 236 let get_location field = field._loc
 237 let get_offset field = field.offset