Patchwork [Ada] Ambiguities with prefixed views of synchronized primitives

login
register
mail settings
Submitter Arnaud Charlet
Date Aug. 31, 2011, 9:07 a.m.
Message ID <20110831090739.GA6495@adacore.com>
Download mbox | patch
Permalink /patch/112476/
State New
Headers show

Comments

Arnaud Charlet - Aug. 31, 2011, 9:07 a.m.
A selected_component whose selector_name denotes an entity of a concurrent
tagged type may be ambiguous because the target entity may be covered by
a class-wide subprogram. This patch adds this missing test to the frontend
to report the ambiguity. The following test must now compile with errors:

package Synch_Pkg2 is
   type Synch_Interface is synchronized interface;
   procedure Yet_Another_Op (Obj : in out Synch_Interface'Class);
end Synch_Pkg2;

with Synch_Pkg2;
package Task_Pkg2 is
   task type Task_Type is new Synch_Pkg2.Synch_Interface with
      entry Yet_Another_Op;
   end Task_Type;
end Task_Pkg2;

with Synch_Pkg2; use Synch_Pkg2;
with Task_Pkg2;
procedure ai05_0090 is
   T : Task_Pkg2.Task_Type;
begin
   T.Yet_Another_Op;  -- (3) Ambiguous? (Yes.)
end;

Command: gcc -c -gnat05 ai05_0090.adb
Output:
ai05_0090.adb:7:05: ambiguous call to "Yet_Another_Op"
ai05_0090.adb:7:05: possible interpretation at task_pkg2.ads:5
ai05_0090:7:05: possible interpretation at synch_pkg2.ads:3

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-31  Javier Miranda  <miranda@adacore.com>

	* sem_ch4.adb (Try_Object_Operation): Addition of one formal to search
	only for class-wide subprograms conflicting with entities of concurrent
	tagged types.

Patch

Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb	(revision 178361)
+++ sem_ch4.adb	(working copy)
@@ -276,11 +276,16 @@ 
    --  subprogram, and the call F (X) interpreted as F.all (X). In this case
    --  the call may be overloaded with both interpretations.
 
-   function Try_Object_Operation (N : Node_Id) return Boolean;
+   function Try_Object_Operation
+     (N : Node_Id; CW_Test_Only : Boolean := False) return Boolean;
    --  Ada 2005 (AI-252): Support the object.operation notation. If node N
    --  is a call in this notation, it is transformed into a normal subprogram
    --  call where the prefix is a parameter, and True is returned. If node
-   --  N is not of this form, it is unchanged, and False is returned.
+   --  N is not of this form, it is unchanged, and False is returned. if
+   --  CW_Test_Only is true then N is an N_Selected_Component node which
+   --  is part of a call to an entry or procedure of a tagged concurrent
+   --  type and this routine is invoked to search for class-wide subprograms
+   --  conflicting with the target entity.
 
    procedure wpo (T : Entity_Id);
    pragma Warnings (Off, wpo);
@@ -4165,6 +4170,25 @@ 
             then
                return;
             end if;
+
+            --  Ada 2012 (AI05-0090-1): If we found a candidate of a call to an
+            --  entry or procedure of a tagged concurrent type we must check
+            --  if there are class-wide subprograms covering the primitive. If
+            --  true then Try_Object_Operation reports the error.
+
+            if Has_Candidate
+              and then Is_Concurrent_Type (Prefix_Type)
+              and then Nkind (Parent (N)) = N_Procedure_Call_Statement
+
+               --  Duplicate the call. This is required to avoid problems with
+               --  the tree transformations performed by Try_Object_Operation.
+
+              and then Try_Object_Operation
+                         (N => Sinfo.Name (New_Copy_Tree (Parent (N))),
+                          CW_Test_Only => True)
+            then
+               return;
+            end if;
          end if;
 
          if Etype (N) = Any_Type and then Is_Protected_Type (Prefix_Type) then
@@ -6609,7 +6633,9 @@ 
    -- Try_Object_Operation --
    --------------------------
 
-   function Try_Object_Operation (N : Node_Id) return Boolean is
+   function Try_Object_Operation
+     (N : Node_Id; CW_Test_Only : Boolean := False) return Boolean
+   is
       K              : constant Node_Kind  := Nkind (Parent (N));
       Is_Subprg_Call : constant Boolean    := Nkind_In
                                                (K, N_Procedure_Call_Statement,
@@ -6898,14 +6924,17 @@ 
       ----------------------
 
       procedure Report_Ambiguity (Op : Entity_Id) is
-         Access_Formal : constant Boolean :=
-                           Is_Access_Type (Etype (First_Formal (Op)));
          Access_Actual : constant Boolean :=
                            Is_Access_Type (Etype (Prefix (N)));
+         Access_Formal : Boolean := False;
 
       begin
          Error_Msg_Sloc := Sloc (Op);
 
+         if Present (First_Formal (Op)) then
+            Access_Formal := Is_Access_Type (Etype (First_Formal (Op)));
+         end if;
+
          if Access_Formal and then not Access_Actual then
             if Nkind (Parent (Op)) = N_Full_Type_Declaration then
                Error_Msg_N
@@ -7205,6 +7234,13 @@ 
       --  Start of processing for Try_Class_Wide_Operation
 
       begin
+         --  If we are searching only for conflicting class-wide subprograms
+         --  then initialize directly Matching_Op with the target entity.
+
+         if CW_Test_Only then
+            Matching_Op := Entity (Selector_Name (N));
+         end if;
+
          --  Loop through ancestor types (including interfaces), traversing
          --  the homonym chain of the subprogram, trying out those homonyms
          --  whose first formal has the class-wide type of the ancestor, or
@@ -7286,10 +7322,12 @@ 
             pragma Unreferenced (CW_Result);
 
          begin
-            Prim_Result :=
-              Try_Primitive_Operation
-                (Call_Node       => New_Call_Node,
-                 Node_To_Replace => Node_To_Replace);
+            if not CW_Test_Only then
+               Prim_Result :=
+                  Try_Primitive_Operation
+                   (Call_Node       => New_Call_Node,
+                    Node_To_Replace => Node_To_Replace);
+            end if;
 
             --  Check if there is a class-wide subprogram covering the
             --  primitive. This check must be done even if a candidate
@@ -7663,11 +7701,19 @@ 
       end if;
 
       if Etype (New_Call_Node) /= Any_Type then
-         Complete_Object_Operation
-           (Call_Node       => New_Call_Node,
-            Node_To_Replace => Node_To_Replace);
-         return True;
 
+         --  No need to complete the tree transformations if we are only
+         --  searching for conflicting class-wide subprograms
+
+         if CW_Test_Only then
+            return False;
+         else
+            Complete_Object_Operation
+              (Call_Node       => New_Call_Node,
+               Node_To_Replace => Node_To_Replace);
+            return True;
+         end if;
+
       elsif Present (Candidate) then
 
          --  The argument list is not type correct. Re-analyze with error