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(s,_),_) ->
 132       let typedefs =
 133         try List.assoc !current_outfile !typedefs
 134         with Not_found ->
 135           let td = ref [] in
 136           typedefs := (!current_outfile,td)::!typedefs;
 137           td in
 138       if not (List.mem s !typedefs)
 139       then (typedefs := s::!typedefs; pr "typedef "; pr s; pr ";\n")
 140   | (Ast_c.Pointer(_,ty),_) -> print_typedef pr ty
 141   | _ -> ()
 142
 143 let rewrap_str s ii =
 144   {ii with Ast_c.pinfo =
 145     (match ii.Ast_c.pinfo with
 146       Ast_c.OriginTok pi ->
 147         Ast_c.OriginTok { pi with Common.str = s;}
 148     | Ast_c.ExpandedTok (pi,vpi) ->
 149         Ast_c.ExpandedTok ({ pi with Common.str = s;},vpi)
 150     | Ast_c.FakeTok (_,vpi) -> Ast_c.FakeTok (s,vpi)
 151     | Ast_c.AbstractLineTok pi ->
 152         Ast_c.AbstractLineTok { pi with Common.str = s;})}
 153
 154 let print_metavar pr = function
 155     ((_,Some param,(_,(Ast_c.Pointer(_,(Ast_c.BaseType(Ast_c.Void),_)),_))),_)
 156     ->
 157       pr ("expression "^prefix); pr param
 158   | (((_,Some param,(_,ty)),il) : Ast_c.parameterType) ->
 159       let il =
 160         match List.rev il with
 161           name::rest -> (rewrap_str (prefix^param) name) :: rest
 162         | _ -> failwith "no name" in
 163       print_typedef pr ty;
 164       Pretty_print_c.pp_param_gen
 165         (function x ->
 166           let str = Ast_c.str_of_info x in
 167           if not (List.mem str ["const";"volatile"])
 168           then pr str)
 169         (function _ -> pr " ")
 170         ((false,Some param,
 171           (({Ast_c.const = false; Ast_c.volatile = false},[]),ty)),
 172          il)
 173   | _ -> failwith "function must have named parameters"
 174
 175 let make_exp = function
 176     (((_,Some name,ty),param_ii),comma_ii) ->
 177       let no_info = (None,Ast_c.NotTest) in
 178       let nm = prefix^name in
 179       let exp =
 180         ((Ast_c.Ident nm,ref no_info),
 181          [rewrap_str nm (List.hd(List.rev param_ii))]) in
 182       (name,(Common.Left exp,comma_ii))
 183   | _ -> failwith "bad parameter"
 184
 185 let print_extra_typedefs pr env =
 186   let bigf =
 187     { Visitor_c.default_visitor_c with
 188       Visitor_c.ktype = (fun (k, bigf) ty ->
 189         match ty with
 190           (_,((Ast_c.TypeName(_,_),_) as ty)) -> print_typedef pr ty
 191         | _ -> k ty) } in
 192   List.iter
 193     (function (_,vl) ->
 194       match vl with
 195         Ast_c.MetaIdVal(_) | Ast_c.MetaFuncVal(_)
 196       | Ast_c.MetaLocalFuncVal(_) -> ()
 197       | Ast_c.MetaExprVal(exp) -> Visitor_c.vk_expr bigf exp
 198       | Ast_c.MetaExprListVal(args) -> Visitor_c.vk_argument_list bigf args
 199       | Ast_c.MetaParamVal(param) -> Visitor_c.vk_param bigf param
 200       | Ast_c.MetaParamListVal(params) -> Visitor_c.vk_param_list bigf params
 201
 202       | Ast_c.MetaTypeVal(ty) -> Visitor_c.vk_type bigf ty
 203       | Ast_c.MetaInitVal(ty) -> Visitor_c.vk_ini bigf ty
 204       | Ast_c.MetaStmtVal(stm) -> Visitor_c.vk_statement bigf stm
 205       | Ast_c.MetaPosVal _ | Ast_c.MetaPosValList _
 206       | Ast_c.MetaListlenVal _ -> ())
 207     env
 208
 209 let rename argids env =
 210   let argenv = List.map (function arg -> (arg,prefix^arg)) argids in
 211   let lookup x = try List.assoc x argenv with Not_found -> x in
 212   let bigf =
 213     { Visitor_c.default_visitor_c_s with
 214     Visitor_c.kexpr_s = (fun (k,bigf) e ->
 215       match e with
 216         ((Ast_c.Ident s, info), [ii]) ->
 217           let new_name = lookup s in
 218           ((Ast_c.Ident new_name, info), [rewrap_str new_name ii])
 219       | _ -> k e) } in
 220   List.map
 221     (function (x,vl) ->
 222       (x,
 223        match vl with
 224          Ast_c.MetaIdVal(_) | Ast_c.MetaFuncVal(_)
 225        | Ast_c.MetaLocalFuncVal(_) -> vl
 226        | Ast_c.MetaExprVal(exp) ->
 227            Ast_c.MetaExprVal(Visitor_c.vk_expr_s bigf exp)
 228        | Ast_c.MetaExprListVal(args) ->
 229            Ast_c.MetaExprListVal(Visitor_c.vk_arguments_s bigf args)
 230        | Ast_c.MetaParamVal(param) ->
 231            Ast_c.MetaParamVal(Visitor_c.vk_param_s bigf param)
 232        | Ast_c.MetaParamListVal(params) ->
 233            Ast_c.MetaParamListVal(Visitor_c.vk_params_s bigf params)
 234
 235        | Ast_c.MetaTypeVal(ty) ->
 236            Ast_c.MetaTypeVal(Visitor_c.vk_type_s bigf ty)
 237        | Ast_c.MetaInitVal(ini) ->
 238            Ast_c.MetaInitVal(Visitor_c.vk_ini_s bigf ini)
 239        | Ast_c.MetaStmtVal(stm) ->
 240            Ast_c.MetaStmtVal(Visitor_c.vk_statement_s bigf stm)
 241        | Ast_c.MetaPosVal _ | Ast_c.MetaPosValList _
 242        | Ast_c.MetaListlenVal _ -> vl))
 243     env
 244
 245 let print_one_type pr env = function
 246     (Type_cocci.MetaType(name,keep,inherited)) as ty ->
 247       (try
 248         match List.assoc name env with
 249           Ast_c.MetaTypeVal ty ->
 250             Pretty_print_c.pp_type_gen
 251               (function x -> pr (Ast_c.str_of_info x))
 252               (function _ -> pr " ")
 253               ty
 254         | _ -> failwith "impossible"
 255       with Not_found -> pr (Type_cocci.type2c ty))
 256   | ty -> pr (Type_cocci.type2c ty)
 257
 258 let print_types pr env = function
 259     None -> ()
 260   | Some [ty] -> print_one_type pr env ty
 261   | Some types ->
 262       pr "{";
 263       Common.print_between (function _ -> pr ", ") (print_one_type pr env)
 264         types;
 265       pr "}"
 266
 267 let pp_meta_decl pr env decl =
 268   let no_arity = function Ast.NONE -> () | _ -> failwith "no arity allowed" in
 269   let pp_name (_,n) = pr n in
 270   match decl with
 271     Ast.MetaIdDecl(ar, name) ->
 272       no_arity ar; pr "identifier "; pp_name name; pr ";\n"
 273   | Ast.MetaFreshIdDecl(ar, name) ->
 274       no_arity ar; pr "fresh identifier "; pp_name name; pr ";\n"
 275   | Ast.MetaTypeDecl(ar, name) ->
 276       no_arity ar; pr "type "; pp_name name; pr ";\n"
 277   | Ast.MetaInitDecl(ar, name) ->
 278       no_arity ar; pr "initialiser "; pp_name name; pr ";\n"
 279   | Ast.MetaListlenDecl(name) -> ()
 280   | Ast.MetaParamDecl(ar, name) ->
 281       no_arity ar; pr "parameter "; pp_name name; pr ";\n"
 282   | Ast.MetaParamListDecl(ar, name, None) ->
 283       no_arity ar; pr "parameter list "; pp_name name; pr ";\n"
 284   | Ast.MetaParamListDecl(ar, name, Some len) ->
 285       no_arity ar; pr "parameter list "; pp_name name;
 286       pr "["; pp_name len; pr "]"; pr ";\n"
 287   | Ast.MetaConstDecl(ar, name, types) ->
 288       no_arity ar; pr "constant "; print_types pr env types;
 289       pp_name name; pr ";\n"
 290   | Ast.MetaErrDecl(ar, name) ->
 291       no_arity ar; pr "error "; pp_name name; pr ";\n"
 292   | Ast.MetaExpDecl(ar, name, None) ->
 293       no_arity ar; pr "expression "; pp_name name; pr ";\n"
 294   | Ast.MetaExpDecl(ar, name, types) ->
 295       no_arity ar; print_types pr env types; pp_name name; pr ";\n"
 296   | Ast.MetaIdExpDecl(ar, name, types) ->
 297       no_arity ar; pr "idexpression ";
 298       print_types pr env types; pp_name name; pr ";\n"
 299   | Ast.MetaLocalIdExpDecl(ar, name, types) ->
 300       no_arity ar; pr "local idexpression ";
 301       print_types pr env types; pp_name name; pr ";\n"
 302   | Ast.MetaExpListDecl(ar, name, None) ->
 303       no_arity ar; pr "parameter list "; pp_name name; pr ";\n"
 304   | Ast.MetaExpListDecl(ar, name, Some len) ->
 305       no_arity ar; pr "parameter list ";
 306       pp_name name; pr "["; pp_name len; pr "]"; pr ";\n"
 307   | Ast.MetaStmDecl(ar, name) ->
 308       no_arity ar; pr "statement "; pp_name name; pr ";\n"
 309   | Ast.MetaStmListDecl(ar, name) ->
 310       no_arity ar; pr "statement list "; pp_name name; pr ";\n"
 311   | Ast.MetaFuncDecl(ar, name) ->
 312       no_arity ar; pr "function "; pp_name name; pr ";\n"
 313   | Ast.MetaLocalFuncDecl(ar, name) ->
 314       no_arity ar; pr "local function "; pp_name name; pr ";\n"
 315   | Ast.MetaPosDecl(ar, name) ->
 316       no_arity ar; pr "position "; pp_name name; pr ";\n"
 317   | Ast.MetaDeclarerDecl(ar, name) ->
 318       no_arity ar; pr "declarer "; pp_name name; pr ";\n"
 319   | Ast.MetaIteratorDecl(ar, name) ->
 320       no_arity ar; pr "iterator "; pp_name name; pr ";\n"
 321
 322 let print_metavariables pr local_metas paramst env header_req function_name =
 323   (if header_req
 324   then pr "@depends on header@\n"
 325   else pr "@@\n");
 326   pr (Printf.sprintf "position _p!=same_%s.p;\n" function_name);
 327   pr "identifier _f;\n";
 328   let rec loop = function
 329       [] | [(((_,_,(_,(Ast_c.BaseType(Ast_c.Void),_))),_),_)] -> []
 330     | ((first,_) as f)::rest ->
 331         print_metavar pr first; pr ";\n";
 332         (make_exp f) :: loop rest in
 333   let args = loop paramst in
 334   print_extra_typedefs pr env;
 335   List.iter (pp_meta_decl pr env) local_metas;
 336   pr "@@\n\n";
 337   args
 338
 339 (* ----------------------------------------------------------------------- *)
 340 (* print_start/end *)
 341
 342 let print_start pr =
 343   pr "_f@_p(...) { <+...\n"
 344
 345 let print_end pr =
 346   pr "\n...+> }\n"
 347
 348 (* ----------------------------------------------------------------------- *)
 349 (* Print call to the defined function *)
 350
 351 let print_param_name pr = function
 352     ((_,Some param,_),_) -> pr param
 353   | _ -> failwith "function must have named parameters"
 354
 355 let pp_def_gen pr defn isexp =
 356   let {Ast_c.f_name = s; f_type = (_, (paramst, (b, iib))); } = defn in
 357   pr s; pr "(";
 358   (if b then failwith "not handling variable argument functions");
 359   (match paramst with
 360     [] | [(((_,_,(_,(Ast_c.BaseType(Ast_c.Void),_))),_),_)] -> ()
 361   | (first,_)::rest ->
 362       print_param_name pr first;
 363       List.iter (function (x,_) -> pr ", "; print_param_name pr x) rest);
 364   pr ")"; if not isexp then pr ";"
 365
 366 (* ----------------------------------------------------------------------- *)
 367 (* Entry point *)
 368
 369 let pp_rule local_metas ast env srcfile =
 370   let (paramst,args_name) = get_paramst env in
 371   (* get rule information *)
 372   let (rule,printable) =
 373     match ast with
 374       Ast.CocciRule(_,_,[body],_,_) -> (* could extend to use attributes *)
 375         (body,
 376          match Ast.unwrap body with
 377            Ast.DECL(s) -> [[Ast.StatementTag s]]
 378          | Ast.CODE(ss) -> [[Ast.StmtDotsTag ss]]
 379          | _ -> error body "bad rule body")
 380     | _ -> failwith "bad rule" in
 381   (* create the output file *)
 382   let outdir =
 383     match !Flag.make_hrule with
 384       Some outdir -> outdir
 385     | None -> error rule "not possible" in
 386   let function_name = get_function_name rule env in
 387   let function_name_count =
 388     try
 389       let cell = List.assoc function_name !names in
 390       let ct = !cell in
 391       cell := ct + 1;
 392       function_name ^ (string_of_int ct)
 393     with Not_found ->
 394       let cell = ref 1 in
 395       names := (function_name,cell) :: !names;
 396       function_name in
 397   let outfile = outdir ^ "/" ^
 398     (if !Flag.hrule_per_file
 399     then Filename.chop_extension (Filename.basename srcfile)
 400     else function_name_count) in
 401   let escape_re = Str.regexp_string "/" in
 402   let dir = if !Flag.dir = "" then Filename.dirname srcfile else !Flag.dir in
 403   let outdirfile = Str.global_replace escape_re "_"dir in
 404   let outfile = outfile ^ outdirfile ^ ".cocci" in
 405   let saved_header_req =
 406     try let res = List.assoc outfile !started_files in Some res
 407     with Not_found -> None in
 408   current_outfile := outfile;
 409   Common.with_open_outfile_append outfile (fun (pr,chan) ->
 410     let header_req =
 411       match saved_header_req with
 412         Some x -> x
 413       | None ->
 414           let res = print_header_rule pr srcfile in
 415           started_files := (outfile,res)::!started_files;
 416           res in
 417     print_check_rule pr function_name function_name_count header_req;
 418     let args =
 419       print_metavariables pr local_metas paramst env header_req
 420         function_name_count in
 421     let (argids,args) = List.split args in
 422     let env = rename argids env in
 423     let env = (args_name,Ast_c.MetaExprListVal args)::env in
 424     print_start pr;
 425     (* for printing C tokens *)
 426     let pr_c info =
 427       match Ast_c.pinfo_of_info info with
 428         Ast_c.AbstractLineTok _ -> pr (Ast_c.str_of_info info)
 429       | Ast_c.FakeTok (s,_) -> pr s
 430       | _ ->
 431           Printf.printf "line: %s\n" (Common.dump info);
 432           error rule "not an abstract line" in
 433     Unparse_cocci.pp_list_list_any
 434       (env, pr, pr_c, (function _ -> pr " "),
 435        (function _ -> ()), (function _ -> ()))
 436       true printable Unparse_cocci.InPlace;
 437     print_end pr;
 438     pr "\n")