Release coccinelle-0.2.4
[bpt/coccinelle.git] / parsing_cocci / free_vars.ml
index b5ff789..c5eab34 100644 (file)
@@ -1,5 +1,31 @@
 (*
 (*
- * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
+ * Copyright 2010, 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
+ * 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 2010, 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
  * This file is part of Coccinelle.
  *
  * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
  * This file is part of Coccinelle.
  *
@@ -86,13 +112,25 @@ let collect_refs include_constraints =
   let astfvident recursor k i =
     bind (k i)
       (match Ast.unwrap i with
   let astfvident recursor k i =
     bind (k i)
       (match Ast.unwrap i with
-       Ast.MetaId(name,_,_,_) | Ast.MetaFunc(name,_,_,_)
-      | Ast.MetaLocalFunc(name,_,_,_) -> [metaid name]
+       Ast.MetaId(name,idconstraint,_,_) | Ast.MetaFunc(name,idconstraint,_,_)
+      | Ast.MetaLocalFunc(name,idconstraint,_,_) ->
+         let metas =
+           if include_constraints
+           then
+             match idconstraint with
+               Ast.IdNegIdSet (_,metas) -> metas
+             | _ -> []
+           else [] in
+         bind (List.rev metas) [metaid name]
       | _ -> option_default) in
 
   let rec type_collect res = function
       TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty)
     | TC.Array(ty) -> type_collect res ty
       | _ -> option_default) in
 
   let rec type_collect res = function
       TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty)
     | TC.Array(ty) -> type_collect res ty
+    | TC.EnumName(TC.MV(tyname,_,_)) ->
+       bind [tyname] res
+    | TC.StructUnionName(_,TC.MV(tyname,_,_)) ->
+       bind [tyname] res
     | TC.MetaType(tyname,_,_) ->
        bind [tyname] res
     | TC.SignedT(_,Some ty) -> type_collect res ty
     | TC.MetaType(tyname,_,_) ->
        bind [tyname] res
     | TC.SignedT(_,Some ty) -> type_collect res ty
@@ -101,20 +139,37 @@ let collect_refs include_constraints =
   let astfvexpr recursor k e =
     bind (k e)
       (match Ast.unwrap e with
   let astfvexpr recursor k e =
     bind (k e)
       (match Ast.unwrap e with
-       Ast.MetaExpr(name,_,_,Some type_list,_,_) ->
+       Ast.MetaExpr(name,constraints,_,Some type_list,_,_) ->
          let types = List.fold_left type_collect option_default type_list in
          let types = List.fold_left type_collect option_default type_list in
-         bind [metaid name] types
-      | Ast.MetaErr(name,_,_,_) | Ast.MetaExpr(name,_,_,_,_,_) -> [metaid name]
-      | Ast.MetaExprList(name,None,_,_) -> [metaid name]
-      | Ast.MetaExprList(name,Some (lenname,_,_),_,_) ->
+         let extra =
+           if include_constraints
+           then
+             match constraints with
+               Ast.SubExpCstrt l -> l
+             | _ -> []
+           else [] in
+         bind extra (bind [metaid name] types)
+      | Ast.MetaErr(name,constraints,_,_)
+      | Ast.MetaExpr(name,constraints,_,_,_,_) ->
+         let extra =
+           if include_constraints
+           then
+             match constraints with
+               Ast.SubExpCstrt l -> l
+             | _ -> []
+           else [] in
+         bind extra [metaid name]
+      | Ast.MetaExprList(name,Ast.MetaListLen (lenname,_,_),_,_) ->
          [metaid name;metaid lenname]
          [metaid name;metaid lenname]
+      | Ast.MetaExprList(name,_,_,_) -> [metaid name]
       | Ast.DisjExpr(exps) -> bind_disj (List.map k exps)
       | _ -> option_default) in
 
   let astfvdecls recursor k d =
     bind (k d)
       (match Ast.unwrap d with
       | Ast.DisjExpr(exps) -> bind_disj (List.map k exps)
       | _ -> option_default) in
 
   let astfvdecls recursor k d =
     bind (k d)
       (match Ast.unwrap d with
-       Ast.DisjDecl(decls) -> bind_disj (List.map k decls)
+       Ast.MetaDecl(name,_,_) | Ast.MetaField(name,_,_) -> [metaid name]
+      | Ast.DisjDecl(decls) -> bind_disj (List.map k decls)
       | _ -> option_default) in
 
   let astfvfullType recursor k ty =
       | _ -> option_default) in
 
   let astfvfullType recursor k ty =
