engine/asttomember.ml

   1 (*
   2 * Copyright 2005-2008, 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 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 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       mcode
 124       do_nothing do_nothing do_nothing do_nothing
 125       do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
 126       do_nothing rule_elem do_nothing do_nothing
 127       do_nothing do_absolutely_nothing in
 128   recursor.V.rebuilder_rule_elem
 129
 130 (* --------------------------------------------------------------------- *)
 131
 132 let disj l1 l2 = l1 l2
 133
 134 let rec conj xs ys =
 135   match (xs,ys) with
 136     ([],_) -> ys
 137   | (_,[]) -> xs
 138   | _ ->
 139       List.fold_left
 140         (function prev ->
 141           function x ->
 142             List.fold_left
 143               (function prev ->
 144                 function cur ->
 145                   let cur_res = (List.sort compare (Common.union_set x cur)) in
 146                   cur_res ::
 147                   (List.filter
 148                      (function x -> not (Common.include_set cur_res x))
 149                      prev))
 150               prev ys)
 151         [] xs
 152
 153 let conj_wrapped x l = conj [List.map (function x -> (1,strip x)) x] l
 154
 155 (* --------------------------------------------------------------------- *)
 156 (* the main translation loop *)
 157
 158 let rule_elem re =
 159   match Ast.unwrap re with
 160     Ast.DisjRuleElem(res) -> [[(List.length res,strip re)]]
 161   | _ -> [[(1,strip re)]]
 162
 163 let conj_one testfn x l =
 164   if testfn x
 165   then conj (rule_elem x) l
 166   else l
 167
 168 let rec statement_list testfn mcode tail stmt_list : 'a list list =
 169   match Ast.unwrap stmt_list with
 170     Ast.DOTS(x) | Ast.CIRCLES(x) | Ast.STARS(x) ->
 171       (match List.rev x with
 172         [] -> []
 173       | last::rest ->
 174           List.fold_right
 175             (function cur ->
 176               function rest ->
 177                 conj (statement testfn mcode false cur) rest)
 178             rest (statement testfn mcode tail last))
 179
 180 and statement testfn mcode tail stmt : 'a list list =
 181   match Ast.unwrap stmt with
 182     Ast.Atomic(ast) ->
 183       (match Ast.unwrap ast with
 184         (* modifications on return are managed in some other way *)
 185         Ast.Return(_,_) | Ast.ReturnExpr(_,_,_) when tail -> []
 186       | _ -> if testfn ast then rule_elem ast else [])
 187   | Ast.Seq(lbrace,decls,body,rbrace) ->
 188       let body_info =
 189         conj
 190           (statement_list testfn mcode false decls)
 191           (statement_list testfn mcode tail body) in
 192       if testfn lbrace or testfn rbrace
 193       then conj_wrapped [lbrace;rbrace] body_info
 194       else body_info
 195
 196   | Ast.IfThen(header,branch,(_,_,_,aft))
 197   | Ast.While(header,branch,(_,_,_,aft))
 198   | Ast.For(header,branch,(_,_,_,aft))
 199   | Ast.Iterator(header,branch,(_,_,_,aft)) ->
 200       if testfn header or mcode () ((),(),aft,Ast.NoMetaPos)
 201       then conj (rule_elem header) (statement testfn mcode tail branch)
 202       else statement testfn mcode tail branch
 203
 204   | Ast.Switch(header,lb,cases,rb) ->
 205       let body_info = case_lines  testfn mcode tail cases in
 206       if testfn header or testfn lb or testfn rb
 207       then conj (rule_elem header) body_info
 208       else body_info
 209
 210   | Ast.IfThenElse(ifheader,branch1,els,branch2,(_,_,_,aft)) ->
 211       let branches =
 212         conj
 213           (statement testfn mcode tail branch1)
 214           (statement testfn mcode tail branch2) in
 215       if testfn ifheader or mcode () ((),(),aft,Ast.NoMetaPos)
 216       then conj (rule_elem ifheader) branches
 217       else branches
 218
 219   | Ast.Disj(stmt_dots_list) ->
 220       let processed =
 221         List.map (statement_list testfn mcode tail) stmt_dots_list in
 222       (* if one branch gives no information, then we have to take anything *)
 223       if List.exists (function [] -> true | _ -> false) processed
 224       then []
 225       else Common.union_all processed
 226
 227   | Ast.Nest(stmt_dots,whencode,true,_,_) ->
 228       statement_list testfn mcode false stmt_dots
 229
 230   | Ast.Nest(stmt_dots,whencode,false,_,_) -> []
 231
 232   | Ast.Dots(_,whencodes,_,_) -> []
 233
 234   | Ast.FunDecl(header,lbrace,decls,body,rbrace) ->
 235       let body_info =
 236         conj
 237           (statement_list testfn mcode false decls)
 238           (statement_list testfn mcode true body) in
 239       if testfn header or testfn lbrace or testfn rbrace
 240       then conj (rule_elem header) body_info
 241       else body_info
 242
 243   | Ast.Define(header,body) ->
 244       conj_one testfn header (statement_list testfn mcode tail body)
 245
 246   | Ast.OptStm(stm) -> []
 247
 248   | Ast.UniqueStm(stm) -> statement testfn mcode tail stm
 249
 250   | _ -> failwith "not supported"
 251
 252 and case_lines testfn mcode tail cases =
 253   match cases with
 254     [] -> []
 255   | last::rest ->
 256       List.fold_right
 257         (function cur ->
 258           function rest ->
 259             conj (case_line testfn mcode false cur) rest)
 260         rest (case_line testfn mcode tail last)
 261
 262 and case_line testfn mcode tail case =
 263   match Ast.unwrap case with
 264     Ast.CaseLine(header,code) ->
 265       conj_one testfn header (statement_list testfn mcode tail code)
 266
 267   | Ast.OptCase(case) -> []
 268
 269 (* --------------------------------------------------------------------- *)
 270 (* Function declaration *)
 271
 272 let top_level testfn mcode t : 'a list list =
 273   match Ast.unwrap t with
 274     Ast.FILEINFO(old_file,new_file) -> failwith "not supported fileinfo"
 275   | Ast.DECL(stmt) -> statement testfn mcode false stmt
 276   | Ast.CODE(stmt_dots) -> statement_list testfn mcode false stmt_dots
 277   | Ast.ERRORWORDS(exps) -> failwith "not supported errorwords"
 278
 279 (* --------------------------------------------------------------------- *)
 280 (* Entry points *)
 281
 282 let debug = false
 283
 284 (* if we end up with nothing, we assume that this rule is only here because
 285 someone depends on it, and thus we try again with testfn as contains_modif.
 286 Alternatively, we could check that this rule is mentioned in some
 287 dependency, but that would be a little more work, and doesn't seem
 288 worthwhile. *)
 289
 290 (* lists are sorted such that smaller DisjRuleElem are first, because they
 291 are cheaper to test *)
 292
 293 let asttomemberz (_,_,l) used_after =
 294   let process_one (l : (int * Ast_cocci.rule_elem) list list) =
 295     if debug
 296     then print_info l;
 297     List.map
 298       (function info ->
 299         let info =
 300           List.sort (function (n1,_) -> function (n2,_) -> compare n1 n2)
 301             info in
 302         List.map (function (_,x) -> (Lib_engine.Match(x),CTL.Control)) info)
 303       l in
 304   List.map2
 305     (function min -> function (max,big_max) ->
 306       match min with
 307         [] ->
 308           (match max() with
 309             [] -> process_one (big_max())
 310           | max -> process_one max)
 311       | _ -> process_one min)
 312     (List.map (top_level contains_constant no_mcode) l)
 313     (List.combine
 314         (List.map2
 315            (function x -> function ua -> function _ ->
 316              top_level (contains_modif ua) mcode x)
 317            l used_after)
 318         (List.map
 319            (function x -> function _ ->
 320              top_level (function _ -> true) no_mcode x)
 321            l))
 322
 323 let asttomember r used_after =
 324   match r with
 325     Ast.ScriptRule _ -> []
 326   | Ast.CocciRule (a,b,c,_) -> asttomemberz (a,b,c) used_after
 327