From: Steve Baird <[email protected]>
Implement the predefined unit Ada.Containers.Bounded_Indefinite_Holders.
gcc/ada/ChangeLog:
* Makefile.rtl: add entry for new unit
* impunit.adb: add entry for new unit
* libgnat/a-cbinho.adb: new file with body for new unit
* libgnat/a-cbinho.ads: new file with spec for new unit
* libgnat/a-coboho.ads: add comment
* libgnat/a-undesu.ads: add Preelaborate aspect specification,
as per AI22-0050.
Tested on x86_64-pc-linux-gnu (before the recent bootstrap breakage), committed
on master.
---
gcc/ada/Makefile.rtl | 1 +
gcc/ada/impunit.adb | 1 +
gcc/ada/libgnat/a-cbinho.adb | 413 +++++++++++++++++++++++++++++++++++
gcc/ada/libgnat/a-cbinho.ads | 316 +++++++++++++++++++++++++++
gcc/ada/libgnat/a-coboho.ads | 4 +
gcc/ada/libgnat/a-undesu.ads | 3 +-
6 files changed, 737 insertions(+), 1 deletion(-)
create mode 100644 gcc/ada/libgnat/a-cbinho.adb
create mode 100644 gcc/ada/libgnat/a-cbinho.ads
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
index 2c3891dc464..cd777237cfe 100644
--- a/gcc/ada/Makefile.rtl
+++ b/gcc/ada/Makefile.rtl
@@ -110,6 +110,7 @@ GNATRTL_NONTASKING_OBJS= \
a-cbdlli$(objext) \
a-cbhama$(objext) \
a-cbhase$(objext) \
+ a-cbinho$(objext) \
a-cbmutr$(objext) \
a-cborma$(objext) \
a-cborse$(objext) \
diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb
index b73c65e0c2a..003a765e48c 100644
--- a/gcc/ada/impunit.adb
+++ b/gcc/ada/impunit.adb
@@ -584,6 +584,7 @@ package body Impunit is
("a-cborma", T), -- Ada.Containers.Bounded_Ordered_Maps
("a-cbhase", T), -- Ada.Containers.Bounded_Hashed_Sets
("a-cbhama", T), -- Ada.Containers.Bounded_Hashed_Maps
+ ("a-cbinho", T), -- Ada.Containers.Bounded_Indefinite_Holders
("a-coinho", T), -- Ada.Containers.Indefinite_Holders
("a-comutr", T), -- Ada.Containers.Multiway_Trees
("a-cimutr", T), -- Ada.Containers.Indefinite_Multiway_Trees
diff --git a/gcc/ada/libgnat/a-cbinho.adb b/gcc/ada/libgnat/a-cbinho.adb
new file mode 100644
index 00000000000..94f479b487f
--- /dev/null
+++ b/gcc/ada/libgnat/a-cbinho.adb
@@ -0,0 +1,413 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.BOUNDED_INDEFINITE_HOLDERS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2011-2025, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocate_Subpool;
+with Ada.Unchecked_Deallocation;
+with System.Put_Images;
+
+package body Ada.Containers.Bounded_Indefinite_Holders is
+
+ use type System.Address;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Element_Type, Element_Access);
+
+ function "=" (Left, Right : Holder) return Boolean is
+ (if Left.Element = null or Right.Element = null
+ then Left.Element = Right.Element
+ else Left.Element.all = Right.Element.all);
+
+ ------------
+ -- Adjust --
+ ------------
+
+ overriding procedure Adjust (Container : in out Holder) is
+ begin
+ Container.Handle := Create_Subpool (The_Storage_Pool, Container);
+ Container.Element :=
+ new (Container.Handle) Element_Type'(Container.Element.all);
+ end Adjust;
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (Target : in out Holder; Source : Holder) is
+ begin
+ if Target'Address /= Source'Address then
+ if Is_Empty (Source) then
+ Clear (Target);
+ else
+ Replace_Element (Target, Source.Element.all);
+ end if;
+ end if;
+ end Assign;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Holder) is
+ begin
+ if Is_Empty (Container) then
+ return; -- nothing to do
+ end if;
+ if Container.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+ end if;
+ Free (Container.Element); -- finalize element
+ Ada.Unchecked_Deallocate_Subpool (Container.Handle);
+ end Clear;
+
+ ------------------------
+ -- Constant_Reference --
+ ------------------------
+
+ function Constant_Reference
+ (Container : aliased Holder) return Constant_Reference_Type
+ is
+ Ref : constant Constant_Reference_Type :=
+ (Element => Container.Element,
+ Control => (Controlled with Container'Unrestricted_Access));
+ B : Natural renames Ref.Control.Container.Busy;
+ begin
+ B := B + 1;
+ return Ref;
+ end Constant_Reference;
+
+ ----------
+ -- Copy --
+ ----------
+
+ function Copy (Source : Holder) return Holder is
+ (if Is_Empty (Source)
+ then Empty_Holder
+ else To_Holder (Source.Element.all));
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Container : Holder) return Element_Type is
+ (Container.Element.all);
+
+ --------------
+ -- Finalize --
+ --------------
+
+ overriding procedure Finalize (Container : in out Holder) is
+ begin
+ Clear (Container);
+ end Finalize;
+
+ -- NOTE: No procedure Initialize because requires preelaborable init.
+ overriding procedure Finalize (Control : in out Reference_Control_Type) is
+ begin
+ if Control.Container /= null then
+ declare
+ B : Natural renames Control.Container.Busy;
+ begin
+ B := B - 1;
+ end;
+ end if;
+
+ Control.Container := null;
+ end Finalize;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Holder) return Boolean
+ is (Container.Element = null);
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out Holder; Source : in out Holder) is
+ begin
+ if Target'Address /= Source'Address then
+ Assign (Target => Target, Source => Source);
+ Clear (Source);
+ end if;
+ end Move;
+
+ ---------------
+ -- Put_Image --
+ ---------------
+
+ procedure Put_Image
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Holder)
+ is
+ use System.Put_Images;
+ begin
+ Array_Before (S);
+ if not Is_Empty (V) then
+ Element_Type'Put_Image (S, Element (V));
+ end if;
+ Array_After (S);
+ end Put_Image;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Container : Holder;
+ Process : not null access procedure (Element : Element_Type)) is
+ begin
+ Process.all (Container.Element.all);
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Holder)
+ is
+ begin
+ if Boolean'Input (Stream) then
+ Clear (Container);
+ else
+ Replace_Element (Container, Element_Type'Input (Stream));
+ end if;
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference
+ (Container : aliased in out Holder) return Reference_Type
+ is
+ Ref : constant Reference_Type :=
+ (Element => Container.Element,
+ Control => (Controlled with Container'Unrestricted_Access));
+ begin
+ Container.Busy := Container.Busy + 1;
+ return Ref;
+ end Reference;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Container : in out Holder; New_Item : Element_Type)
+ is
+ begin
+ if (New_Item'Size / System.Storage_Unit) +
+ Boolean'Pos (New_Item'Size mod System.Storage_Unit /= 0) >
+ Max_Element_Size_In_Storage_Elements
+ then
+ -- New_Item is too big; detect this early, before calling Clear
+ -- (as opposed to catching it later in Allocate_From_Subpool).
+ raise Program_Error;
+ end if;
+ Clear (Container);
+ if Container.Handle = null then
+ Container.Handle := Create_Subpool (The_Storage_Pool, Container);
+ end if;
+ Container.Element := new (Container.Handle) Element_Type'(New_Item);
+ end Replace_Element;
+
+ ---------------------
+ -- Subpool_Support --
+ ---------------------
+
+ package body Subpool_Support is
+ function Create_Subpool (Pool : in out Holder_Pool_Type)
+ return not null Subpool_Handle is
+ begin
+ return (raise Program_Error);
+ end Create_Subpool;
+
+ function Aligned_Address
+ (Addr : System.Address; Alignment : Storage_Count)
+ return System.Address;
+ -- Return Addr, rounded up to multiple of Alignment
+
+ function Aligned_Address
+ (Addr : System.Address; Alignment : Storage_Count)
+ return System.Address
+ is
+ Initial_Align : constant Storage_Count := Addr mod Alignment;
+ begin
+ if Initial_Align = 0 then
+ -- Already aligned
+ return Addr;
+ else
+ -- Adjust to get into alignment
+ return Addr + (Alignment - Initial_Align);
+ end if;
+ end Aligned_Address;
+
+ function Create_Subpool
+ (Pool : in out Holder_Pool_Type'Class; Container : Holder)
+ return not null Subpool_Handle
+ is
+ -- Compute start addresses for subpool and element within Storage
+ Subpool_Start : constant System.Address :=
+ Aligned_Address
+ (Container.Wrapper.Storage'Address, Holder_Subpool'Alignment);
+
+ Element_Start : constant System.Address :=
+ 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).
+ begin
+ Set_Pool_Of_Subpool (Subpool'Unchecked_Access, Pool);
+ -- Return the handle
+ return Subpool'Unchecked_Access;
+ end Create_Subpool;
+
+ procedure Allocate_From_Subpool
+ (Pool : in out Holder_Pool_Type;
+ Storage_Address : out System.Address;
+ Size_In_Storage_Elements : Storage_Count;
+ Alignment : Storage_Count;
+ Subpool : not null Subpool_Handle) is
+ begin
+ if Size_In_Storage_Elements + Alignment >
+ Max_Element_Size_In_Storage_Elements + Element_Type'Alignment
+ then
+ -- If we pass the size check in Replace_Element (which we had to
+ -- in order to get here) and then fail this check, then that is
+ -- a bug (although arguably a corner case).
+ -- If we get here, that probably means that the result returned
+ -- by Max_Allocation_Overhead_In_Storage_Elements was too small
+ -- (with the result that Bound_Range'Last is too small).
+ raise Program_Error;
+ end if;
+ Storage_Address :=
+ Aligned_Address (Holder_Subpool (Subpool.all).Start, Alignment);
+ end Allocate_From_Subpool;
+
+ procedure Deallocate_Subpool
+ (Pool : in out Holder_Pool_Type;
+ Subpool : in out Subpool_Handle) is
+ begin
+ -- Nothing to do
+ null;
+ end Deallocate_Subpool;
+
+ end Subpool_Support;
+
+ ----------
+ -- Swap --
+ ----------
+
+ procedure Swap (Left, Right : in out Holder) is
+ Temp : Holder;
+ begin
+ Assign (Target => Temp, Source => Left);
+ Move (Target => Left, Source => Right);
+ Move (Target => Right, Source => Temp);
+ end Swap;
+
+ ---------------
+ -- To_Holder --
+ ---------------
+
+ function To_Holder (New_Item : Element_Type) return Holder is
+ begin
+ return Result : Holder do
+ Replace_Element (Result, New_Item);
+ end return;
+ end To_Holder;
+
+ --------------------
+ -- Update_Element --
+ --------------------
+
+ procedure Update_Element
+ (Container : in out Holder;
+ Process : not null access procedure (Element : in out Element_Type)) is
+ begin
+ Process.all (Container.Element.all);
+ end Update_Element;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Holder)
+ is
+ begin
+ -- Polarity of this Boolean determined by streaming-related
+ -- implementation requirements of RM A.18.32.
+
+ Boolean'Write (Stream, Container.Element = null);
+ if Container.Element /= null then
+ Element_Type'Write (Stream, Container.Element.all);
+ end if;
+ end Write;
+
+end Ada.Containers.Bounded_Indefinite_Holders;
diff --git a/gcc/ada/libgnat/a-cbinho.ads b/gcc/ada/libgnat/a-cbinho.ads
new file mode 100644
index 00000000000..0aaacd356aa
--- /dev/null
+++ b/gcc/ada/libgnat/a-cbinho.ads
@@ -0,0 +1,316 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.BOUNDED_INDEFINITE_HOLDERS --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2011-2025, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements; use System.Storage_Elements;
+
+private with Ada.Finalization;
+private with Ada.Streams;
+private with Ada.Strings.Text_Buffers;
+private with System.Storage_Pools.Subpools;
+
+generic
+ type Element_Type (<>) is private;
+ Max_Element_Size_In_Storage_Elements : Storage_Count;
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Bounded_Indefinite_Holders is
+ pragma Annotate (CodePeer, Skip_Analysis);
+ pragma Preelaborate (Bounded_Indefinite_Holders);
+ pragma Remote_Types (Bounded_Indefinite_Holders);
+
+ type Holder is tagged private
+ with
+ Preelaborable_Initialization => Element_Type'Preelaborable_Initialization;
+
+ Empty_Holder : constant Holder;
+
+ function "=" (Left, Right : Holder) return Boolean;
+
+ function To_Holder (New_Item : Element_Type) return Holder;
+
+ function Is_Empty (Container : Holder) return Boolean;
+
+ procedure Clear (Container : in out Holder);
+
+ function Element (Container : Holder) return Element_Type;
+
+ procedure Replace_Element
+ (Container : in out Holder;
+ New_Item : Element_Type);
+
+ procedure Query_Element
+ (Container : Holder;
+ Process : not null access procedure (Element : Element_Type));
+
+ procedure Update_Element
+ (Container : in out Holder;
+ Process : not null access procedure (Element : in out Element_Type));
+
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is limited private
+ with
+ Implicit_Dereference => Element;
+
+ type Reference_Type
+ (Element : not null access Element_Type) is limited private
+ with
+ Implicit_Dereference => Element;
+
+ function Constant_Reference
+ (Container : aliased Holder) return Constant_Reference_Type;
+ pragma Inline (Constant_Reference);
+
+ function Reference
+ (Container : aliased in out Holder) return Reference_Type;
+ pragma Inline (Reference);
+
+ procedure Assign (Target : in out Holder; Source : Holder);
+
+ function Copy (Source : Holder) return Holder;
+
+ procedure Move (Target : in out Holder; Source : in out Holder);
+
+ procedure Swap (Left, Right : in out Holder);
+
+private
+
+ use Ada.Finalization;
+ use Ada.Streams;
+ use System.Storage_Pools.Subpools;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Holder);
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Holder);
+
+ procedure Put_Image
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Holder);
+
+ package Subpool_Support is
+
+ type Holder_Pool_Type is
+ limited new Root_Storage_Pool_With_Subpools with null record;
+
+ type Holder_Subpool is
+ limited new Root_Subpool with record
+ Start : System.Address := System.Null_Address;
+ end record;
+
+ overriding
+ function Create_Subpool (Pool : in out Holder_Pool_Type)
+ return not null Subpool_Handle
+ ; -- tbd with No_Return;
+ -- We never use this one. It will raise Program_Error
+
+ overriding
+ procedure Allocate_From_Subpool
+ (Pool : in out Holder_Pool_Type;
+ Storage_Address : out System.Address;
+ Size_In_Storage_Elements : Storage_Count;
+ Alignment : Storage_Count;
+ Subpool : not null Subpool_Handle);
+
+ overriding
+ procedure Deallocate_Subpool
+ (Pool : in out Holder_Pool_Type;
+ Subpool : in out Subpool_Handle);
+
+ function Create_Subpool
+ (Pool : in out Holder_Pool_Type'Class; Container : Holder)
+ return not null Subpool_Handle;
+
+ The_Storage_Pool : Holder_Pool_Type;
+ -- The one and only object of this type ever created.
+ end Subpool_Support;
+
+ use Subpool_Support;
+
+ type Element_Access is access Element_Type
+ with Storage_Pool => Subpool_Support.The_Storage_Pool,
+ Size => Standard'Address_Size;
+ -- Size specification needed to ensure contiguous bounds if Element_Type
+ -- turns out to be an unconstrained array subtype. We do not want a
+ -- fat-pointer representation in that case.
+
+ pragma No_Strict_Aliasing (Element_Access);
+ -- Needed because we are unchecked-converting from Address to
+ -- Element_Access (see package body), which is a violation of the
+ -- normal aliasing rules enforced by gcc.
+
+ Worst_Case_Alignment : constant Storage_Count :=
+ Storage_Count'Max (Holder_Subpool'Alignment,
+ Storage_Count'Max (System.Address'Alignment,
+ Element_Type'Alignment));
+
+ -- Convert Element_Type'Size from bits to bytes, rounding up
+ Element_Size_In_Storage_Elements : constant Long_Integer :=
+ Long_Integer ((Element_Type'Size / System.Storage_Unit) +
+ Boolean'Pos (Element_Type'Size mod System.Storage_Unit /= 0));
+
+ -- An upper bound on additional storage required for an allocator for data
+ -- other than the allocated object itself. This includes things like
+ -- array bounds (if Element_Type is an unconstrained array subtype),
+ -- finalization-related linkage (if Element_Type requires
+ -- finalization), alignment-related gaps between such prefix info and the
+ -- allocated object, etc. This does not include alignment-related
+ -- overhead except for aforementioned possibility of an alignment-related
+ -- gap between some prefix data and the object itself.
+
+ function Max_Allocation_Overhead_In_Storage_Elements return Storage_Count is
+ (if Element_Size_In_Storage_Elements >= Long_Integer (Integer'Last) then
+ -- If the more precise computation in the else-arm (below) could
+ -- overflow or return the wrong answer then return a guess.
+ -- We get a multiplier of 6 by adding 2 for finalization-linkage
+ -- and 4 for array bounds. If we have an unconstrained array subtype
+ -- with a controlled element type and with multiple dimensions each
+ -- indexed by Long_Long_Integer, then this guess could be too small.
+ System.Address'Max_Size_In_Storage_Elements * 6
+ else
+ Storage_Count (Element_Type'Max_Size_In_Storage_Elements -
+ Element_Size_In_Storage_Elements));
+ --
+ -- ??? It would be helpful if GNAT provided this value as an attribute so
+ -- that we would not have to deal with the "huge" case here. Instead, we
+ -- use a very imprecise "hugeness" test; in the "huge" case, we return an
+ -- estimate. If the estimate turns out to be too small, then it is
+ -- possible for the size check in Allocate_From_Subpool to fail even
+ -- though the earlier (earlier at run-time) size check in Replace_Element
+ -- passed. A GNAT-defined attribute could eliminate this issue.
+
+ -- Compute extra amount needed for space requested for an allocator
+ -- (specifically, in a call to Allocate_From_Subpool) in addition to
+ -- the space required for the allocated object itself.
+ Extra_Storage : constant Storage_Count :=
+ Holder_Subpool'Max_Size_In_Storage_Elements +
+ Worst_Case_Alignment * 2 +
+ Max_Allocation_Overhead_In_Storage_Elements;
+
+ subtype Bound_Range is Storage_Count range
+ 0 .. Max_Element_Size_In_Storage_Elements + Extra_Storage;
+
+ type Storage_Wrapper (Bound : Bound_Range := 0) is record
+ Storage : aliased Storage_Array (1 .. Bound);
+ -- Should allocate space for case when Bound = Bound_Range'Last
+ -- but we actually leave Bound at zero so assignment
+ -- is faster (this wouldn't work if the compiler didn't
+ -- allocate the "max" for types with defaulted discriminants).
+ end record;
+
+ type Holder is new Ada.Finalization.Controlled with record
+ Busy : Natural := 0;
+ Handle : Subpool_Handle;
+ Element : Element_Access;
+ Wrapper : Storage_Wrapper;
+ end record
+ with Put_Image => Put_Image, Read => Read, Write => Write;
+
+ overriding procedure Adjust (Container : in out Holder);
+ overriding procedure Finalize (Container : in out Holder);
+
+ type Holder_Access is access all Holder;
+ for Holder_Access'Storage_Size use 0;
+
+ -- Instead of declaring Reference_Control_Type as a controlled type,
+ -- we could use the GNAT-defined Finalizable aspect instead.
+ -- But we would not want to make this change only in this unit - many
+ -- of the container generics declare a Reference_Control_Type type.
+ -- In particular, we want to minimize differences between this unit
+ -- and the corresponding unbounded unit (Ada.Indefinite_Holders).
+
+ type Reference_Control_Type is new Controlled with record
+ Container : Holder_Access;
+ end record;
+
+ overriding procedure Finalize (Control : in out Reference_Control_Type);
+ pragma Inline (Finalize);
+
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is
+ record
+ Control : Reference_Control_Type :=
+ (raise Program_Error with "default initialized reference");
+ -- The RM says, "The default initialization of an object of
+ -- type Constant_Reference_Type or Reference_Type propagates
+ -- Program_Error."
+ end record;
+
+ type Reference_Type
+ (Element : not null access Element_Type) is
+ record
+ Control : Reference_Control_Type :=
+ (raise Program_Error with "default initialized reference");
+ -- The RM says, "The default initialization of an object of
+ -- type Constant_Reference_Type or Reference_Type propagates
+ -- Program_Error."
+ end record;
+
+ -- The following four streaming-related subprograms could be
+ -- deleted (the two reference types are limited as a result of
+ -- AI22-0082, so streaming operations are not available for them).
+ -- But we do not want to perform this cleanup only in this unit - the
+ -- same change should be made for all the container generics.
+ -- In particular, we want to minimize differences between this unit
+ -- and the corresponding unbounded unit (Ada.Indefinite_Holders).
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type);
+
+ for Constant_Reference_Type'Read use Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type);
+
+ for Reference_Type'Read use Read;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type);
+
+ for Constant_Reference_Type'Write use Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type);
+
+ for Reference_Type'Write use Write;
+
+ Empty_Holder : constant Holder := (Controlled with
+ Busy => 0,
+ Handle => null,
+ Element => null,
+ Wrapper => (Bound => 0, others => <>));
+
+end Ada.Containers.Bounded_Indefinite_Holders;
diff --git a/gcc/ada/libgnat/a-coboho.ads b/gcc/ada/libgnat/a-coboho.ads
index ad3f3a9278b..6709a9f73f0 100644
--- a/gcc/ada/libgnat/a-coboho.ads
+++ b/gcc/ada/libgnat/a-coboho.ads
@@ -69,6 +69,10 @@ package Ada.Containers.Bounded_Holders is
-- The 'Size of each Element_Type object must be a multiple of
-- System.Storage_Unit; e.g. creating Holders from 5-bit objects won't
-- work.
+ --
+ -- Do not confuse this GNAT-defined unit with the similar (similar
+ -- in both name and functionality) predefined unit
+ -- Ada.Containers.Bounded_Indefinite_Holders described in Ada RM A.18.32.
type Holder is private
with Preelaborable_Initialization
diff --git a/gcc/ada/libgnat/a-undesu.ads b/gcc/ada/libgnat/a-undesu.ads
index 666572530dd..8c76590c883 100644
--- a/gcc/ada/libgnat/a-undesu.ads
+++ b/gcc/ada/libgnat/a-undesu.ads
@@ -16,4 +16,5 @@
with System.Storage_Pools.Subpools;
procedure Ada.Unchecked_Deallocate_Subpool
- (Subpool : in out System.Storage_Pools.Subpools.Subpool_Handle);
+ (Subpool : in out System.Storage_Pools.Subpools.Subpool_Handle)
+ with Preelaborate;
--
2.51.0
