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

Ada: Rework implementation of Ada.Containers.Bounded_Indefinite_Holders

Browse Source 
In particular, this adds support for the case where the Element_Type actual
parameter is a class-wide type.

gcc/ada/
	PR ada/124016
	* doc/gnat_rm/implementation_defined_attributes.rst: Document
	that Finalization_Size attribute is defined for class-wide types.
	* exp_attr.adb (Expand_N_Attribute_Reference) <Finalization_Size>:
	Add support for class-wide types.
	<Size>: Raise Constraint_Error for class-wide types.
	* exp_imgv.adb (Expand_Image_Attribute): Adjust call to renaming.
	(Expand_Wide_Image_Attribute): Likewise.
	(Expand_Wide_Wide_Image_Attribute): Likewise.
	* sem_attr.ads (Finalization_Size): Update comment.
	* sem_attr.adb (Analyze_Image): Adjust call to renaming.
	(Analyze_Attribute): Remove check disallowing Finalization_Size
	attribute for class-wide types.
	* sem_util.ads (Is_Object_Image): Rename into...
	(Is_Object_Prefix): ...this.
	* sem_util.adb (Is_Object_Image): Rename into...
	(Is_Object_Prefix): ...this.
	* libgnat/a-cbinho.ads (Extra_Storage): Use Descriptor_Size and
	Finalization_Size attributes.
	(Max_Allocation_Overhead_In_Storage_Elements): Delete.
This commit is contained in:
Steve Baird
2026-02-11 13:04:20 +01:00
committed by Eric Botcazou
parent cd0bab7469
commit 1f8f7ad8cd
8 changed files with 39 additions and 60 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
View File

@@ -416,13 +416,15 @@ Attribute Finalization_Size
.. index:: Finalization_Size
The prefix of attribute ``Finalization_Size`` must be an object or
a non-class-wide type. This attribute returns the size of any hidden data
a type. This attribute returns the size of any hidden data
reserved by the compiler to handle finalization-related actions. The type of
the attribute is *universal_integer*.
``Finalization_Size`` yields a value of zero for a type with no controlled
parts, an object whose type has no controlled parts, or an object of a
class-wide type whose tag denotes a type with no controlled parts.
For a class-wide type, ``Finalization_Size`` yields a non-zero value except
if a No_Finalization restriction is in effect, in which case it yields zero.
Note that only heap-allocated objects contain finalization data.

22
gcc/ada/exp_attr.adb
View File

