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