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 --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 625d291fc28d9b94a5bc249b806489a02f62a6ec..41ace8cc250f5417901fb773b8c3040bebb2cff3 100644 (file)
--- 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 =>