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