X-Git-Url: http://git.hcoop.net/bpt/coccinelle.git/blobdiff_plain/978fd7e56b141f7e4c8930acdbf0a806489e63a5..9f8e26f459677a621822918b7539ae94214621ac:/engine/cocci_vs_c.ml

diff --git a/engine/cocci_vs_c.ml b/engine/cocci_vs_c.ml
index f081cea..f5087b4 100644
--- a/engine/cocci_vs_c.ml
+++ b/engine/cocci_vs_c.ml
@@ -1,23 +1,41 @@
 (*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-* 
-* Coccinelle is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, according to version 2 of the License.
-* 
-* Coccinelle is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-* GNU General Public License for more details.
-* 
-* You should have received a copy of the GNU General Public License
-* along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
-* 
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
+ * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
+ * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
+ * This file is part of Coccinelle.
+ *
+ * Coccinelle is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, according to version 2 of the License.
+ *
+ * Coccinelle is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
+ *
+ * The authors reserve the right to distribute this or future versions of
+ * Coccinelle under other licenses.
+ *)
+
+
+(* Yoann Padioleau, Julia Lawall
+ *
+ * Copyright (C) 2006, 2007, 2008 Ecole des Mines de Nantes
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License (GPL)
+ * version 2 as published by the Free Software Foundation.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * file license.txt for more details.
+ *
+ * This file was part of Coccinelle.
+ *)
+
 open Common
 
 module A = Ast_cocci
@@ -38,10 +56,10 @@ let pr2, pr2_once = Common.mk_pr2_wrappers Flag_matcher.verbose_matcher
 
 type sequence = Ordered | Unordered
 
