X-Git-Url: https://git.hcoop.net/bpt/coccinelle.git/blobdiff_plain/90aeb998d88488b4402e7b211b064056d175fcbb..7f339edd551eefcd6c99f379ce91c27df997cfe3:/parsing_cocci/get_constants2.ml

diff --git a/parsing_cocci/get_constants2.ml b/parsing_cocci/get_constants2.ml
index bd11836..0be5611 100644
--- a/parsing_cocci/get_constants2.ml
+++ b/parsing_cocci/get_constants2.ml
@@ -1,5 +1,7 @@
 (*
- * Copyright 2010, INRIA, University of Copenhagen
+ * Copyright 2012, INRIA
+ * Julia Lawall, Gilles Muller
+ * Copyright 2010-2011, INRIA, University of Copenhagen
  * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
  * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
  * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
@@ -22,6 +24,7 @@
  *)
 
 
+# 0 "./get_constants2.ml"
 module Ast = Ast_cocci
 module V = Visitor_ast
 module TC = Type_cocci
@@ -54,6 +57,59 @@ wanted *)
 type combine =
     And of combine list | Or of combine list | Elem of string | False | True
 
+let rec dep2c = function
+    And l -> Printf.sprintf "(%s)" (String.concat "&" (List.map dep2c l))
+  | Or l -> Printf.sprintf "(%s)" (String.concat "|" (List.map dep2c l))
+  | Elem x -> x
+  | False -> "false"
+  | True -> "true"
+
+(* glimpse often fails on large queries.  We can safely remove arguments of
+&& as long as we don't remove all of them (note that there is no negation).
+This tries just removing one of them and then orders the results by
+increasing number of ors (ors are long, increasing the chance of failure,
+and are less restrictive, possibly increasing the chance of irrelevant
+code. *)
+let reduce_glimpse x =
+  let rec loop x k q =
+    match x with
+      Elem _ -> q()
+    | And [x] -> loop x (function changed_l -> k (And [changed_l])) q
+    | And l ->
+	kloop l
+	  (function changed_l -> k (And changed_l))
+	  (function _ ->
+	    let rec rloop l k =
+	      match l with
+		[] -> q()
+	      | x::xs ->
+		  (k xs) ::
+		  rloop xs (function changed_xs -> k (x :: changed_xs)) in
+	    rloop l (function changed_l -> k (And changed_l)))
+    | Or l -> kloop l (function changed_l -> k (Or changed_l)) q
+    | _ -> failwith "not possible"
+  and kloop l k q =
+    match l with
+      [] -> q()
+    | x::xs ->
+	loop x
+	  (function changed_x -> k (changed_x::xs))
+	  (function _ ->
+	    kloop xs
+	      (function changed_xs -> k (x :: changed_xs))
+	      q) in
+  let rec count_ors = function
+      Elem _ -> 0
+    | And l -> List.fold_left (+) 0 (List.map count_ors l)
+    | Or l ->
+	((List.length l) - 1) +
+	  (List.fold_left (+) 0 (List.map count_ors l))
+    | _ -> failwith "not possible" in
+  let res = loop x (function x -> x) (function _ -> []) in
+  let res = List.map (function x -> (count_ors x,x)) res in
+  let res = List.sort compare res in
+  List.map (function (_,x) -> x) res
+
 let interpret_glimpse strict x =
   let rec loop = function
       Elem x -> x
@@ -73,7 +129,8 @@ let interpret_glimpse strict x =
     True -> None
   | False when strict ->
       failwith "False should not be in the final result.  Perhaps your rule doesn't contain any +/-/* code"
-  | _ -> Some [(loop x)]
+  | _ ->
+      Some (if strict then List.map loop (x::reduce_glimpse x) else [loop x])
 
 (* grep only does or *)
 let interpret_grep strict x =
@@ -213,18 +270,20 @@ let drop x = True
 let do_get_constants constants keywords env neg_pos =
   let donothing r k e = k e in
   let option_default = True in
+  let bad_default = False in
   let bind = build_and in
   let inherited ((nm1,_) as x) =
-    (* ignore virtuals *)
-    if nm1 = "virtual" then option_default
+    (* ignore virtuals, can never match *)
+    if nm1 = "virtual" then bad_default
     (* perhaps inherited, but value not required, so no constraints *)
     else if List.mem x neg_pos then option_default
     else (try List.assoc nm1 env with Not_found -> False) in
   let minherited name = inherited (Ast.unwrap_mcode name) in
   let mcode _ x =
-    match Ast.get_pos_var x with
-      Ast.MetaPos(name,constraints,_,keep,inh) -> minherited name
-    | _ -> option_default in
+    List.fold_left bind option_default
+      (List.map
+	 (function Ast.MetaPos(name,constraints,_,keep,inh) -> minherited name)
+	 (Ast.get_pos_var x)) in
 
   (* if one branch gives no information, then we have to take anything *)
   let disj_union_all = List.fold_left build_or False in
@@ -237,7 +296,9 @@ let do_get_constants constants keywords env neg_pos =
 	    "NULL" -> keywords "NULL"
 	  | nm -> constants nm)
     | Ast.MetaId(name,_,_,_) | Ast.MetaFunc(name,_,_,_)
