X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=cil-tools%2Fbitmatch_import_c.ml;h=6936facf52fb4dd73f600c61442e0ab121da589a;hb=1be824ff4774c2df525b7647c6d9ca4502a753f8;hp=7587fc4582eca15a78ba6e8f63e32c708dc3ae5a;hpb=909f573d797eee83641263fbfe9c42417185ec26;p=ocaml-bitstring.git diff --git a/cil-tools/bitmatch_import_c.ml b/cil-tools/bitmatch_import_c.ml index 7587fc4..6936fac 100644 --- a/cil-tools/bitmatch_import_c.ml +++ b/cil-tools/bitmatch_import_c.ml @@ -21,8 +21,11 @@ open Printf open ExtList open ExtString + open Cil +module P = Bitmatch_persistent + let () = (* Parse command line arguments. *) let debug = ref false in @@ -31,14 +34,24 @@ let () = printf "bitmatch-import-c %s" Bitmatch.version; exit 1 in + let cpp_args = ref [] in + let cpp_arg2 name value = + cpp_args := (name ^ value) :: !cpp_args + in let argspec = Arg.align [ "--debug", Arg.Set debug, " Debug messages"; - "-save-temps", Arg.Set save_temps, - " Save temporary files"; "--version", Arg.Unit version, " Display version and exit"; + "-save-temps", Arg.Set save_temps, + " Save temporary files"; + "-I", Arg.String (cpp_arg2 "-I"), + "dir Specify extra include directory for cpp"; + "-D", Arg.String (cpp_arg2 "-D"), + "name=value Define value in cpp"; + "-U", Arg.String (cpp_arg2 "-U"), + "name Undefine value in cpp"; ] in let input_file = ref None in @@ -67,6 +80,7 @@ OPTIONS" in | None -> eprintf "bitmatch-import-c: no input file specified\n"; exit 1 in + let cpp_args = List.rev !cpp_args in (* Grab the file and pass it to the preprocessor, and then read the * C code into memory using CIL. @@ -85,7 +99,8 @@ OPTIONS" in ) in let cmd = - sprintf "cpp -include bitmatch-import-prefix.h %s > %s" + sprintf "cpp %s -include bitmatch-import-prefix.h %s > %s" + (String.concat " " (List.map Filename.quote cpp_args)) (Filename.quote input_file) (Filename.quote tmp) in if debug then prerr_endline cmd; if Sys.command cmd <> 0 then ( @@ -148,3 +163,209 @@ OPTIONS" in ) structs; ); +(* + (* 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 ( + fun (tname, ttype, loc) -> + (* Uncomment the next line if you want to really print the + * complete CIL structure of the type (for debugging etc.). + * The ASTs printed here are usually quite large. + *) + (*Errormsg.log "%a: %s %a\n" d_loc loc tname d_plaintype ttype;*) + + (* 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. + *) + 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 . + *) + | (TNamed ({ tname = tname; + ttype = TNamed (_, attrs) }, + _) as t) + when hasAttribute "bitwise" attrs -> + let endian = + if String.starts_with tname "__le" then + Some Bitmatch.LittleEndian + else if String.starts_with tname "__be" then + Some Bitmatch.BigEndian + else ( + Errormsg.warn "%a: unknown bitwise attribute typename: %s\n" + d_loc loc tname; + endian + ) in + pattern_of_struct ~names ~offset ~endian (unrollType t) + + (* See into named types. *) + | (TNamed _ as t) -> + pattern_of_struct ~names ~offset ~endian (unrollType t) + + (* struct or union *) + | TComp ({ cdefined = true; cfields = cfields }, _) -> + let cfields = + List.map ( + fun ({ fname = fname; ftype = ftype } as finfo) -> + let offset = Field (finfo, offset) in + let names = fname :: names in + 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 nr_elems = lenOfArray len in + let bitsoffset, totalwidth = bitsOffset ttype offset in + let bitswidth = totalwidth / nr_elems (* of the element *) in + let basetype = unrollType basetype in + let ikind = + match basetype with + | TInt (ikind, _) -> ikind + | t -> + Errormsg.unimp "%a: unhandled type: %a" d_loc loc d_type t; + IInt in + let fname = String.concat "_" (List.rev names) in + + (* 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 bitsoffset, bitswidth = bitsOffset ttype offset in + (*if debug then ( + let name = String.concat "." (List.rev names) in + Errormsg.log "%s: int: %d, %d\n" name bitsoffset bitswidth + );*) + let fname = String.concat "_" (List.rev names) in + let field = + pattern_field_of_int fname bitsoffset bitswidth ikind endian in + [field] + + (* a pointer - in this mapping we assume this is an address + * (endianness and wordsize come from function parameters), + * in other words we DON'T try to follow pointers, we just + * note that they are there. + *) + | TPtr _ -> + let bitsoffset, bitswidth = bitsOffset ttype offset in + let fname = String.concat "_" (List.rev names) in + if debug then + eprintf "--> pointer %s: bitsoffset=%d bitswidth=%d\n" + fname bitsoffset bitswidth; + [] (* XXX *) + + | t -> + Errormsg.warn "pattern_of_struct: %a: unhandled type: %a" + d_loc loc d_type t; + [] + + (* 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 + 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; + + exit 0