@@ -139,9 +194,9 @@ let collect_refs include_constraints =
     bind (k p)
       (match Ast.unwrap p with
        Ast.MetaParam(name,_,_) -> [metaid name]
     bind (k p)
       (match Ast.unwrap p with
        Ast.MetaParam(name,_,_) -> [metaid name]
-      | Ast.MetaParamList(name,None,_,_) -> [metaid name]
-      | Ast.MetaParamList(name,Some(lenname,_,_),_,_) ->
+      | Ast.MetaParamList(name,Ast.MetaListLen(lenname,_,_),_,_) ->
          [metaid name;metaid lenname]
          [metaid name;metaid lenname]
+      | Ast.MetaParamList(name,_,_,_) -> [metaid name]
       | _ -> option_default) in
 
   let astfvrule_elem recursor k re =
       | _ -> option_default) in
 
   let astfvrule_elem recursor k re =
@@ -170,7 +225,7 @@ let collect_refs include_constraints =
 
   V.combiner bind option_default
     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 
   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
     astfvident astfvexpr astfvfullType astfvtypeC astfvinit astfvparam
     astfvdecls astfvrule_elem astfvstatement donothing donothing donothing_a
 
     astfvident astfvexpr astfvfullType astfvtypeC astfvinit astfvparam
     astfvdecls astfvrule_elem astfvstatement donothing donothing donothing_a
 
@@ -206,6 +261,10 @@ let collect_saved =
   let rec type_collect res = function
       TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty)
     | TC.Array(ty) -> type_collect res ty
   let rec type_collect res = function
       TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty)
     | TC.Array(ty) -> type_collect res ty
+    | TC.EnumName(TC.MV(tyname,TC.Saved,_)) ->
+       bind [tyname] res
+    | TC.StructUnionName(_,TC.MV(tyname,TC.Saved,_)) ->
+       bind [tyname] res
     | TC.MetaType(tyname,TC.Saved,_) ->
        bind [tyname] res
     | TC.SignedT(_,Some ty) -> type_collect res ty
     | TC.MetaType(tyname,TC.Saved,_) ->
        bind [tyname] res
     | TC.SignedT(_,Some ty) -> type_collect res ty
@@ -221,13 +280,14 @@ let collect_saved =
       bind (k e)
        (match Ast.unwrap e with
          Ast.MetaErr(name,_,TC.Saved,_) | Ast.MetaExpr(name,_,TC.Saved,_,_,_)
       bind (k e)
        (match Ast.unwrap e with
          Ast.MetaErr(name,_,TC.Saved,_) | Ast.MetaExpr(name,_,TC.Saved,_,_,_)
-       | Ast.MetaExprList(name,None,TC.Saved,_) -> [metaid name]
-       | Ast.MetaExprList(name,Some (lenname,ls,_),ns,_) ->
+         -> [metaid name]
+       | Ast.MetaExprList(name,Ast.MetaListLen (lenname,ls,_),ns,_) ->
            let namesaved =
              match ns with TC.Saved -> [metaid name] | _ -> [] in
            let lensaved =
              match ls with TC.Saved -> [metaid lenname] | _ -> [] in
            lensaved @ namesaved
            let namesaved =
              match ns with TC.Saved -> [metaid name] | _ -> [] in
            let lensaved =
              match ls with TC.Saved -> [metaid lenname] | _ -> [] in
            lensaved @ namesaved
+       | Ast.MetaExprList(name,_,TC.Saved,_) -> [metaid name]
        | _ -> option_default) in
     bind tymetas vars in
 
        | _ -> option_default) in
     bind tymetas vars in
 