-let seqstyle eas =      
-   match A.unwrap eas with 
-   | A.DOTS _ -> Ordered 
-   | A.CIRCLES _ -> Unordered 
+let seqstyle eas =
+   match A.unwrap eas with
+   | A.DOTS _ -> Ordered
+   | A.CIRCLES _ -> Unordered
    | A.STARS _ -> failwith "not handling stars"
 
 let (redots : 'a A.dots -> 'a list -> 'a A.dots)=fun eas easundots ->
@@ -94,7 +112,7 @@ let mcode_contain_plus = function
   | A.CONTEXT _ -> true
   | A.MINUS (_,_,_,[]) -> false
   | A.MINUS (_,_,_,x::xs) -> true
-  | A.PLUS -> raise Impossible
+  | A.PLUS _ -> raise Impossible
 
 let mcode_simple_minus = function
   | A.MINUS (_,_,_,[]) -> true
@@ -119,7 +137,7 @@ let generalize_mcode ia =
   let (s1, i, mck, pos) = ia in
   let new_mck =
     match mck with
-    | A.PLUS -> raise Impossible
+    | A.PLUS _ -> raise Impossible
     | A.CONTEXT (A.NoPos,x) -> 
 	A.CONTEXT (A.DontCarePos,x)
     | A.MINUS   (A.NoPos,inst,adj,x) -> 
@@ -274,7 +292,7 @@ let equal_metavarval valu valu' =
 
   | Ast_c.MetaPosVal (posa1,posa2), Ast_c.MetaPosVal (posb1,posb2) -> 
       Ast_cocci.equal_pos posa1 posb1 && Ast_cocci.equal_pos posa2 posb2
-        
+
   | Ast_c.MetaPosValList l1, Ast_c.MetaPosValList l2 ->
       List.exists
 	(function (fla,cea,posa1,posa2) ->
@@ -292,7 +310,10 @@ let equal_metavarval valu valu' =
     ), _
       -> raise Impossible
 
-let equal_inh_metavarval valu valu' =
+(* probably only one argument needs to be stripped, because inherited
+metavariables containing expressions are stripped in advance. But don't
+know which one is which... *)
+let equal_inh_metavarval valu valu'=
   match valu, valu' with
   | Ast_c.MetaIdVal a, Ast_c.MetaIdVal b -> a =$= b
   | Ast_c.MetaFuncVal a, Ast_c.MetaFuncVal b -> a =$= b
@@ -638,7 +659,11 @@ module type PARAM =
 	  (unit -> Common.filename * string * Ast_c.posl * Ast_c.posl) ->
       (unit -> tin -> 'x tout) -> (tin -> 'x tout)
 
-    val check_constraints :
+    val check_idconstraint :
+      ('a -> 'b -> bool) -> 'a -> 'b ->
+	(unit -> tin -> 'x tout) -> (tin -> 'x tout)
+
+    val check_constraints_ne :
       ('a, 'b) matcher -> 'a list -> 'b ->
 	(unit -> tin -> 'x tout) -> (tin -> 'x tout)
 
@@ -656,7 +681,7 @@ module type PARAM =
 (*****************************************************************************)
 
 module COCCI_VS_C =
-  functor (X : PARAM) -> 
+  functor (X : PARAM) ->
 struct
 
 type ('a, 'b) matcher = 'a -> 'b  -> X.tin -> ('a * 'b) X.tout
@@ -694,6 +719,45 @@ but I don't know how to declare polymorphism across functors *)
 let dots2metavar (_,info,mcodekind,pos) = (("","..."),info,mcodekind,pos)
 let metavar2dots (_,info,mcodekind,pos) = ("...",info,mcodekind,pos)
 
+let satisfies_iconstraint c id : bool =
+  match c with
+      A.IdNoConstraint -> true
+    | A.IdNegIdSet l -> not (List.mem id l)
+    | A.IdRegExp (_,recompiled) ->
+	if Str.string_match recompiled id 0 then
+	  true
+	else
+	  false
+    | A.IdNotRegExp (_,recompiled) ->
+	if Str.string_match recompiled id 0 then
+	  false
+	else
+	  true
+
+let satisfies_econstraint c exp : bool =
+    match Ast_c.unwrap_expr exp with
+	Ast_c.Ident (name) ->
+	  (
+	    match name with
+		Ast_c.RegularName     rname -> satisfies_iconstraint c (Ast_c.unwrap_st rname)
+	      | Ast_c.CppConcatenatedName _ ->
+		  pr2_once ("WARNING: Unable to apply a constraint on a CppConcatenatedName identifier !"); true
+	      | Ast_c.CppVariadicName     _ ->
+		  pr2_once ("WARNING: Unable to apply a constraint on a CppVariadicName identifier !"); true
+	      | Ast_c.CppIdentBuilder     _ ->
+		  pr2_once ("WARNING: Unable to apply a constraint on a CppIdentBuilder identifier !");	true
+	  )
+      | Ast_c.Constant cst ->
+	  (match cst with
+	     | Ast_c.String (str, _) -> satisfies_iconstraint c str
+	     | Ast_c.MultiString strlist ->
+		 pr2_once ("WARNING: Unable to apply a constraint on an multistring constant !"); true
+	     | Ast_c.Char  (char , _) -> satisfies_iconstraint c char
+	     | Ast_c.Int   (int  , _) -> satisfies_iconstraint c int
+	     | Ast_c.Float (float, _) -> satisfies_iconstraint c float
+	  )
+      | _ -> pr2_once ("WARNING: Unable to apply a constraint on an expression !"); true
+
 (*---------------------------------------------------------------------------*)
 (* toc: 
  *  - expression
@@ -733,7 +797,7 @@ let rec (expression: (A.expression, Ast_c.expression) matcher) =
                   let s = Ast_c.str_of_name nameidb in 
                   if s =~ "^[A-Z_][A-Z_0-9]*$" 
                   then begin
-		    pr2_once ("warning: I consider " ^ s ^ " as a constant");
+		    pr2_once ("warning: " ^ s ^ " treated as a constant");
 		    true
                   end
                   else false
@@ -759,27 +823,60 @@ let rec (expression: (A.expression, Ast_c.expression) matcher) =
             pr2_once ("Missing type information. Certainly a pb in " ^
                       "annotate_typer.ml");
             fail
-	      
-        | Some tas, Some tb -> 
-            tas +> List.fold_left (fun acc ta ->  
+
+        | Some tas, Some tb ->
+            tas +> List.fold_left (fun acc ta ->
               acc >|+|> compatible_type ta tb) fail
 	) >>=
 	(fun () () ->
-	  X.check_constraints expression constraints eb
-            (fun () ->
-	  let max_min _ =
-	    Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_expr expb) in
-	  X.envf keep inherited (ida, Ast_c.MetaExprVal expb, max_min)
-	    (fun () -> 
-	  X.distrf_e ida expb >>= (fun ida expb -> 
-	     return (
-	       A.MetaExpr (ida,constraints,keep,opttypa,form,inherited)+>
-	           A.rewrap ea,
-	       expb
-	     ))
-	  )))
+	   match constraints with
+	       Ast_cocci.NoConstraint ->
+		 let max_min _ =
+		   Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_expr expb) in
+		   X.envf keep inherited (ida, Ast_c.MetaExprVal expb, max_min)
+		     (fun () ->
+			X.distrf_e ida expb >>=
+			  (fun ida expb ->
+			     return (
+			       A.MetaExpr (ida,constraints,keep,opttypa,form,inherited)+>
+				 A.rewrap ea,
+			       expb
+			     ))
+		     )
+
+	     | Ast_cocci.NotIdCstrt cstrt ->
+		 X.check_idconstraint satisfies_econstraint cstrt eb
+		   (fun () ->
+		      let max_min _ =
+			Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_expr expb) in
+			X.envf keep inherited (ida, Ast_c.MetaExprVal expb, max_min)
+			  (fun () ->
+			     X.distrf_e ida expb >>=
+			       (fun ida expb ->
+				  return (
+				    A.MetaExpr (ida,constraints,keep,opttypa,form,inherited)+>
+				      A.rewrap ea,
+				    expb
+				  ))
+			  ))
+
+	     | Ast_cocci.NotExpCstrt cstrts ->
+		 X.check_constraints_ne expression cstrts eb
+		   (fun () ->
+		      let max_min _ =
+			Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_expr expb) in
+			X.envf keep inherited (ida, Ast_c.MetaExprVal expb, max_min)
+			  (fun () ->
+			     X.distrf_e ida expb >>=
+			       (fun ida expb ->
+				  return (
+				    A.MetaExpr (ida,constraints,keep,opttypa,form,inherited)+>
+				      A.rewrap ea,
+				    expb
+				  ))
+			  )))
       else fail
