From: Gary Dismukes <[email protected]> This set of changes completes the support for the "attribute subprogram" feature outlined in the RFC at:
https://github.com/AdaCore/ada-spark-rfcs/blob/master/features/rfc-oop-attributes.rst There was already preliminary support implemented for the Constructor and Destructor aspects. Support has now been added for all of the other cases of subprogram-valued aspects, which are the indexing aspects, literal aspects, Default_Iterator, Put_Image, and the stream attributes/aspects. Part of these changes involves revising the form of internal names for attribute subprograms, where they now consist of just the type and aspect names separated by an apostrophe (rather than adding special prefixes and suffixes, and using "__" as a separator). There are also a number of changes related to improved error reporting, so that messages are flagged on the attribute subprograms themselves rather than on the type. Support is also added for allowing the names of attribute subprograms to be used in expanded names, plus allowing attribute subprograms to be called directly using the attribute name. Finally, documentation of the feature is added in the GNAT Reference Manual. gcc/ada/ChangeLog: * doc/gnat_rm/gnat_language_extensions.rst: Add documentation for "attribute subprograms" extension feature. * errout.adb (Set_Msg_Node): Remove special-case treatment for attribute names (no longer call Replace_With_Attribute_Definition). * erroutc.ads (Replace_With_Attribute_Definition): Removed. * erroutc.adb (Replace_With_Attribute_Definition): Removed. (Set_Msg_Insertion_Name): Remove special-case treatment for attribute names. * exp_attr.adb (Expand_N_Attribute_Reference): Add indexing, literal, and Default_Iterator attributes as case choices in the alternative that raises Program_Error. * par-ch4.adb (Is_Parameterless_Attribute): Add various aspects as entries in this table that are set to True (for proper handling of actual parameters on subprogram calls made using the attribute name). * par-ch6.adb (P_Subprogram): Add calls to procedure Rewrite_Entity_If_Direct_Attribute_Def for subprogram renamings and body stubs. * sem_attr.adb (Analyze_Attribute): Add indexing, Default_Iterator, and literal attributes to case choices. Rewrite_As_Attribute_Subp_Name is called for those, as well as for stream and Put_Image attribute cases (the latter group being guarded by a call to the following new function). (Is_Reference_To_Attribute_Subp_Name): New function to determine whether to rewrite an N_Attribute_Reference as an N_Identifier denoting an attribute subprogram. (Rewrite_As_Attribute_Subp_Name): New procedure to rewrite an attribute reference as an N_Identifier whose Chars field is the combined type and aspect name, and call Analyze on that (providing support for use in expanded names). Also validates that the prefix is a type and that the type has the aspect corresponding to the attribute. (Eval_Attribute): Add choices for the various subprogram-valued aspects/attributes to the alternative that raises Program_Error. * sem_ch3.adb (Set_Derived_Name): Construct a direct attribute name for an inherited subprogram whose parent subprogram has such a name, and augment spec comment. * sem_ch6.adb (Create_And_Append_Aspect): New procedure local to procedure Analyze_Direct_Attribute_Definition, for creating implicit aspects on a type for aspects associated with attribute subprograms. (Analyze_Direct_Attribute_Definition): Add handling for the various subprogram-valued aspects, including special handling for "'Class" aspects. Add an error check to prevent library attribute subprograms, plus validate that "'Class" can only be written for stream cases and when the prefix type is tagged. * sem_ch8.adb (Find_Direct_Name): Add missing init on Msg to avoid invalid data usages. * sem_ch10.adb (Analyze_Subprogram_Body_Stub): Add an error check to disallow attribute subprograms with bodies given by body stubs. * sem_ch13.ads (Analyze_One_Aspect): Procedure declaration moved here from package body. * sem_ch13.adb (Analyze_One_Aspect): Procedure declaration moved to package spec. Save and restore Expander_Active (in Aspect_Initialize handling). (Analyze_Put_Image_TSS_Definition): In the abstract-subprogram case, flag the error on the subprogram rather than the attribute name. When the attribute name is not Comes_From_Source, flag a bad subprogram itself rather than flagging the attribute name. (Analyze_Stream_TSS_Definition): Ditto. (Analyze_Attribute_Definition_Clause, case Default_Iterator): Move error check about untagged to the end of the case alternative, and remove error about nonfunctions (checking in Check_Iterator_Functions is sufficient). (Check_Aspect_At_Freeze_Point, case Default_Iterator): Add test of Is_Direct_Attribute_Subp_Name as additional condition for calling Check_Iterator_Functions. (Report_Ineligible_Indexing_Function): Don't issue warnings in the case of attribute subprograms (always give an error). Flag the error on the subprogram rather than the type in the case of attribute subprograms. (Check_Function_For_Indexing_Aspect): Force error messages in the case of attribute subprograms, despite Has_Eligible_Func being True. (Check_Iterator_Functions): Minor improvement to message requiring Expr to denote a function. (Validate_Literal_Aspect): Add test of whether the aspect denotes an attribute subprogram, to avoid returning early due to the "not Comes_From_Source" condition. Code cleanup to traverse formals rather than Parameter_Specifications. Flag the subprogram rather than the aspect when found function is an attribute subprogram. * sem_util.ads (Is_Direct_Attribute_Subp_Name): New function. * sem_util.adb (Direct_Attribute_Definition_Name): Remove 'D' prefix and "_Attr" suffix, plus adjust suffix to start with "'" rather than "_". Handle class-wide stream attribute names, and remove error about unsupported stream attributes. Add error check to reject child units. (Corresponding_Op_Of_Derived_Type): Account for differences between names of parent and descendant subprograms when they have direct attribute names. (Direct_Attribute_Names_Correspond): New function. (Inherit_Nonoverridable_Aspect): Construct a new name denoted by an inherited aspect when the parent aspect has a direct attribute name. (Is_Direct_Attribute_Subp_Name): New function. (Primitive_Names_Match): Add testing for direct attribute subprograms to condition of return statement. * snames.ads-tmpl: Move indexing and Default_Iterator aspect names earlier in name ordering and move literal aspect names later (these are all now considered to be recognized as attribute names). (type Attribute_Id): Move indexing attribute names earlier in attribute ordering (those no longer considered to be "internal" attribute names). (subtype Internal_Attribute_Id): Adjust subtype bounds. * snames.adb-tmpl (Get_Attribute_Id): Remove alternatives for indexing and Default_Iterator names, as these now belong to the "normal" attribute range. (Is_Direct_Attribute_Definition_Name): Return True for indexing aspect names, literal aspect names, stream attribute names, and Put_Image and Default_Iterator aspect names. * gnat_rm.texi: Regenerate. Tested on x86_64-pc-linux-gnu, committed on master. --- .../doc/gnat_rm/gnat_language_extensions.rst | 99 ++++++++ gcc/ada/errout.adb | 10 - gcc/ada/erroutc.adb | 46 +--- gcc/ada/erroutc.ads | 6 - gcc/ada/exp_attr.adb | 6 + gcc/ada/gnat_rm.texi | 186 +++++++++++--- gcc/ada/par-ch4.adb | 44 ++-- gcc/ada/par-ch6.adb | 4 + gcc/ada/sem_attr.adb | 146 +++++++++-- gcc/ada/sem_ch10.adb | 7 +- gcc/ada/sem_ch13.adb | 237 ++++++++++++------ gcc/ada/sem_ch13.ads | 7 + gcc/ada/sem_ch3.adb | 38 ++- gcc/ada/sem_ch6.adb | 188 +++++++++++++- gcc/ada/sem_ch8.adb | 2 +- gcc/ada/sem_util.adb | 140 ++++++++++- gcc/ada/sem_util.ads | 5 + gcc/ada/snames.adb-tmpl | 21 +- gcc/ada/snames.ads-tmpl | 25 +- 19 files changed, 969 insertions(+), 248 deletions(-) diff --git a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst index f87bba24dab..a4ac3d5d7d3 100644 --- a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst +++ b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst @@ -2069,3 +2069,102 @@ Another example, which additionally uses the inference of dependent types: begin Ada.Unchecked_Deallocation(Name => Integer_Access) (A); end; + +Attribute Subprograms +--------------------- + +This feature allows declaring subprograms that are associated with a named +aspect or attribute of a given type, as an alternative to explicitly +specifying the aspect or attribute for the type (using an aspect_specification +or attribute_definition_clause), by defining the name of the subprogram +using attribute syntax. In effect, this implicitly specifies the aspect +or attribute for the type, and is intended to be semantically equivalent to +using an explicit aspect specification, but without needing to give a specific +name in the aspect and subprogram. This is allowed for the various aspects that +denote subprograms (see below for the exact list of supported aspects). + +Here is an example of the use of this feature for defining indexing functions +for a container type and an integer-literal function for the container's +element type: + +.. code-block:: ada + + package My_Container is + + type Container is tagged ...; -- Implicit indexing aspects + + type Element_Type is ...; -- Implicit Integer_Literal aspect + + type Cursor_Type is ...; + + type Reference_Type is ...; + + function Container'Constant_Indexing (C : Container; Index : Positive) + return Element_Type; + + function Container'Constant_Indexing (C : Container; Index : Cursor_Type) + return Element_Type; + + function Container'Variable_Indexing + (C : in out Container; Index : Positive) + return Reference_Type; + + function Element_Type'Integer_Literal (S : String) return Element_Type; + + end My_Container; + +Syntax +^^^^^^ + +.. code-block:: text + + defining_program_unit_name ::= + [parent_unit_name . ]defining_identifier + | defining_attribute_subprogram_name + + defining_attribute_subprogram_name ::= + prefix'attribute_designator + +Legality Rules +^^^^^^^^^^^^^^ + +The prefix of a ``defining_attribute_subprogram_name`` shall be either +a ``direct_name`` denoting a type (more properly, a first subtype) +declared immediately within the scope where the associated subprogram +is declared, or else an attribute name itself whose ``attribute_designator`` +is ``Class`` and whose prefix denotes a type subject to the same +declaration condition. A ``defining_program_unit_name`` that is +a ``defining_attribute_subprogram_name`` may only be used to define +the name of a subprogram that is neither a library subprogram nor +a subprogram whose body is given by a ``body_stub`` (nor can it be +used to define the name of a generic subprogram). + +The ``attribute_designator`` given in a ``defining_attribute_subprogram_name`` +shall name an aspect that is allowed to designate a subprogram. Specifically, +it shall be one of the predefined aspects ``Constant_Indexing``, +``Variable_Indexing``, ``Default_Iterator``, ``Integer_Literal``, +``Real_Literal``, ``String_Literal``, ``Put_Image``, ``Read``, ``Write``, +``Input``, or ``Output``, or else one of the implementation-defined aspects +``Constructor`` or ``Destructor``. (Note that this feature is not supported +for aspects that have elements that may designate a subprogram, such as the +``Aggregate`` aspect.) + +If the prefix of a ``defining_attribute_subprogram_name`` is an attribute name +whose ``attribute_designator`` is ``Class``, then the ``attribute_designator`` +of the ``defining_attribute_subprogram_name`` shall be the name of a stream +attribute. + +An attribute subprogram for a given type and aspect is subject to +the same restrictions as would be imposed on a subprogram denoted by +an explicit ``aspect_specification`` or ``attribute_definition_clause`` +for that type and aspect. In particular, the profile of the subprogram +must satisfy any expected profile defined for the aspect. + +If a subprogram is declared using a ``defining_attribute_subprogram_name``, +then the type named in the attribute subprogram's name shall not have +an explicit ``aspect_specification`` that specifies the same aspect as +that named by the subprogram, nor shall the type derive from an ancestor +type that explicitly specifies that aspect. Similarly, an explicit +``aspect_specification`` shall not specify an aspect for a type that +is derived from a type for which any attribute subprograms have been +declared for the same aspect. diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 2263168bbba..321f7a14274 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -3854,16 +3854,6 @@ package body Errout is Kill_Message := True; end if; - -- Replace compiler generated name for direct attribute definitions with - -- a nicer name. - - if Name_Len > 5 - and then Name_Buffer (1) = 'D' - and then Name_Buffer (Name_Len - 3 .. Name_Len) = "_Att" - then - Replace_With_Attribute_Definition; - end if; - -- Remaining step is to adjust casing and possibly add 'Class Adjust_Name_Case (Global_Name_Buffer, Loc); diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index aa2810b5b04..e045a1f2fa6 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -1448,41 +1448,6 @@ package body Erroutc is end loop; end Prescan_Message; - --------------------------------------- - -- Replace_With_Attribute_Definition -- - --------------------------------------- - - procedure Replace_With_Attribute_Definition is - First : constant Integer := 2; - Last : constant Integer := Name_Len - 4; - Att_Buf : Bounded_String (Max_Length => Name_Len - 7); - - begin - Until_Tick : - for J in First .. Last loop - - -- J could be at the position separating the prefix from the - -- attribute name. - - if Name_Buffer (J) = '_' then - Att_Buf.Length := 0; - Append (Att_Buf, Name_Buffer (J + 1 .. Last)); - Set_Casing (Att_Buf, All_Lower_Case); - - if Is_Direct_Attribute_Definition_Name (Name_Find (Att_Buf)) then - Name_Buffer (J) := '''; - exit Until_Tick; - end if; - end if; - end loop Until_Tick; - - -- Remove prefix 'D' and suffix "_Att" - - Name_Buffer (1 .. Last - 1) := Name_Buffer (2 .. Last); - Name_Len := Last - 1; - Set_Casing (All_Lower_Case); - end Replace_With_Attribute_Definition; - ---------------- -- Same_Error -- ---------------- @@ -1793,16 +1758,7 @@ package body Erroutc is -- Else output with surrounding quotes in proper casing mode else - -- Replace compiler generated name for direct attribute - -- definitions with a nicer one. - - if Name_Buffer (1) = 'D' - and then Name_Buffer (Name_Len - 3 .. Name_Len) = "_Att" - then - Replace_With_Attribute_Definition; - else - Set_Casing (Identifier_Casing (Flag_Source)); - end if; + Set_Casing (Identifier_Casing (Flag_Source)); Set_Msg_Quote; Set_Msg_Name_Buffer; diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 039c342d05e..2a3f7e3c6bc 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -770,12 +770,6 @@ package Erroutc is -- Iterate over all of the errors in the error chain and mark all messages -- as deleted if they match the Filter. - procedure Replace_With_Attribute_Definition; - -- The caller has placed in Namet.Global_Name_Buffer the internal encoding - -- of a direct attribute definition; this subprogram rewrites that name to - -- a user-readable T'attribute string. The original source casing cannot - -- be recovered from the names table, so the result is all lowercase. - function Same_Error (M1, M2 : Error_Msg_Id) return Boolean; -- See if two messages have the same text. Returns true if the text of the -- two messages is identical, or if one of them is the same as the other diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 08329dbd34c..15219a73c27 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -9152,8 +9152,10 @@ package body Exp_Attr is | Attribute_Bit_Order | Attribute_Class | Attribute_Compiler_Version + | Attribute_Constant_Indexing | Attribute_Constructor | Attribute_Default_Bit_Order + | Attribute_Default_Iterator | Attribute_Default_Scalar_Storage_Order | Attribute_Definite | Attribute_Delta @@ -9168,6 +9170,7 @@ package body Exp_Attr is | Attribute_Has_Access_Values | Attribute_Has_Discriminants | Attribute_Has_Tagged_Values + | Attribute_Integer_Literal | Attribute_Large | Attribute_Last_Valid | Attribute_Library_Level @@ -9187,6 +9190,7 @@ package body Exp_Attr is | Attribute_Modulus | Attribute_Partition_ID | Attribute_Range + | Attribute_Real_Literal | Attribute_Restriction_Set | Attribute_Safe_Emax | Attribute_Safe_First @@ -9200,6 +9204,7 @@ package body Exp_Attr is | Attribute_Small_Denominator | Attribute_Small_Numerator | Attribute_Storage_Unit + | Attribute_String_Literal | Attribute_Stub_Type | Attribute_Super | Attribute_System_Allocator_Alignment @@ -9209,6 +9214,7 @@ package body Exp_Attr is | Attribute_Unconstrained_Array | Attribute_Universal_Literal_String | Attribute_Unsigned_Base_Range + | Attribute_Variable_Indexing | Attribute_Wchar_T_Size | Attribute_Word_Size => diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 0c7a0870264..4f660e8d297 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -19,7 +19,7 @@ @copying @quotation -GNAT Reference Manual , Jun 18, 2026 +GNAT Reference Manual , Jun 29, 2026 AdaCore @@ -961,6 +961,7 @@ Experimental Language Extensions * Continue statement:: * Destructors:: * Structural Generic Instantiation:: +* Attribute Subprograms:: Storage Model @@ -986,6 +987,11 @@ Structural Generic Instantiation * Legality Rules: Legality Rules<3>. * Static Semantics:: +Attribute Subprograms + +* Syntax: Syntax<4>. +* Legality Rules: Legality Rules<4>. + Security Hardening Features * Register Scrubbing:: @@ -31992,6 +31998,7 @@ Features activated via @code{-gnatX0} or * Continue statement:: * Destructors:: * Structural Generic Instantiation:: +* Attribute Subprograms:: @end menu @@ -33258,7 +33265,7 @@ procedure T2'Destructor (X : in out T2); When an object of type @code{T2} is finalized, there will be first a call to @code{T2'Destructor}, and then a call to @code{T1'Destructor} on the object. -@node Structural Generic Instantiation,,Destructors,Experimental Language Extensions +@node Structural Generic Instantiation,Attribute Subprograms,Destructors,Experimental Language Extensions @anchor{gnat_rm/gnat_language_extensions structural-generic-instantiation}@anchor{488} @subsection Structural Generic Instantiation @@ -33466,8 +33473,119 @@ begin end; @end example +@node Attribute Subprograms,,Structural Generic Instantiation,Experimental Language Extensions +@anchor{gnat_rm/gnat_language_extensions attribute-subprograms}@anchor{48c} +@subsection Attribute Subprograms + + +This feature allows declaring subprograms that are associated with a named +aspect or attribute of a given type, as an alternative to explicitly +specifying the aspect or attribute for the type (using an aspect_specification +or attribute_definition_clause), by defining the name of the subprogram +using attribute syntax. In effect, this implicitly specifies the aspect +or attribute for the type, and is intended to be semantically equivalent to +using an explicit aspect specification, but without needing to give a specific +name in the aspect and subprogram. This is allowed for the various aspects that +denote subprograms (see below for the exact list of supported aspects). + +Here is an example of the use of this feature for defining indexing functions +for a container type and an integer-literal function for the container’s +element type: + +@example +package My_Container is + + type Container is tagged ...; -- Implicit indexing aspects + + type Element_Type is ...; -- Implicit Integer_Literal aspect + + type Cursor_Type is ...; + + type Reference_Type is ...; + + function Container'Constant_Indexing (C : Container; Index : Positive) + return Element_Type; + + function Container'Constant_Indexing (C : Container; Index : Cursor_Type) + return Element_Type; + + function Container'Variable_Indexing + (C : in out Container; Index : Positive) + return Reference_Type; + + function Element_Type'Integer_Literal (S : String) return Element_Type; + +end My_Container; +@end example + +@menu +* Syntax: Syntax<4>. +* Legality Rules: Legality Rules<4>. + +@end menu + +@node Syntax<4>,Legality Rules<4>,,Attribute Subprograms +@anchor{gnat_rm/gnat_language_extensions id9}@anchor{48d} +@subsubsection Syntax + + +@example +defining_program_unit_name ::= + [parent_unit_name . ]defining_identifier +| defining_attribute_subprogram_name + +defining_attribute_subprogram_name ::= + prefix'attribute_designator +@end example + +@node Legality Rules<4>,,Syntax<4>,Attribute Subprograms +@anchor{gnat_rm/gnat_language_extensions id10}@anchor{48e} +@subsubsection Legality Rules + + +The prefix of a @code{defining_attribute_subprogram_name} shall be either +a @code{direct_name} denoting a type (more properly, a first subtype) +declared immediately within the scope where the associated subprogram +is declared, or else an attribute name itself whose @code{attribute_designator} +is @code{Class} and whose prefix denotes a type subject to the same +declaration condition. A @code{defining_program_unit_name} that is +a @code{defining_attribute_subprogram_name} may only be used to define +the name of a subprogram that is neither a library subprogram nor +a subprogram whose body is given by a @code{body_stub} (nor can it be +used to define the name of a generic subprogram). + +The @code{attribute_designator} given in a @code{defining_attribute_subprogram_name} +shall name an aspect that is allowed to designate a subprogram. Specifically, +it shall be one of the predefined aspects @code{Constant_Indexing}, +@code{Variable_Indexing}, @code{Default_Iterator}, @code{Integer_Literal}, +@code{Real_Literal}, @code{String_Literal}, @code{Put_Image}, @code{Read}, @code{Write}, +@code{Input}, or @code{Output}, or else one of the implementation-defined aspects +@code{Constructor} or @code{Destructor}. (Note that this feature is not supported +for aspects that have elements that may designate a subprogram, such as the +@code{Aggregate} aspect.) + +If the prefix of a @code{defining_attribute_subprogram_name} is an attribute name +whose @code{attribute_designator} is @code{Class}, then the @code{attribute_designator} +of the @code{defining_attribute_subprogram_name} shall be the name of a stream +attribute. + +An attribute subprogram for a given type and aspect is subject to +the same restrictions as would be imposed on a subprogram denoted by +an explicit @code{aspect_specification} or @code{attribute_definition_clause} +for that type and aspect. In particular, the profile of the subprogram +must satisfy any expected profile defined for the aspect. + +If a subprogram is declared using a @code{defining_attribute_subprogram_name}, +then the type named in the attribute subprogram’s name shall not have +an explicit @code{aspect_specification} that specifies the same aspect as +that named by the subprogram, nor shall the type derive from an ancestor +type that explicitly specifies that aspect. Similarly, an explicit +@code{aspect_specification} shall not specify an aspect for a type that +is derived from a type for which any attribute subprograms have been +declared for the same aspect. + @node Security Hardening Features,Obsolescent Features,GNAT language extensions,Top -@anchor{gnat_rm/security_hardening_features doc}@anchor{48c}@anchor{gnat_rm/security_hardening_features id1}@anchor{48d}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{16} +@anchor{gnat_rm/security_hardening_features doc}@anchor{48f}@anchor{gnat_rm/security_hardening_features id1}@anchor{490}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{16} @chapter Security Hardening Features @@ -33491,7 +33609,7 @@ These features are supported only by the GCC back end, not by LLVM. @end menu @node Register Scrubbing,Stack Scrubbing,,Security Hardening Features -@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{48e} +@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{491} @section Register Scrubbing @@ -33527,7 +33645,7 @@ programming languages, see @cite{Using the GNU Compiler Collection (GCC)}. @c Stack Scrubbing: @node Stack Scrubbing,Hardened Conditionals,Register Scrubbing,Security Hardening Features -@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{48f} +@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{492} @section Stack Scrubbing @@ -33671,7 +33789,7 @@ Bar_Callable_Ptr. @c Hardened Conditionals: @node Hardened Conditionals,Hardened Booleans,Stack Scrubbing,Security Hardening Features -@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{490} +@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{493} @section Hardened Conditionals @@ -33761,7 +33879,7 @@ be used with other programming languages supported by GCC. @c Hardened Booleans: @node Hardened Booleans,Control Flow Redundancy,Hardened Conditionals,Security Hardening Features -@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{491} +@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{494} @section Hardened Booleans @@ -33822,7 +33940,7 @@ and more details on that attribute, see @cite{Using the GNU Compiler Collection @c Control Flow Redundancy: @node Control Flow Redundancy,,Hardened Booleans,Security Hardening Features -@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{492} +@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{495} @section Control Flow Redundancy @@ -33990,7 +34108,7 @@ see @cite{Using the GNU Compiler Collection (GCC)}. These options can be used with other programming languages supported by GCC. @node Obsolescent Features,Compatibility and Porting Guide,Security Hardening Features,Top -@anchor{gnat_rm/obsolescent_features doc}@anchor{493}@anchor{gnat_rm/obsolescent_features id1}@anchor{494}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{17} +@anchor{gnat_rm/obsolescent_features doc}@anchor{496}@anchor{gnat_rm/obsolescent_features id1}@anchor{497}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{17} @chapter Obsolescent Features @@ -34010,7 +34128,7 @@ historical compatibility purposes. @end menu @node PolyORB,pragma No_Run_Time,,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id2}@anchor{495}@anchor{gnat_rm/obsolescent_features polyorb}@anchor{276} +@anchor{gnat_rm/obsolescent_features id2}@anchor{498}@anchor{gnat_rm/obsolescent_features polyorb}@anchor{276} @section PolyORB @@ -34019,7 +34137,7 @@ release 28. After this release, there will be no new versions of this product. Contact AdaCore support to get recommendations for replacements. @node pragma No_Run_Time,pragma Ravenscar,PolyORB,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id3}@anchor{496}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{497} +@anchor{gnat_rm/obsolescent_features id3}@anchor{499}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{49a} @section pragma No_Run_Time @@ -34032,7 +34150,7 @@ preferred usage is to use an appropriately configured run-time that includes just those features that are to be made accessible. @node pragma Ravenscar,pragma Restricted_Run_Time,pragma No_Run_Time,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id4}@anchor{498}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{499} +@anchor{gnat_rm/obsolescent_features id4}@anchor{49b}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{49c} @section pragma Ravenscar @@ -34041,7 +34159,7 @@ The pragma @code{Ravenscar} has exactly the same effect as pragma is part of the new Ada 2005 standard. @node pragma Restricted_Run_Time,pragma Task_Info,pragma Ravenscar,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id5}@anchor{49a}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{49b} +@anchor{gnat_rm/obsolescent_features id5}@anchor{49d}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{49e} @section pragma Restricted_Run_Time @@ -34051,7 +34169,7 @@ preferred since the Ada 2005 pragma @code{Profile} is intended for this kind of implementation dependent addition. @node pragma Task_Info,package System Task_Info s-tasinf ads,pragma Restricted_Run_Time,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id6}@anchor{49c}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{49d} +@anchor{gnat_rm/obsolescent_features id6}@anchor{49f}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{4a0} @section pragma Task_Info @@ -34077,7 +34195,7 @@ in the spec of package System.Task_Info in the runtime library. @node package System Task_Info s-tasinf ads,,pragma Task_Info,Obsolescent Features -@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{49e}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{49f} +@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{4a1}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{4a2} @section package System.Task_Info (@code{s-tasinf.ads}) @@ -34087,7 +34205,7 @@ to support the @code{Task_Info} pragma. The predefined Ada package standard replacement for GNAT’s @code{Task_Info} functionality. @node Compatibility and Porting Guide,GNU Free Documentation License,Obsolescent Features,Top -@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{4a0}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{18}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{4a1} +@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{4a3}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{18}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{4a4} @chapter Compatibility and Porting Guide @@ -34109,7 +34227,7 @@ applications developed in other Ada environments. @end menu @node Writing Portable Fixed-Point Declarations,Compatibility with Ada 83,,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{4a2}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{4a3} +@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{4a5}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{4a6} @section Writing Portable Fixed-Point Declarations @@ -34231,7 +34349,7 @@ If you follow this scheme you will be guaranteed that your fixed-point types will be portable. @node Compatibility with Ada 83,Compatibility between Ada 95 and Ada 2005,Writing Portable Fixed-Point Declarations,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{4a4}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{4a5} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{4a7}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{4a8} @section Compatibility with Ada 83 @@ -34259,7 +34377,7 @@ following subsections treat the most likely issues to be encountered. @end menu @node Legal Ada 83 programs that are illegal in Ada 95,More deterministic semantics,,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{4a6}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{4a7} +@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{4a9}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{4aa} @subsection Legal Ada 83 programs that are illegal in Ada 95 @@ -34359,7 +34477,7 @@ the fix is usually simply to add the @code{(<>)} to the generic declaration. @end itemize @node More deterministic semantics,Changed semantics,Legal Ada 83 programs that are illegal in Ada 95,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{4a8}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{4a9} +@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{4ab}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{4ac} @subsection More deterministic semantics @@ -34387,7 +34505,7 @@ which open select branches are executed. @end itemize @node Changed semantics,Other language compatibility issues,More deterministic semantics,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{4aa}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{4ab} +@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{4ad}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{4ae} @subsection Changed semantics @@ -34429,7 +34547,7 @@ covers only the restricted range. @end itemize @node Other language compatibility issues,,Changed semantics,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{4ac}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{4ad} +@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{4af}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{4b0} @subsection Other language compatibility issues @@ -34462,7 +34580,7 @@ include @code{pragma Interface} and the floating point type attributes @end itemize @node Compatibility between Ada 95 and Ada 2005,Implementation-dependent characteristics,Compatibility with Ada 83,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{4ae}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{4af} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{4b1}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{4b2} @section Compatibility between Ada 95 and Ada 2005 @@ -34534,7 +34652,7 @@ can declare a function returning a value from an anonymous access type. @end itemize @node Implementation-dependent characteristics,Compatibility with Other Ada Systems,Compatibility between Ada 95 and Ada 2005,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{4b0}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{4b1} +@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{4b3}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{4b4} @section Implementation-dependent characteristics @@ -34557,7 +34675,7 @@ transition from certain Ada 83 compilers. @end menu @node Implementation-defined pragmas,Implementation-defined attributes,,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{4b2}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{4b3} +@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{4b5}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{4b6} @subsection Implementation-defined pragmas @@ -34579,7 +34697,7 @@ avoiding compiler rejection of units that contain such pragmas; they are not relevant in a GNAT context and hence are not otherwise implemented. @node Implementation-defined attributes,Libraries,Implementation-defined pragmas,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{4b4}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{4b5} +@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{4b7}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{4b8} @subsection Implementation-defined attributes @@ -34593,7 +34711,7 @@ Ada 83, GNAT supplies the attributes @code{Bit}, @code{Machine_Size} and @code{Type_Class}. @node Libraries,Elaboration order,Implementation-defined attributes,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{4b6}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{4b7} +@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{4b9}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{4ba} @subsection Libraries @@ -34622,7 +34740,7 @@ be preferable to retrofit the application using modular types. @end itemize @node Elaboration order,Target-specific aspects,Libraries,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{4b8}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{4b9} +@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{4bb}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{4bc} @subsection Elaboration order @@ -34658,7 +34776,7 @@ pragmas either globally (as an effect of the `-gnatE' switch) or locally @end itemize @node Target-specific aspects,,Elaboration order,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{4ba}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{4bb} +@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{4bd}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{4be} @subsection Target-specific aspects @@ -34671,10 +34789,10 @@ on the robustness of the original design. Moreover, Ada 95 (and thus Ada 2005, Ada 2012, and Ada 2022) are sometimes incompatible with typical Ada 83 compiler practices regarding implicit packing, the meaning of the Size attribute, and the size of access values. -GNAT’s approach to these issues is described in @ref{4bc,,Representation Clauses}. +GNAT’s approach to these issues is described in @ref{4bf,,Representation Clauses}. @node Compatibility with Other Ada Systems,Representation Clauses,Implementation-dependent characteristics,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{4bd}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{4be} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{4c0}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{4c1} @section Compatibility with Other Ada Systems @@ -34717,7 +34835,7 @@ far beyond this minimal set, as described in the next section. @end itemize @node Representation Clauses,Compatibility with HP Ada 83,Compatibility with Other Ada Systems,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{4bf}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{4bc} +@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{4c2}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{4bf} @section Representation Clauses @@ -34810,7 +34928,7 @@ with thin pointers. @end itemize @node Compatibility with HP Ada 83,,Representation Clauses,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{4c0}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{4c1} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{4c3}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{4c4} @section Compatibility with HP Ada 83 @@ -34840,7 +34958,7 @@ extension of package System. @end itemize @node GNU Free Documentation License,Index,Compatibility and Porting Guide,Top -@anchor{share/gnu_free_documentation_license doc}@anchor{4c2}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{4c3} +@anchor{share/gnu_free_documentation_license doc}@anchor{4c5}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{4c6} @chapter GNU Free Documentation License diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 13328c959e4..cab7bb63c14 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -35,23 +35,33 @@ package body Ch4 is -- Attributes that cannot have arguments Is_Parameterless_Attribute : constant Attribute_Set := - (Attribute_Base | - Attribute_Body_Version | - Attribute_Class | - Attribute_External_Tag | - Attribute_Img | - Attribute_Loop_Entry | - Attribute_Old | - Attribute_Result | - Attribute_Stub_Type | - Attribute_Version | - Attribute_Type_Key => True, - others => False); - -- This map contains True for parameterless attributes that return a string - -- or a type. For those attributes, a left parenthesis after the attribute - -- should not be analyzed as the beginning of a parameters list because it - -- may denote a slice operation (X'Img (1 .. 2)) or a type conversion - -- (X'Class (Y)). + (Attribute_Base | + Attribute_Body_Version | + Attribute_Class | + Attribute_Constant_Indexing | + Attribute_Constructor | + Attribute_Default_Iterator | + Attribute_Destructor | + Attribute_External_Tag | + Attribute_Img | + Attribute_Integer_Literal | + Attribute_Loop_Entry | + Attribute_Old | + Attribute_Real_Literal | + Attribute_Result | + Attribute_String_Literal | + Attribute_Stub_Type | + Attribute_Type_Key | + Attribute_Variable_Indexing | + Attribute_Version => True, + others => False); + -- This map contains True for parameterless attributes that return a value + -- or a type or correspond to subprogram-valued aspects. For those, a left + -- parenthesis after the attribute should not be analyzed as the beginning + -- of an arguments list because it may denote an indexing, slice operation + -- (such as X'Img (1 .. 2)), type conversion (such as X'Class (Y)), or + -- be the actual parameters for a subprogram call (such as for generalized + -- indexing). -- Note: Loop_Entry is in this list because, although it can take an -- optional argument (the loop name), we can't distinguish that at parse diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 2ec198293c5..8013b84dd2e 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -616,6 +616,8 @@ package body Ch6 is Scan; -- past RENAMES Set_Name (Rename_Node, P_Name); Set_Specification (Rename_Node, Specification_Node); + Rewrite_Entity_If_Direct_Attribute_Def + (Name_Node, Specification_Node); P_Aspect_Specifications (Rename_Node, Semicolon => True); TF_Semicolon; Pop_Scope_Stack; @@ -744,6 +746,8 @@ package body Ch6 is Stub_Node := New_Node (N_Subprogram_Body_Stub, Sloc (Specification_Node)); Set_Specification (Stub_Node, Specification_Node); + Rewrite_Entity_If_Direct_Attribute_Def + (Name_Node, Specification_Node); if Is_Non_Empty_List (Aspects) then Error_Msg diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index bb1967de1e6..695b1140a1f 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -467,6 +467,22 @@ package body Sem_Attr is -- second message Msg_Cont is useful to issue a continuation message -- before raising Bad_Attribute. + function Is_Reference_To_Attribute_Subp_Name + (N : Node_Id) return Boolean is + (No (Expressions (N)) + and then Nkind (Parent (N)) = N_Selected_Component + and then Prefix (Parent (N)) = N); + -- Returns True if N, which is assumed to be an N_Attribute_Reference, + -- is being used as the prefix of an expanded name, such as when + -- referring to a local declaration of the body of an attribute + -- subprogram (for example, Pkg.T'Constant_Indexing.Local_Var). + -- This is used as a guard for calling Rewrite_As_Attribute_Subp_Name. + -- + -- We test whether Expressions is present, and return False if it is, + -- because that indicates that the attribute is being used for a call, + -- in which case we definitely don't want to do the rewriting (like + -- in cases of calls to stream attributes). + procedure Legal_Formal_Attribute; -- Common processing for attributes Definite and Has_Discriminants. -- Checks that prefix is generic indefinite formal type. @@ -478,6 +494,15 @@ package body Sem_Attr is procedure Min_Max; -- Common processing for attributes Max and Min + procedure Rewrite_As_Attribute_Subp_Name; + -- Checks that the attribute prefix is a type that has an aspect + -- corresponding to the attribute part of the name, and rewrites + -- the attribute name in the form of the name of an attribute + -- subprogram (usually an N_Identifier whose Chars is a name of + -- form "<type-id>'<attribute-name>", but possibly as an N_Expanded_Name + -- whose Selector denotes a name of that form in the case where the + -- prefix is an expanded name). The rewritten name is then analyzed. + procedure Standard_Attribute (Val : Int); -- Used to process attributes whose prefix is package Standard which -- yield values of type Universal_Integer. The attribute reference @@ -3180,6 +3205,48 @@ package body Sem_Attr is end if; end Min_Max; + ------------------------------------- + -- Rewrite_As_Attribute_Subp_Name -- + ------------------------------------- + + procedure Rewrite_As_Attribute_Subp_Name is + begin + -- Verify that the prefix of an attribute associated with aspects + -- that denote subprograms is a type, and that the type specifies + -- the associated aspect. Note that such attribute names can only + -- occur for subprograms whose name has the form of an attribute + -- (a GNAT extension feature). + + Check_Type; + + if not Has_Aspect (Entity (P), Get_Aspect_Id (Aname)) then + Error_Attr_P ("aspect% not available for type"); + end if; + + -- Change the attribute name into a simple entity reference, so it + -- can be used as the prefix in expanded names like the name of a + -- normal scope entity. If the prefix of the attribute name is + -- itself an expanded name, then account for that in constructing + -- the name. + + declare + Subp_Name : Node_Id := + Make_Identifier (Sloc (N), + Direct_Attribute_Definition_Name (Entity (P), Aname)); + begin + if Nkind (P) = N_Expanded_Name then + Subp_Name := Make_Expanded_Name (Sloc (P), + Chars => Chars (Subp_Name), + Prefix => Prefix (P), + Selector_Name => Subp_Name); + end if; + + Rewrite (N, Subp_Name); + end; + + Analyze (N); + end Rewrite_As_Attribute_Subp_Name; + ------------------------ -- Standard_Attribute -- ------------------------ @@ -4981,9 +5048,14 @@ package body Sem_Attr is ----------- when Attribute_Input => - Check_E1; - Check_Stream_Attribute (TSS_Stream_Input); - Set_Etype (N, P_Base_Type); + if Is_Reference_To_Attribute_Subp_Name (N) then + Rewrite_As_Attribute_Subp_Name; + + else + Check_E1; + Check_Stream_Attribute (TSS_Stream_Input); + Set_Etype (N, P_Base_Type); + end if; ------------------- -- Integer_Value -- @@ -6072,10 +6144,15 @@ package body Sem_Attr is ------------ when Attribute_Output => - Check_E2; - Check_Stream_Attribute (TSS_Stream_Output); - Set_Etype (N, Standard_Void_Type); - Resolve (N, Standard_Void_Type); + if Is_Reference_To_Attribute_Subp_Name (N) then + Rewrite_As_Attribute_Subp_Name; + + else + Check_E2; + Check_Stream_Attribute (TSS_Stream_Output); + Set_Etype (N, Standard_Void_Type); + Resolve (N, Standard_Void_Type); + end if; ------------------ -- Partition_ID -- @@ -6256,10 +6333,15 @@ package body Sem_Attr is --------------- when Attribute_Put_Image => - Check_E2; - Check_Put_Image_Attribute; - Set_Etype (N, Standard_Void_Type); - Resolve (N, Standard_Void_Type); + if Is_Reference_To_Attribute_Subp_Name (N) then + Rewrite_As_Attribute_Subp_Name; + + else + Check_E2; + Check_Put_Image_Attribute; + Set_Etype (N, Standard_Void_Type); + Resolve (N, Standard_Void_Type); + end if; ----------- -- Range -- @@ -6662,11 +6744,16 @@ package body Sem_Attr is ---------- when Attribute_Read => - Check_E2; - Check_Stream_Attribute (TSS_Stream_Read); - Set_Etype (N, Standard_Void_Type); - Resolve (N, Standard_Void_Type); - Note_Possible_Modification (E2, Sure => True); + if Is_Reference_To_Attribute_Subp_Name (N) then + Rewrite_As_Attribute_Subp_Name; + + else + Check_E2; + Check_Stream_Attribute (TSS_Stream_Read); + Set_Etype (N, Standard_Void_Type); + Resolve (N, Standard_Void_Type); + Note_Possible_Modification (E2, Sure => True); + end if; --------- -- Ref -- @@ -8240,11 +8327,24 @@ package body Sem_Attr is ----------- when Attribute_Write => - Check_E2; - Check_Stream_Attribute (TSS_Stream_Write); - Set_Etype (N, Standard_Void_Type); - Resolve (N, Standard_Void_Type); + if Is_Reference_To_Attribute_Subp_Name (N) then + Rewrite_As_Attribute_Subp_Name; + else + Check_E2; + Check_Stream_Attribute (TSS_Stream_Write); + Set_Etype (N, Standard_Void_Type); + Resolve (N, Standard_Void_Type); + end if; + + when Attribute_Constant_Indexing + | Attribute_Default_Iterator + | Attribute_Integer_Literal + | Attribute_Real_Literal + | Attribute_String_Literal + | Attribute_Variable_Indexing + => + Rewrite_As_Attribute_Subp_Name; end case; -- In SPARK certain attributes (see below) depend on Tasking_State. @@ -11636,9 +11736,11 @@ package body Sem_Attr is | Attribute_Class | Attribute_Code_Address | Attribute_Compiler_Version + | Attribute_Constant_Indexing | Attribute_Constructor | Attribute_Count | Attribute_Default_Bit_Order + | Attribute_Default_Iterator | Attribute_Default_Scalar_Storage_Order | Attribute_Deref | Attribute_Destructor @@ -11653,6 +11755,7 @@ package body Sem_Attr is | Attribute_Img | Attribute_Input | Attribute_Index + | Attribute_Integer_Literal | Attribute_Initialized | Attribute_Last_Bit | Attribute_Library_Level @@ -11666,12 +11769,14 @@ package body Sem_Attr is | Attribute_Priority | Attribute_Put_Image | Attribute_Read + | Attribute_Real_Literal | Attribute_Result | Attribute_Scalar_Storage_Order | Attribute_Simple_Storage_Pool | Attribute_Storage_Pool | Attribute_Storage_Size | Attribute_Storage_Unit + | Attribute_String_Literal | Attribute_Stub_Type | Attribute_Super | Attribute_System_Allocator_Alignment @@ -11687,6 +11792,7 @@ package body Sem_Attr is | Attribute_Valid_Scalars | Attribute_Valid_Value | Attribute_Value + | Attribute_Variable_Indexing | Attribute_Wchar_T_Size | Attribute_Wide_Value | Attribute_Wide_Wide_Value diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 756032f6a4c..8596be3122f 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -2420,11 +2420,14 @@ package body Sem_Ch10 is begin Check_Stub_Level (N); + if Is_Direct_Attribute_Subp_Spec (Specification (N)) then + Error_Msg_N ("body stubs not allowed for attribute subprograms", N); + -- Verify that the identifier for the stub is unique within this -- declarative part. - if Nkind (Parent (N)) in - N_Block_Statement | N_Package_Body | N_Subprogram_Body + elsif Nkind (Parent (N)) in + N_Block_Statement | N_Package_Body | N_Subprogram_Body then Decl := First (Declarations (Parent (N))); while Present (Decl) and then Decl /= N loop diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index e1541ccc331..e2be2592870 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -379,13 +379,6 @@ package body Sem_Ch13 is -- a corresponding pragma (or an attribute definition clause). This -- parallels what is done in sem_prag.adb (see Get_Argument). - procedure Analyze_One_Aspect - (N : Node_Id; - E : N_Entity_Id; - Aspect : Node_Id); - -- N and E are what was passed to Analyze_Aspect_Specifications. - -- Aspect is one element of Aspect_Specifications (N). - ----------------------------------------------------------- -- Visibility of Discriminants in Aspect Specifications -- ----------------------------------------------------------- @@ -5011,17 +5004,23 @@ package body Sem_Ch13 is Next (Aspect_Comp); end loop; - -- Do a psuedo pass over the aggregate to ensure its + -- Do a "pseudo" pass over the aggregate to ensure its -- validity. The expression with actions is required to -- have a valid node where to place the ABE check during -- resolution. - Expander_Active := False; - Dummy := Make_Expression_With_Actions (Loc, - Actions => Empty_List, - Expression => New_Copy_Tree (Expression (Aspect))); - Resolve_Aggregate (Expression (Dummy), Typ); - Expander_Active := True; + declare + EA_Save : constant Boolean := Expander_Active; + begin + Expander_Active := False; + + Dummy := Make_Expression_With_Actions (Loc, + Actions => Empty_List, + Expression => New_Copy_Tree (Expression (Aspect))); + Resolve_Aggregate (Expression (Dummy), Typ); + + Expander_Active := EA_Save; + end; end Initialize; -- Aspect Initializes is never delayed because it is equivalent @@ -6174,10 +6173,13 @@ package body Sem_Ch13 is ----------------------------------- procedure Analyze_Put_Image_TSS_Definition is - Subp : Entity_Id := Empty; - I : Interp_Index; - It : Interp; - Pnam : Entity_Id; + Subp : Entity_Id := Empty; + Bad_Subp : Entity_Id := Empty; + Err_Node : Node_Id := Empty; + Is_Attr_Subp : Boolean; + I : Interp_Index; + It : Interp; + Pnam : Entity_Id; function Has_Good_Profile (Subp : Entity_Id; @@ -6305,6 +6307,8 @@ package body Sem_Ch13 is if not Is_Overloaded (Expr) then if Has_Good_Profile (Entity (Expr), Report => True) then Subp := Entity (Expr); + else + Bad_Subp := Entity (Expr); end if; else @@ -6313,6 +6317,8 @@ package body Sem_Ch13 is if Has_Good_Profile (It.Nam) then Subp := It.Nam; exit; + else + Bad_Subp := It.Nam; end if; Get_Next_Interp (I, It); @@ -6320,9 +6326,22 @@ package body Sem_Ch13 is end if; end if; + -- If Expr does not come from source, then the clause must be + -- associated with an aspect_specification that was implicitly + -- created due to an attribute subprogram. When there are errors + -- on such a subprogram, we want to flag errors on the subprogram + -- itself rather than the type (which is where the errors would + -- end up being placed otherwise), so we set Err_Node accordingly. + + Is_Attr_Subp := not Comes_From_Source (Expr); + + Err_Node := (if not Is_Attr_Subp then Expr + elsif Present (Bad_Subp) then Bad_Subp else Subp); + if Present (Subp) then if Is_Abstract_Subprogram (Subp) then - Error_Msg_N ("Put_Image subprogram must not be abstract", Expr); + Error_Msg_N + ("Put_Image subprogram must not be abstract", Err_Node); return; end if; @@ -6333,7 +6352,10 @@ package body Sem_Ch13 is else Error_Msg_Name_1 := Attr; - Error_Msg_N ("incorrect expression for% attribute", Expr); + Error_Msg_N + ("incorrect " + & (if Is_Attr_Subp then "subprogram" else "expression") + & " for% attribute", Err_Node); end if; end Analyze_Put_Image_TSS_Definition; @@ -6342,10 +6364,13 @@ package body Sem_Ch13 is ----------------------------------- procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is - Subp : Entity_Id := Empty; - I : Interp_Index; - It : Interp; - Pnam : Entity_Id; + Subp : Entity_Id := Empty; + Bad_Subp : Entity_Id := Empty; + Err_Node : Node_Id := Empty; + Is_Attr_Subp : Boolean; + I : Interp_Index; + It : Interp; + Pnam : Entity_Id; Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read); -- True for Read attribute, False for other attributes @@ -6475,6 +6500,8 @@ package body Sem_Ch13 is if not Is_Overloaded (Expr) then if Has_Good_Profile (Entity (Expr), Report => True) then Subp := Entity (Expr); + else + Bad_Subp := Entity (Expr); end if; else @@ -6483,6 +6510,8 @@ package body Sem_Ch13 is if Has_Good_Profile (It.Nam) then Subp := It.Nam; exit; + else + Bad_Subp := It.Nam; end if; Get_Next_Interp (I, It); @@ -6490,9 +6519,22 @@ package body Sem_Ch13 is end if; end if; + -- If Expr does not come from source, then the clause must be + -- associated with an aspect_specification that was implicitly + -- created due to an attribute subprogram. When there are errors + -- on such a subprogram, we want to flag errors on the subprogram + -- itself rather than the type (which is where the errors would + -- end up being placed otherwise), so we set Err_Node accordingly. + + Is_Attr_Subp := not Comes_From_Source (Expr); + + Err_Node := (if not Is_Attr_Subp then Expr + elsif Present (Bad_Subp) then Bad_Subp else Subp); + if Present (Subp) then if Is_Abstract_Subprogram (Subp) then - Error_Msg_N ("stream subprogram must not be abstract", Expr); + Error_Msg_N + ("stream subprogram must not be abstract", Err_Node); return; -- A stream subprogram for an interface type must be a null @@ -6511,7 +6553,7 @@ package body Sem_Ch13 is then Error_Msg_N ("stream subprogram for interface type must be null " - & "procedure", Expr); + & "procedure", Err_Node); end if; Set_Entity (Expr, Subp); @@ -6524,9 +6566,14 @@ package body Sem_Ch13 is if Is_Class_Wide_Type (Base_Type (Ent)) then Error_Msg_N - ("incorrect expression for class-wide% attribute", Expr); + ("incorrect " + & (if Is_Attr_Subp then "subprogram" else "expression") + & " for class-wide% attribute", Err_Node); else - Error_Msg_N ("incorrect expression for% attribute", Expr); + Error_Msg_N + ("incorrect " + & (if Is_Attr_Subp then "subprogram" else "expression") + & " for% attribute", Err_Node); end if; end if; end Analyze_Stream_TSS_Definition; @@ -7383,15 +7430,6 @@ package body Sem_Ch13 is when Attribute_Default_Iterator => Default_Iterator : declare begin - -- If target type is untagged, further checks are irrelevant - - if not Is_Tagged_Type (U_Ent) then - Error_Msg_N - ("aspect Default_Iterator can only apply to a tagged type", - Nam); - return; - end if; - declare Parent_Aspect : constant Node_Id := Find_Aspect (U_Ent, Aspect_Default_Iterator); @@ -7399,10 +7437,15 @@ package body Sem_Ch13 is -- If the attribute definition clause comes from an aspect that -- is not Comes_From_Source, then the aspect must be inherited -- from a parent type, in which case the operation has already - -- been set properly, and there's no need to do the check. + -- been set properly, and there's no need to do the check, + -- except for the case of an implicit aspect that denotes + -- an attribute subprogram, where we do want to check. if No (Parent_Aspect) or else Comes_From_Source (Parent_Aspect) + or else + (Nkind (Expr) in N_Has_Chars + and then Is_Direct_Attribute_Subp_Name (Chars (Expr))) then Check_Iterator_Functions (Typ => U_Ent, Expr => Expr); end if; @@ -7410,10 +7453,20 @@ package body Sem_Ch13 is Analyze (Expr); - if not Is_Entity_Name (Expr) - or else Ekind (Entity (Expr)) /= E_Function - then - Error_Msg_N ("aspect Iterator must be a function", Expr); + -- If target type is untagged, further checks are irrelevant + + if not Is_Tagged_Type (U_Ent) then + + -- If an attribute subprogram is denoted, then flag the error + -- on the subprogram. Otherwise, flag the error on the type. + + Error_Msg_N + ("aspect Default_Iterator can only apply to a tagged type", + (if not Comes_From_Source (Expr) + and then Is_Direct_Attribute_Subp_Name (Chars (Expr)) + then Entity (Expr) + else Nam)); + return; end if; end Default_Iterator; @@ -12073,11 +12126,17 @@ package body Sem_Ch13 is -- If the aspect is not Comes_From_Source, then it's an inherited -- aspect, in which case the aspect's operation has already been -- set, and there's no need to call Check_Iterator_Functions. + -- Except when the aspect expression is a name that's an attribute + -- name, so it denotes one or more attribute subprograms, and the + -- checks are needed. - if Comes_From_Source (ASN) then + if Comes_From_Source (ASN) + or else Is_Direct_Attribute_Subp_Name (Chars (Expr)) + then Check_Iterator_Functions (Typ => Entity (ASN), Expr => Expression (ASN)); end if; + return; -- Finalizable, legality checks in Validate_Finalizable_Aspect @@ -12795,13 +12854,27 @@ package body Sem_Ch13 is -- Set Error_Msg_Warn based on whether errors are wanted, so that -- messages with "<<" will be reported appropriately as warnings - -- or errors. + -- or errors. Note that we always want messages to be errors in + -- the case of attribute subprograms. - Error_Msg_Warn := not Error_On_Ineligible; - Error_Msg_NE (Msg, ASN, Typ); + Error_Msg_Warn := not Error_On_Ineligible + and then not Is_Direct_Attribute_Subp_Name (Chars (Subp)); - Error_Msg_Sloc := Sloc (Subp); - Error_Msg_NE ("\ineligible operation & declared#", ASN, Subp); + -- When the subprogram's name is an attribute name, then we flag + -- the error on the subprogram itself rather than the aspect, which + -- was implicitly created in this case (so the error would be flagged + -- on the type, which would be confusing). (Maybe we should always + -- flag these errors on the subprograms themselves???) + + if Is_Direct_Attribute_Subp_Name (Chars (Subp)) then + Error_Msg_NE (Msg, Subp, Typ); + + else + Error_Msg_NE (Msg, ASN, Typ); + + Error_Msg_Sloc := Sloc (Subp); + Error_Msg_NE ("\ineligible operation & declared#", ASN, Subp); + end if; end Report_Ineligible_Indexing_Function; --------------------------- @@ -12889,6 +12962,10 @@ package body Sem_Ch13 is (Param_Type => Etype (First_Formal (Subp)), Specific_Type => Typ); + No_Eligible_Func_Or_Is_Attr_Subp : constant Boolean := + not Has_Eligible_Func + or else Is_Direct_Attribute_Subp_Name (Chars (Subp)); + -- Start of processing for Check_Function_For_Indexing_Aspect begin @@ -12916,7 +12993,7 @@ package body Sem_Ch13 is if Scope (Subp) /= Scope (Typ) and then not Has_Class_Wide_First_Formal then - if not Has_Eligible_Func and then Error_On_Ineligible then + if Error_On_Ineligible and then No_Eligible_Func_Or_Is_Attr_Subp then Report_Ineligible_Indexing_Function ("indexing aspect requires function with same scope as type&"); end if; @@ -12928,7 +13005,7 @@ package body Sem_Ch13 is -- identified, and never issue a warning. elsif not Is_Overloadable (Subp) or else No (Ret_Type) then - if not Has_Eligible_Func and then Error_On_Ineligible then + if Error_On_Ineligible and then No_Eligible_Func_Or_Is_Attr_Subp then Report_Ineligible_Indexing_Function ("illegal indexing function for type&"); end if; @@ -12936,7 +13013,7 @@ package body Sem_Ch13 is return; elsif No (First_Formal (Subp)) then - if not Has_Eligible_Func then + if No_Eligible_Func_Or_Is_Attr_Subp then Report_Ineligible_Indexing_Function ("indexing aspect requires a function that applies to type&<<"); end if; @@ -12946,7 +13023,7 @@ package body Sem_Ch13 is elsif not Subp_Is_Dispatching_Op_Of_Typ (Subp => Subp, Typ => Typ) and then not Has_Class_Wide_First_Formal then - if not Has_Eligible_Func then + if No_Eligible_Func_Or_Is_Attr_Subp then Report_Ineligible_Indexing_Function ("indexing aspect requires function with first formal " & "applying to type& or its class-wide type<<"); @@ -12954,7 +13031,7 @@ package body Sem_Ch13 is return; elsif No (Next_Formal (First_Formal (Subp))) then - if not Has_Eligible_Func then + if No_Eligible_Func_Or_Is_Attr_Subp then Report_Ineligible_Indexing_Function ("at least two parameters required for indexing function<<"); end if; @@ -13147,7 +13224,9 @@ package body Sem_Ch13 is Analyze (Expr); if not Is_Entity_Name (Expr) then - Error_Msg_N ("aspect Default_Iterator must be a function name", Expr); + Error_Msg_N ("aspect Default_Iterator must denote a function", Expr); + + return; end if; if not Is_Overloaded (Expr) then @@ -19469,6 +19548,7 @@ package body Sem_Ch13 is Is_Match : Boolean; Match : Interp; Match2 : Entity_Id := Empty; + Subp : Entity_Id := Empty; function Matching (Param_Id : Entity_Id; Param_Type : Entity_Id) return Boolean; @@ -19492,8 +19572,12 @@ package body Sem_Ch13 is begin -- If the aspect specification was effectively inherited from the parent -- type (so constructed anew by analysis), then no point in validating. + -- Except when the aspect expression is an attribute name, as it denotes + -- an attribute subprogram, and we do want to do the checks here. - if not Comes_From_Source (ASN) then + if not Comes_From_Source (ASN) + and then not Is_Direct_Attribute_Subp_Name (Chars (Func_Name)) + then return; end if; @@ -19551,28 +19635,27 @@ package body Sem_Ch13 is and then Base_Type (Etype (It.Nam)) = Base_Type (Typ) then declare - Params : constant List_Id := - Parameter_Specifications (Parent (It.Nam)); - Param_Spec : Node_Id; + Formal : Entity_Id := First_Formal (It.Nam); begin - if List_Length (Params) = 1 then - Param_Spec := First (Params); - Is_Match := - Matching (Defining_Identifier (Param_Spec), Param_Type); + Subp := It.Nam; + + if Present (Formal) + and then not Present (Next_Formal (Formal)) + then + Is_Match := Matching (Formal, Param_Type); -- Look for the optional overloaded 2-param Real_Literal - elsif List_Length (Params) = 2 + elsif Present (Formal) + and then Present (Next_Formal (Formal)) and then A_Id = Aspect_Real_Literal then - Param_Spec := First (Params); + if Matching (Formal, Param_Type) then + Formal := Next_Formal (Formal); - if Matching (Defining_Identifier (Param_Spec), Param_Type) - then - Param_Spec := Next (Param_Spec); - - if Matching (Defining_Identifier (Param_Spec), Param_Type) + if not Present (Next_Formal (Formal)) + and then Matching (Formal, Param_Type) then if No (Match2) then Match2 := It.Nam; @@ -19613,8 +19696,20 @@ package body Sem_Ch13 is end loop; if not Match_Found then - Error_Msg_N - ("function name in aspect specification cannot be resolved", ASN); + if not Comes_From_Source (ASN) + and then Present (Subp) + and then Is_Direct_Attribute_Subp_Name (Chars (Subp)) + then + Error_Msg_Name_1 := Chars (Identifier (ASN)); + + Error_Msg_N + ("attribute subprogram not valid for aspect%", Subp); + else + Error_Msg_N + ("function name in aspect specification cannot be resolved", + ASN); + end if; + return; end if; diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 0b31c9e15d6..d5f1e6887b1 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -53,6 +53,13 @@ package Sem_Ch13 is -- routine. This routine diagnoses misplaced aspects that should appear on -- the initial declaration of N and offers suggestions for replacements. + procedure Analyze_One_Aspect + (N : Node_Id; + E : N_Entity_Id; + Aspect : Node_Id); + -- N and E are what was passed to Analyze_Aspect_Specifications. + -- Aspect is one element of Aspect_Specifications (N). + procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id); -- Called from Freeze where R is a record entity for which reverse bit -- order is specified and there is at least one component clause. Note: diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 47556e147f2..293f3376039 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -16567,7 +16567,10 @@ package body Sem_Ch3 is -- is normally just a copy of the parent name. An exception arises for -- type support subprograms, where the name is changed to reflect the -- name of the derived type, e.g. if type foo is derived from type bar, - -- then a procedure barDA is derived with a name fooDA. + -- then a procedure barDA is derived with name fooDA. Another exception + -- is for the case of attribute subprograms, where the name is changed + -- to substitute the derived type's name for the parent type's name + -- (e.g., changing "parent'put_image" to "derived'put_image"). --------------------------- -- Is_Private_Overriding -- @@ -16739,7 +16742,38 @@ package body Sem_Ch3 is procedure Set_Derived_Name is Nm : constant TSS_Name_Type := Get_TSS_Name (Parent_Subp); begin - if Nm = TSS_Null then + if Is_Direct_Attribute_Subp_Name (Chars (Parent_Subp)) then + declare + Derived_Type_Name : constant String := + Get_Name_String (Chars (Derived_Type)); + + Parent_Subp_Name : constant String := + Get_Name_String (Chars (Parent_Subp)); + + Att_Buf : Bounded_String + (Max_Length => Derived_Type_Name'Length + + Parent_Subp_Name'Length); + begin + for J in 2 .. Parent_Subp_Name'Length loop + + -- J is at the position separating the prefix from the + -- attribute name. + + if Parent_Subp_Name (J) = ''' then + Append (Att_Buf, Derived_Type_Name); + Append (Att_Buf, "'"); + Append + (Att_Buf, + Parent_Subp_Name (J + 1 .. Parent_Subp_Name'Length)); + + exit; + end if; + end loop; + + Set_Chars (New_Subp, Name_Find (Att_Buf)); + end; + + elsif Nm = TSS_Null then Set_Chars (New_Subp, Chars (Parent_Subp)); else Set_Chars (New_Subp, Make_TSS_Name (Base_Type (Derived_Type), Nm)); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d2fc515596b..0f886a5db56 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -5231,6 +5231,19 @@ package body Sem_Ch6 is (E : Entity_Id; T : Entity_Id) return Boolean; -- Returns whether E can be declared the destructor of T + procedure Create_And_Append_Aspect + (Aspect_Name : Name_Id; + Subp_Name : Name_Id; + Typ : Entity_Id); + -- Creates, adds, and analyzes an aspect spec for Aspect_Name that + -- specifies Subp_Name to Typ's list of representation items, unless + -- the type already has such an aspect, or the type is a derived type + -- that will inherit the aspect from its parent, or the aspect is + -- a nonoverridable aspect. An error will be issued for an attempt + -- to specify the aspect via an attribute subprogram if the type + -- already explicitly specifies the aspect or inherits the aspect + -- from a type that explicitly specifies it. + ----------------------------------- -- Add_Default_Initialize_Aspect -- ----------------------------------- @@ -5275,34 +5288,155 @@ package body Sem_Ch6 is and then No (Next_Formal (First_Formal (E))); end Can_Be_Destructor_Of; + ------------------------------ + -- Create_And_Append_Aspect -- + ------------------------------ + + procedure Create_And_Append_Aspect + (Aspect_Name : Name_Id; + Subp_Name : Name_Id; + Typ : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Typ); + + Subp_Aspect_Id : constant Aspect_Id := + Get_Aspect_Id (Aspect_Name); + + Subp_Aspect : Node_Id := Find_Aspect (Typ, Subp_Aspect_Id); + + Type_Decl : constant Node_Id := Parent (Typ); + + begin + -- We disallow attempts to use both forms of specifying the aspect + -- (an explicit aspect together with using attribute subprograms). + -- This also applies to derived types where the parent type has + -- an explicit aspect specification. + + if Present (Subp_Aspect) + and then Comes_From_Source (Subp_Aspect) + then + Error_Msg_Sloc := Sloc (Designator); + + Error_Msg_NE + ("aspect% conflicts with use of attribute subprogram&#", + Subp_Aspect, Designator); + + return; + end if; + + -- If the type doesn't already have an aspect associated with + -- itself, and it's not a derived type, or it is derived but + -- its parent type doesn't have the aspect (which, if it had + -- it, would be inherited in Inherit_Nonoverridable_Aspects), + -- or it's not a nonoverridable aspect (so it won't be inherited + -- from a parent type), then create the aspect now. + + if (not Present (Subp_Aspect) + or else Entity (Subp_Aspect) /= Typ) + and then + (not Is_Derived_Type (Typ) + or else + not Present (Find_Aspect (Etype (Typ), Subp_Aspect_Id)) + or else + Subp_Aspect_Id not in Nonoverridable_Aspect_Id) + then + Subp_Aspect := + Make_Aspect_Specification (Loc, + Identifier => Make_Identifier (Loc, Aspect_Name), + Expression => Make_Identifier (Loc, Subp_Name), + Class_Present => Is_Class_Wide_Type (Typ)); + Set_Entity (Subp_Aspect, Typ); + + if No (Aspect_Specifications (Type_Decl)) then + Set_Aspect_Specifications + (Type_Decl, New_List (Subp_Aspect)); + else + Append_To + (Aspect_Specifications (Type_Decl), Subp_Aspect); + end if; + + Set_Expression_Copy + (Subp_Aspect, New_Copy_Tree (Expression (Subp_Aspect))); + + Analyze_One_Aspect (Type_Decl, Typ, Subp_Aspect); + end if; + end Create_And_Append_Aspect; + -- Local variables - Att_N : constant Node_Id := Original_Node (N); - Prefix_E : constant Entity_Id := - Get_Full_View - (Current_Entity (Prefix (Defining_Unit_Name (Att_N)))); - Att_Name : constant Name_Id := + Att_N : constant Node_Id := Original_Node (N); + Att_Prefix : constant Node_Id := Prefix (Defining_Unit_Name (Att_N)); + Att_Name : constant Name_Id := Attribute_Name (Defining_Unit_Name (Att_N)); + Is_Class_Wide_Attr : constant Boolean := + Nkind (Att_Prefix) = N_Attribute_Reference + and then Attribute_Name (Att_Prefix) = Name_Class; + + Curr_Ent_In_Scope : constant Entity_Id := + Current_Entity_In_Scope + (if Is_Class_Wide_Attr + then Prefix (Att_Prefix) -- cases like T'Class'Write + else Att_Prefix); + + Prefix_E : Entity_Id := Empty; + -- Start of processing for Analyze_Direct_Attribute_Definition begin pragma Assert (N /= Att_N); + Error_Msg_Name_1 := Att_Name; + if not Is_Direct_Attribute_Definition_Name (Att_Name) then - Error_Msg_Name_1 := Att_Name; Error_Msg_N ("direct definition syntax not supported for attribute%", Designator); end if; + if Is_Library_Level_Entity (Designator) + and then Scope (Designator) = Standard_Standard + then + Error_Msg_N + ("attribute names not allowed for library subprograms", + Designator); + return; + end if; + + if Is_Class_Wide_Attr + and then + Att_Name not in Name_Input | Name_Output | Name_Read | Name_Write + then + Error_Msg_N + ("% not supported as class-wide attribute", Designator); + return; + end if; + + if No (Curr_Ent_In_Scope) then + Error_Msg_N + ("prefix& of attribute% must be a type with same scope", + Att_Prefix); + return; + + else + Prefix_E := Get_Full_View (Curr_Ent_In_Scope); + + if Is_Class_Wide_Attr then + if Is_Tagged_Type (Prefix_E) then + Prefix_E := Class_Wide_Type (Prefix_E); + else + Error_Msg_N + ("prefix& not allowed for untagged type", Att_Prefix); + return; + end if; + end if; + end if; + -- Handle each kind of attribute separately case Att_Name is when Name_Constructor => - Error_Msg_Name_1 := Att_Name; - -- If missing, add a default initialization aspect for this -- constructor's body stub: Initialize => (others => <>). @@ -5374,7 +5508,9 @@ package body Sem_Ch6 is when Name_Destructor => if Parent_Kind (N) not in N_Subprogram_Declaration then return; - elsif not Is_Record_Type (Prefix_E) then + elsif not Present (Prefix_E) + or else not Is_Record_Type (Prefix_E) + then Error_Msg_N ("destructors can only be specified for record types", Designator); @@ -5404,9 +5540,39 @@ package body Sem_Ch6 is Set_Destructor (Prefix_E, Designator); end if; - when others => - null; + when Name_Constant_Indexing + | Name_Default_Iterator + | Name_Integer_Literal + | Name_Put_Image + | Name_Real_Literal + | Name_String_Literal + | Name_Variable_Indexing + | Name_Read + | Name_Input + | Name_Write + | Name_Output + => + if Scope (Prefix_E) /= Current_Scope then + Error_Msg_N ("subprogram for aspect must be declared in " + & "same scope as&", Att_Prefix); + elsif not Is_Type (Prefix_E) then + Error_Msg_N + ("prefix& of attribute% must be a type with same scope", + Att_Prefix); + + -- Create an aspect for the appropriate type, unless we have + -- a subprogram body, since the aspect will already have been + -- created for the subprogram declaration. (Except maybe for + -- rare case of subp body that serves as the declaration? ???) + + elsif Nkind (Parent (N)) /= N_Subprogram_Body then + Create_And_Append_Aspect + (Att_Name, Chars (Designator), Prefix_E); + end if; + + when others => + null; end case; end Analyze_Direct_Attribute_Definition; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 3df3ebdb103..e8490bc503e 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -5647,7 +5647,7 @@ package body Sem_Ch8 is procedure Find_Direct_Name (N : Node_Id) is E : Entity_Id; E2 : Entity_Id; - Msg : Boolean; + Msg : Boolean := False; Homonyms : Entity_Id; -- Saves start of homonym chain diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index bed4e74793f..4c56f906c3c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -111,6 +111,12 @@ package body Sem_Util is -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints, -- Loc is the source location, T is the original subtype. + function Direct_Attribute_Names_Correspond + (Parent_Subp : Entity_Id; Candidate_Subp : Entity_Id) return Boolean; + -- Returns True if both Parent_Subp and Candidate_Subp are names of + -- attribute subprograms and the aspect parts of their names are for + -- the same aspect; otherwise returns False. + procedure Examine_Array_Bounds (Typ : Entity_Id; All_Static : out Boolean; @@ -6392,19 +6398,50 @@ package body Sem_Util is -------------------------------------- function Direct_Attribute_Definition_Name - (Prefix : Entity_Id; Att_Name : Name_Id) return Name_Id is + (Prefix : Entity_Id; Att_Name : Name_Id) return Name_Id + is + Initial_Prefix : Entity_Id := Prefix; + Prefix_Attr_Name : Name_Id; + Is_Class_Wide_Attr : Boolean := False; + begin - if Nkind (Prefix) = N_Attribute_Reference then - Error_Msg_N ("attribute streams not supported in " - & "direct attribute definitions", - Prefix); + -- Account for "Class" attribute names (for stream attributes), + -- when either the prefix already denotes a class-wide type or + -- the prefix has the form "T'Class". + + if Is_Entity (Prefix) and then Is_Class_Wide_Type (Prefix) then + Initial_Prefix := Root_Type (Prefix); + Is_Class_Wide_Attr := True; + + elsif Nkind (Prefix) = N_Attribute_Reference then + Prefix_Attr_Name := Attribute_Name (Prefix); + + if Prefix_Attr_Name /= Name_Class then + Error_Msg_N ("unsupported kind of attribute in " + & "direct attribute definition", + Prefix); + else + Is_Class_Wide_Attr := True; + end if; + + Initial_Prefix := Sinfo.Nodes.Prefix (Prefix); + end if; + + if Nkind (Prefix) = N_Defining_Program_Unit_Name then + if Present (Name (Prefix)) then + Error_Msg_N + ("attribute names not allowed for library subprograms", Prefix); + end if; + + Initial_Prefix := Defining_Identifier (Prefix); end if; pragma Assert (Is_Attribute_Name (Att_Name)); return New_External_Name - (Related_Id => Chars (Prefix), - Suffix => "_" & Get_Name_String (Att_Name) & "_Att", - Prefix => 'D'); + (Related_Id => Chars (Initial_Prefix), + Suffix => + (if Is_Class_Wide_Attr then "'class" else "") + & "'" & Get_Name_String (Att_Name)); end Direct_Attribute_Definition_Name; -------------------------------------- @@ -6754,10 +6791,13 @@ package body Sem_Util is -- but for predefined dispatching operations we cannot rely on -- the name of the primitive to identify a candidate since their -- name is internally built by adding a suffix to the name of the - -- tagged type. + -- tagged type. We also account for cases of attribute subprograms, + -- where the subprogram names may differ, but correspondence and + -- overriding can still occur. if Chars (Subp) = Chars (Ancestor_Op) or else Is_Predefined_Dispatching_Operation (Subp) + or else Direct_Attribute_Names_Correspond (Ancestor_Op, Subp) then -- Handle case where Ancestor_Op is a primitive of a progenitor. -- We rely on internal entities that map interface primitives: @@ -7584,6 +7624,46 @@ package body Sem_Util is end if; end Designate_Same_Unit; + --------------------------------------- + -- Direct_Attribute_Names_Correspond -- + --------------------------------------- + + function Direct_Attribute_Names_Correspond + (Parent_Subp : Entity_Id; Candidate_Subp : Entity_Id) return Boolean + is + begin + if not Is_Direct_Attribute_Subp_Name (Chars (Parent_Subp)) + or else not Is_Direct_Attribute_Subp_Name (Chars (Candidate_Subp)) + then + return False; + + else + declare + Parent_Name : constant String := + Get_Name_String (Chars (Parent_Subp)); + Parent_Attr_Start : Natural := 2; + + Cand_Name : constant String := + Get_Name_String (Chars (Candidate_Subp)); + Cand_Attr_Start : Natural := 2; + begin + while Parent_Name (Parent_Attr_Start) /= ''' loop + Parent_Attr_Start := Parent_Attr_Start + 1; + end loop; + + while Cand_Name (Cand_Attr_Start) /= ''' loop + Cand_Attr_Start := Cand_Attr_Start + 1; + end loop; + + -- Compare the internal subprogram names from the apostrophe on, + -- to determine whether names are for the same aspect/attribute. + + return Parent_Name (Parent_Attr_Start .. Parent_Name'Last) + = Cand_Name (Cand_Attr_Start .. Cand_Name'Last); + end; + end if; + end Direct_Attribute_Names_Correspond; + ------------------------ -- Discriminated_Size -- ------------------------ @@ -15426,12 +15506,30 @@ package body Sem_Util is New_Item : Node_Id; Item_Aspect_Id : constant Nonoverridable_Aspect_Id := Get_Aspect_Id (Item); + New_Expr : Node_Id; begin + -- When the expression of the parent aspect is a name that has + -- the form of a direct attribute subprogram name, then construct + -- a new name using the derived type's name combined with the same + -- attribute/aspect name. + + if Nkind (Expression (Item)) = N_Identifier + and then + Is_Direct_Attribute_Subp_Name (Chars (Expression (Item))) + then + New_Expr := + Make_Identifier (Loc, + Direct_Attribute_Definition_Name + (Typ, Aspect_Names (Item_Aspect_Id))); + else + New_Expr := New_Copy_Tree (Expression (Item)); + end if; + New_Item := Make_Aspect_Specification ( Sloc => Loc, Identifier => Identifier (Item), - Expression => New_Copy_Tree (Expression (Item))); + Expression => New_Expr); Set_Entity (New_Item, Typ); -- We are trying here to implement RM 13.1(15.5): @@ -16487,6 +16585,24 @@ package body Sem_Util is and then Attribute_Name (N) = Name_Result; end Is_Attribute_Result; + ----------------------------------- + -- Is_Direct_Attribute_Subp_Name -- + ----------------------------------- + + function Is_Direct_Attribute_Subp_Name (Nam : Name_Id) return Boolean is + Name_Str : constant String := Get_Name_String (Nam); + Index : Positive := 1; + + begin + while Index < Name_Str'Length and then Name_Str (Index) /= ''' loop + Index := Index + 1; + end loop; + + -- Return True iff an apostrophe is found before the end of the name + + return Index < Name_Str'Length; + end Is_Direct_Attribute_Subp_Name; + ----------------------------------- -- Is_Direct_Attribute_Subp_Spec -- ----------------------------------- @@ -27543,7 +27659,9 @@ package body Sem_Util is and then Is_Predefined_Dispatching_Operation (E2) and then Same_TSS (E1, E2)) or else - (Is_Init_Proc (E1) and then Is_Init_Proc (E2)); + (Is_Init_Proc (E1) and then Is_Init_Proc (E2)) + or else + Direct_Attribute_Names_Correspond (E1, E2); end Primitive_Names_Match; ----------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 2c2eb1a3678..97a219c88e8 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1941,6 +1941,11 @@ package Sem_Util is function Is_Attribute_Result (N : Node_Id) return Boolean; -- Determine whether node N denotes attribute 'Result + function Is_Direct_Attribute_Subp_Name (Nam : Name_Id) return Boolean; + -- Determine whether Nam has the proper form for being the name of + -- a direct attribute definition subprogram (basically the function + -- tests that the name string includes an apostrophe). + function Is_Direct_Attribute_Subp_Spec (N : Node_Id) return Boolean; -- Determine whether N denotes a direct attribute definition subprogram -- specification node. diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl index 28a0c9a9d18..20868c8776d 100644 --- a/gcc/ada/snames.adb-tmpl +++ b/gcc/ada/snames.adb-tmpl @@ -126,12 +126,8 @@ package body Snames is function Get_Attribute_Id (N : Name_Id) return Attribute_Id is begin case N is - when Name_Constant_Indexing => - return Attribute_Constant_Indexing; when Name_CPU => return Attribute_CPU; - when Name_Default_Iterator => - return Attribute_Default_Iterator; when Name_Dispatching_Domain => return Attribute_Dispatching_Domain; when Name_Implicit_Dereference => @@ -142,8 +138,6 @@ package body Snames is return Attribute_Iterable; when Name_Iterator_Element => return Attribute_Iterator_Element; - when Name_Variable_Indexing => - return Attribute_Variable_Indexing; when First_Attribute_Name .. Last_Attribute_Name => return Attribute_Id'Val (N - First_Attribute_Name); when others => @@ -419,7 +413,20 @@ package body Snames is function Is_Direct_Attribute_Definition_Name (N : Name_Id) return Boolean is begin return - Is_Attribute_Name (N) and then N in Name_Constructor | Name_Destructor; + Is_Attribute_Name (N) + and then N in Name_Constant_Indexing + | Name_Constructor + | Name_Default_Iterator + | Name_Destructor + | Name_Input + | Name_Integer_Literal + | Name_Output + | Name_Put_Image + | Name_Read + | Name_Real_Literal + | Name_String_Literal + | Name_Variable_Indexing + | Name_Write; end Is_Direct_Attribute_Definition_Name; ------------------------------ diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 45156b461c5..6359c3714e1 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -159,17 +159,14 @@ package Snames is Name_Finalizable : constant Name_Id := N + $; Name_Full_Access_Only : constant Name_Id := N + $; Name_Ghost_Predicate : constant Name_Id := N + $; - Name_Integer_Literal : constant Name_Id := N + $; Name_Local_Restrictions : constant Name_Id := N + $; Name_No_Controlled_Parts : constant Name_Id := N + $; Name_No_Task_Parts : constant Name_Id := N + $; Name_Potentially_Invalid : constant Name_Id := N + $; - Name_Real_Literal : constant Name_Id := N + $; Name_Relaxed_Initialization : constant Name_Id := N + $; Name_Stable_Properties : constant Name_Id := N + $; Name_Static_Predicate : constant Name_Id := N + $; Name_Storage_Model_Type : constant Name_Id := N + $; - Name_String_Literal : constant Name_Id := N + $; Name_Synchronization : constant Name_Id := N + $; Name_Taint_Sanitizer : constant Name_Id := N + $; Name_Taint_Sink : constant Name_Id := N + $; @@ -960,10 +957,12 @@ package Snames is Name_Compiler_Version : constant Name_Id := N + $; -- GNAT Name_Component_Size : constant Name_Id := N + $; Name_Compose : constant Name_Id := N + $; + Name_Constant_Indexing : constant Name_Id := N + $; -- Ada 05 Name_Constrained : constant Name_Id := N + $; Name_Constructor : constant Name_Id := N + $; Name_Count : constant Name_Id := N + $; Name_Default_Bit_Order : constant Name_Id := N + $; -- GNAT + Name_Default_Iterator : constant Name_Id := N + $; -- GNAT Name_Default_Scalar_Storage_Order : constant Name_Id := N + $; -- GNAT Name_Definite : constant Name_Id := N + $; Name_Delta : constant Name_Id := N + $; @@ -994,6 +993,7 @@ package Snames is Name_Identity : constant Name_Id := N + $; Name_Index : constant Name_Id := N + $; -- Ada 22 Name_Initialized : constant Name_Id := N + $; -- GNAT + Name_Integer_Literal : constant Name_Id := N + $; -- Ada 12 Name_Integer_Value : constant Name_Id := N + $; -- GNAT Name_Invalid_Value : constant Name_Id := N + $; -- GNAT Name_Large : constant Name_Id := N + $; -- Ada 83 @@ -1037,6 +1037,7 @@ package Snames is Name_Priority : constant Name_Id := N + $; -- Ada 05 Name_Range : constant Name_Id := N + $; Name_Range_Length : constant Name_Id := N + $; -- GNAT + Name_Real_Literal : constant Name_Id := N + $; -- Ada 12 Name_Reduce : constant Name_Id := N + $; -- Ada 22 Name_Ref : constant Name_Id := N + $; -- GNAT Name_Restriction_Set : constant Name_Id := N + $; -- GNAT @@ -1058,6 +1059,7 @@ package Snames is Name_Storage_Size : constant Name_Id := N + $; Name_Storage_Unit : constant Name_Id := N + $; -- GNAT Name_Stream_Size : constant Name_Id := N + $; -- Ada 05 + Name_String_Literal : constant Name_Id := N + $; -- Ada 12 Name_Super : constant Name_Id := N + $; -- GNAT Name_System_Allocator_Alignment : constant Name_Id := N + $; -- GNAT Name_Tag : constant Name_Id := N + $; @@ -1078,6 +1080,7 @@ package Snames is Name_Valid : constant Name_Id := N + $; Name_Valid_Scalars : constant Name_Id := N + $; -- GNAT Name_Value_Size : constant Name_Id := N + $; -- GNAT + Name_Variable_Indexing : constant Name_Id := N + $; -- Ada 05 Name_Version : constant Name_Id := N + $; Name_Wchar_T_Size : constant Name_Id := N + $; -- GNAT Name_Wide_Wide_Width : constant Name_Id := N + $; -- Ada 05 @@ -1168,16 +1171,13 @@ package Snames is -- internal attributes is not permitted). First_Internal_Attribute_Name : constant Name_Id := N + $; - Name_Constant_Indexing : constant Name_Id := N + $; -- GNAT Name_CPU : constant Name_Id := N + $; - Name_Default_Iterator : constant Name_Id := N + $; -- GNAT Name_Dispatching_Domain : constant Name_Id := N + $; Name_Implicit_Dereference : constant Name_Id := N + $; -- GNAT Name_Interrupt_Priority : constant Name_Id := N + $; Name_Iterable : constant Name_Id := N + $; -- GNAT Name_Iterator_Element : constant Name_Id := N + $; -- GNAT Name_Secondary_Stack_Size : constant Name_Id := N + $; -- GNAT - Name_Variable_Indexing : constant Name_Id := N + $; -- GNAT Last_Internal_Attribute_Name : constant Name_Id := N + $; -- Names of recognized locking policy identifiers @@ -1499,10 +1499,12 @@ package Snames is Attribute_Compiler_Version, Attribute_Component_Size, Attribute_Compose, + Attribute_Constant_Indexing, Attribute_Constrained, Attribute_Constructor, Attribute_Count, Attribute_Default_Bit_Order, + Attribute_Default_Iterator, Attribute_Default_Scalar_Storage_Order, Attribute_Definite, Attribute_Delta, @@ -1533,6 +1535,7 @@ package Snames is Attribute_Identity, Attribute_Index, Attribute_Initialized, + Attribute_Integer_Literal, Attribute_Integer_Value, Attribute_Invalid_Value, Attribute_Large, @@ -1576,6 +1579,7 @@ package Snames is Attribute_Priority, Attribute_Range, Attribute_Range_Length, + Attribute_Real_Literal, Attribute_Reduce, Attribute_Ref, Attribute_Restriction_Set, @@ -1597,6 +1601,7 @@ package Snames is Attribute_Storage_Size, Attribute_Storage_Unit, Attribute_Stream_Size, + Attribute_String_Literal, Attribute_Super, Attribute_System_Allocator_Alignment, Attribute_Tag, @@ -1617,6 +1622,7 @@ package Snames is Attribute_Valid, Attribute_Valid_Scalars, Attribute_Value_Size, + Attribute_Variable_Indexing, Attribute_Version, Attribute_Wchar_T_Size, Attribute_Wide_Wide_Width, @@ -1680,18 +1686,15 @@ package Snames is -- the special processing required to deal with the fact that their -- names are not attribute names. - Attribute_Constant_Indexing, Attribute_CPU, - Attribute_Default_Iterator, Attribute_Dispatching_Domain, Attribute_Implicit_Dereference, Attribute_Interrupt_Priority, Attribute_Iterable, - Attribute_Iterator_Element, - Attribute_Variable_Indexing); + Attribute_Iterator_Element); subtype Internal_Attribute_Id is Attribute_Id - range Attribute_Constant_Indexing .. Attribute_Variable_Indexing; + range Attribute_CPU .. Attribute_Iterator_Element; type Attribute_Set is array (Attribute_Id) of Boolean; -- Type used to build attribute classification flag arrays -- 2.53.0