@@ -246,14 +306,21 @@ let collect_saved =
   let astfvparam recursor k p =
     bind (k p)
       (match Ast.unwrap p with
   let astfvparam recursor k p =
     bind (k p)
       (match Ast.unwrap p with
-       Ast.MetaParam(name,TC.Saved,_)
-      | Ast.MetaParamList(name,None,_,_) -> [metaid name]
-      | Ast.MetaParamList(name,Some (lenname,ls,_),ns,_) ->
+       Ast.MetaParam(name,TC.Saved,_) -> [metaid name]
+      | Ast.MetaParamList(name,Ast.MetaListLen (lenname,ls,_),ns,_) ->
          let namesaved =
            match ns with TC.Saved -> [metaid name] | _ -> [] in
          let lensaved =
            match ls with TC.Saved -> [metaid lenname] | _ -> [] in
          lensaved @ namesaved
          let namesaved =
            match ns with TC.Saved -> [metaid name] | _ -> [] in
          let lensaved =
            match ls with TC.Saved -> [metaid lenname] | _ -> [] in
          lensaved @ namesaved
+      | Ast.MetaParamList(name,_,_,_) -> [metaid name]
+      | _ -> option_default) in
+
+  let astfvdecls recursor k d =
+    bind (k d)
+      (match Ast.unwrap d with
+       Ast.MetaDecl(name,TC.Saved,_) | Ast.MetaField(name,TC.Saved,_) ->
+         [metaid name]
       | _ -> option_default) in
 
   let astfvrule_elem recursor k re =
       | _ -> option_default) in
 
   let astfvrule_elem recursor k re =
@@ -272,9 +339,9 @@ let collect_saved =
 
   V.combiner bind option_default
     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 
   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
     astfvident astfvexpr donothing astfvtypeC astfvinit astfvparam
     astfvident astfvexpr donothing astfvtypeC astfvinit astfvparam
-    donothing astfvrule_elem donothing donothing donothing donothing
+    astfvdecls astfvrule_elem donothing donothing donothing donothing
 
 (* ---------------------------------------------------------------- *)
 
 
 (* ---------------------------------------------------------------- *)
 
@@ -385,7 +452,7 @@ let collect_in_plus_term =
 
   V.combiner bind option_default
     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 
   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 astfvrule_elem astfvstatement donothing donothing donothing
 
     donothing donothing donothing donothing donothing donothing
     donothing astfvrule_elem astfvstatement donothing donothing donothing
 
@@ -456,6 +523,12 @@ let classify_variables metavar_decls minirules used_after =
     | TC.Pointer(ty) -> TC.Pointer(type_infos ty)
     | TC.FunctionPointer(ty) -> TC.FunctionPointer(type_infos ty)
     | TC.Array(ty) -> TC.Array(type_infos ty)
     | TC.Pointer(ty) -> TC.Pointer(type_infos ty)
     | TC.FunctionPointer(ty) -> TC.FunctionPointer(type_infos ty)
     | TC.Array(ty) -> TC.Array(type_infos ty)
+    | TC.EnumName(TC.MV(name,_,_)) ->
+       let (unitary,inherited) = classify (name,(),(),Ast.NoMetaPos) in
+       TC.EnumName(TC.MV(name,unitary,inherited))
+    | TC.StructUnionName(su,TC.MV(name,_,_)) ->
+       let (unitary,inherited) = classify (name,(),(),Ast.NoMetaPos) in
+       TC.StructUnionName(su,TC.MV(name,unitary,inherited))
     | TC.MetaType(name,_,_) ->
        let (unitary,inherited) = classify (name,(),(),Ast.NoMetaPos) in
        Type_cocci.MetaType(name,unitary,inherited)
     | TC.MetaType(name,_,_) ->
        let (unitary,inherited) = classify (name,(),(),Ast.NoMetaPos) in
        Type_cocci.MetaType(name,unitary,inherited)
@@ -472,19 +545,21 @@ let classify_variables metavar_decls minirules used_after =
        let (unitary,inherited) = classify name in
        let ty = get_option (List.map type_infos) ty in
        Ast.rewrap e (Ast.MetaExpr(name,constraints,unitary,ty,form,inherited))
        let (unitary,inherited) = classify name in
        let ty = get_option (List.map type_infos) ty in
        Ast.rewrap e (Ast.MetaExpr(name,constraints,unitary,ty,form,inherited))
