ada: Fix too small secondary stack allocation for returned conversion

The previous fix did not address a latent issue whereby the allocation
would be made using the (static) subtype of the conversion instead of
the (dynamic) subtype of the return object, so this change rewrites the
code responsible for determining the type used for the allocation, and
also contains a small improvement to the Has_Tag_Of_Type predicate.

gcc/ada/

	* exp_ch3.adb (Make_Allocator_For_Return): Rewrite the logic that
	determines the type used for the allocation and add assertions.
	* exp_util.adb (Has_Tag_Of_Type): Also return true for extension
	aggregates.

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 778eed7f16e811e854349bc7b2d6ed2df7c77e53..7ac4680b3956f94188147c76780bf2de0316dc17 100644 (file)
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -7114,8 +7114,64 @@ package body Exp_Ch3 is
       function Make_Allocator_For_Return (Expr : Node_Id) return Node_Id is
          Alloc      : Node_Id;
          Alloc_Expr : Entity_Id;
+         Alloc_Typ  : Entity_Id;
 
       begin
+         --  If the return object's declaration does not include an expression,
+         --  then we use its subtype for the allocation. Likewise in the case
+         --  of a degenerate expression like a raise expression.
+
+         if No (Expr)
+           or else Nkind (Original_Node (Expr)) = N_Raise_Expression
+         then
+            Alloc_Typ := Typ;
+
+         --  If the return object's declaration includes an expression, then
+         --  there are two cases: either the nominal subtype of the object is
+         --  definite and we can use it for the allocation directly, or it is
+         --  not and Analyze_Object_Declaration should have built an actual
+         --  subtype from the expression.
+
+         --  However, there are exceptions in the latter case for interfaces
+         --  (see Analyze_Object_Declaration), as well as class-wide types and
+         --  types with unknown discriminants if they are additionally limited
+         --  (see Expand_Subtype_From_Expr), so we must cope with them.
+
+         elsif Is_Interface (Typ) then
+            pragma Assert (Is_Class_Wide_Type (Typ));
+
+            --  For interfaces, we use the type of the expression, except if
+            --  we need to put back a conversion that we have removed earlier
+            --  in the processing.
+
+            if Is_Class_Wide_Type (Etype (Expr)) then
+               Alloc_Typ := Typ;
+            else
+               Alloc_Typ := Etype (Expr);
+            end if;
+
+         elsif Is_Class_Wide_Type (Typ) then
+
+            --  For class-wide types, we have to make sure that we use the
+            --  dynamic type of the expression for the allocation, either by
+            --  means of its (static) subtype or through the actual subtype.
+
+            if Has_Tag_Of_Type (Expr) then
+               Alloc_Typ := Etype (Expr);
+
+            else pragma Assert (Ekind (Typ) = E_Class_Wide_Subtype
+              and then Present (Equivalent_Type (Typ)));
+
+               Alloc_Typ := Typ;
+            end if;
+
+         else pragma Assert (Is_Definite_Subtype (Typ)
+           or else (Has_Unknown_Discriminants (Typ)
+                     and then Is_Limited_View (Typ)));
+
+            Alloc_Typ := Typ;
+         end if;
+
          --  If the return object's declaration includes an expression and the
          --  declaration isn't marked as No_Initialization, then we generate an
          --  allocator with a qualified expression. Although this is necessary
@@ -7141,46 +7197,22 @@ package body Exp_Ch3 is
 
             Alloc_Expr := New_Copy_Tree (Expr);
 
-            --  In the constrained array case, deal with a potential sliding.
-            --  In the interface case, put back a conversion that we may have
-            --  removed earlier in the processing.
-
-            if (Ekind (Typ) = E_Array_Subtype
-                 or else (Is_Interface (Typ)
-                           and then Is_Class_Wide_Type (Etype (Alloc_Expr))))
-              and then Typ /= Etype (Alloc_Expr)
-            then
-               Alloc_Expr := Convert_To (Typ, Alloc_Expr);
+            if Etype (Alloc_Expr) /= Alloc_Typ then
+               Alloc_Expr := Convert_To (Alloc_Typ, Alloc_Expr);
             end if;
 
-            --  We always use the type of the expression for the qualified
-            --  expression, rather than the return object's type. We cannot
-            --  always use the return object's type because the expression
-            --  might be of a specific type and the return object might not.
-
             Alloc :=
               Make_Allocator (Loc,
                 Expression =>
                   Make_Qualified_Expression (Loc,
                     Subtype_Mark =>
-                      New_Occurrence_Of (Etype (Alloc_Expr), Loc),
+                      New_Occurrence_Of (Alloc_Typ, Loc),
                     Expression   => Alloc_Expr));
 
          else
-            --  If the return object is of a class-wide type, we cannot use
-            --  its type for the allocator. Instead we use the type of the
-            --  expression, which must be an aggregate of a definite type.
-
-            if Is_Class_Wide_Type (Typ) then
-               Alloc :=
-                 Make_Allocator (Loc,
-                   Expression => New_Occurrence_Of (Etype (Expr), Loc));
-
-            else
-               Alloc :=
-                 Make_Allocator (Loc,
-                   Expression => New_Occurrence_Of (Typ, Loc));
-            end if;
+            Alloc :=
+              Make_Allocator (Loc,
+                Expression => New_Occurrence_Of (Alloc_Typ, Loc));
 
             --  If the return object requires default initialization, then it
             --  will happen later following the elaboration of the renaming.

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 91959793638170975ed96219a5c59870877d2356..0d0ad8a5d6c22ce0526be3b23fc6db2e92ecf6c0 100644 (file)
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -7283,6 +7283,7 @@ package body Exp_Util is
             when N_Indexed_Component
               |  N_Selected_Component
               |  N_Aggregate
+              |  N_Extension_Aggregate
             =>
                return True;