Release coccinelle-0.1.5

[bpt/coccinelle.git] / parsing_c / cpp_ast_c.ml

(* Copyright (C) 2008, 2009 University of Urbana Champaign
 *
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License (GPL)
 * version 2 as published by the Free Software Foundation.
 * 
 * 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
 * file license.txt for more details.
 *)
open Common

open Ast_c

(*****************************************************************************)
(* Cpp Ast Manipulations *)
(*****************************************************************************)

(*
 * cpp-include-expander-builtin.
 * 
 * alternative1: parse and call cpp tour a tour. So let cpp work at 
 *  the token level. That's what most tools do.
 * alternative2: apply cpp at the very end. Process that go through ast
 *  and do the stuff such as #include,  macro expand, 
 *  ifdef but on the ast!
 * 
 * But need keep those info in ast at least, even bad
 * macro for instance, and for parse error region ? maybe can 
 * get another chance ?
 * I think it's better to do the cpp-include-expander in a different step
 * rather than embedding it in the parser. The parser is already too complex. 
 * Also keep with the tradition to try to parse as-is.
 * 
 * todo? but maybe could discover new info that could help reparse
 * the ParseError in original file. Try again parsing it by
 * putting it in a minifile ? 
 * 
 * 
 * todo? maybe can do some pass that work at the ifdef level and for instance
 * try to paren them, so have in Ast some stuff that are not
 * present at parsing time but that can then be constructed after
 * some processing (a little bit like my type for expression filler,
 * or position info filler, or include relative position filler).
 * 
 * ??add such info about what was done somewhere ? could build new
 * ??ast each time but too tedious (maybe need delta-programming!)
 *
 * todo? maybe change cpp_ast_c to go deeper on local "" ?
 * 
 * 
 * TODO: macro expand, 
 * TODO: handle ifdef
 * 
 * 
 * 
 * cpp_ifdef_statementize: again better to separate concern and in parser
 *  just add the directives in a flat way (IfdefStmt) and later do more
 *  processing and transform them in a tree with some IfdefStmt2.
 *)



(*****************************************************************************)
(* Types  *)
(*****************************************************************************)

type cpp_option = 
  | I of Common.dirname
  | D of string * string option



let i_of_cpp_options xs = 
  xs +> Common.map_filter (function
  | I f -> Some f
  | D _ -> None
  )

let cpp_option_of_cmdline (xs, ys) = 
  (xs +> List.map (fun s -> I s)) ++
  (ys +> List.map (fun s -> 
    if s =~ "\\([A-Z][A-Z0-9_]*\\)=\\(.*\\)"
    then
      let (def, value) = matched2 s in
      D (def, Some value)
    else 
      D (s, None)
  ))

(*****************************************************************************)
(* Helpers *)
(*****************************************************************************)

let _hcandidates = Hashtbl.create 101

let init_adjust_candidate_header_files dir = 
  let ext = "[h]" in
  let files = Common.files_of_dir_or_files ext [dir] in

  files +> List.iter (fun file -> 
    let base = Filename.basename file in
    pr2 file;
    Hashtbl.add _hcandidates base file;
  );
  ()



(* may return a list of match ? *)
let find_header_file1 cppopts dirname inc_file =
  match inc_file with
  | Local f -> 
      let finalfile = 
        Filename.concat dirname (Ast_c.s_of_inc_file inc_file) in
      if Sys.file_exists finalfile 
      then [finalfile]
      else []
  | NonLocal f -> 
      i_of_cpp_options cppopts +> Common.map_filter (fun dirname -> 
        let finalfile = 
          Filename.concat dirname (Ast_c.s_of_inc_file inc_file) in
        if Sys.file_exists finalfile 
        then Some finalfile
        else None
      )
  | Wierd s -> 
      pr2 ("CPPAST: wierd include not handled:" ^ s);
      []

(* todo? can try find most precise ? first just use basename but
 * then maybe look if have also some dir in common ?
 *)
let find_header_file2 inc_file = 
  match inc_file with
  | Local f 
  | NonLocal f -> 
      let s = (Ast_c.s_of_inc_file inc_file) in
      let base = Filename.basename s in

      let res = Hashtbl.find_all _hcandidates base in
      (match res with
      | [file] -> 
          pr2 ("CPPAST: find header in other dir: " ^ file);
          res
      | [] -> 
          []
      | x::y::xs -> res
      )
  | Wierd s -> 
      []


