parsing_c/unparse_hrule.ml

   1 (*
   2  * Copyright (C) 2010, University of Copenhagen DIKU and INRIA.
   3  * Copyright (C) 2006, 2007 Julia Lawall
   4  *
   5  * This program is free software; you can redistribute it and/or
   6  * modify it under the terms of the GNU General Public License (GPL)
   7  * version 2 as published by the Free Software Foundation.
   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  * file license.txt for more details.
  13  *
  14  * This file was part of Coccinelle.
  15  *)
  16
  17 module Ast = Ast_cocci
  18 module V = Visitor_ast
  19
  20 let error x s =
  21   failwith
  22     (Printf.sprintf "unparse_hrule: line: %d, %s" (Ast.get_line x) s)
  23
  24 let names = ref ([] : (string * int ref) list)
  25
  26 let started_files = ref ([] : (string * bool) list)
  27 let typedefs = ref ([] : (string * string list ref) list)
  28 let current_outfile = ref ""
  29
  30 let prefix = "_cocci_"
  31
  32 (* ----------------------------------------------------------------------- *)
  33 (* Create rule to check for header include *)
  34
  35 let print_header_rule pr srcfile =
  36   match Str.split (Str.regexp "/") srcfile with
  37     [x] ->
  38       pr "@header@\n@@\n\n#include \"";
  39       pr x; pr "\"\n\n"; true
  40   | l ->
  41       let rec loop = function
  42           [] -> false
  43         | [x] ->
  44             pr "@header@\n@@\n\n#include \"";
  45             pr x; pr "\"\n\n"; true
  46         | "include"::(x::xs) ->
  47             pr "@header@\n@@\n\n#include <";
  48             let x =
  49               if Str.string_match (Str.regexp "asm-") x 0 then "asm" else x in
  50             pr (String.concat "/" (x::xs));
  51             pr ">\n\n"; true
  52         | x::xs -> loop xs in
  53       loop l
  54
  55 (* ----------------------------------------------------------------------- *)
  56 (* Print check that we are not in the defining function *)
  57
  58 let print_check_rule pr function_name function_name_count header_req =
  59   (if header_req
  60   then pr (Printf.sprintf "@same_%s depends on header@\n" function_name_count)
  61   else pr (Printf.sprintf "@same_%s@\n" function_name_count));
  62   pr "position p;\n";
  63   pr "@@\n\n";
  64   pr function_name; pr "@p(...) { ... }\n\n"
  65
  66 (* ----------------------------------------------------------------------- *)
  67 (* get parameters of the matched function *)
  68
  69 let rec env_lookup fn = function
  70     [] -> failwith "no binding"
  71   | (nm,vl)::rest when fn nm -> vl
  72   | _::rest -> env_lookup fn rest
  73
  74 let get_paramst env =
  75   let argname = ref ("","") in
  76   let fn ((_,nm) as name) =
  77     if nm = "ARGS"
  78     then (argname := name; true)
  79     else false in
  80   match env_lookup fn env with
  81     Ast_c.MetaParamListVal(paramst) -> (paramst,!argname)
  82   | _ -> failwith "not possible"
  83
  84 let get_function_name rule env =
  85   let donothing r k e = k e in
  86   let option_default = [] in
  87   let bind = Common.union_set in
  88   let do_any_list_list r any_list_list =
  89     List.fold_left
  90       (List.fold_left
  91          (function prev -> function cur ->
  92            bind (r.V.combiner_anything cur) prev))
  93       [] any_list_list in
  94   let mcode r mc =
  95     match Ast.get_mcodekind mc with
  96       Ast.MINUS(_,_,_,any_list_list) -> do_any_list_list r any_list_list
  97     | Ast.CONTEXT(_,any_befaft) ->
  98         (match any_befaft with
  99           Ast.BEFORE(any_list_list,_) | Ast.AFTER(any_list_list,_) ->
 100             do_any_list_list r any_list_list
 101         | Ast.BEFOREAFTER(ba,aa,_) ->
 102             bind (do_any_list_list r ba) (do_any_list_list r aa)
 103         | Ast.NOTHING -> [])
 104     | Ast.PLUS _ -> [] in
 105   let expression r k e =
 106     bind (k e)
 107     (match Ast.unwrap e with
 108       Ast.FunCall(fn,lp,args,rp) ->
 109         (match Ast.undots args with
 110           [e] ->
 111             (match Ast.unwrap e with
 112               Ast.MetaExprList(nm,_,_,_) ->
 113                 (match (Ast.unwrap_mcode nm,Ast.get_mcodekind nm) with
 114                   ((_,"ARGS"), Ast.PLUS _) ->
 115                     (match Ast.unwrap fn with
 116                       Ast.Ident(id) ->
 117                         (match Ast.unwrap id with
 118                           Ast.MetaId(nm,_,_,_)
 119                         | Ast.MetaFunc(nm,_,_,_)
 120                         | Ast.MetaLocalFunc(nm,_,_,_) ->
 121                             [Ast.unwrap_mcode nm]
 122                         | _ -> [])
 123                     | _ -> [])
 124                 | _ -> [])
 125             | _ -> [])
 126         | _ -> [])
 127     | _ -> []) in
 128   let names =
 129     (V.combiner bind option_default
 130       mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 131       donothing donothing donothing donothing
 132       donothing expression donothing donothing donothing donothing donothing
 133       donothing donothing donothing donothing donothing).V.combiner_top_level
 134       rule in
 135   match names with
 136     [name] ->
 137       (match env_lookup (function nm -> nm = name) env with
 138         Ast_c.MetaIdVal(s,_) | Ast_c.MetaFuncVal(s)
 139       | Ast_c.MetaLocalFuncVal(s) -> s
 140       | _ -> error rule "not possible")
 141   | _ -> error rule "inconsistent rule generation"
 142
 143 (* ----------------------------------------------------------------------- *)
 144 (* Print metavariable declarations *)
 145
 146 let rec print_typedef pr = function
 147     (Ast_c.TypeName(name,_),_) ->
 148       let s = Ast_c.str_of_name name in
 149       let typedefs =
 150         try List.assoc !current_outfile !typedefs
 151         with Not_found ->
 152           let td = ref [] in
 153           typedefs := (!current_outfile,td)::!typedefs;
 154           td in
 155       if not (List.mem s !typedefs)
 156       then (typedefs := s::!typedefs; pr "typedef "; pr s; pr ";\n")
 157   | (Ast_c.Pointer(_,ty),_) -> print_typedef pr ty
 158   | _ -> ()
 159
 160 let rewrap_str s ii =
 161   {ii with Ast_c.pinfo =
 162     (match ii.Ast_c.pinfo with
 163       Ast_c.OriginTok pi ->
 164         Ast_c.OriginTok { pi with Common.str = s;}
 165     | Ast_c.ExpandedTok (pi,vpi) ->
 166         Ast_c.ExpandedTok ({ pi with Common.str = s;},vpi)
 167     | Ast_c.FakeTok (_,vpi) -> Ast_c.FakeTok (s,vpi)
 168     | Ast_c.AbstractLineTok pi ->
 169         Ast_c.AbstractLineTok { pi with Common.str = s;})}
 170
 171 let rewrap_prefix_name prefix name =
 172   match name with
 173   | Ast_c.RegularName (s, iiname) ->
 174       let iis = Common.tuple_of_list1 iiname in
 175       let iis' = rewrap_str (prefix^s) iis in
 176       Ast_c.RegularName (prefix ^ s, [iis'])
 177   | Ast_c.CppConcatenatedName _ | Ast_c.CppVariadicName _
 178   | Ast_c.CppIdentBuilder _
 179       -> raise Common.Todo
 180
 181
 182 let print_metavar pr = function
 183   | {Ast_c.p_namei = Some name;
 184      p_type = (_,(Ast_c.Pointer(_,(Ast_c.BaseType(Ast_c.Void),_)),_));
 185     }
 186     ->
 187       let param = Ast_c.str_of_name name in
 188       pr ("expression "^prefix); pr param
 189   | ({Ast_c.p_namei = Some name; p_type = (_,ty)} : Ast_c.parameterType) ->
 190
 191       let name' = rewrap_prefix_name prefix name in
 192
 193       print_typedef pr ty;
 194
 195       Pretty_print_c.pp_param_gen
 196         (function x ->
 197           let str = Ast_c.str_of_info x in
 198           if not (List.mem str ["const";"volatile"])
 199           then pr str)
 200         (function _ -> pr " ")
 201         {Ast_c.p_register = (false,[]);
 202          p_namei = Some name';
 203          p_type = (({Ast_c.const = false; Ast_c.volatile = false},[]),ty)
 204         }
 205   | _ -> failwith "function must have named parameters"
 206
 207 let make_exp = function
 208     ({Ast_c.p_namei = Some name; p_type = ty}, comma_ii) ->
 209       let no_info = (None,Ast_c.NotTest) in
 210
 211       let name' = rewrap_prefix_name prefix name in
 212
 213       let exp =
 214         ((Ast_c.Ident (name'),ref no_info),Ast_c.noii) in
 215       (name,(Common.Left exp,comma_ii))
 216   | _ -> failwith "bad parameter"
 217
 218 let print_extra_typedefs pr env =
 219   let bigf =
 220     { Visitor_c.default_visitor_c with
 221       Visitor_c.ktype = (fun (k, bigf) ty ->
 222         match ty with
 223           (_,((Ast_c.TypeName(_,_),_) as ty)) -> print_typedef pr ty
 224         | _ -> k ty) } in
 225   List.iter
 226     (function (_,vl) ->
 227       match vl with
 228         Ast_c.MetaIdVal(_) | Ast_c.MetaFuncVal(_)
 229       | Ast_c.MetaLocalFuncVal(_) -> ()
 230       | Ast_c.MetaExprVal(exp,_) -> Visitor_c.vk_expr bigf exp
 231       | Ast_c.MetaExprListVal(args) -> Visitor_c.vk_argument_list bigf args
 232       | Ast_c.MetaParamVal(param) -> Visitor_c.vk_param bigf param
 233       | Ast_c.MetaParamListVal(params) -> Visitor_c.vk_param_list bigf params
 234
 235       | Ast_c.MetaTypeVal(ty) -> Visitor_c.vk_type bigf ty
 236       | Ast_c.MetaInitVal(ty) -> Visitor_c.vk_ini bigf ty
 237       | Ast_c.MetaStmtVal(stm) -> Visitor_c.vk_statement bigf stm
 238       | Ast_c.MetaPosVal _ | Ast_c.MetaPosValList _
 239       | Ast_c.MetaListlenVal _ -> ())
 240     env
 241
 242 let rename argids env =
 243   let argenv = List.map (function name ->
 244     let arg = Ast_c.str_of_name name in
 245     (arg,prefix^arg)
 246   ) argids in
 247   let lookup x = try List.assoc x argenv with Not_found -> x in
 248   let bigf =
 249     { Visitor_c.default_visitor_c_s with
 250     Visitor_c.kexpr_s = (fun (k,bigf) e ->
 251       match e with
 252         ((Ast_c.Ident (name), info), []) ->
 253
 254           (* pad: assert is_regular_ident ? *)
 255           let s = Ast_c.str_of_name name in
 256           let ii = Ast_c.info_of_name name in
 257           let new_name = lookup s in
 258           let new_id = Ast_c.RegularName (new_name, [rewrap_str new_name ii]) in
 259           ((Ast_c.Ident (new_id), info), Ast_c.noii)
 260       | _ -> k e) } in
 261   List.map
 262     (function (x,vl) ->
 263       (x,
 264        match vl with
 265          Ast_c.MetaIdVal(_) | Ast_c.MetaFuncVal(_)
 266        | Ast_c.MetaLocalFuncVal(_) -> vl
 267        | Ast_c.MetaExprVal(exp,c) ->
 268            Ast_c.MetaExprVal(Visitor_c.vk_expr_s bigf exp,c)
 269        | Ast_c.MetaExprListVal(args) ->
 270            Ast_c.MetaExprListVal(Visitor_c.vk_arguments_s bigf args)
 271        | Ast_c.MetaParamVal(param) ->
 272            Ast_c.MetaParamVal(Visitor_c.vk_param_s bigf param)
 273        | Ast_c.MetaParamListVal(params) ->
 274            Ast_c.MetaParamListVal(Visitor_c.vk_params_s bigf params)
 275
 276        | Ast_c.MetaTypeVal(ty) ->
 277            Ast_c.MetaTypeVal(Visitor_c.vk_type_s bigf ty)
 278        | Ast_c.MetaInitVal(ini) ->
 279            Ast_c.MetaInitVal(Visitor_c.vk_ini_s bigf ini)
 280        | Ast_c.MetaStmtVal(stm) ->
 281            Ast_c.MetaStmtVal(Visitor_c.vk_statement_s bigf stm)
 282        | Ast_c.MetaPosVal _ | Ast_c.MetaPosValList _
 283        | Ast_c.MetaListlenVal _ -> vl))
 284     env
 285
 286 let print_one_type pr env = function
 287     (Type_cocci.MetaType(name,keep,inherited)) as ty ->
 288       (try
 289         match List.assoc name env with
 290           Ast_c.MetaTypeVal ty ->
 291             Pretty_print_c.pp_type_gen
 292               (function x -> pr (Ast_c.str_of_info x))
 293               (function _ -> pr " ")
 294               ty
 295         | _ -> failwith "impossible"
 296       with Not_found -> pr (Type_cocci.type2c ty))
 297   | ty -> pr (Type_cocci.type2c ty)
 298
 299 let print_types pr env = function
 300     None -> ()
 301   | Some [ty] -> print_one_type pr env ty
 302   | Some types ->
 303       pr "{";
 304       Common.print_between (function _ -> pr ", ") (print_one_type pr env)
 305         types;
 306       pr "}"
 307
 308 let pp_meta_decl pr env decl =
 309   let no_arity = function Ast.NONE -> () | _ -> failwith "no arity allowed" in
 310   let pp_name (_,n) = pr n in
 311   match decl with
 312     Ast.MetaIdDecl(ar, name) ->
 313       (* ignore virtual *)
 314       no_arity ar; pr "identifier "; pp_name name; pr ";\n"
 315   | Ast.MetaFreshIdDecl(name, Ast.NoVal) ->
 316       pr "fresh identifier "; pp_name name; pr ";\n"
 317   | Ast.MetaFreshIdDecl(name, Ast.StringSeed x) ->
 318       pr "fresh identifier "; pp_name name; pr " = \""; pr x; pr "\";\n"
 319   | Ast.MetaFreshIdDecl(name, Ast.ListSeed x) ->
 320       failwith "unparse_hrule: not supported"
 321   | Ast.MetaTypeDecl(ar, name) ->
 322       no_arity ar; pr "type "; pp_name name; pr ";\n"
 323   | Ast.MetaInitDecl(ar, name) ->
 324       no_arity ar; pr "initialiser "; pp_name name; pr ";\n"
 325   | Ast.MetaListlenDecl(name) -> ()
 326   | Ast.MetaParamDecl(ar, name) ->
 327       no_arity ar; pr "parameter "; pp_name name; pr ";\n"
 328   | Ast.MetaParamListDecl(ar, name, None) ->
 329       no_arity ar; pr "parameter list "; pp_name name; pr ";\n"
 330   | Ast.MetaParamListDecl(ar, name, Some len) ->
 331       no_arity ar; pr "parameter list "; pp_name name;
 332       pr "["; pp_name len; pr "]"; pr ";\n"
 333   | Ast.MetaConstDecl(ar, name, types) ->
 334       no_arity ar; pr "constant "; print_types pr env types;
 335       pp_name name; pr ";\n"
 336   | Ast.MetaErrDecl(ar, name) ->
 337       no_arity ar; pr "error "; pp_name name; pr ";\n"
 338   | Ast.MetaExpDecl(ar, name, None) ->
 339       no_arity ar; pr "expression "; pp_name name; pr ";\n"
 340   | Ast.MetaExpDecl(ar, name, types) ->
 341       no_arity ar; print_types pr env types; pp_name name; pr ";\n"
 342   | Ast.MetaIdExpDecl(ar, name, types) ->
 343       no_arity ar; pr "idexpression ";
 344       print_types pr env types; pp_name name; pr ";\n"
 345   | Ast.MetaLocalIdExpDecl(ar, name, types) ->
 346       no_arity ar; pr "local idexpression ";
 347       print_types pr env types; pp_name name; pr ";\n"
 348   | Ast.MetaExpListDecl(ar, name, None) ->
 349       no_arity ar; pr "parameter list "; pp_name name; pr ";\n"
 350   | Ast.MetaExpListDecl(ar, name, Some len) ->
 351       no_arity ar; pr "parameter list ";
 352       pp_name name; pr "["; pp_name len; pr "]"; pr ";\n"
 353   | Ast.MetaStmDecl(ar, name) ->
 354       no_arity ar; pr "statement "; pp_name name; pr ";\n"
 355   | Ast.MetaStmListDecl(ar, name) ->
 356       no_arity ar; pr "statement list "; pp_name name; pr ";\n"
 357   | Ast.MetaFuncDecl(ar, name) ->
 358       no_arity ar; pr "function "; pp_name name; pr ";\n"
 359   | Ast.MetaLocalFuncDecl(ar, name) ->
 360       no_arity ar; pr "local function "; pp_name name; pr ";\n"
 361   | Ast.MetaPosDecl(ar, name) ->
 362       no_arity ar; pr "position "; pp_name name; pr ";\n"
 363   | Ast.MetaDeclarerDecl(ar, name) ->
 364       no_arity ar; pr "declarer "; pp_name name; pr ";\n"
 365   | Ast.MetaIteratorDecl(ar, name) ->
 366       no_arity ar; pr "iterator "; pp_name name; pr ";\n"
 367
 368 let print_metavariables pr local_metas paramst env header_req function_name =
 369   (if header_req
 370   then pr "@depends on header@\n"
 371   else pr "@@\n");
 372   pr (Printf.sprintf "position _p!=same_%s.p;\n" function_name);
 373   pr "identifier _f;\n";
 374   let rec loop = function
 375       [] | [{Ast_c.p_type =(_,(Ast_c.BaseType(Ast_c.Void),_))},_] -> []
 376     | ((first,_) as f)::rest ->
 377         print_metavar pr first; pr ";\n";
 378         (make_exp f) :: loop rest in
 379   let args = loop paramst in
 380   print_extra_typedefs pr env;
 381   List.iter (pp_meta_decl pr env) local_metas;
 382   pr "@@\n\n";
 383   args
 384
 385 (* ----------------------------------------------------------------------- *)
 386 (* print_start/end *)
 387
 388 let print_start pr =
 389   pr "_f@_p(...) { <+...\n"
 390
 391 let print_end pr =
 392   pr "\n...+> }\n"
 393
 394 (* ----------------------------------------------------------------------- *)
 395 (* Print call to the defined function *)
 396
 397 let print_param_name pr = function
 398     {Ast_c.p_namei = Some name} -> pr (Ast_c.str_of_name name)
 399   | _ -> failwith "function must have named parameters"
 400
 401 let pp_def_gen pr defn isexp =
 402   let {Ast_c.f_name = name; f_type = (_, (paramst, (b, iib))); } = defn in
 403   pr (Ast_c.str_of_name name); pr "(";
 404   (if b then failwith "not handling variable argument functions");
 405   (match paramst with
 406     [] | [{Ast_c.p_type = (_,(Ast_c.BaseType(Ast_c.Void),_))},_] -> ()
 407   | (first,_)::rest ->
 408       print_param_name pr first;
 409       List.iter (function (x,_) -> pr ", "; print_param_name pr x) rest);
 410   pr ")"; if not isexp then pr ";"
 411
 412 (* ----------------------------------------------------------------------- *)
 413 (* Entry point *)
 414
 415 let pp_rule local_metas ast env srcfile =
 416   let (paramst,args_name) = get_paramst env in
 417   (* get rule information *)
 418   let (rule,printable) =
 419     match ast with
 420       Ast.CocciRule(_,_,[body],_,_) -> (* could extend to use attributes *)
 421         (body,
 422          match Ast.unwrap body with
 423            Ast.DECL(s) -> [[Ast.StatementTag s]]
 424          | Ast.CODE(ss) -> [[Ast.StmtDotsTag ss]]
 425          | _ -> error body "bad rule body")
 426     | _ -> failwith "bad rule" in
 427   (* create the output file *)
 428   let outdir =
 429     match !Flag.make_hrule with
 430       Some outdir -> outdir
 431     | None -> error rule "not possible" in
 432   let function_name = get_function_name rule env in
 433   let function_name_count =
 434     try
 435       let cell = List.assoc function_name !names in
 436       let ct = !cell in
 437       cell := ct + 1;
 438       function_name ^ (string_of_int ct)
 439     with Not_found ->
 440       let cell = ref 1 in
 441       names := (function_name,cell) :: !names;
 442       function_name in
 443   let outfile = outdir ^ "/" ^
 444     (if !Flag.hrule_per_file
 445     then Filename.chop_extension (Filename.basename srcfile)
 446     else function_name_count) in
 447   let escape_re = Str.regexp_string "/" in
 448   let dir = if !Flag.dir = "" then Filename.dirname srcfile else !Flag.dir in
 449   let outdirfile = Str.global_replace escape_re "_"dir in
 450   let outfile = outfile ^ outdirfile ^ ".cocci" in
 451   let saved_header_req =
 452     try let res = List.assoc outfile !started_files in Some res
 453     with Not_found -> None in
 454   current_outfile := outfile;
 455   Common.with_open_outfile_append outfile (fun (pr,chan) ->
 456     let header_req =
 457       match saved_header_req with
 458         Some x -> x
 459       | None ->
 460           let res = print_header_rule pr srcfile in
 461           started_files := (outfile,res)::!started_files;
 462           res in
 463     print_check_rule pr function_name function_name_count header_req;
 464     let args =
 465       print_metavariables pr local_metas paramst env header_req
 466         function_name_count in
 467     let (argids,args) = List.split args in
 468     let env = rename argids env in
 469     let env = (args_name,Ast_c.MetaExprListVal args)::env in
 470     print_start pr;
 471     (* for printing C tokens *)
 472     let pr_c info =
 473       match Ast_c.pinfo_of_info info with
 474         Ast_c.AbstractLineTok _ -> pr (Ast_c.str_of_info info)
 475       | Ast_c.FakeTok (s,_) -> pr s
 476       | _ ->
 477           Printf.printf "line: %s\n" (Common.dump info);
 478           error rule "not an abstract line" in
 479     let pr_space _ = pr " " in
 480     Unparse_cocci.pp_list_list_any
 481       ([env], (fun s _ _ _ _ -> pr s), pr_c, pr_space, pr_space, pr,
 482        (fun _ _ -> ()), (function _ -> ()), (function _ -> ()))
 483       true printable Unparse_cocci.InPlace;
 484     print_end pr;
 485     pr "\n")