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  *
   9  * This library is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17  *
  18  * $Id$
  19  *)
  20
  21 open Printf
  22
  23 open Camlp4.PreCast
  24 open Syntax
  25 open Ast
  26
  27 type patt = Camlp4.PreCast.Syntax.Ast.patt
  28 type expr = Camlp4.PreCast.Syntax.Ast.expr
  29 type loc_t = Camlp4.PreCast.Syntax.Ast.Loc.t
  30
  31 (* Field.  In bitmatch (patterns) the type is [patt field].  In
  32  * BITSTRING (constructor) the type is [expr field].
  33  *)
  34 type 'a field = {
  35   field : 'a;                           (* field ('a is either patt or expr) *)
  36   flen : expr;                          (* length in bits, may be non-const *)
  37   endian : endian_expr;                 (* endianness *)
  38   signed : bool;                        (* true if signed, false if unsigned *)
  39   t : field_type;                       (* type *)
  40   _loc : Loc.t;                         (* location in source code *)
  41   offset : expr option;                 (* offset expression *)
  42
  43   (* Turn the field into a string.  This used to be a function,
  44    * but that would prevent this structure from being marshalled.
  45    * This is unsatisfactory at the moment because it means we
  46    * can't print out the 'a field.
  47    *)
  48   printer : printer_t;
  49 }
  50 and field_type = Int | String | Bitstring (* field type *)
  51 and endian_expr =
  52   | ConstantEndian of Bitmatch.endian   (* a constant little/big/nativeendian *)
  53   | EndianExpr of expr                  (* an endian expression *)
  54 and printer_t = PattPrinter | ExprPrinter | NoPrinter
  55
  56 type pattern = patt field list
  57
  58 type constructor = expr field list
  59
  60 type named = string * alt
  61 and alt =
  62   | Pattern of pattern
  63   | Constructor of constructor
  64
  65 (* Work out if an expression is an integer constant.
  66  *
  67  * Returns [Some i] if so (where i is the integer value), else [None].
  68  *
  69  * Fairly simplistic algorithm: we can only detect simple constant
  70  * expressions such as [k], [k+c], [k-c] etc.
  71  *)
  72 let rec expr_is_constant = function
  73   | <:expr< $int:i$ >> ->               (* Literal integer constant. *)
  74     Some (int_of_string i)
  75   | <:expr< $a$ + $b$ >> ->             (* Addition of constants. *)
  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$ >> ->             (* Subtraction. *)
  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$ >> ->             (* Multiplication. *)
  84     (match expr_is_constant a, expr_is_constant b with
  85      | Some a, Some b -> Some (a*b)
  86      | _ -> None)
  87   | <:expr< $a$ / $b$ >> ->             (* Division. *)
  88     (match expr_is_constant a, expr_is_constant b with
  89      | Some a, Some b -> Some (a/b)
  90      | _ -> None)
  91   | <:expr< $a$ lsl $b$ >> ->           (* Shift left. *)
  92     (match expr_is_constant a, expr_is_constant b with
  93      | Some a, Some b -> Some (a lsl b)
  94      | _ -> None)
  95   | <:expr< $a$ lsr $b$ >> ->           (* Shift right. *)
  96     (match expr_is_constant a, expr_is_constant b with
  97      | Some a, Some b -> Some (a lsr b)
  98      | _ -> None)
  99   | _ -> None                           (* Anything else is not constant. *)
 100
 101 let string_of_field_type = function
 102   | Int -> "int"
 103   | String -> "string"
 104   | Bitstring -> "bitstring"
 105
 106 let patt_printer = function
 107   | <:patt< $lid:id$ >> -> id
 108   | <:patt< _ >> -> "_"
 109   | _ -> "[pattern]"
 110
 111 let expr_printer = function
 112   | <:expr< $lid:id$ >> -> id
 113   | <:expr< $int:i$ >> -> i
 114   | _ -> "[expression]"
 115
 116 let string_of_field { field = field; flen = flen;
 117                       endian = endian; signed = signed; t = t;
 118                       _loc = _loc;
 119                       printer = printer} =
 120   let flen =
 121     match expr_is_constant flen with
 122     | Some i -> string_of_int i
 123     | None -> "[non-const-len]" in
 124   let endian =
 125     match endian with
 126     | ConstantEndian endian -> Bitmatch.string_of_endian endian
 127     | EndianExpr _ -> "endian [expr]" in
 128   let signed = if signed then "signed" else "unsigned" in
 129   let t = string_of_field_type t in
 130   let loc_fname = Loc.file_name _loc in
 131   let loc_line = Loc.start_line _loc in
 132   let loc_char = Loc.start_off _loc - Loc.start_bol _loc in
 133
 134   sprintf "[field] : %s : %s, %s, %s @ (%S, %d, %d)"
 135     (*printer field*) flen t endian signed loc_fname loc_line loc_char
 136
 137 let string_of_pattern pattern =
 138   "{ " ^ String.concat ";\n  " (List.map string_of_field pattern) ^ " }\n"
 139
 140 let string_of_constructor constructor =
 141   "{ " ^ String.concat ";\n  " (List.map string_of_field constructor) ^ " }\n"
 142
 143 let named_to_channel chan n = Marshal.to_channel chan n []
 144
 145 let named_to_string n = Marshal.to_string n []
 146
 147 let named_to_buffer str ofs len n = Marshal.to_buffer str ofs len n []
 148
 149 let named_from_channel = Marshal.from_channel
 150
 151 let named_from_string = Marshal.from_string
 152
 153 let create_pattern_field _loc =
 154   {
 155     field = <:patt< _ >>;
 156     flen = <:expr< 32 >>;
 157     endian = ConstantEndian Bitmatch.BigEndian;
 158     signed = false;
 159     t = Int;
 160     _loc = _loc;
 161     printer = PattPrinter;
 162     offset = None;
 163   }
 164
 165 let set_lident_patt field id =
 166   let _loc = field._loc in
 167   { field with field = <:patt< $lid:id$ >> }
 168 let set_int_patt field i =
 169   let _loc = field._loc in
 170   { field with field = <:patt< $`int:i$ >> }
 171 let set_string_patt field str =
 172   let _loc = field._loc in
 173   { field with field = <:patt< $str:str$ >> }
 174 let set_unbound_patt field =
 175   let _loc = field._loc in
 176   { field with field = <:patt< _ >> }
 177 let set_patt field patt = { field with field = patt }
 178 let set_length_int field flen =
 179   let _loc = field._loc in
 180   { field with flen = <:expr< $`int:flen$ >> }
 181 let set_length field flen = { field with flen = flen }
 182 let set_endian field endian = { field with endian = ConstantEndian endian }
 183 let set_endian_expr field expr = { field with endian = EndianExpr expr }
 184 let set_signed field signed = { field with signed = signed }
 185 let set_type_int field = { field with t = Int }
 186 let set_type_string field = { field with t = String }
 187 let set_type_bitstring field = { field with t = Bitstring }
 188 let set_location field loc = { field with _loc = loc }
 189 let set_offset_int field i =
 190   let _loc = field._loc in
 191   { field with offset = Some <:expr< $`int:i$ >> }
 192 let set_offset field expr = { field with offset = Some expr }
 193 let set_no_offset field = { field with offset = None }
 194
 195 let create_constructor_field _loc =
 196   {
 197     field = <:expr< 0 >>;
 198     flen = <:expr< 32 >>;
 199     endian = ConstantEndian Bitmatch.BigEndian;
 200     signed = false;
 201     t = Int;
 202     _loc = _loc;
 203     printer = ExprPrinter;
 204     offset = None;
 205   }
 206
 207 let set_lident_expr field id =
 208   let _loc = field._loc in
 209   { field with field = <:expr< $lid:id$ >> }
 210 let set_int_expr field i =
 211   let _loc = field._loc in
 212   { field with field = <:expr< $`int:i$ >> }
 213 let set_string_expr field str =
 214   let _loc = field._loc in
 215   { field with field = <:expr< $str:str$ >> }
 216 let set_expr field expr =
 217   let _loc = field._loc in
 218   { field with field = expr }
 219
 220 let get_patt field = field.field
 221 let get_expr field = field.field
 222 let get_length field = field.flen
 223 let get_endian field = field.endian
 224 let get_signed field = field.signed
 225 let get_type field = field.t
 226 let get_location field = field._loc
 227 let get_offset field = field.offset