[gcc r16-8051] Ada: Fix Program_Error raised in a Bounded_Indefinite_Holders instance

[Eric Botcazou]

https://gcc.gnu.org/g:ec93f25c4b0fa3d17928d576157cdfac9985459e

commit r16-8051-gec93f25c4b0fa3d17928d576157cdfac9985459e
Author: Steve Baird <baird@adacore.com>
Date:   Thu Mar 12 18:18:36 2026 +0100

    Ada: Fix Program_Error raised in a Bounded_Indefinite_Holders instance
    
    If Ada.Containers.Bounded_Indefinite_Holders is instantiated with an
    Element_Type that requires finalization, the declaration of a Holder
    object with an explicit initial value may incorrectly raise Program_Error
    during its elaboration.
    
    gcc/ada/
            PR ada/124016
            * libgnat/a-cbinho.adb (Create_Subpool): Handle the case where
            the type Holder_Subpool has nontrivial finalization. Declare the
            local variable Subpool with its Import aspect specified (to avoid
            unwanted finalization), and make corresponding changes in order to
            initialize that variable.
            * libgnat/s-stposu.ads (_Adjust_Clone): New procedure.
            * libgnat/s-stposu.adb (_Adjust_Clone): New body.

Diff:
---
 gcc/ada/libgnat/a-cbinho.adb | 36 ++++++++++++++++++++++++++++++------
 gcc/ada/libgnat/s-stposu.adb |  9 +++++++++
 gcc/ada/libgnat/s-stposu.ads | 12 ++++++++++++
 3 files changed, 51 insertions(+), 6 deletions(-)

diff --git a/gcc/ada/libgnat/a-cbinho.adb b/gcc/ada/libgnat/a-cbinho.adb
index a5c513c24e67..8949bfe4c5dc 100644
--- a/gcc/ada/libgnat/a-cbinho.adb
+++ b/gcc/ada/libgnat/a-cbinho.adb
@@ -298,13 +298,37 @@ package body Ada.Containers.Bounded_Indefinite_Holders is
            Subpool_Start + Holder_Subpool'Max_Size_In_Storage_Elements;
             --  Will deal with alignment on allocation
 
-         Subpool : aliased Holder_Subpool :=
-           (Root_Subpool with Start => Element_Start)
-           with Address => Subpool_Start;
-          --  We depend here on the type Holder_Subpool not having nontrivial
-          --  finalization (if it did then this local object would be
-          --  finalized earlier than what we want).
+         Subpool : aliased Holder_Subpool
+           with Address => Subpool_Start, Import;
+         --  Import is specified to avoid unwanted early finalization.
+         --  But that also prevents initialization (via either default
+         --  initialization or an explicit initial value expression) ...
       begin
+         --  ... so instead initialize Subpool via overlays. But that
+         --  assumes a representation where copying bytes works, and that
+         --  assumption doesn't hold for self-referential pointers.
+         --  So we also call Subpools._Adjust_Clone (sic). Ugly.
+
+         declare
+            use System;
+
+            Subpool_Init_Source : aliased Holder_Subpool :=
+              (Root_Subpool with Start => Element_Start);
+
+            pragma Assert (Holder_Subpool'Size mod Storage_Unit = 0);
+
+            subtype Holder_Subpool_Storage is
+              Storage_Array (1 .. Holder_Subpool'Size / Storage_Unit);
+            Source : Holder_Subpool_Storage with Import,
+              Address => Subpool_Init_Source'Address;
+            Target : Holder_Subpool_Storage with Import,
+              Address => Subpool'Address;
+         begin
+            Target := Source;
+            --  leading underscore is deliberate
+            _Adjust_Clone (Root_Subpool (Subpool));
+         end;
+
          Set_Pool_Of_Subpool (Subpool'Unchecked_Access, Pool);
          --  Return the handle
          return Subpool'Unchecked_Access;
diff --git a/gcc/ada/libgnat/s-stposu.adb b/gcc/ada/libgnat/s-stposu.adb
index bc55665e0e33..c6d941af0a07 100644
--- a/gcc/ada/libgnat/s-stposu.adb
+++ b/gcc/ada/libgnat/s-stposu.adb
@@ -695,4 +695,13 @@ package body System.Storage_Pools.Subpools is
       Attach (N_Ptr, To.Subpools'Unchecked_Access);
    end Set_Pool_Of_Subpool;
 
+   -------------------
+   -- _Adjust_Clone --
+   -------------------
+
+   procedure _Adjust_Clone (Subpool : in out Root_Subpool) is
+   begin
+      Finalization_Primitives.Initialize (Subpool.Collection);
+   end _Adjust_Clone;
+
 end System.Storage_Pools.Subpools;
diff --git a/gcc/ada/libgnat/s-stposu.ads b/gcc/ada/libgnat/s-stposu.ads
index b5ef2a0e9fe0..13d7889471a8 100644
--- a/gcc/ada/libgnat/s-stposu.ads
+++ b/gcc/ada/libgnat/s-stposu.ads
@@ -131,6 +131,18 @@ package System.Storage_Pools.Subpools is
    is
       (System.Storage_Elements.Storage_Count'Last);
 
+   procedure _Adjust_Clone (Subpool : in out Root_Subpool);
+   --  After copying the value of an initialized (but otherwise unused)
+   --  Root_Subpool object into another subpool object using unchecked
+   --  techniques (an assignment statement would be illegal), this
+   --  procedure is called to fixup the copy (in particular, it fixes up
+   --  self-referential access values contained therein).
+   --
+   --  The leading underscore is intentional. We don't want a user-visible
+   --  declaration that is not mentioned in the spec for this package that
+   --  is given in the Ada RM. This subprogram is called only from the body
+   --  of Ada.Containers.Bounded_Indefinite_Holders.
+
 private
    --  SP_Nodes are created on the heap, while collection nodes and associated
    --  objects are created on the pool_with_subpools.