let find_header_file cppopts dirname inc_file =
  let res1 = find_header_file1 cppopts dirname inc_file in
  match res1 with
  | [file] -> res1 
  | [] -> find_header_file2 inc_file
  | x::y::xs -> res1




(* ---------------------------------------------------------------------- *)
let trace_cpp_process depth mark inc_file =
  pr2 (spf "%s>%s %s" 
          (Common.repeat "-" depth +> Common.join "")
          mark
          (s_of_inc_file_bis inc_file));
  ()


(* ---------------------------------------------------------------------- *)
let _headers_hash = Hashtbl.create 101 

(* On freebsd ocaml is trashing, use up to 1.6Go of memory and then
 * building the database_c takes ages. 
 * 
 * So just limit with following threshold to avoid this trashing, simple.
 * 
 * On netbsd, got a Out_of_memory exn on this file;
 * /home/pad/software-os-src2/netbsd/dev/microcode/cyclades-z/
 * even if the cache is small. That's because huge single 
 * ast element and probably the ast marshalling fail.
 *)
let threshold_cache_nb_files = ref 200

let parse_c_and_cpp_cache file =
  if Hashtbl.length _headers_hash > !threshold_cache_nb_files
  then Hashtbl.clear _headers_hash;

  Common.memoized _headers_hash file (fun () -> 
    Parse_c.parse_c_and_cpp file
  )


(* ---------------------------------------------------------------------- *)
let (show_cpp_i_opts: string list -> unit) = fun xs -> 
  if not (null xs) then begin 
    pr2 "-I";
    xs +> List.iter pr2
  end

  
let (show_cpp_d_opts: string list -> unit) = fun xs ->
  if not (null xs) then begin
    pr2 "-D";
    xs +> List.iter pr2
  end

(*****************************************************************************)
(* Main entry *)
(*****************************************************************************)


