engine/asttomember.ml

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