-    | Ast.MetaLocalFunc(name,_,_,_) -> bind (k i) (minherited name)
+    | Ast.MetaLocalFunc(name,_,_,_) ->
+	bind (k i) (minherited name)
+    | Ast.DisjId(ids) -> disj_union_all (List.map r.V.combiner_ident ids)
     | _ -> k i in
 
   let rec type_collect res = function
@@ -246,8 +307,8 @@ let do_get_constants constants keywords env neg_pos =
     | TC.MetaType(tyname,_,_) ->
 	inherited tyname
     | TC.TypeName(s) -> constants s
-    | TC.EnumName(false,s) -> constants s
-    | TC.StructUnionName(_,false,s) -> constants s
+    | TC.EnumName(TC.Name s) -> constants s
+    | TC.StructUnionName(_,TC.Name s) -> constants s
     | ty -> res in
 
   (* no point to do anything special for records because glimpse is
@@ -268,9 +329,9 @@ let do_get_constants constants keywords env neg_pos =
 	bind (k e) (bind (minherited name) types)
     | Ast.MetaErr(name,_,_,_) | Ast.MetaExpr(name,_,_,_,_,_) ->
 	bind (k e) (minherited name)
-    | Ast.MetaExprList(name,None,_,_) -> minherited name
-    | Ast.MetaExprList(name,Some (lenname,_,_),_,_) ->
+    | Ast.MetaExprList(name,Ast.MetaListLen (lenname,_,_),_,_) ->
 	bind (k e) (bind (minherited name) (minherited lenname))
+    | Ast.MetaExprList(name,_,_,_) -> minherited name
     | Ast.SizeOfExpr(sizeof,exp) -> bind (keywords "sizeof") (k e)
     | Ast.SizeOfType(sizeof,lp,ty,rp) -> bind (keywords "sizeof") (k e)
     | Ast.NestExpr(starter,expr_dots,ender,wc,false) -> option_default
@@ -290,13 +351,19 @@ let do_get_constants constants keywords env neg_pos =
     | _ -> k ft in
 
   let baseType = function
-      Ast.VoidType -> keywords "void "
-    | Ast.CharType -> keywords "char "
-    | Ast.ShortType -> keywords "short "
-    | Ast.IntType -> keywords "int "
-    | Ast.DoubleType -> keywords "double "
-    | Ast.FloatType -> keywords "float "
-    | Ast.LongType | Ast.LongLongType -> keywords "long " in
+      Ast.VoidType -> keywords "void"
+    | Ast.CharType -> keywords "char"
+    | Ast.ShortType -> keywords "short"
+    | Ast.ShortIntType -> keywords "short"
+    | Ast.IntType -> keywords "int"
+    | Ast.DoubleType -> keywords "double"
+    | Ast.LongDoubleType -> keywords "double"
+    | Ast.FloatType -> keywords "float"
+    | Ast.LongType | Ast.LongLongType
+    | Ast.LongIntType | Ast.LongLongIntType -> keywords "long"
+    | Ast.SizeType -> keywords "size_t"
+    | Ast.SSizeType -> keywords "ssize_t"
+    | Ast.PtrDiffType -> keywords "ptrdiff_t" in
 
   let typeC r k ty =
     match Ast.unwrap ty with
@@ -307,7 +374,11 @@ let do_get_constants constants keywords env neg_pos =
 
   let declaration r k d =
     match Ast.unwrap d with
-      Ast.DisjDecl(decls) ->
+      Ast.MetaDecl(name,_,_) | Ast.MetaField(name,_,_) ->
+	bind (k d) (minherited name)
+    | Ast.MetaFieldList(name,Ast.MetaListLen(lenname,_,_),_,_) ->
+	bind (minherited name) (bind (minherited lenname) (k d))
+    | Ast.DisjDecl(decls) ->
 	disj_union_all (List.map r.V.combiner_declaration decls)
     | Ast.OptDecl(decl) -> option_default
     | Ast.Ddots(dots,whencode) -> option_default
@@ -322,9 +393,9 @@ let do_get_constants constants keywords env neg_pos =
     match Ast.unwrap p with
       Ast.OptParam(param) -> option_default
     | Ast.MetaParam(name,_,_) -> bind (k p) (minherited name)
-    | Ast.MetaParamList(name,None,_,_) -> bind (k p) (minherited name)
-    | Ast.MetaParamList(name,Some(lenname,_,_),_,_) ->
+    | Ast.MetaParamList(name,Ast.MetaListLen(lenname,_,_),_,_) ->
 	bind (minherited name) (bind (minherited lenname) (k p))
+    | Ast.MetaParamList(name,_,_,_) -> bind (k p) (minherited name)
     | _ -> k p in
 
   let rule_elem r k re =
@@ -381,7 +452,7 @@ let do_get_constants constants keywords env neg_pos =
 
   V.combiner bind option_default
     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
-    donothing donothing donothing donothing
+    donothing donothing donothing donothing donothing
     ident expression fullType typeC initialiser parameter declaration
     rule_elem statement donothing donothing donothing
 
@@ -414,7 +485,7 @@ let get_all_constants minus_only =
   V.combiner bind option_default
     other mcode other other other other other other other other other other
 
-    donothing donothing donothing donothing
+    donothing donothing donothing donothing donothing
     donothing donothing donothing donothing donothing donothing donothing
     donothing donothing donothing donothing donothing
 
@@ -433,7 +504,7 @@ let get_plus_constants =
 	     bind ((get_all_constants false).V.combiner_anything cur) prev))
       [] l in
   let process_mcodekind = function
