[Ada] Fix Program_Error raised in a Bounded_Indefinite_Holders instance

[Eric Botcazou]

From: Steve Baird <ba...@adacore.com>

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.

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


gcc/ada/ChangeLog:
        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.

-- 
Eric Botcazou
diff --git a/gcc/ada/libgnat/a-cbinho.adb b/gcc/ada/libgnat/a-cbinho.adb
index a5c513c24e6..8949bfe4c5d 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 bc55665e0e3..c6d941af0a0 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 b5ef2a0e9fe..13d7889471a 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.