KJ16609/gcc
1
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2026-02-22 12:00:03 -05:00
Code Issues Packages Projects Releases Wiki Activity

Ada: Fix internal error on access attribute used as subpool in allocator

Browse Source 
This is a regression present for quite a long time: the compiler aborts
on an allocator whose subpool name is an access attribute and when an
allocation procedure must be generated, for example when the allocation
is controlled.

The fix is to do what is done elsewhere in Build_Allocate_Deallocate_Proc,
that is to say pass the allocation procedure as the new scope in the call
to the New_Copy_Tree function.

gcc/ada/
	PR ada/124054
	* exp_util.adb (Build_Allocate_Deallocate_Proc): Tidy up and pass
	Proc_Id as the new scope in the call to the New_Copy_Tree function.

gcc/testsuite/
	* gnat.dg/allocator4.adb: New test.

Co-authored-by: Liam Powell <liam@liampwll.com>
This commit is contained in:
Eric Botcazou
2026-02-11 11:38:24 +01:00
parent 7a4b0cec47
commit f474ff7fc7
2 changed files with 36 additions and 15 deletions
Download Patch File Download Diff File Expand all files Collapse all files

28
gcc/ada/exp_util.adb
View File

@@ -987,23 +987,22 @@ package body Exp_Util is
Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
Actuals : List_Id;
Alloc_Expr : Node_Id := Empty;
Alloc_Expr : Node_Id;
Fin_Coll_Id : Entity_Id;
Proc_To_Call : Entity_Id;
Ptr_Coll_Id : Entity_Id;
Subpool : Node_Id := Empty;
Subpool : Node_Id;
begin
-- When we are building an allocator procedure, extract the allocator
-- node for later processing and calculation of alignment.
-- When we are building an allocator procedure, extract the qualified
-- expression from the allocator if there is one.
if Is_Allocate then
-- Extract the qualified expression if there is one from the
-- allocator.
if Nkind (Expression (Expr)) = N_Qualified_Expression then
Alloc_Expr := Expression (Expr);
end if;
if Is_Allocate
and then Nkind (Expression (Expr)) = N_Qualified_Expression
then
Alloc_Expr := Expression (Expr);
else
Alloc_Expr := Empty;
end if;
-- Step 1: Construct all the actuals for the call to library routine
@@ -1017,15 +1016,14 @@ package body Exp_Util is
-- b) Subpool
if Nkind (Expr) = N_Allocator then
Subpool := Subpool_Handle_Name (Expr);
end if;
Subpool := Subpool_Handle_Name (Expr);
-- If a subpool is present it can be an arbitrary name, so make
-- the actual by copying the tree.
if Present (Subpool) then
Append_To (Actuals, New_Copy_Tree (Subpool, New_Sloc => Loc));
Append_To
(Actuals, New_Copy_Tree (Subpool, New_Scope => Proc_Id));
else
Append_To (Actuals, Make_Null (Loc));
end if;

23
gcc/testsuite/gnat.dg/allocator4.adb Normal file
View File

@@ -0,0 +1,23 @@
-- { dg-do compile }
-- { dg-options "-gnatws" }
with System.Storage_Pools.Subpools; use System.Storage_Pools.Subpools;
with Ada.Finalization; use Ada.Finalization;
procedure Allocator4 is
type My_Subpool_Type is new Root_Subpool with null record;
type My_Subpool_Access_Type is access all My_Subpool_Type;
My_Subpool : aliased My_Subpool_Type;
My_Subpool_Access : Subpool_Handle := My_Subpool'Unchecked_Access;
type T is new Ada.Finalization.Controlled with null record;
A : access T := new (Subpool_Handle'(My_Subpool'Unchecked_Access)) T;
B : access T := new (My_Subpool_Access) T;
C : access T := new (My_Subpool'Access) T;
begin
null;
end;