From 7cbdab5aa839ffd54dccbde6430905bb9c596201 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Thu, 4 Jul 2019 08:06:14 +0000 Subject: [PATCH] [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 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 --- gcc/ada/ChangeLog | 9 +++++++++ gcc/ada/sem_attr.adb | 5 ++++- gcc/testsuite/ChangeLog | 4 ++++ gcc/testsuite/gnat.dg/aspect2.adb | 5 +++++ gcc/testsuite/gnat.dg/aspect2.ads | 30 ++++++++++++++++++++++++++++++ 5 files changed, 52 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gnat.dg/aspect2.adb create mode 100644 gcc/testsuite/gnat.dg/aspect2.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 34a86ca..be26421 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2019-07-04 Ed Schonberg + + * 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 * sem_util.adb (Yields_Synchronized_Object): Fix typos in diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index bdc76c3..fd2c6d6 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 fc041c8..dd22271 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-07-04 Ed Schonberg + + * gnat.dg/aspect2.adb, gnat.dg/aspect2.ads: New testcase. + 2019-07-04 Yannick Moy * 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 0000000..acf3329 --- /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 0000000..73d3fe0 --- /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; -- 2.7.4