cil-tools/bitstring_import_c.ml

   1 (* Import a C header file.
   2  * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
   3  *
   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.
   8  *
   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.
  13  *
  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.
  17  *
  18  * $Id$
  19  *)
  20
  21 open Printf
  22 open ExtList
  23 open ExtString
  24
  25 open Cil
  26
  27 module P = Bitstring_persistent
  28
  29 let (//) = Filename.concat
  30
  31 let () =
  32   (* Parse command line arguments. *)
  33   let debug = ref false in
  34   let save_temps = ref false in
  35   let version () =
  36     printf "bitstring-import-c %s" Bitstring.version;
  37     exit 1
  38   in
  39   let cpp_args = ref [] in
  40   let cpp_arg2 name value =
  41     cpp_args := (name ^ value) :: !cpp_args
  42   in
  43
  44   let argspec = Arg.align [
  45     "--debug", Arg.Set debug,
  46       " Debug messages";
  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";
  57   ] in
  58
  59   let input_file = ref None in
  60   let anon_fun str =
  61     match !input_file with
  62     | None -> input_file := Some str
  63     | Some _ ->
  64         eprintf "bitstring-import-c: only give a single input file\n";
  65         exit 1
  66   in
  67   let usage_msg = "\
  68
  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.
  72
  73 OPTIONS" in
  74
  75   Arg.parse argspec anon_fun usage_msg;
  76
  77   let debug = !debug in
  78   let save_temps = !save_temps in
  79   let input_file =
  80     match !input_file with
  81     | Some f -> f
  82     | None ->
  83         eprintf "bitstring-import-c: no input file specified\n";
  84         exit 1 in
  85   let cpp_args = List.rev !cpp_args in
  86
  87   (* Grab the file and pass it to the preprocessor, and then read the
  88    * C code into memory using CIL.
  89    *)
  90   msvcMode := false;
  91   Cil.initCIL ();
  92
  93   (* XXX Unavoidable tmp exploit here.  Fix? *)
  94   let tmp, delete_tmp =
  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 _ -> ()
  98     ) else (
  99       let tmp = Filename.chop_extension input_file ^ ".i" in
 100       tmp, fun () -> (* -save-temps, so do nothing *) ()
 101     ) in
 102
 103   let cmd =
 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;
 111     delete_tmp ();
 112     exit 1
 113   );
 114
 115   (* Why does Frontc.parse return a continuation ...? *)
 116   let file = (Frontc.parse tmp) () in
 117   delete_tmp ();
 118
 119   (* Find out which structures, #defines, etc. are to be imported.
 120    * (cf. the macros in bitstring-import-prefix.h)
 121    *)
 122   let constants =
 123     List.filter_map (
 124       function
 125       | GVar ({vname = vname; vtype = vtype},
 126               { init = Some (SingleInit vinit) },
 127               loc)
 128           when String.starts_with vname "__bitstring_constant_" ->
 129           let vname = String.sub vname 20 (String.length vname - 20) in
 130
 131           (* Do constant folding on the initializer and then calculate
 132            * its compile-time value.
 133            *)
 134           let vinit =
 135             match isInteger (constFold true vinit) with
 136             | Some i -> i
 137             | None ->
 138                 Errormsg.error
 139                   "%a: non-constant initializer: %a" d_loc loc d_exp vinit;
 140                 -1L in
 141
 142           Some (vname, vinit, loc)
 143       | _ -> None
 144     ) file.globals in
 145   let structs =
 146     List.filter_map (
 147       function
 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)
 152       | _ -> None
 153     ) file.globals in
 154
 155   if !Errormsg.hadErrors then exit 1;
 156
 157   (* If debugging, print out the imports. *)
 158   if debug then (
 159     List.iter (
 160       fun (vname, vinit, loc) ->
 161         Errormsg.log "%a: import %s as constant 0x%LX\n" d_loc loc vname vinit;
 162     ) constants;
 163     List.iter (
 164       fun (tname, ttype, loc) ->
 165         Errormsg.log "%a: import %s as %a\n" d_loc loc tname d_type ttype;
 166     ) structs;
 167   );
 168
 169 (*
 170   (* Output constants.
 171    * XXX Disabled at the moment until we work out where to put them XXX
 172    *)
 173   List.iter (
 174     fun (vname, vinit, loc) ->
 175       printf "let %s = 0x%LX\n" vname vinit
 176   ) constants;
 177 *)
 178
 179   (* Output structures. *)
 180   List.iter (
 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.
 185        *)
 186       (*Errormsg.log "%a: %s %a\n" d_loc loc tname d_plaintype ttype;*)
 187
 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].
 192        *
 193        * Parameters:
 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.
 201        * Returns:
 202        *   pattern  A bitstring persistent pattern.
 203        *)
 204       let rec pattern_of_struct ?(names=[]) ?(offset=NoOffset) ?(endian=None)
 205           ttype =
 206         match ttype with
 207         (* Some types contain attributes to indicate their
 208          * endianness.  See many examples from <linux/types.h>.
 209          *)
 210         | (TNamed ({ tname = tname;
 211                      ttype = TNamed (_, attrs) },
 212                    _) as t)
 213             when hasAttribute "bitwise" attrs ->
 214             let endian =
 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
 219               else (
 220                 Errormsg.warn "%a: unknown bitwise attribute typename: %s\n"
 221                   d_loc loc tname;
 222                 endian
 223               ) in
 224             pattern_of_struct ~names ~offset ~endian (unrollType t)
 225
 226         (* See into named types. *)
 227         | (TNamed _ as t) ->
 228             pattern_of_struct ~names ~offset ~endian (unrollType t)
 229
 230         (* struct or union *)
 231         | TComp ({ cdefined = true; cfields = cfields }, _) ->
 232             let cfields =
 233               List.map (
 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
 238               ) cfields in
 239             List.flatten cfields
 240
 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
 247             let ikind =
 248               match basetype with
 249               | TInt (ikind, _) -> ikind
 250               | t ->
 251                   Errormsg.unimp "%a: unhandled type: %a" d_loc loc d_type t;
 252                   IInt in
 253             let fname = String.concat "_" (List.rev names) in
 254
 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.
 258              *)
 259             if bitswidth = 8 then
 260               [pattern_field_of_string fname bitsoffset nr_elems]
 261             else (
 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?
 265                *)
 266               let signed = isSigned ikind in
 267               if debug then
 268                 eprintf "--> array %s: nr_elems=%d signed=%b\n"
 269                   fname nr_elems signed;
 270               [] (* XXX *)
 271             )
 272
 273         (* basic integer type *)
 274         | TInt (ikind, _) ->
 275             let bitsoffset, bitswidth = bitsOffset ttype offset in
 276             (*if debug then (
 277               let name = String.concat "." (List.rev names) in
 278               Errormsg.log "%s: int: %d, %d\n" name bitsoffset bitswidth
 279             );*)
 280             let fname = String.concat "_" (List.rev names) in
 281             let field =
 282               pattern_field_of_int fname bitsoffset bitswidth ikind endian in
 283             [field]
 284
 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.
 289          *)
 290         | TPtr _ ->
 291             let bitsoffset, bitswidth = bitsOffset ttype offset in
 292             let fname = String.concat "_" (List.rev names) in
 293             if debug then
 294               eprintf "--> pointer %s: bitsoffset=%d bitswidth=%d\n"
 295                 fname bitsoffset bitswidth;
 296             [] (* XXX *)
 297
 298         | t ->
 299             Errormsg.warn "pattern_of_struct: %a: unhandled type: %a"
 300               d_loc loc d_type t;
 301             []
 302
 303       (* Convert a single int field into a pattern field.
 304        * Could be a bitfield, byte, short, etc.
 305        *)
 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
 309
 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
 316         let field =
 317           match endian with
 318           | Some endian -> P.set_endian field endian
 319           | None -> P.set_endian field Bitstring.NativeEndian in
 320
 321         field
 322
 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
 330         field
 331
 332       (* Convert a CIL location into a camlp4 location.  Grrr these
 333        * should be compatible!
 334        *)
 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
 338       in
 339
 340       (* Match on the type of this structure, and from it generate
 341        * a single parsing function.
 342        *)
 343       match ttype with
 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
 349
 350       (* An undefined struct or union -- means one which was only ever
 351        * defined with 'struct foo;'.  This is an error.
 352        *)
 353       | TComp ({ cdefined = false; cname = cname }, _) ->
 354           Errormsg.error
 355             "%a: struct or union has no definition: %s" d_loc loc cname
 356
 357       (* Types which are not allowed, eg. void, int, arrays. *)
 358       | TVoid _ | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _
 359       | TNamed _ | TBuiltin_va_list _ ->
 360           Errormsg.error
 361             "%a: not a struct or union: %a" d_loc loc d_type ttype
 362
 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.
 366        *)
 367       | TEnum ({ ename = ename }, _) ->
 368           Errormsg.unimp "%a: %a" d_loc loc d_type ttype
 369
 370   ) structs;
 371
 372   if !Errormsg.hadErrors then exit 1;
 373
 374   exit 0