-    | Ast.MetaExprList(name,None,_,_) ->
-       (* lenname should have the same properties of being unitary or
-          inherited as name *)
-       let (unitary,inherited) = classify name in
-       Ast.rewrap e (Ast.MetaExprList(name,None,unitary,inherited))
-    | Ast.MetaExprList(name,Some(lenname,_,_),_,_) ->
+    | Ast.MetaExprList(name,Ast.MetaListLen(lenname,_,_),_,_) ->
        (* lenname should have the same properties of being unitary or
           inherited as name *)
        let (unitary,inherited) = classify name in
        let (lenunitary,leninherited) = classify lenname in
        Ast.rewrap e
          (Ast.MetaExprList
        (* lenname should have the same properties of being unitary or
           inherited as name *)
        let (unitary,inherited) = classify name in
        let (lenunitary,leninherited) = classify lenname in
        Ast.rewrap e
          (Ast.MetaExprList
-            (name,Some(lenname,lenunitary,leninherited),unitary,inherited))
+            (name,
+             Ast.MetaListLen(lenname,lenunitary,leninherited),
+             unitary,inherited))
+    | Ast.MetaExprList(name,lenname,_,_) ->
+       (* lenname should have the same properties of being unitary or
+          inherited as name *)
+       let (unitary,inherited) = classify name in
+       Ast.rewrap e (Ast.MetaExprList(name,lenname,unitary,inherited))
     | _ -> e in
 
   let typeC r k e =
     | _ -> e in
 
   let typeC r k e =
@@ -509,15 +584,27 @@ let classify_variables metavar_decls minirules used_after =
       Ast.MetaParam(name,_,_) ->
        let (unitary,inherited) = classify name in
        Ast.rewrap e (Ast.MetaParam(name,unitary,inherited))
       Ast.MetaParam(name,_,_) ->
        let (unitary,inherited) = classify name in
        Ast.rewrap e (Ast.MetaParam(name,unitary,inherited))
-    | Ast.MetaParamList(name,None,_,_) ->
-       let (unitary,inherited) = classify name in
-       Ast.rewrap e (Ast.MetaParamList(name,None,unitary,inherited))
-    | Ast.MetaParamList(name,Some (lenname,_,_),_,_) ->
+    | Ast.MetaParamList(name,Ast.MetaListLen (lenname,_,_),_,_) ->
        let (unitary,inherited) = classify name in
        let (lenunitary,leninherited) = classify lenname in
        Ast.rewrap e
          (Ast.MetaParamList
        let (unitary,inherited) = classify name in
        let (lenunitary,leninherited) = classify lenname in
        Ast.rewrap e
          (Ast.MetaParamList
-            (name,Some (lenname,lenunitary,leninherited),unitary,inherited))
+            (name,Ast.MetaListLen(lenname,lenunitary,leninherited),
+             unitary,inherited))
+    | Ast.MetaParamList(name,lenname,_,_) ->
+       let (unitary,inherited) = classify name in
+       Ast.rewrap e (Ast.MetaParamList(name,lenname,unitary,inherited))
+    | _ -> e in
+
+  let decl r k e =
+    let e = k e in
+    match Ast.unwrap e with
+      Ast.MetaDecl(name,_,_) ->
+       let (unitary,inherited) = classify name in
+       Ast.rewrap e (Ast.MetaDecl(name,unitary,inherited))
+    | Ast.MetaField(name,_,_) ->
+       let (unitary,inherited) = classify name in
+       Ast.rewrap e (Ast.MetaField(name,unitary,inherited))
     | _ -> e in
 
   let rule_elem r k e =
     | _ -> e in
 
   let rule_elem r k e =
@@ -533,8 +620,8 @@ let classify_variables metavar_decls minirules used_after =
 
   let fn = V.rebuilder
       mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 
   let fn = V.rebuilder
       mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
-      donothing donothing donothing donothing
-      ident expression donothing typeC init param donothing rule_elem
+      donothing donothing donothing donothing donothing
+      ident expression donothing typeC init param decl rule_elem
       donothing donothing donothing donothing in
 
   List.map fn.V.rebuilder_top_level minirules
       donothing donothing donothing donothing in
 
   List.map fn.V.rebuilder_top_level minirules
@@ -665,7 +752,7 @@ let astfvs metavars bound =
 
   V.rebuilder
     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 
   V.rebuilder
     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
-    donothing donothing astfvstatement_dots donothing
+    donothing donothing astfvstatement_dots donothing donothing
     donothing donothing donothing donothing donothing donothing donothing
     astfvrule_elem astfvstatement astfvcase_line astfvtoplevel donothing
 
     donothing donothing donothing donothing donothing donothing donothing
     astfvrule_elem astfvstatement astfvcase_line astfvtoplevel donothing
 
@@ -687,8 +774,11 @@ let collect_astfvs rules =
       [] -> []
     | (metavars, rule)::rules ->
         match rule with
       [] -> []
     | (metavars, rule)::rules ->
         match rule with
