This plugs an annoying loophole, whereby the subpool indication present in an
allocator is dropped in some circumstances, most notably when the allocator is
initialized by an aggregate with defaulted components.
Tested on x86-64/Linux, applied on the mainline and 15 branch.
2026-02-16 Eric Botcazou <[email protected]>
PR ada/124106
* exp_ch4.adb (Expand_N_Allocator): Minor fix in commentary.
(Expand_Allocator_Expression): Propagate the Subpool_Handle_Name
of the original allocator onto the newly built allocators.
* exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Likewise.
Use Preserve_Comes_From_Source to propagate Comes_From_Source.
(Make_CPP_Constructor_Call_In_Allocator): Likewise.
2026-02-16 Eric Botcazou <[email protected]>
* gnat.dg/subpools2.adb: New test.
--
Eric Botcazoudiff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index f9bd98a9e45..c3d996a97d1 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -656,7 +656,9 @@ package body Exp_Ch4 is
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression =>
Make_Allocator (Loc,
- Expression => New_Occurrence_Of (Etype (Exp), Loc)));
+ Subpool_Handle_Name =>
+ Relocate_Node (Subpool_Handle_Name (N)),
+ Expression => New_Occurrence_Of (Etype (Exp), Loc)));
begin
-- Prevent default initialization of the allocator
@@ -695,7 +697,9 @@ package body Exp_Ch4 is
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression =>
Make_Allocator (Loc,
- Expression => New_Occurrence_Of (Etype (Exp), Loc)));
+ Subpool_Handle_Name =>
+ Relocate_Node (Subpool_Handle_Name (N)),
+ Expression => New_Occurrence_Of (Etype (Exp), Loc)));
begin
-- Prevent default initialization of the allocator
@@ -4634,8 +4638,7 @@ package body Exp_Ch4 is
-- Set the storage pool and find the appropriate version of Allocate to
-- call. Do not overwrite the storage pool if it is already set, which
- -- can happen for build-in-place function returns (see
- -- Exp_Ch4.Expand_N_Extended_Return_Statement).
+ -- can occur for BIP function returns (see Expand_N_Object_Declaration).
if No (Storage_Pool (N)) then
Pool := Associated_Storage_Pool (Root_Type (PtrT));
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 67cb2f8d1e2..9e1a68aef12 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -9086,17 +9086,24 @@ package body Exp_Ch6 is
New_Allocator :=
Make_Allocator (Loc,
- Expression => New_Occurrence_Of (Result_Subt, Loc));
+ Subpool_Handle_Name =>
+ Relocate_Node (Subpool_Handle_Name (Allocator)),
+ Expression => New_Occurrence_Of (Result_Subt, Loc));
+
+ -- Prevent default initialization of the allocator
+
Set_No_Initialization (New_Allocator);
- -- Copy attributes to new allocator. Note that the new allocator
- -- logically comes from source if the original one did, so copy the
- -- relevant flag. This ensures proper treatment of the restriction
- -- No_Implicit_Heap_Allocations in this case.
+ -- Copy the Comes_From_Source flag onto the allocator since logically
+ -- this allocator is a replacement of the original allocator. This is
+ -- for proper handling of restriction No_Implicit_Heap_Allocations.
+
+ Preserve_Comes_From_Source (New_Allocator, Allocator);
+
+ -- Copy the attributes set by Expand_N_Allocator
Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator));
Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator));
- Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator));
Rewrite (Allocator, New_Allocator);
@@ -10134,17 +10141,24 @@ package body Exp_Ch6 is
New_Allocator :=
Make_Allocator (Loc,
- Expression => New_Occurrence_Of (Result_Subt, Loc));
+ Subpool_Handle_Name =>
+ Relocate_Node (Subpool_Handle_Name (Allocator)),
+ Expression => New_Occurrence_Of (Result_Subt, Loc));
+
+ -- Prevent default initialization of the allocator
+
Set_No_Initialization (New_Allocator);
- -- Copy attributes to new allocator. Note that the new allocator
- -- logically comes from source if the original one did, so copy the
- -- relevant flag. This ensures proper treatment of the restriction
- -- No_Implicit_Heap_Allocations in this case.
+ -- Copy the Comes_From_Source flag onto the allocator since logically
+ -- this allocator is a replacement of the original allocator. This is
+ -- for proper handling of restriction No_Implicit_Heap_Allocations.
+
+ Preserve_Comes_From_Source (New_Allocator, Allocator);
+
+ -- Copy the attributes set by Expand_N_Allocator
Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator));
Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator));
- Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator));
Rewrite (Allocator, New_Allocator);
-- { dg-do run }
with System.Storage_Elements; use System.Storage_Elements;
with System.Storage_Pools.Subpools; use System.Storage_Pools.Subpools;
procedure Subpools2 is
B : Storage_Array (1 .. 128) with Alignment => Standard'Maximum_Alignment;
type Pool_T is new Root_Storage_Pool_With_Subpools with null record;
type Subpool_T is new Root_Subpool with null record;
type Rec is record I : Integer := 0; end record;
overriding function Create_Subpool
(Pool : in out Pool_T) return not null Subpool_Handle is
(raise Constraint_Error);
overriding procedure Deallocate_Subpool
(Pool : in out Pool_T; Subpool : in out Subpool_Handle) is null;
overriding procedure Allocate_From_Subpool
(Pool : in out Pool_T;
Storage_Address : out System.Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count;
Subpool : not null Subpool_Handle) is
begin
Storage_Address := B'Address;
end;
Pool : Pool_T;
Subpool : aliased Subpool_T;
Handle : Subpool_Handle := Subpool'Unchecked_Access;
type Subpool_A is access Rec with Storage_Pool => Pool;
Ptr : Subpool_A;
begin
Set_Pool_Of_Subpool (Handle, Pool);
Ptr := new (Handle) Rec'(I => <>);
end;
