Compiler rejects an overriding indicator on a Finalize subprogram
for a derived type D when the parent type P is a derivation of a
private type whose full view is controlled, and the ultimate parent
of P has a visible primitive Finalize.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
2017-11-08 Javier Miranda <mira...@adacore.com>
* sem_disp.adb (Is_Inherited_Public_Operation): Extend the
functionality of this routine to handle multiple levels of derivations.
gcc/testsuite/
2017-11-08 Javier Miranda <mira...@adacore.com>
* gnat.dg/overriding_ops2.adb, gnat.dg/overriding_ops2.ads,
gnat.dg/overriding_ops2_pkg.ads, gnat.dg/overriding_ops2_pkg-high.ads:
New testcase.
Index: sem_disp.adb
===================================================================
--- sem_disp.adb (revision 254523)
+++ sem_disp.adb (working copy)
@@ -2371,11 +2371,19 @@
-----------------------------------
function Is_Inherited_Public_Operation (Op : Entity_Id) return Boolean is
- Prim : constant Entity_Id := Alias (Op);
- Scop : constant Entity_Id := Scope (Prim);
+ Prim : Entity_Id := Op;
+ Scop : Entity_Id := Prim;
Pack_Decl : Node_Id;
begin
+ -- Locate the ultimate non-hidden alias entity
+
+ while Present (Alias (Prim)) and then not Is_Hidden (Alias (Prim)) loop
+ pragma Assert (Alias (Prim) /= Prim);
+ Prim := Alias (Prim);
+ Scop := Scope (Prim);
+ end loop;
+
if Comes_From_Source (Prim) and then Ekind (Scop) = E_Package then
Pack_Decl := Unit_Declaration_Node (Scop);
return Nkind (Pack_Decl) = N_Package_Declaration
Index: ../testsuite/gnat.dg/overriding_ops2.adb
===================================================================
--- ../testsuite/gnat.dg/overriding_ops2.adb (revision 0)
+++ ../testsuite/gnat.dg/overriding_ops2.adb (revision 0)
@@ -0,0 +1,8 @@
+-- { dg-do compile }
+
+package body Overriding_Ops2 is
+ overriding procedure Finalize (Self : in out Consumer) is
+ begin
+ null;
+ end Finalize;
+end Overriding_Ops2;
Index: ../testsuite/gnat.dg/overriding_ops2.ads
===================================================================
--- ../testsuite/gnat.dg/overriding_ops2.ads (revision 0)
+++ ../testsuite/gnat.dg/overriding_ops2.ads (revision 0)
@@ -0,0 +1,12 @@
+with Overriding_Ops2_Pkg.High;
+
+package Overriding_Ops2 is
+ type Consumer is tagged limited private;
+private
+ type Consumer is
+ limited
+ new Overriding_Ops2_Pkg.High.High_Level_Session
+ with null record;
+
+ overriding procedure Finalize (Self : in out Consumer);
+end Overriding_Ops2;
Index: ../testsuite/gnat.dg/overriding_ops2_pkg.ads
===================================================================
--- ../testsuite/gnat.dg/overriding_ops2_pkg.ads (revision 0)
+++ ../testsuite/gnat.dg/overriding_ops2_pkg.ads (revision 0)
@@ -0,0 +1,9 @@
+with Ada.Finalization;
+
+package Overriding_Ops2_Pkg is
+ type Session_Type is abstract tagged limited private;
+ procedure Finalize (Session : in out Session_Type);
+private
+ type Session_Type is
+ abstract new Ada.Finalization.Limited_Controlled with null record;
+end Overriding_Ops2_Pkg;
Index: ../testsuite/gnat.dg/overriding_ops2_pkg-high.ads
===================================================================
--- ../testsuite/gnat.dg/overriding_ops2_pkg-high.ads (revision 0)
+++ ../testsuite/gnat.dg/overriding_ops2_pkg-high.ads (revision 0)
@@ -0,0 +1,5 @@
+package Overriding_Ops2_Pkg.High is
+ type High_Level_Session is new Session_Type with private;
+private
+ type High_Level_Session is new Session_Type with null record;
+end Overriding_Ops2_Pkg.High;
