https://gcc.gnu.org/g:4aa366fcb2a1a1d359207c6826f04be696d5e547
commit r15-4146-g4aa366fcb2a1a1d359207c6826f04be696d5e547
Author: Steve Baird <ba...@adacore.com>
Date: Fri Aug 30 14:13:22 2024 -0700
ada: Legal access discriminant default expression incorrectly rejected
If a limited private partial view of a type has an access discriminant with
a default expression, and if the type (perhaps tagged, perhaps not) is
completed by deriving from an immutably limited type, then the default
discriminant expression should not be rejected.
gcc/ada/ChangeLog:
* sem_ch6.adb (Check_Discriminant_Conformance): In testing whether
a default expression is permitted for an access discriminant, we
need to know whether the discriminated type is immutably limited.
Handle another part of this test that cannot easily be handled in
Sem_Aux.Is_Immutably_Limited. This involves declaring a new local
function, Is_Derived_From_Immutably_Limited_Type.
Diff:
---
gcc/ada/sem_ch6.adb | 39 +++++++++++++++++++++++++++++++++++++++
1 file changed, 39 insertions(+)
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 076fb89c7b50..c200871b8520 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -6436,6 +6436,14 @@ package body Sem_Ch6 is
(Typ : Entity_Id) return Boolean;
-- Returns True iff Typ has a tagged limited partial view.
+ function Is_Derived_From_Immutably_Limited_Type
+ (Typ : Entity_Id) return Boolean;
+ -- Returns True iff Typ is a derived type (tagged or not)
+ -- whose ancestor type is immutably limited. The unusual
+ -- ("unusual" is one word for it) thing about this function
+ -- is that it handles the case where the ancestor name's Entity
+ -- attribute has not been set yet.
+
-------------------------------------
-- Has_Tagged_Limited_Partial_View --
-------------------------------------
@@ -6451,6 +6459,31 @@ package body Sem_Ch6 is
and then Limited_Present (Parent (Priv));
end Has_Tagged_Limited_Partial_View;
+ --------------------------------------------
+ -- Is_Derived_From_Immutably_Limited_Type --
+ --------------------------------------------
+
+ function Is_Derived_From_Immutably_Limited_Type
+ (Typ : Entity_Id) return Boolean
+ is
+ Type_Def : constant Node_Id := Type_Definition (Parent (Typ));
+ Parent_Name : Node_Id;
+ begin
+ if Nkind (Type_Def) /= N_Derived_Type_Definition then
+ return False;
+ end if;
+ Parent_Name := Subtype_Indication (Type_Def);
+ if Nkind (Parent_Name) = N_Subtype_Indication then
+ Parent_Name := Subtype_Mark (Parent_Name);
+ end if;
+ if Parent_Name not in N_Has_Entity_Id
+ or else No (Entity (Parent_Name))
+ then
+ Find_Type (Parent_Name);
+ end if;
+ return Is_Immutably_Limited_Type (Entity (Parent_Name));
+ end Is_Derived_From_Immutably_Limited_Type;
+
begin
if NewD or OldD then
@@ -6489,6 +6522,12 @@ package body Sem_Ch6 is
and then not Has_Tagged_Limited_Partial_View
(Defining_Identifier (N))
+
+ -- Check for another case that would be awkward to handle
+ -- in Is_Immutably_Limited_Type
+
+ and then not Is_Derived_From_Immutably_Limited_Type
+ (Defining_Identifier (N))
then
Error_Msg_N
("(Ada 2005) default value for access discriminant "
