[Ada] Spurious error on prefixed call in an instantiation

This patch fixes a spurious error on a prefixed call in an instance, when the
generic parameters include an interface type and an abstract operation of that
type, and the actuals in the instance include an interface type and a
corresponding abstract operation of it, with a different name than the
corresponding generic subprogram parameter. The patch also fixes a similar
error involving class-wide operations and generic private types.

2018-07-17  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_ch4.adb (Try_Object_Operation): Handle properly a prefixed call
	in an instance, when the generic parameters include an interface type
	and a abstract operation of that type, and the actuals in the instance
	include an interface type and a corresponding abstract operation of it,
	with a different name than the corresponding generic subprogram
	parameter.

gcc/testsuite/

	* gnat.dg/generic_call_cw.adb, gnat.dg/generic_call_iface.adb: New
	testcase.

From-SVN: r262803

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 21b7bb897fcda70fecd64d768be0b23a02f2ce14..2375e80ae419d1438c5bc3ab83b23c1b64adf527 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2018-07-17  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_ch4.adb (Try_Object_Operation): Handle properly a prefixed call
+       in an instance, when the generic parameters include an interface type
+       and a abstract operation of that type, and the actuals in the instance
+       include an interface type and a corresponding abstract operation of it,
+       with a different name than the corresponding generic subprogram
+       parameter.
+
 2018-07-17  Arnaud Charlet  <charlet@adacore.com>
 
        * sem_eval.adb (Rewrite_In_Raise_CE): Keep the original reason in more

diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index def317d916c75ebf5abf904025387c5e98beaa6e..597ec1ed939d8fcd15b03eea2ca45fa3027651f6 100644 (file)
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -8928,11 +8928,38 @@ package body Sem_Ch4 is
            (Anc_Type : Entity_Id;
             Error    : out Boolean)
          is
+            Candidate   : Entity_Id;
+            --  If homonym is a renaming, examine the renamed program
+
             Cls_Type    : Entity_Id;
             Hom         : Entity_Id;
             Hom_Ref     : Node_Id;
             Success     : Boolean;
 
+            function First_Formal_Match
+              (Typ : Entity_Id) return Boolean;
+            --  Predicate to verify that the first formal of a class-wide
+            --  candidate matches the type of the prefix.
+
+            ------------------------
+            -- First_Formal_Match --
+            ------------------------
+
+            function First_Formal_Match
+             (Typ : Entity_Id) return Boolean
+            is
+               Ctrl : constant Entity_Id := First_Formal (Candidate);
+            begin
+               return Present (Ctrl)
+                 and then
+                   (Base_Type (Etype (Ctrl)) = Typ
+                     or else
+                       (Ekind (Etype (Ctrl)) = E_Anonymous_Access_Type
+                         and then
+                           Base_Type
+                            (Designated_Type (Etype (Ctrl))) = Typ));
+            end First_Formal_Match;
+
          begin
             Error := False;
 
@@ -8948,25 +8975,23 @@ package body Sem_Ch4 is
 
             while Present (Hom) loop
                if Ekind_In (Hom, E_Procedure, E_Function)
-                 and then (not Is_Hidden (Hom) or else In_Instance)
-                 and then Scope (Hom) = Scope (Base_Type (Anc_Type))
-                 and then Present (First_Formal (Hom))
-                 and then
-                   (Base_Type (Etype (First_Formal (Hom))) = Cls_Type
-                     or else
-                       (Is_Access_Type (Etype (First_Formal (Hom)))
-                         and then
-                           Ekind (Etype (First_Formal (Hom))) =
-                             E_Anonymous_Access_Type
-                         and then
-                           Base_Type
-                             (Designated_Type (Etype (First_Formal (Hom)))) =
-                                                                   Cls_Type))
+                 and then Present (Renamed_Entity (Hom))
+                 and then Is_Generic_Actual_Subprogram (Hom)
+               then
+                  Candidate := Renamed_Entity (Hom);
+               else
+                  Candidate := Hom;
+               end if;
+
+               if Ekind_In (Candidate, E_Procedure, E_Function)
+                 and then (not Is_Hidden (Candidate) or else In_Instance)
+                 and then Scope (Candidate) = Scope (Base_Type (Anc_Type))
+                 and then First_Formal_Match (Cls_Type)
                then
                   --  If the context is a procedure call, ignore functions
                   --  in the name of the call.
 
-                  if Ekind (Hom) = E_Function
+                  if Ekind (Candidate) = E_Function
                     and then Nkind (Parent (N)) = N_Procedure_Call_Statement
                     and then N = Name (Parent (N))
                   then
@@ -8975,7 +9000,7 @@ package body Sem_Ch4 is
                   --  If the context is a function call, ignore procedures
                   --  in the name of the call.
 
-                  elsif Ekind (Hom) = E_Procedure
+                  elsif Ekind (Candidate) = E_Procedure
                     and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
                   then
                      goto Next_Hom;
@@ -8986,7 +9011,7 @@ package body Sem_Ch4 is
                   Success := False;
 
                   if No (Matching_Op) then
-                     Hom_Ref := New_Occurrence_Of (Hom, Sloc (Subprog));
+                     Hom_Ref := New_Occurrence_Of (Candidate, Sloc (Subprog));
                      Set_Etype (Call_Node, Any_Type);
                      Set_Parent (Call_Node, Parent (Node_To_Replace));
 
