(* Import a C header file.
* Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
*
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2 of the License, or (at your option) any later version.
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
+ * This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
*
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*
* $Id$
*)
open Cil
+module P = Bitmatch_persistent
+
+let (//) = Filename.concat
+
let () =
(* Parse command line arguments. *)
let debug = ref false in
) in
let cmd =
- sprintf "cpp %s -include bitmatch-import-prefix.h %s > %s"
+ sprintf "cpp %s -I %s -include bitmatch-import-prefix.h %s > %s"
(String.concat " " (List.map Filename.quote cpp_args))
+ (Filename.quote (Bitmatch_config.ocamllibdir // "bitmatch"))
(Filename.quote input_file) (Filename.quote tmp) in
if debug then prerr_endline cmd;
if Sys.command cmd <> 0 then (
) structs;
);
- (* Output constants. *)
+(*
+ (* Output constants.
+ * XXX Disabled at the moment until we work out where to put them XXX
+ *)
List.iter (
fun (vname, vinit, loc) ->
printf "let %s = 0x%LX\n" vname vinit
) constants;
+*)
(* Output structures. *)
List.iter (
*)
(*Errormsg.log "%a: %s %a\n" d_loc loc tname d_plaintype ttype;*)
- (* Match on the type of this structure, and from it generate
- * a single parsing function.
- *)
- match ttype with
- (* struct or union *)
- | TComp ({ cdefined = true; cname = cname }, _) ->
- printf "let %s_of_bitstring bits =\n" tname;
- printf " bitmatch bits with\n";
- printf " | {\n";
- (*output_struct [] NoOffset None ttype;*)
- printf " } ->\n";
- printf " Some (...)\n";
- printf " | { _ } -> None\n\n"
-
- (* An undefined struct or union -- means one which was only ever
- * defined with 'struct foo;'. This is an error.
- *)
- | TComp ({ cdefined = false; cname = cname }, _) ->
- Errormsg.error
- "%a: struct or union has no definition: %s" d_loc loc cname
-
- (* Types which are not allowed, eg. void, int, arrays. *)
- | TVoid _ | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _
- | TNamed _ | TBuiltin_va_list _ ->
- Errormsg.error
- "%a: not a struct or union: %a" d_loc loc d_type ttype
-
- (* Types which we might implement in the future.
- * For enum we should probably split out enums separately
- * from structs above, since enums are more like constants.
+ (* Recursive function to generate a persistent pattern from a
+ * C struct or union. Quite a few limitations at the moment:
+ * (1) Structure elements must be in order.
+ * (2) Doesn't really work with unions [XXX].
+ *
+ * Parameters:
+ * ?names List of names of parent structs. Used in the
+ * recursive case for nested structs.
+ * ?offset Offset of struct within parent, usually NoOffset. Used
+ * in the recursive case for nested structs.
+ * ?endian Inherited endianness, usually None. Used for C
+ * __attribute__((bitwise)).
+ * ttype CIL type of struct.
+ * Returns:
+ * pattern A bitmatch persistent pattern.
*)
- | TEnum ({ ename = ename }, _) ->
- Errormsg.unimp "%a: %a" d_loc loc d_type ttype
-(*
- let rec to_fields names offset endian = function
- (* Some types contain attributes to indicate their
- * endianness. See many examples from <linux/types.h>.
- *)
+ let rec pattern_of_struct ?(names=[]) ?(offset=NoOffset) ?(endian=None)
+ ttype =
+ match ttype with
+ (* Some types contain attributes to indicate their
+ * endianness. See many examples from <linux/types.h>.
+ *)
| (TNamed ({ tname = tname;
ttype = TNamed (_, attrs) },
_) as t)
d_loc loc tname;
endian
) in
- to_fields names offset endian (unrollType t)
+ pattern_of_struct ~names ~offset ~endian (unrollType t)
(* See into named types. *)
| (TNamed _ as t) ->
- to_fields names offset endian (unrollType t)
+ pattern_of_struct ~names ~offset ~endian (unrollType t)
(* struct or union *)
| TComp ({ cdefined = true; cfields = cfields }, _) ->
fun ({ fname = fname; ftype = ftype } as finfo) ->
let offset = Field (finfo, offset) in
let names = fname :: names in
- to_fields names offset endian ftype
+ pattern_of_struct ~names ~offset ~endian ftype
) cfields in
List.flatten cfields
(* int array with constant length *)
- | TArray (basetype, (Some _ as len), _)
- when isIntegralType basetype ->
- let len = lenOfArray len in
+ | TArray (basetype, (Some _ as len), _) when isIntegralType basetype ->
+ let nr_elems = lenOfArray len in
let bitsoffset, totalwidth = bitsOffset ttype offset in
- let bitswidth = totalwidth / len (* of the element *) in
- (*if debug then (
- let name = String.concat "." (List.rev names) in
- Errormsg.log "%s: int array: %d, %d, len %d\n"
- name bitsoffset bitswidth len
- );*)
+ let bitswidth = totalwidth / nr_elems (* of the element *) in
let basetype = unrollType basetype in
let ikind =
match basetype with
| t ->
Errormsg.unimp "%a: unhandled type: %a" d_loc loc d_type t;
IInt in
- let field =
- to_int_field "" bitsoffset bitswidth ikind endian in
let fname = String.concat "_" (List.rev names) in
- let byteoffset = bitsoffset lsr 3 in
- let bytetotalwidth = totalwidth lsr 3 in
- printf "--> array %s: byteoffset=%d bytetotalwidth=%d len=%d\n"
- fname byteoffset bytetotalwidth len (* field *);
- []
+
+ (* If the base type is 8 bits then we always translate this to
+ * a string (whether the C type is signed or unsigned). There
+ * is no endianness in bytes so ignore that.
+ *)
+ if bitswidth = 8 then
+ [pattern_field_of_string fname bitsoffset nr_elems]
+ else (
+ (* XXX Realistically we don't handle arrays well at
+ * the moment. Perhaps we should give up and match
+ * this to a bitstring?
+ *)
+ let signed = isSigned ikind in
+ if debug then
+ eprintf "--> array %s: nr_elems=%d signed=%b\n"
+ fname nr_elems signed;
+ [] (* XXX *)
+ )
(* basic integer type *)
| TInt (ikind, _) ->
);*)
let fname = String.concat "_" (List.rev names) in
let field =
- to_int_field fname bitsoffset bitswidth ikind endian in
+ pattern_field_of_int fname bitsoffset bitswidth ikind endian in
[field]
(* a pointer - in this mapping we assume this is an address
| TPtr _ ->
let bitsoffset, bitswidth = bitsOffset ttype offset in
let fname = String.concat "_" (List.rev names) in
- printf "--> pointer %s: bitsoffset=%d bitswidth=%d\n"
- fname bitsoffset bitswidth;
- []
+ if debug then
+ eprintf "--> pointer %s: bitsoffset=%d bitswidth=%d\n"
+ fname bitsoffset bitswidth;
+ [] (* XXX *)
| t ->
- Errormsg.unimp "to_fields: %a: unhandled type: %a"
+ Errormsg.warn "pattern_of_struct: %a: unhandled type: %a"
d_loc loc d_type t;
[]
- and to_int_field fname bitsoffset bitswidth ikind endian =
- let byteoffset = bitsoffset lsr 3 in
- let bytewidth = bitswidth lsr 3 in
+ (* Convert a single int field into a pattern field.
+ * Could be a bitfield, byte, short, etc.
+ *)
+ and pattern_field_of_int fname bitsoffset bitswidth ikind endian =
let signed = isSigned ikind in
-
- if bitsoffset land 7 = 0 && bitswidth land 7 = 0 then (
- (* Not a bitfield. *)
- match bitswidth with
- | 8 ->
- printf "--> byte %s: byteoffset=%d bytewidth=%d signed=%b\n"
- fname byteoffset bytewidth signed
- | 16 ->
- printf "--> short %s: byteoffset=%d bytewidth=%d signed=%b endian=%s\n"
- fname byteoffset bytewidth signed (Option.map_default Bitmatch.string_of_endian "None" endian)
- | 32 ->
- printf "--> int %s: byteoffset=%d bytewidth=%d signed=%b endian=%s\n"
- fname byteoffset bytewidth signed (Option.map_default Bitmatch.string_of_endian "None" endian)
- | 64 ->
- printf "--> long %s: byteoffset=%d bytewidth=%d signed=%b endian=%s\n"
- fname byteoffset bytewidth signed (Option.map_default Bitmatch.string_of_endian "None" endian)
- | _ ->
- Errormsg.unimp "%s: unhandled integer width: %d bits"
- fname bitswidth
- ) else (
- (* It's a bitfield if either the offset or width isn't
- * byte-aligned.
- *)
- let bitsoffset = bitsoffset land 7 in
- printf "--> bitfield %s: byteoffset=%d bytewidth=%d signed=%b endian=%s bitsoffset=%d bitswidth=%d\n"
- fname byteoffset bytewidth
- signed (Option.map_default Bitmatch.string_of_endian "None" endian) bitsoffset bitswidth
- )
+ let _loc = camlp4_loc_of_cil_loc loc in
+
+ let field = P.create_pattern_field _loc in
+ let field = P.set_lident_patt field fname in
+ let field = P.set_type_int field in
+ let field = P.set_length_int field bitswidth in
+ let field = P.set_offset_int field bitsoffset in
+ let field = P.set_signed field signed in
+ let field =
+ match endian with
+ | Some endian -> P.set_endian field endian
+ | None -> P.set_endian field Bitmatch.NativeEndian in
+
+ field
+
+ and pattern_field_of_string fname bitsoffset nr_elems =
+ let _loc = camlp4_loc_of_cil_loc loc in
+ let field = P.create_pattern_field _loc in
+ let field = P.set_lident_patt field fname in
+ let field = P.set_type_string field in
+ let field = P.set_length_int field (nr_elems*8) in
+ let field = P.set_offset_int field bitsoffset in
+ field
+
+ (* Convert a CIL location into a camlp4 location. Grrr these
+ * should be compatible!
+ *)
+ and camlp4_loc_of_cil_loc loc =
+ let _loc = Camlp4.PreCast.Syntax.Ast.Loc.mk loc.file in
+ Camlp4.PreCast.Syntax.Ast.Loc.move_line loc.line _loc
in
-*)
+
+ (* Match on the type of this structure, and from it generate
+ * a single parsing function.
+ *)
+ match ttype with
+ (* struct or union *)
+ | TComp ({ cdefined = true; cname = cname }, _) ->
+ let pattern = pattern_of_struct ttype in
+ let named_pattern = cname, P.Pattern pattern in
+ P.named_to_channel stdout named_pattern
+
+ (* An undefined struct or union -- means one which was only ever
+ * defined with 'struct foo;'. This is an error.
+ *)
+ | TComp ({ cdefined = false; cname = cname }, _) ->
+ Errormsg.error
+ "%a: struct or union has no definition: %s" d_loc loc cname
+
+ (* Types which are not allowed, eg. void, int, arrays. *)
+ | TVoid _ | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _
+ | TNamed _ | TBuiltin_va_list _ ->
+ Errormsg.error
+ "%a: not a struct or union: %a" d_loc loc d_type ttype
+
+ (* Types which we might implement in the future.
+ * For enum we should probably split out enums separately
+ * from structs above, since enums are more like constants.
+ *)
+ | TEnum ({ ename = ename }, _) ->
+ Errormsg.unimp "%a: %a" d_loc loc d_type ttype
+
) structs;
if !Errormsg.hadErrors then exit 1;
git.annexia.org / ocaml-bitstring.git / blobdiff