[gcc r14-6697] ada: Fix crash on concurrent type aggregate

[Marc Poulhi?s]

https://gcc.gnu.org/g:346e4645eb13cab2be1c148ca4f01d048b26c397

commit r14-6697-g346e4645eb13cab2be1c148ca4f01d048b26c397
Author: Ronan Desplanques <desplanques@adacore.com>
Date:   Tue Nov 28 09:11:57 2023 +0100

    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:
---
 gcc/ada/exp_aggr.adb | 15 ++++++++++++---
 gcc/ada/exp_util.ads |  8 ++++++--
 2 files changed, 18 insertions(+), 5 deletions(-)

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index d61fbbc8c73..50063ed819e 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 267a127ec5e..d15e4f90865 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;