-          Ast.ScriptRule (_,_,_,_)
-       | Ast.InitialScriptRule (_,_,_) | Ast.FinalScriptRule (_,_,_) ->
+          Ast.ScriptRule (_,_,_,_,script_vars,_) ->
+           (* why are metavars in rule, but outside for cocci rule??? *)
+            let bound = script_vars @ bound in
+           rule::(loop bound rules)
+       | Ast.InitialScriptRule (_,_,_,_) | Ast.FinalScriptRule (_,_,_,_) ->
            (* bound stays as is because script rules have no names, so no
               inheritance is possible *)
            rule::(loop bound rules)
            (* bound stays as is because script rules have no names, so no
               inheritance is possible *)
            rule::(loop bound rules)
@@ -724,7 +814,7 @@ let get_neg_pos_list (_,rule) used_after_list =
   let v =
     V.combiner bind option_default
     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
   let v =
     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 donothing donothing donothing donothing donothing in
   match rule with
     donothing donothing donothing donothing donothing donothing
     donothing donothing donothing donothing donothing donothing in
   match rule with
@@ -759,15 +849,19 @@ let collect_top_level_used_after metavar_rule_list =
     List.fold_right
       (function (metavar_list,r) ->
        function (used_after,used_after_lists) ->
     List.fold_right
       (function (metavar_list,r) ->
        function (used_after,used_after_lists) ->
-         let locally_defined = List.map Ast.get_meta_name metavar_list in
+         let locally_defined =
+            match r with
+              Ast.ScriptRule (_,_,_,_,free_vars,_) -> free_vars
+           | _ -> List.map Ast.get_meta_name metavar_list in
          let continue_propagation =
            List.filter (function x -> not(List.mem x locally_defined))
              used_after in
          let free_vars =
             match r with
          let continue_propagation =
            List.filter (function x -> not(List.mem x locally_defined))
              used_after in
          let free_vars =
             match r with
-              Ast.ScriptRule (_,_,mv,_) ->
-                drop_virt(List.map (function (_,(r,v)) -> (r,v)) mv)
-            | Ast.InitialScriptRule (_,_,_) | Ast.FinalScriptRule (_,_,_) -> []
+              Ast.ScriptRule (_,_,_,mv,_,_) ->
+                drop_virt(List.map (function (_,(r,v),_) -> (r,v)) mv)
+            | Ast.InitialScriptRule (_,_,_,_)
+           | Ast.FinalScriptRule (_,_,_,_) -> []
             | Ast.CocciRule (_,_,rule,_,_) ->
                drop_virt
                  (Common.union_set (nub (collect_all_rule_refs rule))
             | Ast.CocciRule (_,_,rule,_,_) ->
                drop_virt
                  (Common.union_set (nub (collect_all_rule_refs rule))
@@ -874,9 +968,9 @@ let collect_used_after metavar_rule_list =
     (function (metavars,r) ->
       function used_after ->
         match r with
     (function (metavars,r) ->
       function used_after ->
         match r with
-          Ast.ScriptRule (_,_,_,_)
-       | Ast.InitialScriptRule (_,_,_) | Ast.FinalScriptRule (_,_,_) ->
-           ([], [used_after], [], [])
+          Ast.ScriptRule (_,_,_,_,_,_) (* no minirules, so nothing to do? *)
+       | Ast.InitialScriptRule (_,_,_,_) | Ast.FinalScriptRule (_,_,_,_) ->
+           ([], [used_after], [[]], [])
         | Ast.CocciRule (name, rule_info, minirules, _,_) ->
           collect_local_used_after metavars minirules used_after
     )
         | Ast.CocciRule (name, rule_info, minirules, _,_) ->
           collect_local_used_after metavars minirules used_after
     )
@@ -900,7 +994,7 @@ let free_vars rules =
     List.map
       (function (mv, r) ->
          match r with
     List.map
       (function (mv, r) ->
          match r with
-           Ast.ScriptRule _
+           Ast.ScriptRule _ (* doesn't declare position variables *)
         | Ast.InitialScriptRule _ | Ast.FinalScriptRule _ -> []
          | Ast.CocciRule (_,_,rule,_,_) ->
            let positions =
         | Ast.InitialScriptRule _ | Ast.FinalScriptRule _ -> []
          | Ast.CocciRule (_,_,rule,_,_) ->
            let positions =