engine/asttomember.ml

   1 (*
   2  * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
   3  * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
   4  * This file is part of Coccinelle.
   5  *
   6  * Coccinelle is free software: you can redistribute it and/or modify
   7  * it under the terms of the GNU General Public License as published by
   8  * the Free Software Foundation, according to version 2 of the License.
   9  *
  10  * Coccinelle is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  * GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
  17  *
  18  * The authors reserve the right to distribute this or future versions of
  19  * Coccinelle under other licenses.
  20  *)
  21
  22
  23 (*
  24  * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
  25  * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
  26  * This file is part of Coccinelle.
  27  *
  28  * Coccinelle is free software: you can redistribute it and/or modify
  29  * it under the terms of the GNU General Public License as published by
  30  * the Free Software Foundation, according to version 2 of the License.
  31  *
  32  * Coccinelle is distributed in the hope that it will be useful,
  33  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  34  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  35  * GNU General Public License for more details.
  36  *
  37  * You should have received a copy of the GNU General Public License
  38  * along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
  39  *
  40  * The authors reserve the right to distribute this or future versions of
  41  * Coccinelle under other licenses.
  42  *)
  43
  44
  45 (* on the first pass, onlyModif is true, so we don't see all matched nodes,
  46 only modified ones *)
  47
  48 module Ast = Ast_cocci
  49 module V = Visitor_ast
  50 module CTL = Ast_ctl
  51
  52 let mcode r (_,_,kind,_) =
  53   match kind with
  54     Ast.MINUS(_,_,_,_) -> true
  55   | Ast.PLUS _ -> failwith "not possible"
  56   | Ast.CONTEXT(_,info) -> not (info = Ast.NOTHING)
  57
  58 let no_mcode _ _ = false
  59
  60 let contains_modif used_after x =
  61   if List.exists (function x -> List.mem x used_after) (Ast.get_fvs x)
  62   then true
  63   else
  64     let bind x y = x or y in
  65     let option_default = false in
  66     let do_nothing r k e = k e in
  67     let rule_elem r k re =
  68       let res = k re in
  69       match Ast.unwrap re with
  70         Ast.FunHeader(bef,_,fninfo,name,lp,params,rp) ->
  71           bind (mcode r ((),(),bef,Ast.NoMetaPos)) res
  72       | Ast.Decl(bef,_,decl) ->
  73           bind (mcode r ((),(),bef,Ast.NoMetaPos)) res
  74       | _ -> res in
  75     let recursor =
  76       V.combiner bind option_default
  77         mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
  78         mcode
  79         do_nothing do_nothing do_nothing do_nothing
  80         do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
  81         do_nothing rule_elem do_nothing do_nothing do_nothing do_nothing in
  82     recursor.V.combiner_rule_elem x
  83
  84 (* contains an inherited metavariable or contains a constant *)
  85 let contains_constant x =
  86   match Ast.get_inherited x with
  87     [] ->
  88       let bind x y = x or y in
  89       let option_default = false in
  90       let do_nothing r k e = k e in
  91       let mcode _ _ = false in
  92       let ident r k i =
  93         match Ast.unwrap i with
  94           Ast.Id(name) -> true
  95         | _ -> k i in
  96       let expr r k e =
  97         match Ast.unwrap e with
  98           Ast.Constant(const) -> true
  99         | _ -> k e in
 100       let recursor =
 101         V.combiner bind option_default
 102           mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 103           mcode
 104           do_nothing do_nothing do_nothing do_nothing
 105           ident expr do_nothing do_nothing do_nothing do_nothing
 106           do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing in
 107       recursor.V.combiner_rule_elem x
 108   | _ -> true
 109
 110 (* --------------------------------------------------------------------- *)
 111
 112 let print_info = function
 113     [] -> Printf.printf "no information\n"
 114   | l ->
 115       List.iter
 116         (function disj ->
 117           Printf.printf "one set of required things %d:\n"
 118             (List.length disj);
 119           List.iter
 120             (function (_,thing) ->
 121               Printf.printf "%s\n"
 122                 (Pretty_print_cocci.rule_elem_to_string thing))
 123             disj;)
 124         l
 125
 126 (* --------------------------------------------------------------------- *)
 127
 128 (* drop all distinguishing information from a term *)
 129 let strip =
 130   let do_nothing r k e = Ast.make_term (Ast.unwrap (k e)) in
 131   let do_absolutely_nothing r k e = k e in
 132   let mcode m = Ast.make_mcode(Ast.unwrap_mcode m) in
 133   let rule_elem r k re =
 134     let res = do_nothing r k re in
 135     let no_mcode = Ast.CONTEXT(Ast.NoPos,Ast.NOTHING) in
 136     match Ast.unwrap res with
 137       Ast.FunHeader(bef,b,fninfo,name,lp,params,rp) ->
 138         Ast.rewrap res
 139           (Ast.FunHeader(no_mcode,b,fninfo,name,lp,params,rp))
 140     | Ast.Decl(bef,b,decl) -> Ast.rewrap res (Ast.Decl(no_mcode,b,decl))
 141     | _ -> res in
 142   let recursor =
 143     V.rebuilder
 144       mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 145       do_nothing do_nothing do_nothing do_nothing
 146       do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
 147       do_nothing rule_elem do_nothing do_nothing
 148       do_nothing do_absolutely_nothing in
 149   recursor.V.rebuilder_rule_elem
 150
 151 (* --------------------------------------------------------------------- *)
 152
 153 let disj l1 l2 = l1 l2
 154
 155 let rec conj xs ys =
 156   match (xs,ys) with
 157     ([],_) -> ys
 158   | (_,[]) -> xs
 159   | _ ->
 160       List.fold_left
 161         (function prev ->
 162           function x ->
 163             List.fold_left
 164               (function prev ->
 165                 function cur ->
 166                   let cur_res = (List.sort compare (Common.union_set x cur)) in
 167                   cur_res ::
 168                   (List.filter
 169                      (function x -> not (Common.include_set cur_res x))
 170                      prev))
 171               prev ys)
 172         [] xs
 173
 174 let conj_wrapped x l = conj [List.map (function x -> (1,strip x)) x] l
 175
 176 (* --------------------------------------------------------------------- *)
 177 (* the main translation loop *)
 178
 179 let rule_elem re =
 180   match Ast.unwrap re with
 181     Ast.DisjRuleElem(res) -> [[(List.length res,strip re)]]
 182   | _ -> [[(1,strip re)]]
 183
 184 let conj_one testfn x l =
 185   if testfn x
 186   then conj (rule_elem x) l
 187   else l
 188
 189 let rec statement_list testfn mcode tail stmt_list : 'a list list =
 190   match Ast.unwrap stmt_list with
 191     Ast.DOTS(x) | Ast.CIRCLES(x) | Ast.STARS(x) ->
 192       (match List.rev x with
 193         [] -> []
 194       | last::rest ->
 195           List.fold_right
 196             (function cur ->
 197               function rest ->
 198                 conj (statement testfn mcode false cur) rest)
 199             rest (statement testfn mcode tail last))
 200
 201 and statement testfn mcode tail stmt : 'a list list =
 202   match Ast.unwrap stmt with
 203     Ast.Atomic(ast) ->
 204       (match Ast.unwrap ast with
 205         (* modifications on return are managed in some other way *)
 206         Ast.Return(_,_) | Ast.ReturnExpr(_,_,_) when tail -> []
 207       | _ -> if testfn ast then rule_elem ast else [])
 208   | Ast.Seq(lbrace,body,rbrace) ->
 209       let body_info = statement_list testfn mcode tail body in
 210       if testfn lbrace or testfn rbrace
 211       then conj_wrapped [lbrace;rbrace] body_info
 212       else body_info
 213
 214   | Ast.IfThen(header,branch,(_,_,_,aft))
 215   | Ast.While(header,branch,(_,_,_,aft))
 216   | Ast.For(header,branch,(_,_,_,aft))
 217   | Ast.Iterator(header,branch,(_,_,_,aft)) ->
 218       if testfn header or mcode () ((),(),aft,Ast.NoMetaPos)
 219       then conj (rule_elem header) (statement testfn mcode tail branch)
 220       else statement testfn mcode tail branch
 221
 222   | Ast.Switch(header,lb,decls,cases,rb) ->
 223       let body_info =
 224         conj
 225           (statement_list testfn mcode false decls)
 226           (case_lines testfn mcode tail cases) in
 227       if testfn header or testfn lb or testfn rb
 228       then conj (rule_elem header) body_info
 229       else body_info
 230
 231   | Ast.IfThenElse(ifheader,branch1,els,branch2,(_,_,_,aft)) ->
 232       let branches =
 233         conj
 234           (statement testfn mcode tail branch1)
 235           (statement testfn mcode tail branch2) in
 236       if testfn ifheader or mcode () ((),(),aft,Ast.NoMetaPos)
 237       then conj (rule_elem ifheader) branches
 238       else branches
 239
 240   | Ast.Disj(stmt_dots_list) ->
 241       let processed =
 242         List.map (statement_list testfn mcode tail) stmt_dots_list in
 243       (* if one branch gives no information, then we have to take anything *)
 244       if List.exists (function [] -> true | _ -> false) processed
 245       then []
 246       else Common.union_all processed
 247
 248   | Ast.Nest(starter,stmt_dots,ender,whencode,true,_,_) ->
 249       statement_list testfn mcode false stmt_dots
 250
 251   | Ast.Nest(starter,stmt_dots,ender,whencode,false,_,_) -> []
 252
 253   | Ast.Dots(_,whencodes,_,_) -> []
 254
 255   | Ast.FunDecl(header,lbrace,body,rbrace) ->
 256       let body_info = statement_list testfn mcode true body in
 257       if testfn header or testfn lbrace or testfn rbrace
 258       then conj (rule_elem header) body_info
 259       else body_info
 260
 261   | Ast.Define(header,body) ->
 262       conj_one testfn header (statement_list testfn mcode tail body)
 263
 264   | Ast.OptStm(stm) -> []
 265
 266   | Ast.UniqueStm(stm) -> statement testfn mcode tail stm
 267
 268   | _ -> failwith "not supported"
 269
 270 and case_lines testfn mcode tail cases =
 271   match cases with
 272     [] -> []
 273   | last::rest ->
 274       List.fold_right
 275         (function cur ->
 276           function rest ->
 277             conj (case_line testfn mcode false cur) rest)
 278         rest (case_line testfn mcode tail last)
 279
 280 and case_line testfn mcode tail case =
 281   match Ast.unwrap case with
 282     Ast.CaseLine(header,code) ->
 283       conj_one testfn header (statement_list testfn mcode tail code)
 284
 285   | Ast.OptCase(case) -> []
 286
 287 (* --------------------------------------------------------------------- *)
 288 (* Function declaration *)
 289
 290 let top_level testfn mcode t : 'a list list =
 291   match Ast.unwrap t with
 292     Ast.FILEINFO(old_file,new_file) -> failwith "not supported fileinfo"
 293   | Ast.DECL(stmt) -> statement testfn mcode false stmt
 294   | Ast.CODE(stmt_dots) -> statement_list testfn mcode false stmt_dots
 295   | Ast.ERRORWORDS(exps) -> failwith "not supported errorwords"
 296
 297 (* --------------------------------------------------------------------- *)
 298 (* Entry points *)
 299
 300 let debug = false
 301
 302 (* if we end up with nothing, we assume that this rule is only here because
 303 someone depends on it, and thus we try again with testfn as contains_modif.
 304 Alternatively, we could check that this rule is mentioned in some
 305 dependency, but that would be a little more work, and doesn't seem
 306 worthwhile. *)
 307
 308 (* lists are sorted such that smaller DisjRuleElem are first, because they
 309 are cheaper to test *)
 310
 311 let asttomemberz (_,_,l) used_after =
 312   let process_one (l : (int * Ast_cocci.rule_elem) list list) =
 313     if debug
 314     then print_info l;
 315     List.map
 316       (function info ->
 317         let info =
 318           List.sort (function (n1,_) -> function (n2,_) -> compare n1 n2)
 319             info in
 320         List.map (function (_,x) -> (Lib_engine.Match(x),CTL.Control)) info)
 321       l in
 322   List.map2
 323     (function min -> function (max,big_max) ->
 324       match min with
 325         [] ->
 326           (match max() with
 327             [] -> process_one (big_max())
 328           | max -> process_one max)
 329       | _ -> process_one min)
 330     (List.map (top_level contains_constant no_mcode) l)
 331     (List.combine
 332         (List.map2
 333            (function x -> function ua -> function _ ->
 334              top_level (contains_modif ua) mcode x)
 335            l used_after)
 336         (List.map
 337            (function x -> function _ ->
 338              top_level (function _ -> true) no_mcode x)
 339            l))
 340
 341 let asttomember r used_after =
 342   match r with
 343     Ast.ScriptRule _ | Ast.InitialScriptRule _ | Ast.FinalScriptRule _ -> []
 344   | Ast.CocciRule (a,b,c,_,_) -> asttomemberz (a,b,c) used_after
 345