-	  
+
   (* old: 
    * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
    *   D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
@@ -1175,7 +1272,7 @@ and (ident_cpp: info_ident -> (A.ident, B.name) matcher) =
 	 fail
 
 and (ident: info_ident -> (A.ident, string * Ast_c.info) matcher) = 
- fun infoidb ida ((idb, iib) as ib) -> 
+ fun infoidb ida ((idb, iib)) -> (* (idb, iib) as ib *)
   X.all_bound (A.get_inherited ida) >&&>
   match A.unwrap ida with
   | A.Id sa -> 
@@ -1187,9 +1284,8 @@ and (ident: info_ident -> (A.ident, string * Ast_c.info) matcher) =
         ))
       else fail
 
-
   | A.MetaId(mida,constraints,keep,inherited) -> 
-      X.check_constraints (ident infoidb) constraints ib
+      X.check_idconstraint satisfies_iconstraint constraints idb
         (fun () ->
       let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
       (* use drop_pos for ids so that the pos is not added a second time in
@@ -1205,7 +1301,7 @@ and (ident: info_ident -> (A.ident, string * Ast_c.info) matcher) =
 
   | A.MetaFunc(mida,constraints,keep,inherited) -> 
       let is_function _ =
-	X.check_constraints (ident infoidb) constraints ib
+	X.check_idconstraint satisfies_iconstraint constraints idb
             (fun () ->
           let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
           X.envf keep inherited (A.drop_pos mida,Ast_c.MetaFuncVal idb,max_min)
@@ -1229,7 +1325,7 @@ and (ident: info_ident -> (A.ident, string * Ast_c.info) matcher) =
   | A.MetaLocalFunc(mida,constraints,keep,inherited) -> 
       (match infoidb with 
       | LocalFunction -> 
-	  X.check_constraints (ident infoidb) constraints ib
+	  X.check_idconstraint satisfies_iconstraint constraints idb
             (fun () ->
           let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
           X.envf keep inherited
@@ -2285,7 +2381,10 @@ and (struct_fields: (A.declaration list, B.field list) matcher) =
           if optwhen <> None then failwith "not handling when in argument";
 
           (* '...' can take more or less the beginnings of the arguments *)
-          let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
+          let startendxs =
+	    if eas = []
+	    then [(ys,[])] (* hack! the only one that can work *)
+	    else Common.zip (Common.inits ys) (Common.tails ys) in
           startendxs +> List.fold_left (fun acc (startxs, endxs) -> 
             acc >||> (
               
@@ -2841,7 +2940,7 @@ and (typeC: (A.typeC, Ast_c.typeC) matcher) =
 	 | _ -> fail in
 
        process_type
-	 >>= (fun ty ii_sub_sb -> 
+	 >>= (fun ty ii_sub_sb ->
 
             tokenf lba lbb >>= (fun lba lbb -> 
             tokenf rba rbb >>= (fun rba rbb -> 
@@ -3313,7 +3412,8 @@ let rec (rule_elem_node: (A.rule_elem, Control_flow_c.node) matcher) =
       let default = A.MetaRuleElem(mcode,keep,inherited), unwrap_node in
       (match unwrap_node with
       | F.CaseNode _
-      | F.TrueNode | F.FalseNode | F.AfterNode | F.FallThroughNode 
+      | F.TrueNode | F.FalseNode | F.AfterNode
+      | F.LoopFallThroughNode  | F.FallThroughNode 
       | F.InLoopNode -> 
           if X.mode =*= PatternMode 
           then return default 
@@ -3362,7 +3462,8 @@ let rec (rule_elem_node: (A.rule_elem, Control_flow_c.node) matcher) =
    * TODO: and F.Fake ?
    *)
   | _, F.EndStatement _ | _, F.CaseNode _
-  | _, F.TrueNode | _, F.FalseNode | _, F.AfterNode | _, F.FallThroughNode
+  | _, F.TrueNode | _, F.FalseNode | _, F.AfterNode
+  | _, F.FallThroughNode | _, F.LoopFallThroughNode
   | _, F.InLoopNode
     -> fail2()