parsing_cocci/get_constants2.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, 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 module Ast = Ast_cocci
  24 module V = Visitor_ast
  25 module TC = Type_cocci
  26
  27 (* Issues:
  28
  29 1.  If a rule X depends on a rule Y (in a positive way), then we can ignore
  30     the constants in X.
  31
  32 2.  If a rule X contains a metavariable that is not under a disjunction and
  33     that is inherited from rule Y, then we can ignore the constants in X.
  34
  35 3.  If a rule contains a constant x in + code then subsequent rules that
  36     have it in - or context should not include it in their list of required
  37     constants.
  38 *)
  39
  40 (* ----------------------------------------------------------------------- *)
  41 (* This phase collects everything.  One can then filter out what it not
  42 wanted *)
  43
  44 (* True means nothing was found
  45    False should never drift to the top, it is the neutral element of or
  46    and an or is never empty *)
  47 type combine =
  48     And of combine list | Or of combine list | Elem of string | False | True
  49
  50 let interpret_glimpse strict x =
  51   let rec loop = function
  52       Elem x -> x
  53     | And [x] -> loop x
  54     | Or [x] -> loop x
  55     | And l -> Printf.sprintf "{%s}" (String.concat ";" (List.map loop l))
  56     | Or l -> Printf.sprintf "{%s}" (String.concat "," (List.map loop l))
  57     | True -> "True"
  58     | False ->
  59         if strict
  60         then failwith "False should not be in the final result.  Perhaps your rule doesn't contain any +/-/* code"
  61         else "False" in
  62   match x with
  63     True -> None
  64   | False when strict ->
  65       failwith "False should not be in the final result.  Perhaps your rule doesn't contain any +/-/* code"
  66   | _ -> Some [(loop x)]
  67
  68 let interpret_google strict x =
  69   (* convert to dnf *)
  70   let rec dnf = function
  71       Elem x -> [x]
  72     | Or l -> List.fold_left Common.union_set [] (List.map dnf l)
  73     | And l ->
  74         let l = List.map dnf l in
  75         List.fold_left
  76           (function prev ->
  77             function cur ->
  78               List.fold_left Common.union_set []
  79                 (List.map
  80                    (function x ->
  81                      List.map (function y -> Printf.sprintf "%s %s" x y) prev)
  82                    cur))
  83           [] l
  84     | True -> ["True"]
  85     | False ->
  86         if strict
  87         then failwith "False should not be in the final result.  Perhaps your rule doesn't contain any +/-/* code"
  88         else ["False"] in
  89   match x with
  90     True -> None
  91   | False when strict ->
  92       failwith "False should not be in the final result.  Perhaps your rule doesn't contain any +/-/* code"
  93   | _ -> Some (dnf x)
  94
  95 let interpret strict x =
  96   match !Flag.scanner with
  97     Flag.Glimpse -> interpret_glimpse strict x
  98   | Flag.Google _ -> interpret_google strict x
  99   | _ -> failwith "not possible"
 100
 101 let combine2c x =
 102   match interpret false x with
 103     None -> "None"
 104   | Some x -> String.concat " || " x
 105
 106 let norm = function
 107     And l -> And (List.sort compare l)
 108   | Or l  -> Or (List.sort compare l)
 109   | x -> x
 110
 111 let rec merge l1 l2 =
 112   match (l1,l2) with
 113     ([],l2) -> l2
 114   | (l1,[]) -> l1
 115   | (x::xs,y::ys) ->
 116       (match compare x y with
 117         -1 -> x::(merge xs l2)
 118       | 0  -> x::(merge xs ys)
 119       | 1  -> y::(merge l1 ys)
 120       | _ -> failwith "not possible")
 121
 122 let intersect l1 l2 = List.filter (function l1e -> List.mem l1e l2) l1
 123
 124 let minus_set l1 l2 = List.filter (function l1e -> not (List.mem l1e l2)) l1
 125
 126 let rec insert x l = merge [x] l
 127
 128 let rec build_and x y =
 129   if x = y
 130   then x
 131   else
 132     match (x,y) with
 133       (True,x) | (x,True) -> x
 134     | (False,x) | (x,False) -> False
 135     | (And l1,And l2) -> And (merge l1 l2)
 136     | (x,Or l) when List.mem x l -> x
 137     | (Or l,x) when List.mem x l -> x
 138     | (Or l1,Or l2) when not ((intersect l1 l2) = []) ->
 139         let inner =
 140           build_and
 141             (List.fold_left build_or False (minus_set l1 l2))
 142             (List.fold_left build_or False (minus_set l2 l1)) in
 143         List.fold_left build_or inner (intersect l1 l2)
 144     | (x,And l) | (And l,x) ->
 145         if List.mem x l
 146         then And l
 147         else
 148           let others =
 149             List.filter
 150               (function
 151                   Or l -> not(List.mem x l)
 152                 | _ -> true)
 153               l in
 154           And (insert x others)
 155     | (x,y) -> norm(And [x;y])
 156
 157 and build_or x y =
 158   if x = y
 159   then x
 160   else
 161     match (x,y) with
 162       (True,x) | (x,True) -> True
 163     | (False,x) | (x,False) -> x
 164     | (Or l1,Or l2) -> Or (merge l1 l2)
 165     | (x,And l) when List.mem x l -> x
 166     | (And l,x) when List.mem x l -> x
 167     | (And l1,And l2) when not ((intersect l1 l2) = []) ->
 168         let inner =
 169           build_or
 170             (List.fold_left build_and True (minus_set l1 l2))
 171             (List.fold_left build_and True (minus_set l2 l1)) in
 172         List.fold_left build_and inner (intersect l1 l2)
 173     | (x,Or l) | (Or l,x) ->
 174         if List.mem x l
 175         then Or l
 176         else
 177           let others =
 178             List.filter
 179               (function
 180                   And l -> not(List.mem x l)
 181                 | _ -> true)
 182               l in
 183           Or (insert x others)
 184     | (x,y) -> norm(Or [x;y])
 185
 186 let keep x = Elem x
 187 let drop x = True
 188
 189 let do_get_constants constants keywords env neg_pos =
 190   let donothing r k e = k e in
 191   let option_default = True in
 192   let bind = build_and in
 193   let inherited ((nm1,_) as x) =
 194     (* perhaps inherited, but value not required, so no constraints *)
 195     if List.mem x neg_pos then option_default
 196     else try List.assoc nm1 env with Not_found -> False in
 197   let minherited name = inherited (Ast.unwrap_mcode name) in
 198   let mcode _ x =
 199     match Ast.get_pos_var x with
 200       Ast.MetaPos(name,constraints,_,keep,inh) -> minherited name
 201     | _ -> option_default in
 202
 203   (* if one branch gives no information, then we have to take anything *)
 204   let disj_union_all = List.fold_left build_or False in
 205
 206   let ident r k i =
 207     match Ast.unwrap i with
 208       Ast.Id(name) ->
 209         bind (k i)
 210           (match Ast.unwrap_mcode name with
 211             "NULL" -> keywords "NULL"
 212           | nm -> constants nm)
 213     | Ast.MetaId(name,_,_,_) | Ast.MetaFunc(name,_,_,_)
 214     | Ast.MetaLocalFunc(name,_,_,_) -> bind (k i) (minherited name)
 215     | _ -> k i in
 216
 217   let rec type_collect res = function
 218       TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty)
 219     | TC.Array(ty) -> type_collect res ty
 220     | TC.MetaType(tyname,_,_) -> inherited tyname
 221     | TC.TypeName(s) -> constants s
 222     | TC.EnumName(false,s) -> constants s
 223     | TC.StructUnionName(_,false,s) -> constants s
 224     | ty -> res in
 225
 226   (* no point to do anything special for records because glimpse is
 227      word-oriented *)
 228   let expression r k e =
 229     match Ast.unwrap e with
 230       Ast.Constant(const) ->
 231         bind (k e)
 232           (match Ast.unwrap_mcode const with
 233             Ast.String s -> constants s
 234           | Ast.Char "\\0" -> option_default (* glimpse doesn't like it *)
 235           | Ast.Char s -> option_default (* probably not chars either *)
 236           (* the following were eg keywords "1", but not good for glimpse *)
 237           | Ast.Int s -> option_default (* glimpse doesn't index integers *)
 238           | Ast.Float s -> option_default (* probably not floats either *))
 239     | Ast.MetaExpr(name,_,_,Some type_list,_,_) ->
 240         let types = List.fold_left type_collect option_default type_list in
 241         bind (k e) (bind (minherited name) types)
 242     | Ast.MetaErr(name,_,_,_) | Ast.MetaExpr(name,_,_,_,_,_) ->
 243         bind (k e) (minherited name)
 244     | Ast.MetaExprList(name,None,_,_) -> minherited name
 245     | Ast.MetaExprList(name,Some (lenname,_,_),_,_) ->
 246         bind (k e) (bind (minherited name) (minherited lenname))
 247     | Ast.SizeOfExpr(sizeof,exp) -> bind (keywords "sizeof") (k e)
 248     | Ast.SizeOfType(sizeof,lp,ty,rp) -> bind (keywords "sizeof") (k e)
 249     | Ast.NestExpr(expr_dots,wc,false) -> option_default
 250     | Ast.NestExpr(expr_dots,wc,true) ->
 251         r.V.combiner_expression_dots expr_dots
 252     | Ast.DisjExpr(exps) ->
 253         disj_union_all (List.map r.V.combiner_expression exps)
 254     | Ast.OptExp(exp) -> option_default
 255     | Ast.Edots(_,_) | Ast.Ecircles(_,_) | Ast.Estars(_,_) -> option_default
 256     | _ -> k e in
 257
 258   let fullType r k ft =
 259     match Ast.unwrap ft with
 260       Ast.DisjType(decls) ->
 261         disj_union_all (List.map r.V.combiner_fullType decls)
 262     | Ast.OptType(ty) -> option_default
 263     | _ -> k ft in
 264
 265   let baseType = function
 266       Ast.VoidType -> keywords "void "
 267     | Ast.CharType -> keywords "char "
 268     | Ast.ShortType -> keywords "short "
 269     | Ast.IntType -> keywords "int "
 270     | Ast.DoubleType -> keywords "double "
 271     | Ast.FloatType -> keywords "float "
 272     | Ast.LongType | Ast.LongLongType -> keywords "long " in
 273
 274   let typeC r k ty =
 275     match Ast.unwrap ty with
 276       Ast.BaseType(ty1,strings) -> bind (k ty) (baseType ty1)
 277     | Ast.TypeName(name) -> bind (k ty) (constants (Ast.unwrap_mcode name))
 278     | Ast.MetaType(name,_,_) -> bind (minherited name) (k ty)
 279     | _ -> k ty in
 280
 281   let declaration r k d =
 282     match Ast.unwrap d with
 283       Ast.DisjDecl(decls) ->
 284         disj_union_all (List.map r.V.combiner_declaration decls)
 285     | Ast.OptDecl(decl) -> option_default
 286     | Ast.Ddots(dots,whencode) -> option_default
 287     | _ -> k d in
 288
 289   let initialiser r k i =
 290     match Ast.unwrap i with
 291       Ast.OptIni(ini) -> option_default
 292     | _ -> k i in
 293
 294   let parameter r k p =
 295     match Ast.unwrap p with
 296       Ast.OptParam(param) -> option_default
 297     | Ast.MetaParam(name,_,_) -> bind (k p) (minherited name)
 298     | Ast.MetaParamList(name,None,_,_) -> bind (k p) (minherited name)
 299     | Ast.MetaParamList(name,Some(lenname,_,_),_,_) ->
 300         bind (minherited name) (bind (minherited lenname) (k p))
 301     | _ -> k p in
 302
 303   let rule_elem r k re =
 304     match Ast.unwrap re with
 305       Ast.MetaRuleElem(name,_,_) | Ast.MetaStmt(name,_,_,_)
 306     | Ast.MetaStmtList(name,_,_) -> bind (minherited name) (k re)
 307     | Ast.WhileHeader(whl,lp,exp,rp) ->
 308         bind (keywords "while") (k re)
 309     | Ast.WhileTail(whl,lp,exp,rp,sem) ->
 310         bind (keywords "do") (k re)
 311     | Ast.ForHeader(fr,lp,e1,sem1,e2,sem2,e3,rp) ->
 312         bind (keywords "for") (k re)
 313     | Ast.SwitchHeader(switch,lp,exp,rp) ->
 314         bind (keywords "switch") (k re)
 315     | Ast.Break(br,sem) ->
 316         bind (keywords "break") (k re)
 317     | Ast.Continue(cont,sem) ->
 318         bind (keywords "continue") (k re)
 319     | Ast.Goto(_,i,_) ->
 320         bind (keywords "goto") (k re)
 321     | Ast.Default(def,colon) ->
 322         bind (keywords "default") (k re)
 323     | Ast.Include(inc,s) ->
 324         bind (k re)
 325           (match Ast.unwrap_mcode s with
 326             Ast.Local l | Ast.NonLocal l ->
 327               let strings =
 328                 List.fold_left
 329                   (function prev ->
 330                     function
 331                         (* just take the last thing, probably the most
 332                            specific.  everything is necessary anyway. *)
 333                         Ast.IncPath s -> [Elem s]
 334                       | Ast.IncDots -> prev)
 335                   [] l in
 336               (match strings with
 337                 [] -> True
 338               | x::xs -> List.fold_left bind x xs))
 339     | Ast.DisjRuleElem(res) ->
 340         disj_union_all (List.map r.V.combiner_rule_elem res)
 341     | _ -> k re in
 342
 343   let statement r k s =
 344     match Ast.unwrap s with
 345       Ast.Disj(stmt_dots) ->
 346         disj_union_all (List.map r.V.combiner_statement_dots stmt_dots)
 347     | Ast.Nest(stmt_dots,whn,false,_,_) -> option_default
 348     | Ast.Nest(stmt_dots,whn,true,_,_) ->
 349         r.V.combiner_statement_dots stmt_dots
 350     | Ast.OptStm(s) -> option_default
 351     | Ast.Dots(d,whn,_,_) | Ast.Circles(d,whn,_,_) | Ast.Stars(d,whn,_,_) ->
 352         option_default
 353     | _ -> k s in
 354
 355   V.combiner bind option_default
 356     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 357     donothing donothing donothing donothing
 358     ident expression fullType typeC initialiser parameter declaration
 359     rule_elem statement donothing donothing donothing
 360
 361 (* ------------------------------------------------------------------------ *)
 362
 363 let filter_combine combine to_drop =
 364   let rec and_loop = function
 365       Elem x when List.mem x to_drop -> True
 366     | Or l ->  List.fold_left build_or  False (List.map or_loop l)
 367     | x -> x
 368   and or_loop = function
 369       Elem x when List.mem x to_drop -> False
 370     | And l -> List.fold_left build_and True  (List.map and_loop l)
 371     | x -> x in
 372  or_loop combine
 373
 374 (* ------------------------------------------------------------------------ *)
 375
 376 let get_all_constants minus_only =
 377   let donothing r k e = k e in
 378   let bind = Common.union_set in
 379   let option_default = [] in
 380   let mcode r (x,_,mcodekind,_) =
 381     match mcodekind with
 382       Ast.MINUS(_,_,_,_) -> [x]
 383     | _ when minus_only -> []
 384     | _ -> [x] in
 385   let other r _ = [] in
 386
 387   V.combiner bind option_default
 388     other mcode other other other other other other other other other other
 389
 390     donothing donothing donothing donothing
 391     donothing donothing donothing donothing donothing donothing donothing
 392     donothing donothing donothing donothing donothing
 393
 394 (* ------------------------------------------------------------------------ *)
 395
 396 let get_plus_constants =
 397   let donothing r k e = k e in
 398   let bind = Common.union_set in
 399   let option_default = [] in
 400   let mcode r mc =
 401     let mcodekind = Ast.get_mcodekind mc in
 402     let recurse l =
 403       List.fold_left
 404         (List.fold_left
 405            (function prev ->
 406              function cur ->
 407                bind ((get_all_constants false).V.combiner_anything cur) prev))
 408         [] l in
 409     match mcodekind with
 410       Ast.MINUS(_,_,_,anythings) -> recurse anythings
 411     | Ast.CONTEXT(_,Ast.BEFORE(a,_)) -> recurse a
 412     | Ast.CONTEXT(_,Ast.AFTER(a,_)) -> recurse a
 413     | Ast.CONTEXT(_,Ast.BEFOREAFTER(a1,a2,_)) ->
 414         Common.union_set (recurse a1) (recurse a2)
 415     | _ -> [] in
 416
 417   V.combiner bind option_default
 418     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 419     donothing donothing donothing donothing
 420     donothing donothing donothing donothing donothing donothing donothing
 421     donothing donothing donothing donothing donothing
 422
 423 (* ------------------------------------------------------------------------ *)
 424
 425 (* true means the rule should be analyzed, false means it should be ignored *)
 426 let rec dependencies env = function
 427     Ast.Dep s -> (try List.assoc s env with Not_found -> False)
 428   | Ast.AntiDep s -> True
 429   | Ast.EverDep s -> (try List.assoc s env with Not_found -> False)
 430   | Ast.NeverDep s -> True
 431   | Ast.AndDep (d1,d2) -> build_and (dependencies env d1) (dependencies env d2)
 432   | Ast.OrDep (d1,d2) -> build_or (dependencies env d1) (dependencies env d2)
 433   | Ast.NoDep -> True
 434   | Ast.FailDep -> False
 435
 436 (* ------------------------------------------------------------------------ *)
 437
 438 let all_context =
 439   let bind x y = x && y in
 440   let option_default = true in
 441
 442   let donothing recursor k e = k e in
 443
 444   let mcode r e =
 445     match Ast.get_mcodekind e with
 446       Ast.CONTEXT(_,Ast.NOTHING) -> true
 447     | _ -> false in
 448
 449   V.combiner bind option_default
 450     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 451     donothing donothing donothing donothing
 452     donothing donothing donothing donothing donothing donothing
 453     donothing donothing donothing donothing donothing donothing
 454
 455 (* ------------------------------------------------------------------------ *)
 456
 457 let rule_fn tls in_plus env neg_pos =
 458   List.fold_left
 459     (function (rest_info,in_plus) ->
 460       function (cur,neg_pos) ->
 461         let minuses =
 462           (do_get_constants keep drop env neg_pos).V.combiner_top_level cur in
 463         let all_minuses =
 464           if !Flag.sgrep_mode2
 465           then [] (* nothing removed for sgrep *)
 466           else (get_all_constants true).V.combiner_top_level cur in
 467         let plusses = get_plus_constants.V.combiner_top_level cur in
 468         (* the following is for eg -foo(2) +foo(x) then in another rule
 469            -foo(10); don't want to consider that foo is guaranteed to be
 470            created by the rule.  not sure this works completely: what if foo is
 471            in both - and +, but in an or, so the cases aren't related?
 472            not sure this whole thing is a good idea.  how do we know that
 473            something that is only in plus is really freshly created? *)
 474         let plusses = Common.minus_set plusses all_minuses in
 475         let was_bot = minuses = True in
 476         let new_minuses = filter_combine minuses in_plus in
 477         let new_plusses = Common.union_set plusses in_plus in
 478         (* perhaps it should be build_and here?  we don't realy have multiple
 479            minirules anymore anyway. *)
 480         match new_minuses with
 481           True ->
 482             let retry =
 483               (do_get_constants drop keep env neg_pos).V.combiner_top_level
 484                 cur in
 485             (match retry with
 486               True when not was_bot -> (rest_info, new_plusses)
 487             | x -> (build_or x rest_info, new_plusses))
 488         | x -> (build_or x rest_info, new_plusses))
 489     (False,in_plus) (List.combine tls neg_pos)
 490
 491 let get_constants rules neg_pos_vars =
 492   match !Flag.scanner with
 493     Flag.NoScanner -> None
 494   | Flag.Glimpse | Flag.Google _ ->
 495       let (info,_,_,_) =
 496         List.fold_left
 497           (function (rest_info,in_plus,env,locals(*dom of env*)) ->
 498             function
 499                 (Ast.ScriptRule (_,deps,mv,_),_) ->
 500                   let extra_deps =
 501                     List.fold_left
 502                       (function prev ->
 503                         function (_,(rule,_)) ->
 504                           Ast.AndDep (Ast.Dep rule,prev))
 505                       deps mv in
 506                   (match dependencies env extra_deps with
 507                     False -> (rest_info, in_plus, env, locals)
 508                   | dependencies ->
 509                       (build_or dependencies rest_info, in_plus, env, locals))
 510               | (Ast.InitialScriptRule (_,_),_)
 511               | (Ast.FinalScriptRule (_,_),_) -> (rest_info,in_plus,env,locals)
 512               | (Ast.CocciRule (nm,(dep,_,_),cur,_,_),neg_pos_vars) ->
 513                   let (cur_info,cur_plus) =
 514                     rule_fn cur in_plus ((nm,True)::env) neg_pos_vars in
 515                   if List.for_all all_context.V.combiner_top_level cur
 516                   then (rest_info,cur_plus,(nm,cur_info)::env,nm::locals)
 517                   else
 518                (* no constants if dependent on another rule; then we need to
 519                   find the constants of that rule *)
 520                     match dependencies env dep with
 521                       False -> (rest_info,cur_plus,env,locals)
 522                     | dependencies ->
 523                         (build_or (build_and dependencies cur_info) rest_info,
 524                          cur_plus,env,locals))
 525           (False,[],[],[])
 526           (List.combine (rules : Ast.rule list) neg_pos_vars) in
 527       interpret true info