From 5b15ac5f0506f3d9c1cf0913024e1c721521f7c0 Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Tue, 13 Aug 2019 08:08:27 +0000 Subject: [PATCH] [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 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 --- gcc/ada/ChangeLog | 8 +++++ gcc/ada/sem_res.adb | 15 ++++++++++ gcc/testsuite/ChangeLog | 5 ++++ gcc/testsuite/gnat.dg/tagged3.adb | 42 +++++++++++++++++++++++++++ gcc/testsuite/gnat.dg/tagged3_pkg.adb | 12 ++++++++ gcc/testsuite/gnat.dg/tagged3_pkg.ads | 9 ++++++ 6 files changed, 91 insertions(+) create mode 100644 gcc/testsuite/gnat.dg/tagged3.adb create mode 100644 gcc/testsuite/gnat.dg/tagged3_pkg.adb create mode 100644 gcc/testsuite/gnat.dg/tagged3_pkg.ads 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 + + * 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 * 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 + + * gnat.dg/tagged3.adb, gnat.dg/tagged3_pkg.adb, + gnat.dg/tagged3_pkg.ads: New testcase. + 2019-08-13 Ed Schonberg * 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; -- 2.30.2