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