parsing_c/unparse_hrule.ml

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