From: Gary Dismukes <dismu...@adacore.com>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
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 625d291fc28..41ace8cc250 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 =>
--
2.43.0
