From: Ed Schonberg <schonberg@adacore.com>
Date: Fri, 17 Apr 2020 18:07:18 +0000 (-0400)
Subject: [Ada] Additional legality rule for indexing operation for derived type
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=a5c11aa2d569cdeffa74ad3e9db9abee8db384e5;p=gcc.git

[Ada] Additional legality rule for indexing operation for derived type

2020-06-17  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_ch13.adb: (Check_Inherited_Indexing): Check that a type
	derived from an indexable container type cannot specify an
	indexing aspect if the same aspect is not specified for the
	parent type (RM 4.1.6 (6/5), AI12-160). Add a check that a
	specified indexing aspect for a derived type is confirming.
---

diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 05a511f5be3..3a0a4b2331d 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -5172,6 +5172,8 @@ package body Sem_Ch13 is
          procedure Check_Inherited_Indexing;
          --  For a derived type, check that no indexing aspect is specified
          --  for the type if it is also inherited
+         --  AI12-0160: verify that an indexing cannot be specified for
+         --  a derived type unless it is specified for the parent.
 
          procedure Check_One_Function (Subp : Entity_Id);
          --  Check one possible interpretation. Sets Indexing_Found True if a
@@ -5186,15 +5188,21 @@ package body Sem_Ch13 is
          ------------------------------
 
          procedure Check_Inherited_Indexing is
-            Inherited : Node_Id;
+            Inherited      : Node_Id;
+            Other_Indexing : Node_Id;
 
          begin
             if Attr = Name_Constant_Indexing then
                Inherited :=
                  Find_Aspect (Etype (Ent), Aspect_Constant_Indexing);
+               Other_Indexing :=
+                 Find_Aspect (Etype (Ent), Aspect_Variable_Indexing);
+
             else pragma Assert (Attr = Name_Variable_Indexing);
                Inherited :=
                   Find_Aspect (Etype (Ent), Aspect_Variable_Indexing);
+               Other_Indexing :=
+                 Find_Aspect (Etype (Ent), Aspect_Constant_Indexing);
             end if;
 
             if Present (Inherited) then
@@ -5207,6 +5215,16 @@ package body Sem_Ch13 is
                elsif Aspect_Rep_Item (Inherited) = N then
                   null;
 
+               --  Check if this is a confirming specification. The name
+               --  may be overloaded between the parent operation and the
+               --  inherited one, so we check that the Chars fields match.
+
+               elsif Is_Entity_Name (Expression (Inherited))
+                 and then Chars (Entity (Expression (Inherited))) =
+                    Chars (Entity (Expression (N)))
+               then
+                  Indexing_Found := True;
+
                --  Indicate the operation that must be overridden, rather than
                --  redefining the indexing aspect.
 
@@ -5217,6 +5235,15 @@ package body Sem_Ch13 is
                     ("!override & instead",
                      N, Entity (Expression (Inherited)));
                end if;
+
+            --  If not inherited and the parent has another indexing function
+            --  this is illegal, because it leads to inconsistent results in
+            --  class-wide calls.
+
+            elsif Present (Other_Indexing) then
+               Error_Msg_N
+                 ("cannot specify indexing operation on derived type"
+                   & " if not specified for parent", N);
             end if;
          end Check_Inherited_Indexing;
 
@@ -5239,7 +5266,12 @@ package body Sem_Ch13 is
                   --  Indexing function can't be declared elsewhere
 
                   Illegal_Indexing
-                    ("indexing function must be declared in scope of type&");
+                    ("indexing function must be declared"
+                      & " in scope of type&");
+               end if;
+
+               if Is_Derived_Type (Ent) then
+                  Check_Inherited_Indexing;
                end if;
 
                return;