engine/asttomember.ml

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