@@ -30,6 +30,7 @@ with Debug; use Debug;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Atag; use Exp_Atag;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
@@ -4050,7 +4051,7 @@ package body Exp_Attr is
--
-- and the attribute reference is replaced with a reference to Size.
elsif Is_Class_Wide_Type (Ptyp) then
elsif Is_Class_Wide_Type (Ptyp) and then Is_Object_Prefix (Pref) then
Size := Make_Temporary (Loc, 'S');
Insert_Actions (N, New_List (
@@ -7342,14 +7343,25 @@ package body Exp_Attr is
end if;
end if;
-- If the prefix is X'Class, transform it into a direct reference
-- to the class-wide type, because the back end must not see a
-- 'Class reference.
-- If the prefix is X'Class, transform it into a
-- raise of Constraint_Error.
if Is_Entity_Name (Pref)
and then Is_Class_Wide_Type (Entity (Pref))
then
Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
pragma Assert (not Is_Mutably_Tagged_Type (Entity (Pref)));
-- In the Mutably_Tagged_Case, this attribute reference
-- should have been transformed into an integer literal
-- (in Eval_Attribute) before we get here.
-- If this assertion ever fails, the thing to do here
-- is generate a literal equal to the specified
-- T'Size'Class [sic] aspect value.
Error_Msg_N
("Constraint_Error will be raised at run time??", N);
Rewrite (N, Make_Raise_Constraint_Error
(Loc, Reason => CE_Range_Check_Failed));
Set_Etype (N, Etype (Original_Node (N)));
return;
-- For X'Size applied to an object of a class-wide type, transform

6
gcc/ada/exp_imgv.adb
View File

@@ -1042,7 +1042,7 @@ package body Exp_Imgv is
-- Start of processing for Expand_Image_Attribute
begin
if Is_Object_Image (Pref) then
if Is_Object_Prefix (Pref) then
Rewrite_Object_Image (N, Pref, Name_Image, Standard_String);
return;
end if;
@@ -1856,7 +1856,7 @@ package body Exp_Imgv is
Rtyp : Entity_Id;
begin
if Is_Object_Image (Pref) then
if Is_Object_Prefix (Pref) then
Rewrite_Object_Image (N, Pref, Name_Wide_Image, Standard_Wide_String);
return;
end if;
@@ -1965,7 +1965,7 @@ package body Exp_Imgv is
Rtyp : Entity_Id;
begin
if Is_Object_Image (Pref) then
if Is_Object_Prefix (Pref) then
Rewrite_Object_Image
(N, Pref, Name_Wide_Wide_Image, Standard_Wide_Wide_String);
return;

33
gcc/ada/libgnat/a-cbinho.ads
View File

@@ -173,11 +173,6 @@ private
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),
@@ -187,38 +182,14 @@ private
-- overhead except for aforementioned possibility of an alignment-related
-- gap between some prefix data and the object itself.
pragma Warnings (Off); -- avoid warnings for exceptions raised in dead code
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.
pragma Warnings (On);
-- 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;
(Element_Type'Descriptor_Size / System.Storage_Unit) +
(Element_Type'Finalization_Size / System.Storage_Unit);
subtype Bound_Range is Storage_Count range
0 .. Max_Element_Size_In_Storage_Elements + Extra_Storage;

11
gcc/ada/sem_attr.adb
View File

@@ -1575,7 +1575,7 @@ package body Sem_Attr is
-- scalar types, so that the prefix can be an object, a named value,
-- or a type. If the prefix is an object, there is no argument.
if Is_Object_Image (P) then
if Is_Object_Prefix (P) then
Check_E0;
Set_Etype (N, Str_Typ);
Check_Image_Type (Etype (P));
@@ -4418,15 +4418,6 @@ package body Sem_Attr is
Check_Type;
Check_Not_Incomplete_Type;
-- Attribute 'Finalization_Size is not defined for class-wide
-- types because it is not possible to know statically whether
-- a definite type will have controlled components or not.
if Is_Class_Wide_Type (Etype (P)) then
Error_Attr_P
("prefix of % attribute cannot denote a class-wide type");
end if;
-- The prefix denotes an illegal construct
else

5
gcc/ada/sem_attr.ads
View File

@@ -217,10 +217,11 @@ package Sem_Attr is
-----------------------
Attribute_Finalization_Size => True,
-- For every object or non-class-wide-type, Finalization_Size returns
-- the size of the hidden header used for finalization purposes as if
-- For every object or type, Finalization_Size returns the (possibly
-- zero) size of the hidden header used for finalization purposes as if
-- the object or type was allocated on the heap. The size of the header
-- does take into account any extra padding due to alignment issues.
-- See Sem_Util.Needs_Finalization for treatment of class-wide types.
-----------------
-- Fixed_Value --

10
gcc/ada/sem_util.adb
View File

@@ -19849,11 +19849,11 @@ package body Sem_Util is
end case;
end Is_Null_Record_Type;
---------------------
-- Is_Object_Image --
---------------------
----------------------
-- Is_Object_Prefix --
----------------------
function Is_Object_Image (Prefix : Node_Id) return Boolean is
function Is_Object_Prefix (Prefix : Node_Id) return Boolean is
begin
-- Here we test for the case that the prefix is not a type and assume
-- if it is not then it must be a named value or an object reference.
@@ -19863,7 +19863,7 @@ package body Sem_Util is
return not (Is_Entity_Name (Prefix)
and then Is_Type (Entity (Prefix))
and then not Is_Current_Instance (Prefix));
end Is_Object_Image;
end Is_Object_Prefix;
-------------------------
-- Is_Object_Reference --

8
gcc/ada/sem_util.ads
View File

@@ -2350,9 +2350,11 @@ package Sem_Util is
-- (with a null extension if tagged). Returns True for interface types,
-- False for discriminated types.
function Is_Object_Image (Prefix : Node_Id) return Boolean;
-- Returns True if an 'Img, 'Image, 'Wide_Image, or 'Wide_Wide_Image
-- attribute is applied to an object.
function Is_Object_Prefix (Prefix : Node_Id) return Boolean;
-- Returns True if the given prefix of an attribute reference denotes
-- an object. Useful for attributes such as 'Img, 'Image, 'Wide_Image,
-- or 'Wide_Wide_Image, where the prefix may denote either an object or
-- a type/subtype.
function Is_Object_Reference (N : Node_Id) return Boolean;
-- Determines if the tree referenced by N represents an object. Both