From: Javier Miranda <miranda@adacore.com>
Date: Mon, 22 Jul 2019 13:58:09 +0000 (+0000)
Subject: [Ada] Spurious error passing access to class-wide interface type
X-Git-Tag: upstream/12.2.0~22992
X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=137dabdd82648ccd5f0adedea2fbb8504f6c7485;p=platform%2Fupstream%2Fgcc.git

[Ada] Spurious error passing access to class-wide interface type

The compiler reports an spurious error when the formal parameter of a
subprogram is an access to a class wide interface type and the actual
parameter is an allocator of an object covering such interface type.

2019-07-22  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* sem_res.adb (Resolve_Actuals): Replace code that displaces the
	pointer to an allocated object to reference its secondary
	dispatch table by a type conversion (which takes care of
	handling all cases).

gcc/testsuite/

	* gnat.dg/class_wide5.adb: New testcase.

From-SVN: r273690
---

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4b817ce..4711b6d 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2019-07-22  Javier Miranda  <miranda@adacore.com>
+
+	* sem_res.adb (Resolve_Actuals): Replace code that displaces the
+	pointer to an allocated object to reference its secondary
+	dispatch table by a type conversion (which takes care of
+	handling all cases).
+
 2019-07-22  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* sprint.adb (Sprint_Node_Actual)
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index fd4fedc..b668a51 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -4190,17 +4190,16 @@ package body Sem_Res is
                      DDT : constant Entity_Id :=
                              Directly_Designated_Type (Base_Type (Etype (F)));
 
-                     New_Itype : Entity_Id;
-
                   begin
+                     --  Displace the pointer to the object to reference its
+                     --  secondary dispatch table.
+
                      if Is_Class_Wide_Type (DDT)
                        and then Is_Interface (DDT)
                      then
-                        New_Itype := Create_Itype (E_Anonymous_Access_Type, A);
-                        Set_Etype (New_Itype, Etype (A));
-                        Set_Directly_Designated_Type
-                          (New_Itype, Directly_Designated_Type (Etype (A)));
-                        Set_Etype (A, New_Itype);
+                        Rewrite (A, Convert_To (Etype (F), Relocate_Node (A)));
+                        Analyze_And_Resolve (A, Etype (F),
+                          Suppress => Access_Check);
                      end if;
 
                      --  Ada 2005, AI-162:If the actual is an allocator, the
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index acc6063..2ac298f 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2019-07-22  Javier Miranda  <miranda@adacore.com>
+
+	* gnat.dg/class_wide5.adb: New testcase.
+
 2019-07-22  Ed Schonberg  <schonberg@adacore.com>
 
 	* gnat.dg/opt80.adb: New testcase.
diff --git a/gcc/testsuite/gnat.dg/class_wide5.adb b/gcc/testsuite/gnat.dg/class_wide5.adb
new file mode 100644
index 0000000..008273f
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/class_wide5.adb
@@ -0,0 +1,11 @@
+--  { dg-do compile }
+
+procedure Class_Wide5 is
+   type B is interface;
+   type B_Child is new B with null record;
+   type B_Ptr is access B'Class;
+
+   procedure P (Obj : B_Ptr) is begin null; end;
+begin
+   P (new B_child);  -- Test
+end Class_Wide5;