[Ada] Wrong dispatching call in type with aspect Implicit_Dereference

[Pierre-Marie de Rodat <derodat at adacore dot com>]

When a record type with an an access to class-wide type discriminant
has aspect Implicit_Dereference, and the discriminant is used as the
controlling argument of a dispatching call, the compiler may generate
wrong code to dispatch the call.

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

2019-08-13  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* sem_res.adb (Resolve_Selected_Component): When the type of the
	component is an access to a class-wide type and the type of the
	context is an access to a tagged type the relevant type is that
	of the component (since in such case we may need to generate
	implicit type conversions or dispatching calls).

gcc/testsuite/

	* gnat.dg/tagged3.adb, gnat.dg/tagged3_pkg.adb,
	gnat.dg/tagged3_pkg.ads: New testcase.

--- gcc/ada/sem_res.adb
+++ gcc/ada/sem_res.adb
@@ -10598,6 +10598,10 @@ package body Sem_Res is
 
          pragma Assert (Found);
          Resolve (P, It1.Typ);
+
+         --  In general the expected type is the type of the context, not the
+         --  type of the candidate selected component.
+
          Set_Etype (N, Typ);
          Set_Entity_With_Checks (S, Comp1);
 
@@ -10610,6 +10614,17 @@ package body Sem_Res is
 
          if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
             Set_Etype (N, Etype (Comp1));
+
+         --  When the type of the component is an access to a class-wide type
+         --  the relevant type is that of the component (since in such case we
+         --  may need to generate implicit type conversions or dispatching
+         --  calls).
+
+         elsif Is_Access_Type (Typ)
+           and then not Is_Class_Wide_Type (Designated_Type (Typ))
+           and then Is_Class_Wide_Type (Designated_Type (Etype (Comp1)))
+         then
+            Set_Etype (N, Etype (Comp1));
          end if;
 
       else

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/tagged3.adb
@@ -0,0 +1,42 @@
+--  { dg-do run }
+
+with Tagged3_Pkg; use Tagged3_Pkg;
+procedure Tagged3 is
+   package SP is
+      type Ref is tagged private;
+
+      procedure Set (Self : in out Ref'Class; Data : Parent'Class);
+
+      type Reference_Type (Element : access Parent'Class)
+         is limited null record with Implicit_Dereference => Element;
+
+      function Get (Self : Ref'Class) return Reference_Type;
+
+   private
+      type Element_Access is access all Parent'Class;
+      type Ref is tagged record
+         Data : Element_Access;
+      end record;
+   end;
+
+   package body SP is
+      procedure Set (Self : in out Ref'Class; Data : Parent'Class) is
+      begin
+         Self.Data := new Parent'Class'(Data);
+      end;
+
+      function Get (Self : Ref'Class) return Reference_Type is
+      begin
+         return Reference_Type'(Element => Self.Data);
+      end;
+   end;
+
+   DC : Child;
+   RC : SP.Ref;
+begin
+   RC.Set (DC);
+   Prim1 (RC.Get.Element); -- Test
+   if not Tagged3_Pkg.Child_Prim1_Called then
+     raise Program_Error;
+   end if;
+end;

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/tagged3_pkg.adb
@@ -0,0 +1,12 @@
+with Ada.Text_IO; use Ada.Text_IO;
+package body Tagged3_Pkg is
+   procedure Prim1 (Self : access Parent) is
+   begin
+      raise Program_Error;
+   end;
+
+   procedure Prim1 (Self : access Child) is
+   begin
+     Child_Prim1_Called := True;
+   end;
+end;

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/tagged3_pkg.ads
@@ -0,0 +1,9 @@
+package Tagged3_Pkg is
+   type Parent is tagged null record;
+   procedure Prim1 (Self : access Parent);
+
+   type Child is new Parent with null record;
+   procedure Prim1 (Self : access Child);
+
+   Child_Prim1_Called : Boolean := False;
+end;