[COMMITTED,15/31] ada: Handle attributes related to Ada 2012 iterators as internal

Message ID 20250107125350.619654-15-poulhies@adacore.com
State New
Headers
Series [COMMITTED,01/31] ada: Restrict previous change made to expansion of allocators |

Commit Message

Marc Poulhiès Jan. 7, 2025, 12:53 p.m. UTC
  From: Piotr Trojanek <trojanek@adacore.com>

Use existing machinery for internal attributes to handle attributes
related to Ada 2012 iterators. All these attributes exist exclusively
as a mean to delay processing.

Code cleanup. The only change in behavior is the wording of error
emitted when one of the internal attributes appears in source code:
from "illegal attribute" (which used to be emitted in the analysis)
to "unrecognized attribute (which is emitted by the parser).

gcc/ada/ChangeLog:

	* exp_attr.adb (Expand_N_Attribute_Reference): Remove explicit
	handling of attributes related to Ada 2012 iterators.
	* sem_attr.adb (Analyze_Attribute, Eval_Attribute): Likewise;
	move attribute Reduce according to alphabetic order.
	* snames.adb-tmpl (Get_Attribute_Id): Add support for new internal
	attributes.
	* snames.ads-tmpl: Recognize names of new internal attributes.
	(Attribute_Id): Recognize new internal attributes.
	(Internal_Attribute_Id): Likewise.
	(Is_Internal_Attribute_Name): Avoid duplication in comment.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/exp_attr.adb    | 12 ------------
 gcc/ada/sem_attr.adb    | 32 +++++++-------------------------
 gcc/ada/snames.adb-tmpl | 33 ++++++++++++++++++++++++---------
 gcc/ada/snames.ads-tmpl | 32 +++++++++++++++-----------------
 4 files changed, 46 insertions(+), 63 deletions(-)
  

Patch

diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 904293bbd1d..911b9dcf807 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -2266,18 +2266,6 @@  package body Exp_Attr is
 
       case Id is
 
-      --  Attributes related to Ada 2012 iterators. They are only allowed in
-      --  attribute definition clauses and should never be expanded.
-
-      when Attribute_Constant_Indexing
-         | Attribute_Default_Iterator
-         | Attribute_Implicit_Dereference
-         | Attribute_Iterable
-         | Attribute_Iterator_Element
-         | Attribute_Variable_Indexing
-      =>
-         raise Program_Error;
-
       --  Internal attributes used to deal with Ada 2012 delayed aspects. These
       --  were already rejected by the parser. Thus they shouldn't appear here.
 
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 7295784704f..53b96501d78 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -3423,18 +3423,6 @@  package body Sem_Attr is
 
       case Attr_Id is
 
-      --  Attributes related to Ada 2012 iterators. Attribute specifications
-      --  exist for these, but they cannot be queried.
-
-      when Attribute_Constant_Indexing
-         | Attribute_Default_Iterator
-         | Attribute_Implicit_Dereference
-         | Attribute_Iterator_Element
-         | Attribute_Iterable
-         | Attribute_Variable_Indexing
-      =>
-         Error_Msg_N ("illegal attribute", N);
-
       --  Internal attributes used to deal with Ada 2012 delayed aspects. These
       --  were already rejected by the parser. Thus they shouldn't appear here.
 
@@ -9015,19 +9003,6 @@  package body Sem_Attr is
 
       case Id is
 
-      --  Attributes related to Ada 2012 iterators; nothing to evaluate for
-      --  these.
-
-      when Attribute_Constant_Indexing
-         | Attribute_Default_Iterator
-         | Attribute_Implicit_Dereference
-         | Attribute_Iterator_Element
-         | Attribute_Iterable
-         | Attribute_Reduce
-         | Attribute_Variable_Indexing
-      =>
-         null;
-
       --  Internal attributes used to deal with Ada 2012 delayed aspects.
       --  These were already rejected by the parser. Thus they shouldn't
       --  appear here.
@@ -10208,6 +10183,13 @@  package body Sem_Attr is
          end case;
       end Range_Length;
 
+      ------------
+      -- Reduce --
+      ------------
+
+      when Attribute_Reduce =>
+         null;
+
       ---------
       -- Ref --
       ---------
diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl
index d49fdf4d74a..62ca4de4866 100644
--- a/gcc/ada/snames.adb-tmpl
+++ b/gcc/ada/snames.adb-tmpl
@@ -125,15 +125,30 @@  package body Snames is
 
    function Get_Attribute_Id (N : Name_Id) return Attribute_Id is
    begin
