1 (* Bitmatch 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.
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.
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
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
31 (* Field. In bitmatch (patterns) the type is [patt field]. In
32 * BITSTRING (constructor) the type is [expr 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 *)
42 (* Turn the field into a string. This used to be a function,
43 * but that would prevent this structure from being marshalled.
44 * This is unsatisfactory at the moment because it means we
45 * can't print out the 'a field.
49 and field_type = Int | String | Bitstring (* field type *)
51 | ConstantEndian of Bitmatch.endian (* a constant little/big/nativeendian *)
52 | EndianExpr of expr (* an endian expression *)
53 and printer_t = PattPrinter | ExprPrinter | NoPrinter
55 type pattern = patt field list
57 type constructor = expr field list
59 type named = string * alt
62 | Constructor of constructor
64 (* Work out if an expression is an integer constant.
66 * Returns [Some i] if so (where i is the integer value), else [None].
68 * Fairly simplistic algorithm: we can only detect simple constant
69 * expressions such as [k], [k+c], [k-c] etc.
71 let rec expr_is_constant = function
72 | <:expr< $int:i$ >> -> (* Literal integer constant. *)
73 Some (int_of_string i)
74 | <:expr< $a$ + $b$ >> -> (* Addition of constants. *)
75 (match expr_is_constant a, expr_is_constant b with
76 | Some a, Some b -> Some (a+b)
78 | <:expr< $a$ - $b$ >> -> (* Subtraction. *)
79 (match expr_is_constant a, expr_is_constant b with
80 | Some a, Some b -> Some (a-b)
82 | <:expr< $a$ * $b$ >> -> (* Multiplication. *)
83 (match expr_is_constant a, expr_is_constant b with
84 | Some a, Some b -> Some (a*b)
86 | <:expr< $a$ / $b$ >> -> (* Division. *)
87 (match expr_is_constant a, expr_is_constant b with
88 | Some a, Some b -> Some (a/b)
90 | <:expr< $a$ lsl $b$ >> -> (* Shift left. *)
91 (match expr_is_constant a, expr_is_constant b with
92 | Some a, Some b -> Some (a lsl b)
94 | <:expr< $a$ lsr $b$ >> -> (* Shift right. *)
95 (match expr_is_constant a, expr_is_constant b with
96 | Some a, Some b -> Some (a lsr b)
98 | _ -> None (* Anything else is not constant. *)
100 let string_of_field_type = function
103 | Bitstring -> "bitstring"
105 let patt_printer = function
106 | <:patt< $lid:id$ >> -> id
107 | <:patt< _ >> -> "_"
110 let expr_printer = function
111 | <:expr< $lid:id$ >> -> id
112 | <:expr< $int:i$ >> -> i
113 | _ -> "[expression]"
115 let string_of_field { field = field; flen = flen;
116 endian = endian; signed = signed; t = t;
120 match expr_is_constant flen with
121 | Some i -> string_of_int i
122 | None -> "[non-const-len]" in
125 | ConstantEndian endian -> Bitmatch.string_of_endian endian
126 | EndianExpr _ -> "endian [expr]" in
127 let signed = if signed then "signed" else "unsigned" in
128 let t = string_of_field_type t in
129 let loc_fname = Loc.file_name _loc in
130 let loc_line = Loc.start_line _loc in
131 let loc_char = Loc.start_off _loc - Loc.start_bol _loc in
133 sprintf "[field] : %s : %s, %s, %s @ (%S, %d, %d)"
134 (*printer field*) flen t endian signed loc_fname loc_line loc_char
136 let string_of_pattern pattern =
137 "{ " ^ String.concat ";\n " (List.map string_of_field pattern) ^ " }\n"
139 let string_of_constructor constructor =
140 "{ " ^ String.concat ";\n " (List.map string_of_field constructor) ^ " }\n"
142 let named_to_channel chan n = Marshal.to_channel chan n []
144 let named_to_string n = Marshal.to_string n []
146 let named_to_buffer str ofs len n = Marshal.to_buffer str ofs len n []
148 let named_from_channel = Marshal.from_channel
150 let named_from_string = Marshal.from_string
152 let create_pattern_field _loc =
154 field = <:patt< _ >>;
155 flen = <:expr< 32 >>;
156 endian = ConstantEndian Bitmatch.BigEndian;
160 printer = PattPrinter;
163 let set_lident_patt field id =
164 let _loc = field._loc in
165 { field with field = <:patt< $lid:id$ >> }
166 let set_int_patt field i =
167 let _loc = field._loc in
168 { field with field = <:patt< $`int:i$ >> }
169 let set_string_patt field str =
170 let _loc = field._loc in
171 { field with field = <:patt< $str:str$ >> }
172 let set_unbound_patt field =
173 let _loc = field._loc in
174 { field with field = <:patt< _ >> }
175 let set_patt field patt = { field with field = patt }
176 let set_length_int field flen =
177 let _loc = field._loc in
178 { field with flen = <:expr< $`int:flen$ >> }
179 let set_length field flen = { field with flen = flen }
180 let set_endian field endian = { field with endian = ConstantEndian endian }
181 let set_endian_expr field expr = { field with endian = EndianExpr expr }
182 let set_signed field signed = { field with signed = signed }
183 let set_type_int field = { field with t = Int }
184 let set_type_string field = { field with t = String }
185 let set_type_bitstring field = { field with t = Bitstring }
186 let set_location field loc = { field with _loc = loc }
188 let create_constructor_field _loc =
190 field = <:expr< 0 >>;
191 flen = <:expr< 32 >>;
192 endian = ConstantEndian Bitmatch.BigEndian;
196 printer = ExprPrinter;
199 let set_lident_expr field id =
200 let _loc = field._loc in
201 { field with field = <:expr< $lid:id$ >> }
202 let set_int_expr field i =
203 let _loc = field._loc in
204 { field with field = <:expr< $`int:i$ >> }
205 let set_string_expr field str =
206 let _loc = field._loc in
207 { field with field = <:expr< $str:str$ >> }
208 let set_expr field expr =
209 let _loc = field._loc in
210 { field with field = expr }
212 let get_patt field = field.field
213 let get_expr field = field.field
214 let get_length field = field.flen
215 let get_endian field = field.endian
216 let get_signed field = field.signed
217 let get_type field = field.t
218 let get_location field = field._loc