Release coccinelle-0.2.0rc1

[bpt/coccinelle.git] / engine / ctlcocci_integration.ml

diff --git a/engine/ctlcocci_integration.ml b/engine/ctlcocci_integration.ml
index 5c6c12d..7b1af47 100644 (file)
--- a/engine/ctlcocci_integration.ml
+++ b/engine/ctlcocci_integration.ml
@@ -1,25 +1,3 @@
-(*
- * 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.
- *)
-
-
 open Common
 
 open Ograph_extended
@@ -101,18 +79,19 @@ let (labels_for_ctl: string list (* dropped isos *) ->
       | Lib_engine.Paren _, _ -> []
       | Lib_engine.Label s, _ -> 
           let labels = F.extract_labels node in
-          [(nodei, (p,[(s --> (Lib_engine.LabelVal labels))]))]
+          [(nodei,
+           (p,[(s --> (Lib_engine.LabelVal (Lib_engine.Absolute labels)))]))]
       | Lib_engine.BCLabel s, _ -> 
          (match F.extract_bclabels node with
            [] -> [] (* null for all nodes that are not break or continue *)
          | labels ->
-              [(nodei, (p,[(s --> (Lib_engine.LabelVal labels))]))])
+              [(nodei,
+               (p,[(s -->
+                 (Lib_engine.LabelVal (Lib_engine.Absolute labels)))]))])
       | Lib_engine.PrefixLabel s, _ -> 
           let labels = F.extract_labels node in
-          let prefixes = Common.inits labels +> Common.tail in
-          prefixes +> List.map (fun prefixlabels -> 
-            (nodei, (p,[(s --> (Lib_engine.LabelVal prefixlabels))]))
-          )
+          [(nodei,
+           (p,[(s --> (Lib_engine.LabelVal (Lib_engine.Prefix labels)))]))]
 
       | Lib_engine.Match (re), _unwrapnode -> 
           let substs = 
@@ -291,6 +270,36 @@ module PRED =
       Pretty_print_engine.pp_predicate x
   end
 
+(* prefix has to be nonempty *)
+let prefix l1 l2 =
+  let rec loop = function
+      ([],_) -> true
+    | (_,[]) -> false
+    | (x::xs,y::ys) when x = y -> loop (xs,ys)
+    | _ -> false in
+  loop(l1,l2)
+
+let compatible_labels l1 l2 =
+  match (l1,l2) with
+    (Lib_engine.Absolute(l1),Lib_engine.Absolute(l2)) -> l1 =*= l2
+  | (Lib_engine.Absolute(l1),Lib_engine.Prefix(l2))   -> prefix l1 l2
+  | (Lib_engine.Prefix(l1),Lib_engine.Absolute(l2))   -> prefix l2 l1
+  | (Lib_engine.Prefix(l1),Lib_engine.Prefix(l2))     ->
+      not (l1 = []) && not (l2 = []) &&
+      List.hd l1 =*= List.hd l2 (* labels are never empty *)
+
+let merge_labels l1 l2 =
+  match (l1,l2) with
+    (* known to be compatible *)
+    (Lib_engine.Absolute(_),Lib_engine.Absolute(_)) -> l1
+  | (Lib_engine.Absolute(_),Lib_engine.Prefix(_))   -> l1
+  | (Lib_engine.Prefix(_),Lib_engine.Absolute(_))   -> l2
+  | (Lib_engine.Prefix(l1),Lib_engine.Prefix(l2))   ->
+      let rec max_prefix = function
+         (x::xs,y::ys) when x = y -> x::(max_prefix(xs,ys))
+       | (l1,l2) -> [] in
+      Lib_engine.Prefix(max_prefix(l1,l2))
+
 module ENV =
   struct
     type value = Lib_engine.metavar_binding_kind2
@@ -306,6 +315,8 @@ module ENV =
       |        (Lib_engine.NormalMetaVal(Ast_c.MetaTypeVal a),
         Lib_engine.NormalMetaVal(Ast_c.MetaTypeVal b)) ->
           C_vs_c.eq_type a b
+      |        (Lib_engine.LabelVal(l1),Lib_engine.LabelVal(l2)) ->
+         compatible_labels l1 l2
       |        _ -> v =*= v'
     let merge_val v v' = (* values guaranteed to be compatible *)
       (* v *)
@@ -321,6 +332,8 @@ module ENV =
       |        (Lib_engine.NormalMetaVal(Ast_c.MetaTypeVal a),
         Lib_engine.NormalMetaVal(Ast_c.MetaTypeVal b)) ->
           Lib_engine.NormalMetaVal (Ast_c.MetaTypeVal (C_vs_c.merge_type a b))
+      |        (Lib_engine.LabelVal(l1),Lib_engine.LabelVal(l2)) ->
+         Lib_engine.LabelVal(merge_labels l1 l2)
 
       |        _ -> v
     let print_mvar (_,s) = Format.print_string s