parsing_cocci/get_constants.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 (* get a list of all of the constants in the - slice of a SmPL file, to be
  24 used to select which files to process *)
  25
  26 (* This could be made more efficient, by finding only the important things.
  27 eg, if we have a function and its arguments, we could just pick the function.
  28 And we could try to pick only the things annotated with -, and only pick
  29 something else if there is no -.  In general, we only want the most important
  30 constant, not all the constants. *)
  31
  32 module Ast = Ast_cocci
  33 module V = Visitor_ast
  34 module TC = Type_cocci
  35
  36 let keep_some_bind x y = match x with [] -> y | _ -> x
  37 let or_bind x y = match x with [] -> [] | _ -> x
  38 let keep_all_bind = Common.union_set
  39
  40 let get_minus_constants bind orbind =
  41   let donothing r k e = k e in
  42   let option_default = [] in
  43   let mcode _ _ = option_default in
  44
  45   (* if one branch gives no information, then we have to take anything *)
  46   let disj_union_all l =
  47     if List.exists (function [] -> true | _ -> false) l
  48     then orbind [] (Common.union_all l)
  49     else Common.union_all l in
  50
  51   (* need special cases for everything with a disj, because the bind above
  52      would throw away all but the first disj *)
  53
  54   let ident r k e =
  55     match Ast.unwrap e with
  56       Ast.Id(name) ->
  57         (match Ast.unwrap_mcode name with
  58           "NULL" -> [] (* special case, because this is too generic *)
  59         | nm -> [nm])
  60     | _ -> k e in
  61
  62   let expression r k e =
  63     match Ast.unwrap e with
  64       Ast.RecordAccess(exp,_,fld) | Ast.RecordPtAccess(exp,_,fld) ->
  65         bind
  66           (Common.union_all
  67              (List.map (function id -> ["."^id;"->"^id])
  68                 (r.V.combiner_ident fld)))
  69           (r.V.combiner_expression exp)
  70     | Ast.SizeOfExpr(sizeof,_) | Ast.SizeOfType(sizeof,_,_,_) ->
  71         bind (k e) [Ast.unwrap_mcode sizeof]
  72     | Ast.DisjExpr(exps) ->
  73         disj_union_all (List.map r.V.combiner_expression exps)
  74     | Ast.Edots(_,_) | Ast.Ecircles(_,_) | Ast.Estars(_,_) -> []
  75     | Ast.NestExpr(expr_dots,whencode,false) -> []
  76     | Ast.NestExpr(expr_dots,whencode,true) ->
  77         r.V.combiner_expression_dots expr_dots
  78     | _ -> k e in
  79
  80   let typeC r k e =
  81     match Ast.unwrap e with
  82       Ast.TypeName(ty) ->
  83         if !Flag.sgrep_mode2
  84         then
  85           match ty with
  86             (_,_,Ast.MINUS(_,_,_,_),_) -> [Ast.unwrap_mcode ty]
  87           | _ -> []
  88         else [Ast.unwrap_mcode ty]
  89     | _ -> k e in
  90
  91   let fullType r k e =
  92     match Ast.unwrap e with
  93       Ast.DisjType(types) ->
  94         disj_union_all (List.map r.V.combiner_fullType types)
  95     | _ -> k e in
  96
  97   let declaration r k e =
  98     match Ast.unwrap e with
  99       Ast.DisjDecl(decls) ->
 100         disj_union_all (List.map r.V.combiner_declaration decls)
 101     | Ast.Ddots(dots,whencode) -> []
 102     | _ -> k e in
 103
 104   let rule_elem r k e =
 105     match Ast.unwrap e with
 106       Ast.DisjRuleElem(res) ->
 107         disj_union_all (List.map r.V.combiner_rule_elem res)
 108     | _ -> k e in
 109
 110   let statement r k e =
 111     match Ast.unwrap e with
 112       Ast.Disj(stmt_dots) ->
 113         disj_union_all (List.map r.V.combiner_statement_dots stmt_dots)
 114     | Ast.Dots(d,whn,_,_) | Ast.Circles(d,whn,_,_) | Ast.Stars(d,whn,_,_) -> []
 115     | Ast.Nest(stmt_dots,whn,false,_,_) -> []
 116     | Ast.Nest(stmt_dots,whn,true,_,_) -> r.V.combiner_statement_dots stmt_dots
 117     | _ -> k e in
 118
 119   V.combiner bind option_default
 120     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 121     donothing donothing donothing donothing
 122     ident expression fullType typeC donothing donothing declaration
 123     rule_elem statement donothing donothing donothing
 124
 125 (* ------------------------------------------------------------------------ *)
 126
 127 let get_all_minus_constants =
 128   let donothing r k e = k e in
 129   let bind = Common.union_set in
 130   let option_default = [] in
 131   let mcode r (x,_,mcodekind,_) =
 132     match mcodekind with
 133       Ast.MINUS(_,_,_,_) -> [x]
 134     | _ -> [] in
 135   let other r (x,_,mcodekind,_) = [] in
 136
 137   V.combiner bind option_default
 138     other mcode other other other other other other other other other other
 139
 140     donothing donothing donothing donothing
 141     donothing donothing donothing donothing donothing donothing donothing
 142     donothing donothing donothing donothing donothing
 143 (* ------------------------------------------------------------------------ *)
 144
 145 let get_plus_constants =
 146   let donothing r k e = k e in
 147   let bind = Common.union_set in
 148   let option_default = [] in
 149   let mcode r (_,_,mcodekind,_) =
 150     let recurse l =
 151       List.fold_left
 152         (List.fold_left
 153            (function prev ->
 154              function cur ->
 155                let fn = get_minus_constants keep_all_bind keep_all_bind in
 156                bind (fn.V.combiner_anything cur) prev))
 157         [] l in
 158     match mcodekind with
 159       Ast.MINUS(_,_,_,anythings) -> recurse anythings
 160     | Ast.CONTEXT(_,Ast.BEFORE(a,_)) -> recurse a
 161     | Ast.CONTEXT(_,Ast.AFTER(a,_)) -> recurse a
 162     | Ast.CONTEXT(_,Ast.BEFOREAFTER(a1,a2,_)) ->
 163         Common.union_set (recurse a1) (recurse a2)
 164     | _ -> [] in
 165
 166   V.combiner bind option_default
 167     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 168     donothing donothing donothing donothing
 169     donothing donothing donothing donothing donothing donothing donothing
 170     donothing donothing donothing donothing donothing
 171
 172 (* ------------------------------------------------------------------------ *)
 173 (* see if there are any inherited variables that must be bound for this rule
 174 to match *)
 175
 176 let check_inherited nm =
 177   let donothing r k e = k e in
 178   let option_default = false in
 179   let bind x y = x or y in
 180   let inherited (nm1,_) = not(nm = nm1) in
 181   let minherited mc = inherited (Ast.unwrap_mcode mc) in
 182   let mcode _ x =
 183     match Ast.get_pos_var x with
 184       Ast.MetaPos(name,constraints,_,keep,inh) -> minherited name
 185     | _ -> option_default in
 186
 187   (* a case for everything for there is a metavariable, also disjunctions
 188      or optional things *)
 189
 190   let strictident recursor k i =
 191     match Ast.unwrap i with
 192       Ast.MetaId(name,_,_,_) | Ast.MetaFunc(name,_,_,_)
 193     | Ast.MetaLocalFunc(name,_,_,_) -> bind (k i) (minherited name)
 194     | _ -> k i in
 195
 196   let rec type_collect res = function
 197       TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty)
 198     | TC.Array(ty) -> type_collect res ty
 199     | TC.MetaType(tyname,_,_) ->
 200         inherited tyname
 201     | ty -> res in
 202
 203   let strictexpr recursor k e =
 204     match Ast.unwrap e with
 205       Ast.MetaExpr(name,_,_,Some type_list,_,_) ->
 206         let types = List.fold_left type_collect option_default type_list in
 207         bind (minherited name) types
 208     | Ast.MetaErr(name,_,_,_) | Ast.MetaExpr(name,_,_,_,_,_) ->
 209         bind (k e) (minherited name)
 210     | Ast.MetaExprList(name,None,_,_) -> bind (k e) (minherited name)
 211     | Ast.MetaExprList(name,Some (lenname,_,_),_,_) ->
 212         bind (k e) (bind (minherited name) (minherited lenname))
 213     | Ast.DisjExpr(exps) ->
 214         (* could see if there are any variables that appear in all branches,
 215            but perhaps not worth it *)
 216         option_default
 217     | _ -> k e in
 218
 219   let strictdecls recursor k d =
 220     match Ast.unwrap d with
 221       Ast.DisjDecl(decls) -> option_default
 222     | _ -> k d in
 223
 224   let strictfullType recursor k ty =
 225     match Ast.unwrap ty with
 226       Ast.DisjType(types) -> option_default
 227     | _ -> k ty in
 228
 229   let stricttypeC recursor k ty =
 230     match Ast.unwrap ty with
 231       Ast.MetaType(name,_,_) -> bind (k ty) (minherited name)
 232     | _ -> k ty in
 233
 234   let strictparam recursor k p =
 235     match Ast.unwrap p with
 236       Ast.MetaParam(name,_,_) -> bind (k p) (minherited name)
 237     | Ast.MetaParamList(name,None,_,_) -> bind (k p) (minherited name)
 238     | Ast.MetaParamList(name,Some(lenname,_,_),_,_) ->
 239         bind (k p) (bind (minherited name) (minherited lenname))
 240     | _ -> k p in
 241
 242   let strictrule_elem recursor k re =
 243     (*within a rule_elem, pattern3 manages the coherence of the bindings*)
 244     match Ast.unwrap re with
 245       Ast.MetaRuleElem(name,_,_) | Ast.MetaStmt(name,_,_,_)
 246     | Ast.MetaStmtList(name,_,_) -> bind (k re) (minherited name)
 247     | _ -> k re in
 248
 249   let strictstatement recursor k s =
 250     match Ast.unwrap s with
 251       Ast.Disj(stms) -> option_default
 252     | _ -> k s in
 253
 254   V.combiner bind option_default
 255     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 256     donothing donothing donothing donothing
 257     strictident strictexpr strictfullType stricttypeC donothing strictparam
 258     strictdecls strictrule_elem strictstatement donothing donothing donothing
 259
 260 (* ------------------------------------------------------------------------ *)
 261
 262 let rec dependent = function
 263     Ast.Dep s -> true
 264   | Ast.AntiDep s -> false
 265   | Ast.EverDep s -> true
 266   | Ast.NeverDep s -> false
 267   | Ast.AndDep (d1,d2) -> dependent d1 or dependent d2
 268   | Ast.OrDep (d1,d2) -> dependent d1 && dependent d2
 269   | Ast.NoDep -> false
 270   | Ast.FailDep -> true
 271
 272 (* ------------------------------------------------------------------------ *)
 273
 274 let rule_fn tls in_plus =
 275   List.fold_left
 276     (function (rest_info,in_plus) ->
 277       function cur ->
 278         let mfn = get_minus_constants keep_some_bind or_bind in
 279         let minuses = mfn.V.combiner_top_level cur in
 280         let all_minuses =
 281           if !Flag.sgrep_mode2
 282           then [] (* nothing removed for sgrep *)
 283           else get_all_minus_constants.V.combiner_top_level cur in
 284         let plusses = get_plus_constants.V.combiner_top_level cur in
 285         (* the following is for eg -foo(2) +foo(x) then in another rule
 286            -foo(10); don't want to consider that foo is guaranteed to be
 287            created by the rule.  not sure this works completely: what if foo is
 288            in both - and +, but in an or, so the cases aren't related?
 289            not sure this whole thing is a good idea.  how do we know that
 290            something that is only in plus is really freshly created? *)
 291         let plusses = Common.minus_set plusses all_minuses in
 292         let new_minuses = Common.minus_set minuses in_plus in
 293         let new_plusses = Common.union_set plusses in_plus in
 294         (Common.union_set new_minuses rest_info, new_plusses))
 295     ([],in_plus) tls
 296
 297 exception No_info
 298
 299 let get_constants rules =
 300   try
 301     let (info,_) =
 302       List.fold_left
 303         (function (rest_info,in_plus) ->
 304           function r ->
 305             match r with
 306               Ast.ScriptRule (_,_,_,_)
 307             | Ast.InitialScriptRule (_,_,_) | Ast.FinalScriptRule (_,_,_) ->
 308                 (rest_info, in_plus)
 309             | Ast.CocciRule (nm, (dep,_,_), cur, _, _) ->
 310                 let (cur_info,cur_plus) = rule_fn cur in_plus in
 311                 let cur_info =
 312                   (* no dependencies if dependent on another rule; then we
 313                      need to find the constants of that rule *)
 314                   if dependent dep or
 315                     List.for_all (check_inherited nm).V.combiner_top_level cur
 316                   then []
 317                   else
 318                   if cur_info = [] then raise No_info else cur_info in
 319                 (Common.union_set [cur_info] rest_info,cur_plus))
 320         ([],[]) rules in
 321     List.rev info
 322   with No_info -> List.map (function _ -> []) rules