ada: Fix crash on concurrent type aggregate

Before this patch, the compiler would fail to examine the corresponding
record types of concurrent types when building aggregate components.
This patch fixes this, and adds a precondition and additional documentation
on the subprogram that triggered the crash, as it never makes sense
to call it with a concurrent type.

gcc/ada/

	* exp_aggr.adb (Initialize_Component): Use corresponding record
	types of concurrent types.
	* exp_util.ads (Make_Tag_Assignment_From_Type): Add precondition
	and extend documentation.

Co-authored-by: Javier Miranda <miranda@adacore.com>

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index d61fbbc8c7342d8663e0571d1c688394b0485f29..50063ed819edb9868ad5a32becd23f52a5c69f53 100644 (file)
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -8509,9 +8509,18 @@ package body Exp_Aggr is
          Set_No_Ctrl_Actions (Init_Stmt);
 
          if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then
-            Append_To (Blk_Stmts,
-              Make_Tag_Assignment_From_Type
-                (Loc, New_Copy_Tree (Comp), Underlying_Type (Comp_Typ)));
+            declare
+               Typ : Entity_Id := Underlying_Type (Comp_Typ);
+
+            begin
+               if Is_Concurrent_Type (Typ) then
+                  Typ := Corresponding_Record_Type (Typ);
+               end if;
+
+               Append_To (Blk_Stmts,
+                 Make_Tag_Assignment_From_Type
+                   (Loc, New_Copy_Tree (Comp), Typ));
+            end;
          end if;
       end if;
 

diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 267a127ec5e177b7bb695375b5fa99f0285a0484..d15e4f908654c5e5eab15e6f798da23d3df5844d 100644 (file)
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -941,9 +941,13 @@ package Exp_Util is
    function Make_Tag_Assignment_From_Type
      (Loc    : Source_Ptr;
       Target : Node_Id;
-      Typ    : Entity_Id) return Node_Id;
+      Typ    : Entity_Id) return Node_Id
+   with
+     Pre => (not Is_Concurrent_Type (Typ));
    --  Return an assignment of the tag of tagged type Typ to prefix Target,
-   --  which must be a record object of a descendant of Typ.
+   --  which must be a record object of a descendant of Typ. Typ cannot be a
+   --  concurrent type; for concurrent types, the corresponding record types
+   --  should be passed to this function instead.
 
    function Make_Variant_Comparison
      (Loc      : Source_Ptr;