cil-tools/bitmatch_import_c.ml

   1 (* Import a C header file.
   2  * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public
   6  * License as published by the Free Software Foundation; either
   7  * version 2 of the License, or (at your option) any later version.
   8  *
   9  * This library 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 GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17  *
  18  * $Id$
  19  *)
  20
  21 open Printf
  22 open ExtList
  23 open ExtString
  24 open Cil
  25
  26 let () =
  27   (* Parse command line arguments. *)
  28   let debug = ref false in
  29   let save_temps = ref false in
  30   let version () =
  31     printf "bitmatch-import-c %s" Bitmatch.version;
  32     exit 1
  33   in
  34
  35   let argspec = Arg.align [
  36     "--debug", Arg.Set debug,
  37       " Debug messages";
  38     "-save-temps", Arg.Set save_temps,
  39       " Save temporary files";
  40     "--version", Arg.Unit version,
  41       " Display version and exit";
  42   ] in
  43
  44   let input_file = ref None in
  45   let anon_fun str =
  46     match !input_file with
  47     | None -> input_file := Some str
  48     | Some _ ->
  49         eprintf "bitmatch-import-c: only give a single input file\n";
  50         exit 1
  51   in
  52   let usage_msg = "\
  53
  54 bitmatch-import-c: Import C structures and constants and
  55   generate bitmatching functions from them.  Please see the
  56   manual page bitmatch-import-c(1) for more information.
  57
  58 OPTIONS" in
  59
  60   Arg.parse argspec anon_fun usage_msg;
  61
  62   let debug = !debug in
  63   let save_temps = !save_temps in
  64   let input_file =
  65     match !input_file with
  66     | Some f -> f
  67     | None ->
  68         eprintf "bitmatch-import-c: no input file specified\n";
  69         exit 1 in
  70
  71   (* Grab the file and pass it to the preprocessor, and then read the
  72    * C code into memory using CIL.
  73    *)
  74   msvcMode := false;
  75   Cil.initCIL ();
  76
  77   (* XXX Unavoidable tmp exploit here.  Fix? *)
  78   let tmp, delete_tmp =
  79     if not save_temps then (
  80       let tmp = Filename.temp_file (Filename.temp_dir_name) ".i" in
  81       tmp, fun () -> try Unix.unlink tmp with Unix.Unix_error _ -> ()
  82     ) else (
  83       let tmp = Filename.chop_extension input_file ^ ".i" in
  84       tmp, fun () -> (* -save-temps, so do nothing *) ()
  85     ) in
  86
  87   let cmd =
  88     sprintf "cpp -include bitmatch-import-prefix.h %s > %s"
  89       (Filename.quote input_file) (Filename.quote tmp) in
  90   if debug then prerr_endline cmd;
  91   if Sys.command cmd <> 0 then (
  92     eprintf "%s: command failed\n" cmd;
  93     delete_tmp ();
  94     exit 1
  95   );
  96
  97   (* Why does Frontc.parse return a continuation ...? *)
  98   let file = (Frontc.parse tmp) () in
  99   delete_tmp ();
 100
 101   (* Find out which structures, #defines, etc. are to be imported.
 102    * (cf. the macros in bitmatch-import-prefix.h)
 103    *)
 104   let constants =
 105     List.filter_map (
 106       function
 107       | GVar ({vname = vname; vtype = vtype},
 108               { init = Some (SingleInit vinit) },
 109               loc)
 110           when String.starts_with vname "__bitmatch_constant_" ->
 111           let vname = String.sub vname 20 (String.length vname - 20) in
 112
 113           (* Do constant folding on the initializer and then calculate
 114            * its compile-time value.
 115            *)
 116           let vinit =
 117             match isInteger (constFold true vinit) with
 118             | Some i -> i
 119             | None ->
 120                 Errormsg.error
 121                   "%a: non-constant initializer: %a" d_loc loc d_exp vinit;
 122                 -1L in
 123
 124           Some (vname, vinit, loc)
 125       | _ -> None
 126     ) file.globals in
 127   let structs =
 128     List.filter_map (
 129       function
 130       | GType ({tname = tname; ttype = ttype}, loc)
 131           when String.starts_with tname "__bitmatch_import_" ->
 132           let tname = String.sub tname 18 (String.length tname - 18) in
 133           Some (tname, ttype, loc)
 134       | _ -> None
 135     ) file.globals in
 136
 137   if !Errormsg.hadErrors then exit 1;
 138
 139   (* If debugging, print out the imports. *)
 140   if debug then (
 141     List.iter (
 142       fun (vname, vinit, loc) ->
 143         Errormsg.log "%a: import %s as constant 0x%LX\n" d_loc loc vname vinit;
 144     ) constants;
 145     List.iter (
 146       fun (tname, ttype, loc) ->
 147         Errormsg.log "%a: import %s as %a\n" d_loc loc tname d_type ttype;
 148     ) structs;
 149   );
 150