-      Ast.MINUS(_,_,_,anythings) -> recurse anythings
+      Ast.MINUS(_,_,_,Ast.REPLACEMENT(anythings,_)) -> recurse anythings
     | Ast.CONTEXT(_,Ast.BEFORE(a,_)) -> recurse a
     | Ast.CONTEXT(_,Ast.AFTER(a,_)) -> recurse a
     | Ast.CONTEXT(_,Ast.BEFOREAFTER(a1,a2,_)) ->
@@ -458,7 +529,7 @@ let get_plus_constants =
 
   V.combiner bind option_default
     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
-    donothing donothing donothing donothing
+    donothing donothing donothing donothing donothing
     donothing donothing donothing donothing donothing donothing donothing
     rule_elem statement donothing donothing donothing
 
@@ -493,7 +564,7 @@ let all_context =
 
   let initialiser r k e =
     match Ast.unwrap e with
-      Ast.InitList(all_minus,_,_,_,_) ->
+      Ast.StrInitList(all_minus,_,_,_,_) ->
 	not all_minus && k e
     | _ -> k e in
 
@@ -512,7 +583,7 @@ let all_context =
 
   V.combiner bind option_default
     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
-    donothing donothing donothing donothing
+    donothing donothing donothing donothing donothing
     donothing donothing donothing donothing initialiser donothing
     donothing rule_elem statement donothing donothing donothing
 
