https://gcc.gnu.org/g:d6358ae1e9fcdc247d4527b763681cdd22d18ee0
commit r17-1303-gd6358ae1e9fcdc247d4527b763681cdd22d18ee0 Author: Eric Botcazou <[email protected]> Date: Sat May 9 15:50:14 2026 +0200 ada: Lift restriction on Valid_Scalars attribute for private tagged types This just generalizes a trick already used for discriminant checks. gcc/ada/ChangeLog: * doc/gnat_rm/implementation_defined_attributes.rst (Valid_Scalars): Remove reference to private tagged types. * exp_attr.adb (Expand_N_Attribute_Reference) <Valid_Scalars>: Do not bail out for private tagged types. * sem_attr.adb (Analyze_Attribute) <Valid_Scalars>: Do not warn for for private tagged types. * sem_ch3.adb (Is_Visible_Component): Accept any component reference whose prefix is a type conversion that does not come from source. * gnat_rm.texi: Regenerate. Diff: --- .../gnat_rm/implementation_defined_attributes.rst | 4 ++-- gcc/ada/exp_attr.adb | 17 +---------------- gcc/ada/gnat_rm.texi | 4 ++-- gcc/ada/sem_attr.adb | 22 +--------------------- gcc/ada/sem_ch3.adb | 21 +++++++++++++-------- 5 files changed, 19 insertions(+), 49 deletions(-) diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst index ce568c48f6e0..75ecfb7ea864 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst @@ -1687,8 +1687,8 @@ Attribute Valid_Scalars The ``'Valid_Scalars`` attribute is intended to make it easier to check the validity of scalar subcomponents of composite objects. The attribute is defined for any prefix ``P`` which denotes an object. Prefix ``P`` can be any type -except for tagged private or ``Unchecked_Union`` types. The value of the -attribute is of type ``Boolean``. +except for ``Unchecked_Union`` types. The value of the attribute is of type +``Boolean``. ``P'Valid_Scalars`` yields ``True`` if and only if the evaluation of ``C'Valid`` yields ``True`` for every scalar subcomponent ``C`` of ``P``, or if diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 8021a591c67d..32b8297cd580 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -8636,25 +8636,10 @@ package body Exp_Attr is Expr := Empty; - -- Attribute 'Valid_Scalars is not supported on private tagged types; - -- see a detailed explanation where this attribute is analyzed. - - if Is_Private_Type (Ptyp) - and then (Is_Tagged_Type (Ptyp) - or else (Present (Full_View (Ptyp)) - and then Is_Tagged_Type (Full_View (Ptyp)))) - then - null; - - elsif Is_Class_Wide_Type (Ptyp) - and then Is_Private_Type (Root_Type (Ptyp)) - then - null; - -- Attribute 'Valid_Scalars evaluates to True when the type lacks -- scalars. - elsif not Scalar_Part_Present (Val_Typ) then + if not Scalar_Part_Present (Val_Typ) then null; -- Attribute 'Valid_Scalars is the same as attribute 'Valid when the diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index da0fa654e7dd..bfaa204114f9 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -12768,8 +12768,8 @@ returns True if and only if @code{T'Value (S)} would not raise Constraint_Error. The @code{'Valid_Scalars} attribute is intended to make it easier to check the validity of scalar subcomponents of composite objects. The attribute is defined for any prefix @code{P} which denotes an object. Prefix @code{P} can be any type -except for tagged private or @code{Unchecked_Union} types. The value of the -attribute is of type @code{Boolean}. +except for @code{Unchecked_Union} types. The value of the attribute is of type +@code{Boolean}. @code{P'Valid_Scalars} yields @code{True} if and only if the evaluation of @code{C'Valid} yields @code{True} for every scalar subcomponent @code{C} of @code{P}, or if diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 74ad6dac29b7..d40ee73ade3c 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -7981,27 +7981,7 @@ package body Sem_Attr is or else (Is_Class_Wide_Type (P_Type) and then Is_Private_Type (Root_Type (P_Type))) then - -- Attribute 'Valid_Scalars is not supported on private tagged - -- types due to a code generation issue. Is_Visible_Component - -- does not allow for a component of a private tagged type to - -- be successfully retrieved. - -- ??? This attribute should simply ignore type privacy - -- (see Validated_View). It should examine components of the - -- tagged type extensions (if any) and recursively examine - -- 'Valid_Scalars of the parent's type (if any). - - -- Do not use Error_Attr_P because this bypasses any subsequent - -- processing and leaves the attribute with type Any_Type. This - -- in turn prevents the proper expansion of the attribute into - -- True. - - if Is_Tagged_Type (P_Type) - or else (Present (Full_View (P_Type)) - and then Is_Tagged_Type (Full_View (P_Type))) - then - Error_Msg_Name_1 := Aname; - Error_Msg_N ("??effects of attribute % are ignored", N); - end if; + null; -- Otherwise the type is not private diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index f8aeb9410f0e..d54a13b39c25 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -20303,17 +20303,22 @@ package body Sem_Ch3 is elsif not Comes_From_Source (Original_Comp) then return True; + -- If the component reference is inserted for a discriminant check or + -- a validity check on a full view, then it is also visible. + + elsif Present (N) + and then Nkind (N) = N_Selected_Component + and then + Nkind (Prefix (N)) in N_Type_Conversion | N_Unchecked_Type_Conversion + and then not Comes_From_Source (Prefix (N)) + then + return True; + -- Discriminants are visible unless the (private) type has unknown - -- discriminants. If the discriminant reference is inserted for a - -- discriminant check on a full view it is also visible. + -- discriminants. elsif Ekind (Original_Comp) = E_Discriminant - and then - (not Has_Unknown_Discriminants (Original_Typ) - or else (Present (N) - and then Nkind (N) = N_Selected_Component - and then Nkind (Prefix (N)) = N_Type_Conversion - and then not Comes_From_Source (Prefix (N)))) + and then not Has_Unknown_Discriminants (Original_Typ) then return True;
