parsing_cocci/get_constants.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 (* 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,_,_) -> inherited tyname
 200     | ty -> res in
 201
 202   let strictexpr recursor k e =
 203     match Ast.unwrap e with
 204       Ast.MetaExpr(name,_,_,Some type_list,_,_) ->
 205         let types = List.fold_left type_collect option_default type_list in
 206         bind (minherited name) types
 207     | Ast.MetaErr(name,_,_,_) | Ast.MetaExpr(name,_,_,_,_,_) ->
 208         bind (k e) (minherited name)
 209     | Ast.MetaExprList(name,None,_,_) -> bind (k e) (minherited name)
 210     | Ast.MetaExprList(name,Some (lenname,_,_),_,_) ->
 211         bind (k e) (bind (minherited name) (minherited lenname))
 212     | Ast.DisjExpr(exps) ->
 213         (* could see if there are any variables that appear in all branches,
 214            but perhaps not worth it *)
 215         option_default
 216     | _ -> k e in
 217
 218   let strictdecls recursor k d =
 219     match Ast.unwrap d with
 220       Ast.DisjDecl(decls) -> option_default
 221     | _ -> k d in
 222
 223   let strictfullType recursor k ty =
 224     match Ast.unwrap ty with
 225       Ast.DisjType(types) -> option_default
 226     | _ -> k ty in
 227
 228   let stricttypeC recursor k ty =
 229     match Ast.unwrap ty with
 230       Ast.MetaType(name,_,_) -> bind (k ty) (minherited name)
 231     | _ -> k ty in
 232
 233   let strictparam recursor k p =
 234     match Ast.unwrap p with
 235       Ast.MetaParam(name,_,_) -> bind (k p) (minherited name)
 236     | Ast.MetaParamList(name,None,_,_) -> bind (k p) (minherited name)
 237     | Ast.MetaParamList(name,Some(lenname,_,_),_,_) ->
 238         bind (k p) (bind (minherited name) (minherited lenname))
 239     | _ -> k p in
 240
 241   let strictrule_elem recursor k re =
 242     (*within a rule_elem, pattern3 manages the coherence of the bindings*)
 243     match Ast.unwrap re with
 244       Ast.MetaRuleElem(name,_,_) | Ast.MetaStmt(name,_,_,_)
 245     | Ast.MetaStmtList(name,_,_) -> bind (k re) (minherited name)
 246     | _ -> k re in
 247
 248   let strictstatement recursor k s =
 249     match Ast.unwrap s with
 250       Ast.Disj(stms) -> option_default
 251     | _ -> k s in
 252
 253   V.combiner bind option_default
 254     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 255     donothing donothing donothing donothing
 256     strictident strictexpr strictfullType stricttypeC donothing strictparam
 257     strictdecls strictrule_elem strictstatement donothing donothing donothing
 258
 259 (* ------------------------------------------------------------------------ *)
 260
 261 let rec dependent = function
 262     Ast.Dep s -> true
 263   | Ast.AntiDep s -> false
 264   | Ast.EverDep s -> true
 265   | Ast.NeverDep s -> false
 266   | Ast.AndDep (d1,d2) -> dependent d1 or dependent d2
 267   | Ast.OrDep (d1,d2) -> dependent d1 && dependent d2
 268   | Ast.NoDep -> false
 269
 270 (* ------------------------------------------------------------------------ *)
 271
 272 let rule_fn tls in_plus =
 273   List.fold_left
 274     (function (rest_info,in_plus) ->
 275       function cur ->
 276         let mfn = get_minus_constants keep_some_bind or_bind in
 277         let minuses = mfn.V.combiner_top_level cur in
 278         let all_minuses =
 279           if !Flag.sgrep_mode2
 280           then [] (* nothing removed for sgrep *)
 281           else get_all_minus_constants.V.combiner_top_level cur in
 282         let plusses = get_plus_constants.V.combiner_top_level cur in
 283         (* the following is for eg -foo(2) +foo(x) then in another rule
 284            -foo(10); don't want to consider that foo is guaranteed to be
 285            created by the rule.  not sure this works completely: what if foo is
 286            in both - and +, but in an or, so the cases aren't related?
 287            not sure this whole thing is a good idea.  how do we know that
 288            something that is only in plus is really freshly created? *)
 289         let plusses = Common.minus_set plusses all_minuses in
 290         let new_minuses = Common.minus_set minuses in_plus in
 291         let new_plusses = Common.union_set plusses in_plus in
 292         (Common.union_set new_minuses rest_info, new_plusses))
 293     ([],in_plus) tls
 294
 295 exception No_info
 296
 297 let get_constants rules =
 298   try
 299     let (info,_) =
 300       List.fold_left
 301         (function (rest_info,in_plus) ->
 302           function r ->
 303             match r with
 304               Ast.ScriptRule (_,_,_,_)
 305             | Ast.InitialScriptRule (_,_) | Ast.FinalScriptRule (_,_) ->
 306                 (rest_info, in_plus)
 307             | Ast.CocciRule (nm, (dep,_,_), cur, _, _) ->
 308                 let (cur_info,cur_plus) = rule_fn cur in_plus in
 309                 let cur_info =
 310                   (* no dependencies if dependent on another rule; then we
 311                      need to find the constants of that rule *)
 312                   if dependent dep or
 313                     List.for_all (check_inherited nm).V.combiner_top_level cur
 314                   then []
 315                   else
 316                   if cur_info = [] then raise No_info else cur_info in
 317                 (Common.union_set [cur_info] rest_info,cur_plus))
 318         ([],[]) rules in
 319     List.rev info
 320   with No_info -> List.map (function _ -> []) rules