https://gcc.gnu.org/g:f409c452883011c93a91f8057d301920dbc9bbb2
commit r15-6622-gf409c452883011c93a91f8057d301920dbc9bbb2
Author: Gary Dismukes <dismu...@adacore.com>
Date: Fri Dec 13 23:36:05 2024 +0000
ada: Error on instantiation with defaulted formal type referencing other
formal type
The compiler wasn't accounting for default subtypes on generic formal types
that reference other formal types of the same generic, leading to errors
about invalid subtypes. Several other problems that could lead to blowups
or incorrect errors were noticed through testing related cases and fixed
along the way.
gcc/ada/ChangeLog:
* sem_ch12.adb (Analyze_One_Association): In the case of a formal
type
that has a Default_Subtype_Mark that does not have its Entity field
set,
this means the default refers to another formal type of the same
generic
formal part, so locate the matching subtype in the Result_Renamings
and
set Match's Entity to that subtype prior to the call to
Instantiate_Type.
(Validate_Formal_TypeDefault.Reference_Formal): Add test of Entity
being
Present, to prevent blowups on End_Label ids (which don't have
Entity set).
(Validate_Formal_Type_Default.Validate_Derived_Type_Default): Apply
Base_Type to Formal.
(Validate_Formal_Type_Default): Guard interface-related semantic
checks
with a test of Is_Tagged_Type.
Diff:
---
gcc/ada/sem_ch12.adb | 78 ++++++++++++++++++++++++++++++++++++++++++----------
1 file changed, 64 insertions(+), 14 deletions(-)
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 625d291fc28d..41ace8cc250f 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -2512,6 +2512,52 @@ package body Sem_Ch12 is
if Present (Default_Subtype_Mark (Assoc.Un_Formal)) then
Match := New_Copy (Default_Subtype_Mark (Assoc.Un_Formal));
+
+ -- If the Entity of the default subtype denoted by the
+ -- unanalyzed formal has not been set, then it must refer
+ -- to another formal type of the enclosing generic. So we
+ -- locate the subtype "renaming" in Result_Renamings that
+ -- corresponds to the formal type (by comparing the simple
+ -- names), and set Match's Entity to the entity denoted by
+ -- that subtype's subtype_indication (which will denote the
+ -- actual subtype corresponding to the other formal type).
+ -- This must be done before calling Instantiate_Type, since
+ -- that function relies heavily on the entity being set.
+ -- (Note also that there's similar code inside procedure
+ -- Validate_Derived_Type_Instance that deals with retrieving
+ -- the ancestor type of formal derived types.)
+
+ if No (Entity (Match)) then
+ declare
+ pragma Assert (Is_Non_Empty_List (Result_Renamings));
+
+ Decl : Node_Id := First (Result_Renamings);
+
+ begin
+ -- Locate subtype referenced by the default subtype
+ -- in the list of renamings.
+
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Subtype_Declaration
+ and then
+ Chars (Match) =
+ Chars (Defining_Identifier (Decl))
+ then
+ Set_Entity
+ (Match,
+ Entity (Subtype_Indication (Decl)));
+
+ exit;
+
+ else
+ Next (Decl);
+ end if;
+ end loop;
+
+ pragma Assert (Present (Entity (Match)));
+ end;
+ end if;
+
Append_List
(Instantiate_Type
(Assoc.Un_Formal, Match, Assoc.An_Formal,
@@ -18161,6 +18207,7 @@ package body Sem_Ch12 is
function Reference_Formal (N : Node_Id) return Traverse_Result is
begin
if Is_Entity_Name (N)
+ and then Present (Entity (N))
and then Scope (Entity (N)) = Current_Scope
then
return Abandon;
@@ -18356,7 +18403,7 @@ package body Sem_Ch12 is
procedure Validate_Derived_Type_Default is
begin
- if not Is_Ancestor (Etype (Formal), Def_Sub) then
+ if not Is_Ancestor (Etype (Base_Type (Formal)), Def_Sub) then
Error_Msg_NE ("default must be a descendent of&",
Default, Etype (Formal));
end if;
@@ -18529,20 +18576,23 @@ package body Sem_Ch12 is
end if;
when N_Record_Definition => -- Formal interface type
- if not Is_Interface (Def_Sub) then
- Error_Msg_NE
- ("default for formal interface type must be an interface",
- Default, Formal);
+ if Is_Tagged_Type (Def_Sub) then
+ if not Is_Interface (Def_Sub) then
+ Error_Msg_NE
+ ("default for formal interface type must be an interface",
+ Default, Formal);
- elsif Is_Limited_Type (Def_Sub) /= Is_Limited_Type (Formal)
- or else Is_Task_Interface (Formal) /= Is_Task_Interface (Def_Sub)
- or else Is_Protected_Interface (Formal) /=
- Is_Protected_Interface (Def_Sub)
- or else Is_Synchronized_Interface (Formal) /=
- Is_Synchronized_Interface (Def_Sub)
- then
- Error_Msg_NE
- ("default for interface& does not match", Def_Sub, Formal);
+ elsif Is_Limited_Type (Def_Sub) /= Is_Limited_Type (Formal)
+ or else Is_Task_Interface (Formal) /=
+ Is_Task_Interface (Def_Sub)
+ or else Is_Protected_Interface (Formal) /=
+ Is_Protected_Interface (Def_Sub)
+ or else Is_Synchronized_Interface (Formal) /=
+ Is_Synchronized_Interface (Def_Sub)
+ then
+ Error_Msg_NE
+ ("default for interface& does not match", Def_Sub, Formal);
+ end if;
end if;
when N_Derived_Type_Definition =>
