Patchwork [Ada] Check ambiguity with prefixed views of tagged primitives

login
register
mail settings
Submitter Arnaud Charlet
Date Aug. 31, 2011, 8:59 a.m.
Message ID <20110831085941.GA3378@adacore.com>
Download mbox | patch
Permalink /patch/112471/
State New
Headers show

Comments

Arnaud Charlet - Aug. 31, 2011, 8:59 a.m.
When the frontend resolves a dispatching call through the object
operation notation it must also check if there is a class-wide
subprogram covering the target primitive. This check was missing
in the frontend. After this patch the following test must
compile with errors:

package Pkg1 is
   type Iface is interface;
   procedure Yet_Another_Op (Obj : in out Iface'Class);
end;

with Pkg1;
package Pkg2 is
   type Typ is new Pkg1.Iface with null record;

   procedure Yet_Another_Op (Obj : in out Typ);
end;

with Pkg1; use Pkg1;
with Pkg2; use Pkg2;
procedure Main is
   T : Pkg2.Typ;
begin
   T.Yet_Another_Op;  -- Ambiguous? (Yes)
end;

Command: gcc -c -gnat05 main.adb
Output:
main.adb:7:05: ambiguous expression (cannot resolve "Yet_Another_Op")
main.adb:7:05: possible interpretation at pkg2.ads:6
main.adb:7:05: possible interpretation at pkg1.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): When a dispatching primitive is
	found check if there is a class-wide subprogram covering the primitive.

Patch

Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb	(revision 178360)
+++ sem_ch4.adb	(working copy)
@@ -6638,7 +6638,7 @@ 
          Call    : Node_Id;
          Subp    : Entity_Id) return Entity_Id;
       --  If the subprogram is a valid interpretation, record it, and add
-      --  to the list of interpretations of Subprog.
+      --  to the list of interpretations of Subprog. Otherwise return Empty.
 
       procedure Complete_Object_Operation
         (Call_Node       : Node_Id;
@@ -7104,6 +7104,14 @@ 
                     and then N = Name (Parent (N))
                   then
                      goto Next_Hom;
+
+                  --  If the context is a function call, ignore procedures
+                  --  in the name of the call.
+
+                  elsif Ekind (Hom) = E_Procedure
+                    and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
+                  then
+                     goto Next_Hom;
                   end if;
 
                   Set_Etype (Call_Node, Any_Type);
@@ -7271,16 +7279,39 @@ 
             return;
          end if;
 
-         if Try_Primitive_Operation
-              (Call_Node       => New_Call_Node,
-               Node_To_Replace => Node_To_Replace)
-           or else
-             Try_Class_Wide_Operation
-               (Call_Node       => New_Call_Node,
-                Node_To_Replace => Node_To_Replace)
-         then
-            null;
-         end if;
+         declare
+            Dup_Call_Node : constant Node_Id := New_Copy (New_Call_Node);
+            CW_Result     : Boolean;
+            Prim_Result   : Boolean;
+            pragma Unreferenced (CW_Result);
+
+         begin
+            Prim_Result :=
+              Try_Primitive_Operation
+                (Call_Node       => New_Call_Node,
+                 Node_To_Replace => Node_To_Replace);
+
+            --  Check if there is a class-wide subprogram covering the
+            --  primitive. This check must be done even if a candidate
+            --  was found in order to report ambiguous calls.
+
+            if not (Prim_Result) then
+               CW_Result :=
+                 Try_Class_Wide_Operation
+                   (Call_Node       => New_Call_Node,
+                    Node_To_Replace => Node_To_Replace);
+
+            --  If we found a primitive we search for class-wide subprograms
+            --  using a duplicate of the call node (done to avoid missing its
+            --  decoration if there is no ambiguity).
+
+            else
+               CW_Result :=
+                 Try_Class_Wide_Operation
+                   (Call_Node       => Dup_Call_Node,
+                    Node_To_Replace => Node_To_Replace);
+            end if;
+         end;
       end Try_One_Prefix_Interpretation;
 
       -----------------------------