-      if N = Name_CPU then
-         return Attribute_CPU;
-      elsif N = Name_Dispatching_Domain then
-         return Attribute_Dispatching_Domain;
-      elsif N = Name_Interrupt_Priority then
-         return Attribute_Interrupt_Priority;
-      else
-         return Attribute_Id'Val (N - First_Attribute_Name);
-      end if;
+      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 =>
+            return Attribute_Implicit_Dereference;
+         when Name_Interrupt_Priority =>
+            return Attribute_Interrupt_Priority;
+         when Name_Iterable =>
+            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 =>
+            raise Program_Error;
+      end case;
    end Get_Attribute_Id;
 
    -----------------------
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 59637940bee..4e0d94f5113 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -943,12 +943,10 @@  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 + $; -- GNAT
    Name_Constrained                    : constant Name_Id := N + $;
    Name_Count                          : constant Name_Id := N + $;
    Name_Default_Bit_Order              : constant Name_Id := N + $; -- GNAT
    Name_Default_Scalar_Storage_Order   : constant Name_Id := N + $; -- GNAT
-   Name_Default_Iterator               : constant Name_Id := N + $; -- GNAT
    Name_Definite                       : constant Name_Id := N + $;
    Name_Delta                          : constant Name_Id := N + $;
    Name_Denorm                         : constant Name_Id := N + $;
@@ -975,13 +973,10 @@  package Snames is
    Name_Has_Same_Storage               : constant Name_Id := N + $; -- Ada 12
    Name_Has_Tagged_Values              : constant Name_Id := N + $; -- GNAT
    Name_Identity                       : constant Name_Id := N + $;
-   Name_Implicit_Dereference           : constant Name_Id := N + $; -- GNAT
    Name_Index                          : constant Name_Id := N + $; -- Ada 22
    Name_Initialized                    : constant Name_Id := N + $; -- GNAT
    Name_Integer_Value                  : constant Name_Id := N + $; -- GNAT
    Name_Invalid_Value                  : constant Name_Id := N + $; -- GNAT
-   Name_Iterator_Element               : constant Name_Id := N + $; -- GNAT
-   Name_Iterable                       : constant Name_Id := N + $; -- GNAT
    Name_Large                          : constant Name_Id := N + $; -- Ada 83
    Name_Last                           : constant Name_Id := N + $;
    Name_Last_Bit                       : constant Name_Id := N + $;
@@ -1063,7 +1058,6 @@  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 + $; -- GNAT
    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
@@ -1152,10 +1146,16 @@  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
@@ -1480,12 +1480,10 @@  package Snames is
       Attribute_Compiler_Version,
       Attribute_Component_Size,
       Attribute_Compose,
-      Attribute_Constant_Indexing,
       Attribute_Constrained,
       Attribute_Count,
       Attribute_Default_Bit_Order,
       Attribute_Default_Scalar_Storage_Order,
-      Attribute_Default_Iterator,
       Attribute_Definite,
       Attribute_Delta,
       Attribute_Denorm,
@@ -1512,13 +1510,10 @@  package Snames is
       Attribute_Has_Same_Storage,
       Attribute_Has_Tagged_Values,
       Attribute_Identity,
-      Attribute_Implicit_Dereference,
       Attribute_Index,
       Attribute_Initialized,
       Attribute_Integer_Value,
       Attribute_Invalid_Value,
-      Attribute_Iterator_Element,
-      Attribute_Iterable,
       Attribute_Large,
       Attribute_Last,
       Attribute_Last_Bit,
@@ -1600,7 +1595,6 @@  package Snames is
       Attribute_Valid,
       Attribute_Valid_Scalars,
       Attribute_Value_Size,
-      Attribute_Variable_Indexing,
       Attribute_Version,
       Attribute_Wchar_T_Size,
       Attribute_Wide_Wide_Width,
@@ -1662,12 +1656,18 @@  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_Interrupt_Priority);
+      Attribute_Implicit_Dereference,
+      Attribute_Interrupt_Priority,
+      Attribute_Iterable,
+      Attribute_Iterator_Element,
+      Attribute_Variable_Indexing);
 
    subtype Internal_Attribute_Id is Attribute_Id
-     range Attribute_CPU .. Attribute_Interrupt_Priority;
+     range Attribute_Constant_Indexing .. Attribute_Variable_Indexing;
 
    type Attribute_Set is array (Attribute_Id) of Boolean;
    --  Type used to build attribute classification flag arrays
@@ -2058,9 +2058,7 @@  package Snames is
    --  i.e. an attribute reference that returns an entity.
 
    function Is_Internal_Attribute_Name (N : Name_Id) return Boolean;
-   --  Test to see if the name N is the name of an INT attribute (Name_CPU,
-   --  Name_Dispatching_Domain, Name_Interrupt_Priority,
-   --  Name_Secondary_Stack_Size).
+   --  Test to see if the name N is the name of an internal attribute
 
    function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean;
    --  Test to see if the name N is the name of a recognized attribute that