[Ada] Fix internal error on access attribute used as subpool name in allocator

[Eric Botcazou]

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.

Tested on x86-64/Linux, applied on the mainline and 15 branch.


2026-02-11  Eric Botcazou  <ebotca...@adacore.com>
            Liam Powell  <l...@liampwll.com>

        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.


2026-02-11  Eric Botcazou  <ebotca...@adacore.com>
            Liam Powell  <l...@liampwll.com>

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

-- 
Eric Botcazou
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 16691780986..c2346844d0b 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -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;

--  { 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;