let (cpp_expand_include2: 
 ?depth_limit:int option ->
 cpp_option list -> Common.dirname -> Ast_c.program -> Ast_c.program) =
 fun ?(depth_limit=None) iops dirname ast -> 

  pr2_xxxxxxxxxxxxxxxxx();
  let already_included = ref [] in

  let rec aux stack dirname ast = 
    let depth = List.length stack in

    ast +> Visitor_c.vk_program_s { Visitor_c.default_visitor_c_s with
      Visitor_c.kcppdirective_s = (fun (k, bigf) cpp -> 
        match cpp with 
        | Include {i_include = (inc_file, ii);
                   i_rel_pos = h_rel_pos;
                   i_is_in_ifdef = b;
                   i_content = copt;
                   } 
          -> 
          (match depth_limit with
          | Some limit when depth >= limit -> cpp
          | _ -> 
           
            (match find_header_file iops dirname inc_file with
            | [file] -> 
                if List.mem file !already_included
                then begin 
                  (* pr2 ("already included: " ^ file); *)
                  trace_cpp_process depth "*" inc_file;
                  k cpp
                end else begin
                  trace_cpp_process depth "" inc_file;
                  Common.push2 file already_included;
                  (* CONFIG *)
                  Flag_parsing_c.verbose_parsing := false; 
                  Flag_parsing_c.verbose_lexing := false; 
                  let (ast2, _stat) = parse_c_and_cpp_cache file in

                  let ast = Parse_c.program_of_program2 ast2 in
                  let dirname' = Filename.dirname file in 

                  (* recurse *)
                  let ast' = aux (file::stack) dirname' ast in

                  Include {i_include = (inc_file, ii);
                           i_rel_pos = h_rel_pos;
                           i_is_in_ifdef = b;
                           i_content = Some (file, ast');
                  }
                end
            | [] -> 
                trace_cpp_process depth "!!" inc_file;
                pr2 "CPPAST: file not found";
                k cpp
            | x::y::zs -> 
                trace_cpp_process depth "!!" inc_file;
                pr2 "CPPAST: too much candidates";
                k cpp
            )
          )
        | _ -> k cpp
      );
    }
  in
  aux [] dirname ast
    

let cpp_expand_include ?depth_limit a b c = 
  Common.profile_code "cpp_expand_include"
   (fun () -> cpp_expand_include2 ?depth_limit a b c)

(* 
let unparse_showing_include_content ?
*)


(*****************************************************************************)
(* Ifdef-statementize *)
(*****************************************************************************)


let is_ifdef_and_same_tag tag x = 
  match x with
  | IfdefStmt (IfdefDirective ((_, tag2),_)) -> 
      tag = tag2
  | StmtElem _ | CppDirectiveStmt _ -> false
  | IfdefStmt2 _ -> raise Impossible



(* What if I skipped in the parser only some of the ifdef elements
 * of the same tag. Once I passed one, I should pass all of them and so
 * at least should detect here that one tag is not "valid". Maybe in the parser
 * can return or marked some tags as "partially_passed_ifdef_tag".
 * Maybe could do in ast_c a MatchingTag of int * bool ref (* one_was_passed *)
 * where the ref will be shared by the ifdefs with the same matching tag
 * indice. Or simply count  the number of directives with the same tag and
 * put this information in the tag. Hence the total_with_this_tag below.
 *)
let should_ifdefize tag ifdefs_directives xxs = 
  let IfdefTag (_tag, total_with_this_tag) = tag in
  
  if total_with_this_tag <> List.length ifdefs_directives
  then begin
    pr2 "CPPASTC: can not ifdefize, some of its directives were passed";
    false 
  end else 
    (* todo? put more condition ? dont ifdefize declaration ? *)
    true





(* return a triple, (ifdefs directive * grouped xs * remaining sequencable) 
 * XXX1 XXX2 elsif YYY1 else ZZZ1 endif WWW1 WWW2 
 * => [elsif, else, endif], [XXX1 XXX2; YYY1; ZZZ1], [WWW1 WWW2]
 *)
let group_ifdef tag xs = 
  let (xxs, xs) = group_by_post (is_ifdef_and_same_tag tag) xs in
  
  xxs +> List.map snd +> List.map (fun x -> 
    match x with 
    | IfdefStmt y -> y
    | StmtElem _ | CppDirectiveStmt _ | IfdefStmt2 _ -> raise Impossible
  ),
  xxs +> List.map fst, 
  xs


let rec cpp_ifdef_statementize ast = 
  Visitor_c.vk_program_s { Visitor_c.default_visitor_c_s with
    Visitor_c.kstatementseq_list_s = (fun (k, bigf) xs -> 
      
      let rec aux xs = 
        match xs with
        | [] -> []
        | stseq::xs -> 
            (match stseq with
            | StmtElem st -> 
                Visitor_c.vk_statement_sequencable_s bigf stseq::aux xs
            | CppDirectiveStmt directive -> 
                Visitor_c.vk_statement_sequencable_s bigf stseq::aux xs
            | IfdefStmt ifdef -> 
                (match ifdef with
                | IfdefDirective ((Ifdef,tag),ii) -> 

                    let (restifdefs, xxs, xs') = group_ifdef tag xs in
                    if should_ifdefize tag (ifdef::restifdefs) xxs 
                    then
                      let res = IfdefStmt2 (ifdef::restifdefs, xxs) in
                      Visitor_c.vk_statement_sequencable_s bigf res::aux xs'
                    else 
                      Visitor_c.vk_statement_sequencable_s bigf stseq::aux xs
                      
                | IfdefDirective (((IfdefElseif|IfdefElse|IfdefEndif),b),ii) -> 
                    pr2 "wierd: first directive is not a ifdef";
                    (* maybe not wierd, just that should_ifdefize 
                     * returned false *)
                    Visitor_c.vk_statement_sequencable_s bigf stseq::aux xs
                )

            | IfdefStmt2 (ifdef, xxs) -> 
                failwith "already applied cpp_ifdef_statementize"
            )
      in
      aux xs
    );
  } ast


(*****************************************************************************)
(* Macro *)
(*****************************************************************************)

let (cpp_expand_macro_expr: 
  Ast_c.define_kind -> Ast_c.argument Ast_c.wrap2 list -> 
  Ast_c.expression option) = 
 fun defkind args -> 
   raise Todo