X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;ds=sidebyside;f=cil-tools%2Fbitmatch_import_c.ml;fp=cil-tools%2Fbitmatch_import_c.ml;h=0000000000000000000000000000000000000000;hb=46d02767bf223661c05127d86878a74be0bda712;hp=0bf655f6bc0e9a8e99fbfd7498640a0f0ef88c08;hpb=f25c540aaaf288957abacbfd2034c362bb051f90;p=ocaml-bitstring.git diff --git a/cil-tools/bitmatch_import_c.ml b/cil-tools/bitmatch_import_c.ml deleted file mode 100644 index 0bf655f..0000000 --- a/cil-tools/bitmatch_import_c.ml +++ /dev/null @@ -1,374 +0,0 @@ -(* Import a C header file. - * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones - * - * 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 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 General Public License for more details. - * - * 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 Printf -open ExtList -open ExtString - -open Cil - -module P = Bitmatch_persistent - -let (//) = Filename.concat - -let () = - (* Parse command line arguments. *) - let debug = ref false in - let save_temps = ref false in - let version () = - 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"; - "--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 - let anon_fun str = - match !input_file with - | None -> input_file := Some str - | Some _ -> - eprintf "bitmatch-import-c: only give a single input file\n"; - exit 1 - in - let usage_msg = "\ - -bitmatch-import-c: Import C structures and constants and - generate bitmatching functions from them. Please see the - manual page bitmatch-import-c(1) for more information. - -OPTIONS" in - - Arg.parse argspec anon_fun usage_msg; - - let debug = !debug in - let save_temps = !save_temps in - let input_file = - match !input_file with - | Some f -> f - | 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. - *) - msvcMode := false; - Cil.initCIL (); - - (* XXX Unavoidable tmp exploit here. Fix? *) - let tmp, delete_tmp = - if not save_temps then ( - let tmp = Filename.temp_file (Filename.temp_dir_name) ".i" in - tmp, fun () -> try Unix.unlink tmp with Unix.Unix_error _ -> () - ) else ( - let tmp = Filename.chop_extension input_file ^ ".i" in - tmp, fun () -> (* -save-temps, so do nothing *) () - ) in - - let cmd = - 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 ( - eprintf "%s: command failed\n" cmd; - delete_tmp (); - exit 1 - ); - - (* Why does Frontc.parse return a continuation ...? *) - let file = (Frontc.parse tmp) () in - delete_tmp (); - - (* Find out which structures, #defines, etc. are to be imported. - * (cf. the macros in bitmatch-import-prefix.h) - *) - let constants = - List.filter_map ( - function - | GVar ({vname = vname; vtype = vtype}, - { init = Some (SingleInit vinit) }, - loc) - when String.starts_with vname "__bitmatch_constant_" -> - let vname = String.sub vname 20 (String.length vname - 20) in - - (* Do constant folding on the initializer and then calculate - * its compile-time value. - *) - let vinit = - match isInteger (constFold true vinit) with - | Some i -> i - | None -> - Errormsg.error - "%a: non-constant initializer: %a" d_loc loc d_exp vinit; - -1L in - - Some (vname, vinit, loc) - | _ -> None - ) file.globals in - let structs = - List.filter_map ( - function - | GType ({tname = tname; ttype = ttype}, loc) - when String.starts_with tname "__bitmatch_import_" -> - let tname = String.sub tname 18 (String.length tname - 18) in - Some (tname, ttype, loc) - | _ -> None - ) file.globals in - - if !Errormsg.hadErrors then exit 1; - - (* If debugging, print out the imports. *) - if debug then ( - List.iter ( - fun (vname, vinit, loc) -> - Errormsg.log "%a: import %s as constant 0x%LX\n" d_loc loc vname vinit; - ) constants; - List.iter ( - fun (tname, ttype, loc) -> - Errormsg.log "%a: import %s as %a\n" d_loc loc tname d_type ttype; - ) 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