From: Javier Miranda <miranda@adacore.com>
Date: Tue, 13 Aug 2019 08:08:27 +0000 (+0000)
Subject: [Ada] Wrong dispatching call in type with aspect Implicit_Dereference
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=5b15ac5f0506f3d9c1cf0913024e1c721521f7c0;p=gcc.git

[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 dfc30f2094c..5e313305ed3 100644
--- 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 7a9c85c2154..b27171f0be5 100644
--- 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 c1e28aa10a4..887b0c3c3e7 100644
--- 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
index 00000000000..1468ee2c03e
--- /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
index 00000000000..c4629af8764
--- /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
index 00000000000..d32afe2ae11
--- /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;