parsing_cocci/get_constants.ml

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