[Ada] Wrong dispatching call in type with aspect Implicit_Dereference

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.

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.

From-SVN: r274356

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index dfc30f2094ce18a6f728a3c5493c932f5f7e4f03..5e313305ed3c36798ae6abf830d53396519396e6 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,11 @@
+2019-08-13  Javier Miranda  <miranda@adacore.com>
+
+       * 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).
+
 2019-08-13  Ed Schonberg  <schonberg@adacore.com>
 
        * exp_aggr.adb (Aggr_Assignment_OK_For_Backend):  Preanalyze

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 7a9c85c2154f2674c4caa9c3dd4d3f121c570803..b27171f0be508eecd7f3d6fbb69acf839d80a4de 100644 (file)
--- a/gcc/ada/sem_res.adb
+++ b/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

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c1e28aa10a41c3e0992a5da6dc366c24a02eb155..887b0c3c3e73d30230e62995939cf618adbc5aeb 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2019-08-13  Javier Miranda  <miranda@adacore.com>
+
+       * gnat.dg/tagged3.adb, gnat.dg/tagged3_pkg.adb,
+       gnat.dg/tagged3_pkg.ads: New testcase.
+
 2019-08-13  Ed Schonberg  <schonberg@adacore.com>
 
        * gnat.dg/aggr27.adb: New testcase.

diff --git a/gcc/testsuite/gnat.dg/tagged3.adb b/gcc/testsuite/gnat.dg/tagged3.adb
new file mode 100644 (file)
index 0000000..1468ee2
--- /dev/null
+++ b/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;

diff --git a/gcc/testsuite/gnat.dg/tagged3_pkg.adb b/gcc/testsuite/gnat.dg/tagged3_pkg.adb
new file mode 100644 (file)
index 0000000..c4629af
--- /dev/null
+++ b/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;

diff --git a/gcc/testsuite/gnat.dg/tagged3_pkg.ads b/gcc/testsuite/gnat.dg/tagged3_pkg.ads
new file mode 100644 (file)
index 0000000..d32afe2
--- /dev/null
+++ b/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;