1 (* Bitstring persistent patterns.
2 * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
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.
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.
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
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
32 (* Field. In bitmatch (patterns) the type is [patt field]. In
33 * BITSTRING (constructor) the type is [expr 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] *)
47 and field_type = Int | String | Bitstring (* field type *)
49 | ConstantEndian of Bitstring.endian (* a constant little/big/nativeendian *)
50 | EndianExpr of expr (* an endian expression *)
52 type pattern = patt field list
54 type constructor = expr field list
56 type named = string * alt
59 | Constructor of constructor
61 (* Work out if an expression is an integer constant.
63 * Returns [Some i] if so (where i is the integer value), else [None].
65 * Fairly simplistic algorithm: we can only detect simple constant
66 * expressions such as [k], [k+c], [k-c] etc.
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)
75 | <:expr< $a$ - $b$ >> -> (* Subtraction. *)
76 (match expr_is_constant a, expr_is_constant b with
77 | Some a, Some b -> Some (a-b)
79 | <:expr< $a$ * $b$ >> -> (* Multiplication. *)
80 (match expr_is_constant a, expr_is_constant b with
81 | Some a, Some b -> Some (a*b)
83 | <:expr< $a$ / $b$ >> -> (* Division. *)
84 (match expr_is_constant a, expr_is_constant b with
85 | Some a, Some b -> Some (a/b)
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)
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)
95 | _ -> None (* Anything else is not constant. *)
97 let string_of_field_type = function
100 | Bitstring -> "bitstring"
102 let patt_printer = function
103 | <:patt< $lid:id$ >> -> id
104 | <:patt< _ >> -> "_"
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)
114 let _string_of_field { flen = flen;
115 endian = endian; signed = signed; t = t;
117 offset = offset; check = check; bind = bind;
118 save_offset_to = save_offset_to } =
119 let flen = expr_printer flen in
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
130 | Some expr -> sprintf ", offset(%s)" (expr_printer expr) in
135 | Some expr -> sprintf ", check(%s)" (expr_printer expr) in
140 | Some expr -> sprintf ", bind(%s)" (expr_printer expr) in
143 match save_offset_to with
147 | <:patt< $lid:id$ >> -> sprintf ", save_offset_to(%s)" id
148 | _ -> sprintf ", save_offset_to([patt])" in
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
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
158 let rec string_of_pattern_field ({ field = patt } as field) =
159 sprintf "%s : %s" (patt_printer patt) (_string_of_field field)
161 and string_of_constructor_field ({ field = expr } as field) =
162 sprintf "%s : %s" (expr_printer expr) (_string_of_field field)
164 let string_of_pattern pattern =
166 String.concat ";\n " (List.map string_of_pattern_field pattern) ^
169 let string_of_constructor constructor =
171 String.concat ";\n " (List.map string_of_constructor_field constructor) ^
174 let named_to_channel chan n = Marshal.to_channel chan n []
176 let named_to_string n = Marshal.to_string n []
178 let named_to_buffer str ofs len n = Marshal.to_buffer str ofs len n []
180 let named_from_channel = Marshal.from_channel
182 let named_from_string = Marshal.from_string
184 let create_pattern_field _loc =
186 field = <:patt< _ >>;
187 flen = <:expr< 32 >>;
188 endian = ConstantEndian Bitstring.BigEndian;
195 save_offset_to = None;
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 }
237 let create_constructor_field _loc =
239 field = <:expr< 0 >>;
240 flen = <:expr< 32 >>;
241 endian = ConstantEndian Bitstring.BigEndian;
248 save_offset_to = None;
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 }
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