parsing_cocci/get_constants2.ml

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