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 <mira...@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;
