From: Ronan Desplanques <desplanques@adacore.com>
Date: Tue, 28 Nov 2023 08:11:57 +0000 (+0100)
Subject: ada: Fix crash on concurrent type aggregate
X-Git-Tag: basepoints/gcc-15~3442
X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=346e4645eb13cab2be1c148ca4f01d048b26c397;p=thirdparty%2Fgcc.git

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 d61fbbc8c734..50063ed819ed 100644
--- 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 267a127ec5e1..d15e4f908654 100644
--- 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;