From: Ed Schonberg <schonberg@adacore.com>
Date: Thu, 4 Jul 2019 08:06:14 +0000 (+0000)
Subject: [Ada] Spurious error on 'First in a generic context
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=7cbdab5aa839ffd54dccbde6430905bb9c596201;p=gcc.git

[Ada] Spurious error on 'First in a generic context

This patch fixes a spurious error on an attribute reference within an
aspect specification for an unconstrained array type when the
corresponding type  declaration appears within a generic unit.

2019-07-04  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_attr.adb (Check_Array_Type): An array type attribute such
	as 'First can be applied to an unconstrained array tyope when
	the attribute reference appears within an aspect specification
	and the prefix is a current instance, given that the prefix of
	the attribute will become a formal of the subprogram that
	implements the aspect (typically a predicate check).

gcc/testsuite/

	* gnat.dg/aspect2.adb, gnat.dg/aspect2.ads: New testcase.

From-SVN: r273058
---

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 34a86ca402b..be26421081d 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2019-07-04  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_attr.adb (Check_Array_Type): An array type attribute such
+	as 'First can be applied to an unconstrained array tyope when
+	the attribute reference appears within an aspect specification
+	and the prefix is a current instance, given that the prefix of
+	the attribute will become a formal of the subprogram that
+	implements the aspect (typically a predicate check).
+
 2019-07-04  Piotr Trojanek  <trojanek@adacore.com>
 
 	* sem_util.adb (Yields_Synchronized_Object): Fix typos in
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index bdc76c3b200..fd2c6d681cf 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -1634,7 +1634,9 @@ package body Sem_Attr is
             raise Bad_Attribute;
          end if;
 
-         --  Normal case of array type or subtype
+         --  Normal case of array type or subtype. Note that if the
+         --  prefix is a current instance of a type declaration it
+         --  appears within an aspect specification and is legal.
 
          Check_Either_E0_Or_E1;
          Check_Dereference;
@@ -1643,6 +1645,7 @@ package body Sem_Attr is
             if not Is_Constrained (P_Type)
               and then Is_Entity_Name (P)
               and then Is_Type (Entity (P))
+              and then not Is_Current_Instance (P)
             then
                --  Note: we do not call Error_Attr here, since we prefer to
                --  continue, using the relevant index type of the array,
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index fc041c82e67..dd22271efe2 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2019-07-04  Ed Schonberg  <schonberg@adacore.com>
+
+	* gnat.dg/aspect2.adb, gnat.dg/aspect2.ads: New testcase.
+
 2019-07-04  Yannick Moy  <moy@adacore.com>
 
 	* gnat.dg/synchronized2.adb, gnat.dg/synchronized2.ads,
diff --git a/gcc/testsuite/gnat.dg/aspect2.adb b/gcc/testsuite/gnat.dg/aspect2.adb
new file mode 100644
index 00000000000..acf3329a3b4
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/aspect2.adb
@@ -0,0 +1,5 @@
+--  { dg-do compile }
+
+package body Aspect2 is
+    procedure Foo is null;
+end Aspect2;
diff --git a/gcc/testsuite/gnat.dg/aspect2.ads b/gcc/testsuite/gnat.dg/aspect2.ads
new file mode 100644
index 00000000000..73d3fe05074
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/aspect2.ads
@@ -0,0 +1,30 @@
+with Ada.Containers.Functional_Vectors;
+with Ada.Containers; use Ada.Containers;
+
+generic
+   type Element_Type (<>) is private;
+   type Element_Model (<>) is private;
+   with function Model (X : Element_Type) return Element_Model is <>;
+   with function Copy (X : Element_Type) return Element_Type is <>;
+package Aspect2 with SPARK_Mode is
+   pragma Unevaluated_Use_Of_Old (Allow);
+
+   type Vector is private;
+
+   function Length (V : Vector) return Natural;
+
+   procedure Foo;
+
+private
+   type Element_Access is access Element_Type;
+   type Element_Array is array (Positive range <>) of Element_Access with
+     Dynamic_Predicate => Element_Array'First = 1;
+   type Element_Array_Access is access Element_Array;
+   type Vector is record
+      Top     : Natural := 0;
+      Content : Element_Array_Access;
+   end record;
+
+   function Length (V : Vector) return Natural is
+     (V.Top);
+end Aspect2;