parsing_c/unparse_hrule.ml

   1 module TH = Token_helpers
   2
   3 let names = ref ([] : (string * int ref) list)
   4
   5 (* ----------------------------------------------------------------------- *)
   6 (* drop tokens representing the function header and the final close brace *)
   7
   8 let drop_header_toks toks_e =
   9   let remove t =
  10     if not (TH.is_comment_or_space t)
  11     then
  12       (TH.info_of_tok t).Ast_c.cocci_tag :=
  13         (Ast_cocci.MINUS(Ast_cocci.DontCarePos,[]),[]) in
  14   let rec drop_up_to_brace = function
  15       [] -> ()
  16     | ((Parser_c.TOBrace _) as t) :: _ -> remove t
  17     | x :: rest -> remove x; drop_up_to_brace rest in
  18   let drop_final_brace toks =
  19     match List.rev toks with
  20       ((Parser_c.TCBrace _) as t) :: _ -> remove t
  21     | _ -> failwith "unexpected end of function" in
  22   drop_up_to_brace toks_e;
  23   drop_final_brace toks_e
  24
  25 (* ----------------------------------------------------------------------- *)
  26 (* remove coments from tokens *)
  27
  28 let strip_comments toks =
  29  let toks = List.filter (function x -> not (TH.is_just_comment x)) toks in
  30   List.iter
  31     (function t ->
  32       (TH.info_of_tok t).Ast_c.comments_tag :=
  33         {Ast_c.mbefore = []; Ast_c.mafter = [];})
  34     toks;
  35  toks
  36
  37 (* ----------------------------------------------------------------------- *)
  38 (* Create rule to check for header include *)
  39
  40 let print_header_rule pr srcfile =
  41   match Str.split (Str.regexp "/") srcfile with
  42     [x] ->
  43       pr "@header@\n@@\n\n#include \""; pr x; pr "\"\n\n"; true
  44   | l ->
  45       let rec loop = function
  46           [] -> false
  47         | [x] ->
  48             pr "@header@\n@@\n\n#include \""; pr x; pr "\"\n\n"; true
  49         | "include"::(x::xs) ->
  50             pr "@header@\n@@\n\n#include <";
  51             let x =
  52               if Str.string_match (Str.regexp "asm-") x 0 then "asm" else x in
  53             pr (String.concat "/" (x::xs));
  54             pr ">\n\n"; true
  55         | x::xs -> loop xs in
  56       loop l
  57
  58 (* ----------------------------------------------------------------------- *)
  59 (* Print metavariable declarations *)
  60
  61 let rec print_typedef typedefs pr = function
  62     (Ast_c.TypeName(s,_),_) ->
  63       if not (List.mem s !typedefs)
  64       then (typedefs := s::!typedefs; pr "typedef "; pr s; pr ";\n")
  65   | (Ast_c.Pointer(_,ty),_) -> print_typedef typedefs pr ty
  66   | _ -> ()
  67
  68 let print_metavar pr typedefs = function
  69     ((_,Some param,(_,(Ast_c.Pointer(_,(Ast_c.BaseType(Ast_c.Void),_)),_))),_)
  70     ->
  71       pr "expression "; pr param
  72   | (((_,Some param,(_,ty)),il) : Ast_c.parameterType) ->
  73       print_typedef typedefs pr ty;
  74       Pretty_print_c.pp_param_gen
  75         (function x ->
  76           let str = Ast_c.str_of_info x in
  77           if not (List.mem str ["const";"volatile"])
  78           then (pr str; pr " "))
  79         (function _ -> pr " ")
  80         ((false,Some param,
  81           (({Ast_c.const = false; Ast_c.volatile = false},[]),ty)),
  82          il)
  83   | _ -> failwith "function must have named parameters"
  84
  85 let print_metavariables pr defn header_req =
  86   let {Ast_c.f_name = s; f_type = (_, (paramst, (b, iib))); } = defn in
  87   (if header_req
  88   then pr "@depends on header@\n"
  89   else pr "@@\n");
  90   (if b then failwith "not handling variable argument functions");
  91   let typedefs = ref ([] : string list) in
  92   (match paramst with
  93     [] | [(((_,_,(_,(Ast_c.BaseType(Ast_c.Void),_))),_),_)] -> ()
  94   | (first,_)::rest ->
  95       print_metavar pr typedefs first; pr ";\n";
  96       List.iter (function (x,_) -> print_metavar pr typedefs x; pr ";\n")
  97         rest);
  98   pr "@@\n\n"
  99
 100 (* ----------------------------------------------------------------------- *)
 101 (* copy a file, adding - at the beginning of every line *)
 102
 103 let minus_file pr file =
 104   Common.with_open_infile file (function chan ->
 105     let rec loop _ =
 106       let l = input_line chan in
 107       pr "- "; pr l; pr "\n";
 108       loop() in
 109     try loop() with End_of_file -> ())
 110
 111 (* ----------------------------------------------------------------------- *)
 112 (* Print call to the defined function *)
 113
 114 let print_param_name pr = function
 115     ((_,Some param,_),_) -> pr param
 116   | _ -> failwith "function must have named parameters"
 117
 118 let pp_def_gen pr defn isexp =
 119   let {Ast_c.f_name = s; f_type = (_, (paramst, (b, iib))); } = defn in
 120   pr s; pr "(";
 121   (if b then failwith "not handling variable argument functions");
 122   (match paramst with
 123     [] | [(((_,_,(_,(Ast_c.BaseType(Ast_c.Void),_))),_),_)] -> ()
 124   | (first,_)::rest ->
 125       print_param_name pr first;
 126       List.iter (function (x,_) -> pr ", "; print_param_name pr x) rest);
 127   pr ")"; if not isexp then pr ";"
 128
 129 (* ----------------------------------------------------------------------- *)
 130 (* Entry point *)
 131
 132 let pp_program (e,(str, toks_e)) outdir srcfile isexp =
 133   match e with
 134     Ast_c.Definition(({Ast_c.f_name = name;} as defn),_) ->
 135       (* generate the - code *)
 136       drop_header_toks toks_e;
 137       let toks_e = strip_comments toks_e in
 138       let tmp_file = Common.new_temp_file "cocci_small_output" ".c" in
 139       Unparse_c.pp_program [((e,(str, toks_e)), Unparse_c.PPnormal)]
 140         tmp_file;
 141       let outfile = outdir ^ "/" ^ name in
 142       let outfile =
 143         try
 144           let cell = List.assoc outfile !names in
 145           let ct = !cell in
 146           cell := ct + 1;
 147           outfile ^ (string_of_int ct)
 148         with Not_found ->
 149           let cell = ref 1 in names := (outfile,cell) :: !names; outfile in
 150       let outfile = outfile ^ ".cocci" in
 151       Common.with_open_outfile outfile (fun (pr,chan) ->
 152         let header_req = print_header_rule pr srcfile in
 153         print_metavariables pr defn header_req;
 154         minus_file pr tmp_file;
 155         pr "+ ";
 156         pp_def_gen pr defn isexp;
 157         pr "\n")
 158   | _ -> Common.pr2_once "warning: function expected"; ()