diff mbox series

[Ada] Spurious error on overriding of privately inherited primitive

Message ID 20171108151815.GA102843@adacore.com
State New
Headers show
Series [Ada] Spurious error on overriding of privately inherited primitive | expand

Commit Message

Pierre-Marie de Rodat Nov. 8, 2017, 3:18 p.m. UTC 
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  <miranda@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  <miranda@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.
diff mbox series

Patch

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;