From faa163f737cb388f97a285be28060730abd460a0 Mon Sep 17 00:00:00 2001 From: Gary Dismukes Date: Mon, 15 Jun 2020 17:14:14 -0400 Subject: [PATCH] [Ada] AI12-0382: Loosen type-invariant overriding requirement of AI12-0042 gcc/ada/ * sem_ch3.adb (Check_Abstract_Overriding): Remove Scope comparison test from test related to initial implementation of AI12-0042, plus remove the related ??? comment. (Derive_Subprogram): Add test requiring that the type extension appear in the visible part of its enclosing package when checking the overriding requirement of 7.3.2(6.1/4), as clarified by AI12-0382. --- gcc/ada/sem_ch3.adb | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 5f92a779633..6cc315ce40e 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -10763,12 +10763,7 @@ package body Sem_Ch3 is -- AI12-0042: Test for rule in 7.3.2(6.1/4), that requires overriding -- of a visible private primitive inherited from an ancestor with -- the aspect Type_Invariant'Class, unless the inherited primitive - -- is abstract. (The test for the extension occurring in a different - -- scope than the ancestor is to avoid requiring overriding when - -- extending in the same scope, because the inherited primitive will - -- also be private in that case, which looks like an unhelpful - -- restriction that may break reasonable code, though the rule - -- appears to apply in the same-scope case as well???) + -- is abstract. elsif not Is_Abstract_Subprogram (Subp) and then not Comes_From_Source (Subp) -- An inherited subprogram @@ -10778,7 +10773,6 @@ package body Sem_Ch3 is and then Present (Get_Pragma (Etype (T), Pragma_Invariant)) and then Class_Present (Get_Pragma (Etype (T), Pragma_Invariant)) and then Is_Private_Primitive (Alias_Subp) - and then Scope (Subp) /= Scope (Alias_Subp) then Error_Msg_NE ("inherited private primitive & must be overridden", T, Subp); @@ -15732,7 +15726,9 @@ package body Sem_Ch3 is -- AI12-0042: Set Requires_Overriding when a type extension -- inherits a private operation that is visible at the -- point of extension (Has_Private_Ancestor is False) from - -- an ancestor that has Type_Invariant'Class. + -- an ancestor that has Type_Invariant'Class, and when the + -- type extension is in a visible part (the latter as + -- clarified by AI12-0382). or else (not Has_Private_Ancestor (Derived_Type) @@ -15742,7 +15738,8 @@ package body Sem_Ch3 is and then Class_Present (Get_Pragma (Parent_Type, Pragma_Invariant)) - and then Is_Private_Primitive (Parent_Subp))) + and then Is_Private_Primitive (Parent_Subp) + and then In_Visible_Part (Scope (Derived_Type)))) and then No (Actual_Subp) then -- 2.30.2