1 (* Import a C header file.
2 * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
4 * This program is free software; you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation; either version 2 of the License, or
7 * (at your option) any later version.
9 * This program 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
12 * GNU General Public License for more details.
14 * You should have received a copy of the GNU General Public License
15 * along with this program; if not, write to the Free Software
16 * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
27 module P = Bitstring_persistent
29 let (//) = Filename.concat
32 (* Parse command line arguments. *)
33 let debug = ref false in
34 let save_temps = ref false in
36 printf "bitstring-import-c %s" Bitstring.version;
39 let cpp_args = ref [] in
40 let cpp_arg2 name value =
41 cpp_args := (name ^ value) :: !cpp_args
44 let argspec = Arg.align [
45 "--debug", Arg.Set debug,
47 "--version", Arg.Unit version,
48 " Display version and exit";
49 "-save-temps", Arg.Set save_temps,
50 " Save temporary files";
51 "-I", Arg.String (cpp_arg2 "-I"),
52 "dir Specify extra include directory for cpp";
53 "-D", Arg.String (cpp_arg2 "-D"),
54 "name=value Define value in cpp";
55 "-U", Arg.String (cpp_arg2 "-U"),
56 "name Undefine value in cpp";
59 let input_file = ref None in
61 match !input_file with
62 | None -> input_file := Some str
64 eprintf "bitstring-import-c: only give a single input file\n";
69 bitstring-import-c: Import C structures and constants and
70 generate bitmatching functions from them. Please see the
71 manual page bitstring-import-c(1) for more information.
75 Arg.parse argspec anon_fun usage_msg;
78 let save_temps = !save_temps in
80 match !input_file with
83 eprintf "bitstring-import-c: no input file specified\n";
85 let cpp_args = List.rev !cpp_args in
87 (* Grab the file and pass it to the preprocessor, and then read the
88 * C code into memory using CIL.
93 (* XXX Unavoidable tmp exploit here. Fix? *)
95 if not save_temps then (
96 let tmp = Filename.temp_file (Filename.temp_dir_name) ".i" in
97 tmp, fun () -> try Unix.unlink tmp with Unix.Unix_error _ -> ()
99 let tmp = Filename.chop_extension input_file ^ ".i" in
100 tmp, fun () -> (* -save-temps, so do nothing *) ()
104 sprintf "cpp %s -I %s -include bitstring-import-prefix.h %s > %s"
105 (String.concat " " (List.map Filename.quote cpp_args))
106 (Filename.quote (Bitstring_config.ocamllibdir // "bitstring"))
107 (Filename.quote input_file) (Filename.quote tmp) in
108 if debug then prerr_endline cmd;
109 if Sys.command cmd <> 0 then (
110 eprintf "%s: command failed\n" cmd;
115 (* Why does Frontc.parse return a continuation ...? *)
116 let file = (Frontc.parse tmp) () in
119 (* Find out which structures, #defines, etc. are to be imported.
120 * (cf. the macros in bitstring-import-prefix.h)
125 | GVar ({vname = vname; vtype = vtype},
126 { init = Some (SingleInit vinit) },
128 when String.starts_with vname "__bitstring_constant_" ->
129 let vname = String.sub vname 20 (String.length vname - 20) in
131 (* Do constant folding on the initializer and then calculate
132 * its compile-time value.
135 match isInteger (constFold true vinit) with
139 "%a: non-constant initializer: %a" d_loc loc d_exp vinit;
142 Some (vname, vinit, loc)
148 | GType ({tname = tname; ttype = ttype}, loc)
149 when String.starts_with tname "__bitstring_import_" ->
150 let tname = String.sub tname 18 (String.length tname - 18) in
151 Some (tname, ttype, loc)
155 if !Errormsg.hadErrors then exit 1;
157 (* If debugging, print out the imports. *)
160 fun (vname, vinit, loc) ->
161 Errormsg.log "%a: import %s as constant 0x%LX\n" d_loc loc vname vinit;
164 fun (tname, ttype, loc) ->
165 Errormsg.log "%a: import %s as %a\n" d_loc loc tname d_type ttype;
171 * XXX Disabled at the moment until we work out where to put them XXX
174 fun (vname, vinit, loc) ->
175 printf "let %s = 0x%LX\n" vname vinit
179 (* Output structures. *)
181 fun (tname, ttype, loc) ->
182 (* Uncomment the next line if you want to really print the
183 * complete CIL structure of the type (for debugging etc.).
184 * The ASTs printed here are usually quite large.
186 (*Errormsg.log "%a: %s %a\n" d_loc loc tname d_plaintype ttype;*)
188 (* Recursive function to generate a persistent pattern from a
189 * C struct or union. Quite a few limitations at the moment:
190 * (1) Structure elements must be in order.
191 * (2) Doesn't really work with unions [XXX].
194 * ?names List of names of parent structs. Used in the
195 * recursive case for nested structs.
196 * ?offset Offset of struct within parent, usually NoOffset. Used
197 * in the recursive case for nested structs.
198 * ?endian Inherited endianness, usually None. Used for C
199 * __attribute__((bitwise)).
200 * ttype CIL type of struct.
202 * pattern A bitstring persistent pattern.
204 let rec pattern_of_struct ?(names=[]) ?(offset=NoOffset) ?(endian=None)
207 (* Some types contain attributes to indicate their
208 * endianness. See many examples from <linux/types.h>.
210 | (TNamed ({ tname = tname;
211 ttype = TNamed (_, attrs) },
213 when hasAttribute "bitwise" attrs ->
215 if String.starts_with tname "__le" then
216 Some Bitstring.LittleEndian
217 else if String.starts_with tname "__be" then
218 Some Bitstring.BigEndian
220 Errormsg.warn "%a: unknown bitwise attribute typename: %s\n"
224 pattern_of_struct ~names ~offset ~endian (unrollType t)
226 (* See into named types. *)
228 pattern_of_struct ~names ~offset ~endian (unrollType t)
230 (* struct or union *)
231 | TComp ({ cdefined = true; cfields = cfields }, _) ->
234 fun ({ fname = fname; ftype = ftype } as finfo) ->
235 let offset = Field (finfo, offset) in
236 let names = fname :: names in
237 pattern_of_struct ~names ~offset ~endian ftype
241 (* int array with constant length *)
242 | TArray (basetype, (Some _ as len), _) when isIntegralType basetype ->
243 let nr_elems = lenOfArray len in
244 let bitsoffset, totalwidth = bitsOffset ttype offset in
245 let bitswidth = totalwidth / nr_elems (* of the element *) in
246 let basetype = unrollType basetype in
249 | TInt (ikind, _) -> ikind
251 Errormsg.unimp "%a: unhandled type: %a" d_loc loc d_type t;
253 let fname = String.concat "_" (List.rev names) in
255 (* If the base type is 8 bits then we always translate this to
256 * a string (whether the C type is signed or unsigned). There
257 * is no endianness in bytes so ignore that.
259 if bitswidth = 8 then
260 [pattern_field_of_string fname bitsoffset nr_elems]
262 (* XXX Realistically we don't handle arrays well at
263 * the moment. Perhaps we should give up and match
264 * this to a bitstring?
266 let signed = isSigned ikind in
268 eprintf "--> array %s: nr_elems=%d signed=%b\n"
269 fname nr_elems signed;
273 (* basic integer type *)
275 let bitsoffset, bitswidth = bitsOffset ttype offset in
277 let name = String.concat "." (List.rev names) in
278 Errormsg.log "%s: int: %d, %d\n" name bitsoffset bitswidth
280 let fname = String.concat "_" (List.rev names) in
282 pattern_field_of_int fname bitsoffset bitswidth ikind endian in
285 (* a pointer - in this mapping we assume this is an address
286 * (endianness and wordsize come from function parameters),
287 * in other words we DON'T try to follow pointers, we just
288 * note that they are there.
291 let bitsoffset, bitswidth = bitsOffset ttype offset in
292 let fname = String.concat "_" (List.rev names) in
294 eprintf "--> pointer %s: bitsoffset=%d bitswidth=%d\n"
295 fname bitsoffset bitswidth;
299 Errormsg.warn "pattern_of_struct: %a: unhandled type: %a"
303 (* Convert a single int field into a pattern field.
304 * Could be a bitfield, byte, short, etc.
306 and pattern_field_of_int fname bitsoffset bitswidth ikind endian =
307 let signed = isSigned ikind in
308 let _loc = camlp4_loc_of_cil_loc loc in
310 let field = P.create_pattern_field _loc in
311 let field = P.set_lident_patt field fname in
312 let field = P.set_type_int field in
313 let field = P.set_length_int field bitswidth in
314 let field = P.set_offset_int field bitsoffset in
315 let field = P.set_signed field signed in
318 | Some endian -> P.set_endian field endian
319 | None -> P.set_endian field Bitstring.NativeEndian in
323 and pattern_field_of_string fname bitsoffset nr_elems =
324 let _loc = camlp4_loc_of_cil_loc loc in
325 let field = P.create_pattern_field _loc in
326 let field = P.set_lident_patt field fname in
327 let field = P.set_type_string field in
328 let field = P.set_length_int field (nr_elems*8) in
329 let field = P.set_offset_int field bitsoffset in
332 (* Convert a CIL location into a camlp4 location. Grrr these
333 * should be compatible!
335 and camlp4_loc_of_cil_loc loc =
336 let _loc = Camlp4.PreCast.Syntax.Ast.Loc.mk loc.file in
337 Camlp4.PreCast.Syntax.Ast.Loc.move_line loc.line _loc
340 (* Match on the type of this structure, and from it generate
341 * a single parsing function.
344 (* struct or union *)
345 | TComp ({ cdefined = true; cname = cname }, _) ->
346 let pattern = pattern_of_struct ttype in
347 let named_pattern = cname, P.Pattern pattern in
348 P.named_to_channel stdout named_pattern
350 (* An undefined struct or union -- means one which was only ever
351 * defined with 'struct foo;'. This is an error.
353 | TComp ({ cdefined = false; cname = cname }, _) ->
355 "%a: struct or union has no definition: %s" d_loc loc cname
357 (* Types which are not allowed, eg. void, int, arrays. *)
358 | TVoid _ | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _
359 | TNamed _ | TBuiltin_va_list _ ->
361 "%a: not a struct or union: %a" d_loc loc d_type ttype
363 (* Types which we might implement in the future.
364 * For enum we should probably split out enums separately
365 * from structs above, since enums are more like constants.
367 | TEnum ({ ename = ename }, _) ->
368 Errormsg.unimp "%a: %a" d_loc loc d_type ttype
372 if !Errormsg.hadErrors then exit 1;