parsing_cocci/get_constants2.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 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     (* ignore virtuals *)
 195     if nm1 = "virtual" then option_default
 196     (* perhaps inherited, but value not required, so no constraints *)
 197     else if List.mem x neg_pos then option_default
 198     else (try List.assoc nm1 env with Not_found -> False) in
 199   let minherited name = inherited (Ast.unwrap_mcode name) in
 200   let mcode _ x =
 201     match Ast.get_pos_var x with
 202       Ast.MetaPos(name,constraints,_,keep,inh) -> minherited name
 203     | _ -> option_default in
 204
 205   (* if one branch gives no information, then we have to take anything *)
 206   let disj_union_all = List.fold_left build_or False in
 207
 208   let ident r k i =
 209     match Ast.unwrap i with
 210       Ast.Id(name) ->
 211         bind (k i)
 212           (match Ast.unwrap_mcode name with
 213             "NULL" -> keywords "NULL"
 214           | nm -> constants nm)
 215     | Ast.MetaId(name,_,_,_) | Ast.MetaFunc(name,_,_,_)
 216     | Ast.MetaLocalFunc(name,_,_,_) -> bind (k i) (minherited name)
 217     | _ -> k i in
 218
 219   let rec type_collect res = function
 220       TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty)
 221     | TC.Array(ty) -> type_collect res ty
 222     | TC.MetaType(tyname,_,_) ->
 223         inherited tyname
 224     | TC.TypeName(s) -> constants s
 225     | TC.EnumName(false,s) -> constants s
 226     | TC.StructUnionName(_,false,s) -> constants s
 227     | ty -> res in
 228
 229   (* no point to do anything special for records because glimpse is
 230      word-oriented *)
 231   let expression r k e =
 232     match Ast.unwrap e with
 233       Ast.Constant(const) ->
 234         bind (k e)
 235           (match Ast.unwrap_mcode const with
 236             Ast.String s -> constants s
 237           | Ast.Char "\\0" -> option_default (* glimpse doesn't like it *)
 238           | Ast.Char s -> option_default (* probably not chars either *)
 239           (* the following were eg keywords "1", but not good for glimpse *)
 240           | Ast.Int s -> option_default (* glimpse doesn't index integers *)
 241           | Ast.Float s -> option_default (* probably not floats either *))
 242     | Ast.MetaExpr(name,_,_,Some type_list,_,_) ->
 243         let types = List.fold_left type_collect option_default type_list in
 244         bind (k e) (bind (minherited name) types)
 245     | Ast.MetaErr(name,_,_,_) | Ast.MetaExpr(name,_,_,_,_,_) ->
 246         bind (k e) (minherited name)
 247     | Ast.MetaExprList(name,None,_,_) -> minherited name
 248     | Ast.MetaExprList(name,Some (lenname,_,_),_,_) ->
 249         bind (k e) (bind (minherited name) (minherited lenname))
 250     | Ast.SizeOfExpr(sizeof,exp) -> bind (keywords "sizeof") (k e)
 251     | Ast.SizeOfType(sizeof,lp,ty,rp) -> bind (keywords "sizeof") (k e)
 252     | Ast.NestExpr(expr_dots,wc,false) -> option_default
 253     | Ast.NestExpr(expr_dots,wc,true) ->
 254         r.V.combiner_expression_dots expr_dots
 255     | Ast.DisjExpr(exps) ->
 256         disj_union_all (List.map r.V.combiner_expression exps)
 257     | Ast.OptExp(exp) -> option_default
 258     | Ast.Edots(_,_) | Ast.Ecircles(_,_) | Ast.Estars(_,_) -> option_default
 259     | _ -> k e in
 260
 261   let fullType r k ft =
 262     match Ast.unwrap ft with
 263       Ast.DisjType(decls) ->
 264         disj_union_all (List.map r.V.combiner_fullType decls)
 265     | Ast.OptType(ty) -> option_default
 266     | _ -> k ft in
 267
 268   let baseType = function
 269       Ast.VoidType -> keywords "void "
 270     | Ast.CharType -> keywords "char "
 271     | Ast.ShortType -> keywords "short "
 272     | Ast.IntType -> keywords "int "
 273     | Ast.DoubleType -> keywords "double "
 274     | Ast.FloatType -> keywords "float "
 275     | Ast.LongType | Ast.LongLongType -> keywords "long " in
 276
 277   let typeC r k ty =
 278     match Ast.unwrap ty with
 279       Ast.BaseType(ty1,strings) -> bind (k ty) (baseType ty1)
 280     | Ast.TypeName(name) -> bind (k ty) (constants (Ast.unwrap_mcode name))
 281     | Ast.MetaType(name,_,_) -> bind (minherited name) (k ty)
 282     | _ -> k ty in
 283
 284   let declaration r k d =
 285     match Ast.unwrap d with
 286       Ast.DisjDecl(decls) ->
 287         disj_union_all (List.map r.V.combiner_declaration decls)
 288     | Ast.OptDecl(decl) -> option_default
 289     | Ast.Ddots(dots,whencode) -> option_default
 290     | _ -> k d in
 291
 292   let initialiser r k i =
 293     match Ast.unwrap i with
 294       Ast.OptIni(ini) -> option_default
 295     | _ -> k i in
 296
 297   let parameter r k p =
 298     match Ast.unwrap p with
 299       Ast.OptParam(param) -> option_default
 300     | Ast.MetaParam(name,_,_) -> bind (k p) (minherited name)
 301     | Ast.MetaParamList(name,None,_,_) -> bind (k p) (minherited name)
 302     | Ast.MetaParamList(name,Some(lenname,_,_),_,_) ->
 303         bind (minherited name) (bind (minherited lenname) (k p))
 304     | _ -> k p in
 305
 306   let rule_elem r k re =
 307     match Ast.unwrap re with
 308       Ast.MetaRuleElem(name,_,_) | Ast.MetaStmt(name,_,_,_)
 309     | Ast.MetaStmtList(name,_,_) -> bind (minherited name) (k re)
 310     | Ast.WhileHeader(whl,lp,exp,rp) ->
 311         bind (keywords "while") (k re)
 312     | Ast.WhileTail(whl,lp,exp,rp,sem) ->
 313         bind (keywords "do") (k re)
 314     | Ast.ForHeader(fr,lp,e1,sem1,e2,sem2,e3,rp) ->
 315         bind (keywords "for") (k re)
 316     | Ast.SwitchHeader(switch,lp,exp,rp) ->
 317         bind (keywords "switch") (k re)
 318     | Ast.Break(br,sem) ->
 319         bind (keywords "break") (k re)
 320     | Ast.Continue(cont,sem) ->
 321         bind (keywords "continue") (k re)
 322     | Ast.Goto(_,i,_) ->
 323         bind (keywords "goto") (k re)
 324     | Ast.Default(def,colon) ->
 325         bind (keywords "default") (k re)
 326     | Ast.Include(inc,s) ->
 327         bind (k re)
 328           (match Ast.unwrap_mcode s with
 329             Ast.Local l | Ast.NonLocal l ->
 330               let strings =
 331                 List.fold_left
 332                   (function prev ->
 333                     function
 334                         (* just take the last thing, probably the most
 335                            specific.  everything is necessary anyway. *)
 336                         Ast.IncPath s -> [Elem s]
 337                       | Ast.IncDots -> prev)
 338                   [] l in
 339               (match strings with
 340                 [] -> True
 341               | x::xs -> List.fold_left bind x xs))
 342     | Ast.DisjRuleElem(res) ->
 343         disj_union_all (List.map r.V.combiner_rule_elem res)
 344     | _ -> k re in
 345
 346   let statement r k s =
 347     match Ast.unwrap s with
 348       Ast.Disj(stmt_dots) ->
 349         disj_union_all (List.map r.V.combiner_statement_dots stmt_dots)
 350     | Ast.Nest(stmt_dots,whn,false,_,_) -> option_default
 351     | Ast.Nest(stmt_dots,whn,true,_,_) ->
 352         r.V.combiner_statement_dots stmt_dots
 353     | Ast.OptStm(s) -> option_default
 354     | Ast.Dots(d,whn,_,_) | Ast.Circles(d,whn,_,_) | Ast.Stars(d,whn,_,_) ->
 355         option_default
 356     | _ -> k s in
 357
 358   V.combiner bind option_default
 359     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 360     donothing donothing donothing donothing
 361     ident expression fullType typeC initialiser parameter declaration
 362     rule_elem statement donothing donothing donothing
 363
 364 (* ------------------------------------------------------------------------ *)
 365
 366 let filter_combine combine to_drop =
 367   let rec and_loop = function
 368       Elem x when List.mem x to_drop -> True
 369     | Or l ->  List.fold_left build_or  False (List.map or_loop l)
 370     | x -> x
 371   and or_loop = function
 372       Elem x when List.mem x to_drop -> False
 373     | And l -> List.fold_left build_and True  (List.map and_loop l)
 374     | x -> x in
 375  or_loop combine
 376
 377 (* ------------------------------------------------------------------------ *)
 378
 379 let get_all_constants minus_only =
 380   let donothing r k e = k e in
 381   let bind = Common.union_set in
 382   let option_default = [] in
 383   let mcode r (x,_,mcodekind,_) =
 384     match mcodekind with
 385       Ast.MINUS(_,_,_,_) -> [x]
 386     | _ when minus_only -> []
 387     | _ -> [x] in
 388   let other r _ = [] in
 389
 390   V.combiner bind option_default
 391     other mcode other other other other other other other other other other
 392
 393     donothing donothing donothing donothing
 394     donothing donothing donothing donothing donothing donothing donothing
 395     donothing donothing donothing donothing donothing
 396
 397 (* ------------------------------------------------------------------------ *)
 398
 399 let get_plus_constants =
 400   let donothing r k e = k e in
 401   let bind = Common.union_set in
 402   let option_default = [] in
 403   let mcode r mc =
 404     let mcodekind = Ast.get_mcodekind mc in
 405     let recurse l =
 406       List.fold_left
 407         (List.fold_left
 408            (function prev ->
 409              function cur ->
 410                bind ((get_all_constants false).V.combiner_anything cur) prev))
 411         [] l in
 412     match mcodekind with
 413       Ast.MINUS(_,_,_,anythings) -> recurse anythings
 414     | Ast.CONTEXT(_,Ast.BEFORE(a,_)) -> recurse a
 415     | Ast.CONTEXT(_,Ast.AFTER(a,_)) -> recurse a
 416     | Ast.CONTEXT(_,Ast.BEFOREAFTER(a1,a2,_)) ->
 417         Common.union_set (recurse a1) (recurse a2)
 418     | _ -> [] in
 419
 420   V.combiner bind option_default
 421     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 422     donothing donothing donothing donothing
 423     donothing donothing donothing donothing donothing donothing donothing
 424     donothing donothing donothing donothing donothing
 425
 426 (* ------------------------------------------------------------------------ *)
 427
 428 (* true means the rule should be analyzed, false means it should be ignored *)
 429 let rec dependencies env = function
 430     Ast.Dep s -> (try List.assoc s env with Not_found -> False)
 431   | Ast.AntiDep s -> True
 432   | Ast.EverDep s -> (try List.assoc s env with Not_found -> False)
 433   | Ast.NeverDep s -> True
 434   | Ast.AndDep (d1,d2) -> build_and (dependencies env d1) (dependencies env d2)
 435   | Ast.OrDep (d1,d2) -> build_or (dependencies env d1) (dependencies env d2)
 436   | Ast.NoDep -> True
 437   | Ast.FailDep -> False
 438
 439 (* ------------------------------------------------------------------------ *)
 440
 441 let all_context =
 442   let bind x y = x && y in
 443   let option_default = true in
 444
 445   let donothing recursor k e = k e in
 446
 447   let mcode r e =
 448     match Ast.get_mcodekind e with
 449       Ast.CONTEXT(_,Ast.NOTHING) -> true
 450     | _ -> false in
 451
 452   V.combiner bind option_default
 453     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 454     donothing donothing donothing donothing
 455     donothing donothing donothing donothing donothing donothing
 456     donothing donothing donothing donothing donothing donothing
 457
 458 (* ------------------------------------------------------------------------ *)
 459
 460 let rule_fn tls in_plus env neg_pos =
 461   List.fold_left
 462     (function (rest_info,in_plus) ->
 463       function (cur,neg_pos) ->
 464         let minuses =
 465           let getter = do_get_constants keep drop env neg_pos in
 466           getter.V.combiner_top_level cur in
 467         let all_minuses =
 468           if !Flag.sgrep_mode2
 469           then [] (* nothing removed for sgrep *)
 470           else (get_all_constants true).V.combiner_top_level cur in
 471         let plusses = get_plus_constants.V.combiner_top_level cur in
 472         (* the following is for eg -foo(2) +foo(x) then in another rule
 473            -foo(10); don't want to consider that foo is guaranteed to be
 474            created by the rule.  not sure this works completely: what if foo is
 475            in both - and +, but in an or, so the cases aren't related?
 476            not sure this whole thing is a good idea.  how do we know that
 477            something that is only in plus is really freshly created? *)
 478         let plusses = Common.minus_set plusses all_minuses in
 479         let was_bot = minuses = True in
 480         let new_minuses = filter_combine minuses in_plus in
 481         let new_plusses = Common.union_set plusses in_plus in
 482         (* perhaps it should be build_and here?  we don't realy have multiple
 483            minirules anymore anyway. *)
 484         match new_minuses with
 485           True ->
 486             let getter = do_get_constants drop keep env neg_pos in
 487             let retry = getter.V.combiner_top_level cur in
 488             (match retry with
 489               True when not was_bot -> (rest_info, new_plusses)
 490             | x -> (build_or x rest_info, new_plusses))
 491         | x -> (build_or x rest_info, new_plusses))
 492     (False,in_plus) (List.combine tls neg_pos)
 493
 494 let get_constants rules neg_pos_vars =
 495   match !Flag.scanner with
 496     Flag.NoScanner -> None
 497   | Flag.Glimpse | Flag.Google _ ->
 498       let (info,_,_,_) =
 499         List.fold_left
 500           (function (rest_info,in_plus,env,locals(*dom of env*)) ->
 501             function
 502                 (Ast.ScriptRule (_,deps,mv,_),_) ->
 503                   let extra_deps =
 504                     List.fold_left
 505                       (function prev ->
 506                         function (_,(rule,_)) ->
 507                           if rule = "virtual"
 508                           then prev
 509                           else Ast.AndDep (Ast.Dep rule,prev))
 510                       deps mv in
 511                   (match dependencies env extra_deps with
 512                     False -> (rest_info, in_plus, env, locals)
 513                   | dependencies ->
 514                       (build_or dependencies rest_info, in_plus, env, locals))
 515               | (Ast.InitialScriptRule (_,deps,_),_)
 516               | (Ast.FinalScriptRule (_,deps,_),_) ->
 517                   (match dependencies env deps with
 518                     False -> (rest_info, in_plus, env, locals)
 519                   | dependencies ->
 520                       (build_or dependencies rest_info, in_plus, env, locals))
 521               | (Ast.CocciRule (nm,(dep,_,_),cur,_,_),neg_pos_vars) ->
 522                   let (cur_info,cur_plus) =
 523                     rule_fn cur in_plus ((nm,True)::env)
 524                       neg_pos_vars in
 525                   if List.for_all all_context.V.combiner_top_level cur
 526                   then (rest_info,cur_plus,(nm,cur_info)::env,nm::locals)
 527                   else
 528                (* no constants if dependent on another rule; then we need to
 529                   find the constants of that rule *)
 530                     match dependencies env dep with
 531                       False -> (rest_info,cur_plus,env,locals)
 532                     | dependencies ->
 533                         (build_or (build_and dependencies cur_info) rest_info,
 534                          cur_plus,env,locals))
 535           (False,[],[],[])
 536           (List.combine (rules : Ast.rule list) neg_pos_vars) in
 537       interpret true info