From: Steve Baird Date: Wed, 11 Feb 2026 12:04:20 +0000 (+0100) Subject: Ada: Rework implementation of Ada.Containers.Bounded_Indefinite_Holders X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=1f8f7ad8cd77e83d75c2e6004a2d2ec8ab8d78cf;p=thirdparty%2Fgcc.git Ada: Rework implementation of Ada.Containers.Bounded_Indefinite_Holders 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) : Add support for class-wide types. : 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. --- diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst index e06a74f3e9f..e576fdbde8e 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst @@ -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. diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 48aee81609f..24f618c718a 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -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 diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index fd5ddcb4cb4..469c7c065da 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -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; diff --git a/gcc/ada/libgnat/a-cbinho.ads b/gcc/ada/libgnat/a-cbinho.ads index 471542da0bf..d7631aae3db 100644 --- a/gcc/ada/libgnat/a-cbinho.ads +++ b/gcc/ada/libgnat/a-cbinho.ads @@ -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; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index d83b873cef3..d1f9e5e46e1 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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 diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index 88be98ec666..7f77e52ebad 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -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 -- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 00f8aec87b3..05e7844d361 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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 -- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 49c968997f2..03b003db612 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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