(* 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 <linux/types.h>.
	 *)
	| (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