@@ -557,52 +628,56 @@ let run rules neg_pos_vars =
     List.fold_left
       (function (rest_info,in_plus,env,locals(*dom of env*)) ->
         function
-	    (Ast.ScriptRule (_,deps,mv,_),_) ->
+	    (Ast.ScriptRule (nm,_,deps,mv,_,_),_) ->
 	      let extra_deps =
 		List.fold_left
 		  (function prev ->
-		    function (_,(rule,_)) ->
+		    function (_,(rule,_),_) ->
 		      if rule = "virtual"
 		      then prev
 		      else Ast.AndDep (Ast.Dep rule,prev))
 		  deps mv in
 	      (match dependencies env extra_deps with
-		False -> (rest_info, in_plus, env, locals)
+		False ->
+		  (rest_info, in_plus, (nm,True)::env, nm::locals)
 	      | dependencies ->
 		  (build_or dependencies rest_info, in_plus, env, locals))
-          | (Ast.InitialScriptRule (_,deps,_),_)
-	  | (Ast.FinalScriptRule (_,deps,_),_) ->
+          | (Ast.InitialScriptRule (_,_,deps,_),_)
+	  | (Ast.FinalScriptRule (_,_,deps,_),_) ->
 		  (* initialize and finalize dependencies are irrelevant to
 		     get_constants *)
 	      (rest_info, in_plus, env, locals)
           | (Ast.CocciRule (nm,(dep,_,_),cur,_,_),neg_pos_vars) ->
 	      let (cur_info,cur_plus) =
-		rule_fn cur in_plus ((nm,True)::env)
-		  neg_pos_vars in
+		rule_fn cur in_plus ((nm,True)::env) neg_pos_vars in
 	      (match dependencies env dep with
 		False -> (rest_info,cur_plus,env,locals)
 	      | dependencies ->
 		  if List.for_all all_context.V.combiner_top_level cur
-		  then (rest_info,cur_plus,(nm,cur_info)::env,nm::locals)
+		  then
+		    let cur_info = build_and dependencies cur_info in
+		    (rest_info,cur_plus,(nm,cur_info)::env,nm::locals)
 		  else
 	       (* no constants if dependent on another rule; then we need to
 	          find the constants of that rule *)
-		    (build_or (build_and dependencies cur_info) rest_info,
-		     cur_plus,env,locals)))
+		      (build_or (build_and dependencies cur_info) rest_info,
+		       cur_plus,(nm,cur_info)::env,locals)))
       (False,[],[],[])
       (List.combine (rules : Ast.rule list) neg_pos_vars) in
   info
     
 let get_constants rules neg_pos_vars =
   match !Flag.scanner with
-    Flag.NoScanner -> (None,None)
+    Flag.NoScanner -> (None,None,None)
   | Flag.Grep ->
       let res = run rules neg_pos_vars in
-      (interpret_grep true res,None)
+      (interpret_grep true res,None,None)
   | Flag.Glimpse ->
       let res = run rules neg_pos_vars in
-      (interpret_grep true res,interpret_glimpse true res)
+      (interpret_grep true res,interpret_glimpse true res,None)
   | Flag.Google _ ->
       let res = run rules neg_pos_vars in
-      (interpret_grep true res,interpret_google true res)
-      
+      (interpret_grep true res,interpret_google true res,None)
+  | Flag.IdUtils ->
+      let res = run rules neg_pos_vars in
+      (interpret_grep true res,None,Some res)