https://gcc.gnu.org/g:709f6de48ba3fc4e5fc01c86c511bfb21b6ea202
commit r17-5378-g709f6de48ba3fc4e5fc01c86c511bfb21b6ea202 Author: Eric Botcazou <[email protected]> Date: Mon Oct 19 21:06:53 2026 +0200 Ada: Fix assertion failure on allocator for extension aggregate with task It occurs for an allocator whose (qualified) expression is an extension aggregate and an ancestor type contains a task component, because the actual passed for the _Master formal parameter of the initialization procedure of the ancestor part is nowhere to be found. gcc/ada/ PR ada/127994 * exp_aggr.adb (Late_Expansion): Add Ptr_Typ formal parameter and pass it in the call to Build_Record_Aggr_Code. (Build_Record_Aggr_Code): Add Ptr_Typ formal parameter and pass it in the call to Build_Initialization_Call. (Convert_Aggr_In_Allocator): Remove useless test and pass the type of the temporary in the call to Late_Expansion. gcc/testsuite/ * gnat.dg/task7.adb: New test. * gnat.dg/task7_pkg.ads: New helper package. Diff: --- gcc/ada/exp_aggr.adb | 69 +++++++++++++++++++------------------ gcc/testsuite/gnat.dg/task7.adb | 9 +++++ gcc/testsuite/gnat.dg/task7_pkg.ads | 16 +++++++++ 3 files changed, 60 insertions(+), 34 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 4cfe61b6dccd..52916bb28e62 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -120,14 +120,17 @@ package body Exp_Aggr is -- of a statically allocated dispatch table. function Late_Expansion - (N : Node_Id; - Typ : Entity_Id; - Target : Node_Id) return List_Id; - -- This routine implements top-down expansion of nested aggregates. In - -- doing so, it avoids the generation of temporaries at each level. N is - -- a nested record or array aggregate with the Expansion_Delayed flag. - -- Typ is the expected type of the aggregate. Target is a (duplicatable) - -- expression that will hold the result of the aggregate expansion. + (N : Node_Id; + Typ : Entity_Id; + Target : Node_Id; + Ptr_Typ : Entity_Id := Empty) return List_Id; + -- This routine implements top-down expansion of nested aggregates, so as + -- to avoid the generation of temporaries at each level. N is a record or + -- an array aggregate with the Expansion_Delayed flag. Typ is the expected + -- type of the aggregate. Target is a (duplicatable) expression that will + -- hold the result of the elaboration of the aggregate. Ptr_Typ is set to + -- the type of the allocator if N is used as its (qualified) expression, + -- or Empty otherwise. function Make_OK_Assignment_Statement (Sloc : Source_Ptr; @@ -175,14 +178,16 @@ package body Exp_Aggr is ------------------------------------------------------ function Build_Record_Aggr_Code - (N : Node_Id; - Typ : Entity_Id; - Lhs : Node_Id) return List_Id; + (N : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id; + Ptr_Typ : Entity_Id := Empty) return List_Id; -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the -- aggregate. Lhs is an expression containing the location on which the - -- component by component assignments will take place. Returns the list of - -- assignments plus all other adjustments needed for tagged and controlled - -- types. + -- component by component assignments will take place. Ptr_Typ is set to + -- the type of the allocator if N is used as its (qualified) expression, + -- or Empty otherwise. Return the list of assignments, as well as other + -- adjustments needed for tagged and controlled types. procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id); -- Transform a record aggregate into a sequence of assignments performed @@ -2227,9 +2232,10 @@ package body Exp_Aggr is ---------------------------- function Build_Record_Aggr_Code - (N : Node_Id; - Typ : Entity_Id; - Lhs : Node_Id) return List_Id + (N : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id; + Ptr_Typ : Entity_Id := Empty) return List_Id is Loc : constant Source_Ptr := Sloc (N); L : constant List_Id := New_List; @@ -2951,6 +2957,7 @@ package body Exp_Aggr is Id_Ref => Ref, Typ => Init_Typ, In_Init_Proc => Inside_Init_Proc, + Target_Ref => Ptr_Typ, With_Default_Init => Has_Default_Init_Comps (N) or else Has_Task (Base_Type (Init_Typ)))); @@ -3603,21 +3610,14 @@ package body Exp_Aggr is Unchecked_Convert_To (Typ, Make_Explicit_Dereference (Loc, New_Occurrence_Of (Temp, Loc))); - begin - if Has_Default_Init_Comps (Aggr) then - declare - Stmts : constant List_Id := Late_Expansion (Aggr, Typ, Occ); - - begin - if Has_Task (Typ) then - Insert_Action (N, Build_Task_Allocate_Block (Aggr, Stmts)); - else - Insert_Actions (N, Stmts); - end if; - end; + Stmts : constant List_Id := + Late_Expansion (Aggr, Typ, Occ, Etype (Temp)); + begin + if Has_Task (Typ) then + Insert_Action (N, Build_Task_Allocate_Block (Aggr, Stmts)); else - Insert_Actions (N, Late_Expansion (Aggr, Typ, Occ)); + Insert_Actions (N, Stmts); end if; end Convert_Aggr_In_Allocator; @@ -9008,9 +9008,10 @@ package body Exp_Aggr is -------------------- function Late_Expansion - (N : Node_Id; - Typ : Entity_Id; - Target : Node_Id) return List_Id + (N : Node_Id; + Typ : Entity_Id; + Target : Node_Id; + Ptr_Typ : Entity_Id := Empty) return List_Id is Aggr_Code : List_Id; @@ -9025,7 +9026,7 @@ package body Exp_Aggr is Scalar_Comp => Is_Scalar_Type (Component_Type (Typ))); else - Aggr_Code := Build_Record_Aggr_Code (N, Typ, Target); + Aggr_Code := Build_Record_Aggr_Code (N, Typ, Target, Ptr_Typ); end if; -- Save the last assignment statement associated with the aggregate diff --git a/gcc/testsuite/gnat.dg/task7.adb b/gcc/testsuite/gnat.dg/task7.adb new file mode 100644 index 000000000000..8e9692e428e5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/task7.adb @@ -0,0 +1,9 @@ +-- { dg-do compile } + +with Task7_Pkg; use Task7_Pkg; + +procedure Task7 is + A : Ptr := new Ext'(Task_Wrapper with I => 1); +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/task7_pkg.ads b/gcc/testsuite/gnat.dg/task7_pkg.ads new file mode 100644 index 000000000000..6d703746fb9e --- /dev/null +++ b/gcc/testsuite/gnat.dg/task7_pkg.ads @@ -0,0 +1,16 @@ +package Task7_Pkg is + + task type Task_Typ is + end Task_Typ; + + type Task_Wrapper is tagged limited record + Tsk : Task_Typ; + end record; + + type Ext is new Task_Wrapper with record + I : Integer; + end record; + + type Ptr is access Ext; + +end Task7_Pkg;
