sem_ch6.adb (Check_Private_Overriding): Refine the legality checks here.

2015-03-02  Bob Duff  <duff@adacore.com>

	* sem_ch6.adb (Check_Private_Overriding): Refine the legality
	checks here. It used to check that the function is merely
	overriding SOMEthing. Now it checks that the function is
	overriding a corresponding public operation. This is a correction
	to the implementation of the rule in RM-3.9.3(10).

From-SVN: r221110

2 files changed, 66 insertions, 2 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 0a4d3f9..01787e4 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,11 @@
+2015-03-02  Bob Duff  <duff@adacore.com>
+
+	* sem_ch6.adb (Check_Private_Overriding): Refine the legality
+	checks here. It used to check that the function is merely
+	overriding SOMEthing. Now it checks that the function is
+	overriding a corresponding public operation. This is a correction
+	to the implementation of the rule in RM-3.9.3(10).
+
 2015-03-02  Robert Dewar  <dewar@adacore.com>
 
 	* debug.adb: Document new debug flag -gnatd.1.
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index dccecc3..39cd353 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -8905,6 +8905,50 @@ package body Sem_Ch6 is
          ------------------------------
 
          procedure Check_Private_Overriding (T : Entity_Id) is
+
+            function Overrides_Visible_Function return Boolean;
+            --  True if S overrides a function in the visible part. The
+            --  overridden function could be explicitly or implicitly declared.
+
+            function Overrides_Visible_Function return Boolean is
+            begin
+               if not Is_Overriding or else not Has_Homonym (S) then
+                  return False;
+               end if;
+
+               if not Present (Incomplete_Or_Partial_View (T)) then
+                  return True;
+               end if;
+
+               --  Search through all the homonyms H of S in the current
+               --  package spec, and return True if we find one that matches.
+               --  Note that Parent (H) will be the declaration of the
+               --  Incomplete_Or_Partial_View of T for a match.
+
+               declare
+                  H : Entity_Id := S;
+               begin
+                  loop
+                     H := Homonym (H);
+                     exit when not Present (H) or else Scope (H) /= Scope (S);
+
+                     if Nkind_In
+                       (Parent (H),
+                        N_Private_Extension_Declaration,
+                        N_Private_Type_Declaration)
+                       and then Defining_Identifier (Parent (H)) =
+                                  Incomplete_Or_Partial_View (T)
+                     then
+                        return True;
+                     end if;
+                  end loop;
+               end;
+
+               return False;
+            end Overrides_Visible_Function;
+
+         --  Start of processing for Check_Private_Overriding
+
          begin
             if Is_Package_Or_Generic_Package (Current_Scope)
               and then In_Private_Part (Current_Scope)
@@ -8919,8 +8963,20 @@ package body Sem_Ch6 is
                   Error_Msg_N ("abstract subprograms must be visible "
                                & "(RM 3.9.3(10))!", S);
 
-               elsif Ekind (S) = E_Function and then not Is_Overriding then
-                  if Is_Tagged_Type (T) and then T = Base_Type (Etype (S)) then
+               elsif Ekind (S) = E_Function
+                 and then not Overrides_Visible_Function
+               then
+                  --  Here, S is "function ... return T;" declared in the
+                  --  private part, not overriding some visible operation.
+                  --  That's illegal in the tagged case (but not if the
+                  --  private type is untagged).
+
+                  if ((Present (Incomplete_Or_Partial_View (T))
+                      and then Is_Tagged_Type (Incomplete_Or_Partial_View (T)))
+                    or else (not Present (Incomplete_Or_Partial_View (T))
+                      and then Is_Tagged_Type (T)))
+                    and then T = Base_Type (Etype (S))
+                  then
                      Error_Msg_N ("private function with tagged result must"
                                   & " override visible-part function", S);
                      Error_Msg_N ("\move subprogram to the visible part"