@@ -8994,18 +9019,18 @@ package body Sem_Ch4 is
 
                      Analyze_One_Call
                        (N          => Call_Node,
-                        Nam        => Hom,
+                        Nam        => Candidate,
                         Report     => Report_Error,
                         Success    => Success,
                         Skip_First => True);
 
                      Matching_Op :=
-                       Valid_Candidate (Success, Call_Node, Hom);
+                       Valid_Candidate (Success, Call_Node, Candidate);
 
                   else
                      Analyze_One_Call
                        (N          => Call_Node,
-                        Nam        => Hom,
+                        Nam        => Candidate,
                         Report     => Report_Error,
                         Success    => Success,
                         Skip_First => True);
@@ -9014,9 +9039,10 @@ package body Sem_Ch4 is
                      --  traversals, before and after looking at interfaces.
                      --  Check for this case before reporting a real ambiguity.
 
-                     if Present (Valid_Candidate (Success, Call_Node, Hom))
+                     if Present
+                        (Valid_Candidate (Success, Call_Node, Candidate))
                        and then Nkind (Call_Node) /= N_Function_Call
-                       and then Hom /= Matching_Op
+                       and then Candidate /= Matching_Op
                      then
                         Error_Msg_NE ("ambiguous call to&", N, Hom);
                         Report_Ambiguity (Matching_Op);
@@ -9478,6 +9504,23 @@ package body Sem_Ch4 is
                  Present (Original_Protected_Subprogram (Prim_Op))
                    and then Chars (Original_Protected_Subprogram (Prim_Op)) =
                               Chars (Subprog);
+
+            --  In an instance, the selector name may be a generic actual that
+            --  renames a primitive operation of the type of the prefix.
+
+            elsif In_Instance and then Present (Current_Entity (Subprog)) then
+               declare
+                  Subp : constant Entity_Id := Current_Entity (Subprog);
+               begin
+                  if Present (Subp)
+                    and then Is_Subprogram (Subp)
+                    and then Present (Renamed_Entity (Subp))
+                    and then Is_Generic_Actual_Subprogram (Subp)
+                    and then Chars (Renamed_Entity (Subp)) = Chars (Prim_Op)
+                  then
+                     return True;
+                  end if;
+               end;
             end if;
 
             return False;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e24b35d5d190d5864f2f90b9d37450eb046ec305..652d164a85cdf889db540cee00ba257b11e3b3f1 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2018-07-17  Ed Schonberg  <schonberg@adacore.com>
+
+       * gnat.dg/generic_call_cw.adb, gnat.dg/generic_call_iface.adb: New
+       testcase.
+
 2018-07-17  Eric Botcazou  <ebotcazou@adacore.com>
 
        * gnat.dg/sso10.adb, gnat.dg/sso10_pkg.ads: New testcase.

diff --git a/gcc/testsuite/gnat.dg/generic_call_cw.adb b/gcc/testsuite/gnat.dg/generic_call_cw.adb
new file mode 100644 (file)
index 0000000..5f0a514
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/generic_call_cw.adb
@@ -0,0 +1,33 @@
+--  { dg-do compile }
+
+procedure Generic_Call_CW is
+
+   generic
+      type Subscriber_Type is tagged private;
+      with procedure On_Changed (Subscriber : in out Subscriber_Type'Class);
+   package My_Generic is
+      type Subscriber_Ptr is access all Subscriber_Type'Class;
+      procedure Update;
+      Subscriber : Subscriber_Ptr := null;
+   end;
+
+   package body My_Generic is
+      procedure Update is
+      begin
+         if Subscriber /= null then
+            Subscriber.On_Changed;
+         end if;
+      end;
+   end;
+
+   package User is
+      type Integer_Subscriber is tagged null record;
+      procedure On_Changed_Int (I : in out Integer_Subscriber'Class) is null;
+
+      package P is new My_Generic
+        (Subscriber_Type => Integer_Subscriber,
+         On_Changed      => On_Changed_Int);
+   end;
+begin
+   null;
+end;

diff --git a/gcc/testsuite/gnat.dg/generic_call_iface.adb b/gcc/testsuite/gnat.dg/generic_call_iface.adb
new file mode 100644 (file)
index 0000000..0e173ea
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/generic_call_iface.adb
@@ -0,0 +1,34 @@
+--  { dg-do compile }
+
+procedure Generic_Call_Iface is
+
+   generic
+     type Subscriber_Type is interface;
+     with procedure On_Changed (Subscriber : in out Subscriber_Type)
+       is abstract;
+   package My_Generic is
+      type Subscriber_Ptr is access all Subscriber_Type'Class;
+      procedure Update;
+      Subscriber : Subscriber_Ptr := null;
+   end;
+
+   package body My_Generic is
+      procedure Update is
+      begin
+         if Subscriber /= null then
+            Subscriber.On_Changed;
+         end if;
+      end;
+   end;
+
+   package User is
+      type Integer_Subscriber is interface;
+      procedure On_Changed_Int (I : in out Integer_Subscriber) is abstract;
+
+      package P is new My_Generic
+        (Subscriber_Type => Integer_Subscriber,
+         On_Changed      => On_Changed_Int);
+   end;
+begin
+   null;
+end;