From c910db716273c381b4e2f36f3d04c6e480876b63 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 23 Jul 2019 08:13:15 +0000 Subject: [PATCH] [Ada] Iterators are view-specific Operational aspects, such as Default_Iterator, are view-specific, and if such an aspect appears on the full view of a private type, an object of the type cannot be iterated upon if it is not in the scope of the full view, This patch diagnoses properly an attempt to iterate over such an object. 2019-07-23 Ed Schonberg gcc/ada/ * aspects.ads: New table Operational_Aspect, used to distinguish between aspects that are view-specific, such as those related to iterators, and representation aspects that apply to all views of a type. * aspects.adb (Find_Aspect): If the aspect being sought is operational, do not ecamine the full view of a private type to retrieve it. * sem_ch5.adb (Analyze_Iterator_Specification): Improve error message when the intended domain of iteration does not implement the required iterator aspects. gcc/testsuite/ * gnat.dg/iter5.adb: Add an expected error. * gnat.dg/iter6.adb: New testcase. From-SVN: r273722 --- gcc/ada/ChangeLog | 13 +++++++++++++ gcc/ada/aspects.adb | 5 ++++- gcc/ada/aspects.ads | 14 ++++++++++++++ gcc/ada/sem_ch5.adb | 11 ++++++++++- gcc/testsuite/ChangeLog | 5 +++++ gcc/testsuite/gnat.dg/iter5.adb | 2 +- gcc/testsuite/gnat.dg/iter6.adb | 40 ++++++++++++++++++++++++++++++++++++++++ 7 files changed, 87 insertions(+), 3 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/iter6.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 748f1bf..a40a774 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2019-07-23 Ed Schonberg + + * aspects.ads: New table Operational_Aspect, used to distinguish + between aspects that are view-specific, such as those related to + iterators, and representation aspects that apply to all views of + a type. + * aspects.adb (Find_Aspect): If the aspect being sought is + operational, do not ecamine the full view of a private type to + retrieve it. + * sem_ch5.adb (Analyze_Iterator_Specification): Improve error + message when the intended domain of iteration does not implement + the required iterator aspects. + 2019-07-23 Yannick Moy * sem_spark.ads (Is_Local_Context): New function. diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 76fa6c8..54c0e56 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -225,7 +225,10 @@ package body Aspects is Owner := Root_Type (Owner); end if; - if Is_Private_Type (Owner) and then Present (Full_View (Owner)) then + if Is_Private_Type (Owner) + and then Present (Full_View (Owner)) + and then not Operational_Aspect (A) + then Owner := Full_View (Owner); end if; end if; diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 9190a635..2a6acc2 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -277,6 +277,20 @@ package Aspects is Aspect_Warnings => True, others => False); + -- The following array indicates aspects that specify operational + -- characteristics, and thus are view-specific. Representation + -- aspects break privacy, as they are needed during expansion and + -- code generation. + -- List is currently incomplete ??? + + Operational_Aspect : constant array (Aspect_Id) of Boolean := + (Aspect_Constant_Indexing => True, + Aspect_Default_Iterator => True, + Aspect_Iterator_Element => True, + Aspect_Iterable => True, + Aspect_Variable_Indexing => True, + others => False); + -- The following array indicates aspects for which multiple occurrences of -- the same aspect attached to the same declaration are allowed. diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index b77bd7e..ebe610b 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2234,8 +2234,17 @@ package body Sem_Ch5 is It : Interp; begin + -- THe domain of iteralion must implement either the RM + -- iterator interface, or the SPARK Iterable aspect. + if No (Iterator) then - null; -- error reported below + if No + (Find_Aspect (Etype (Iter_Name), Aspect_Iterable)) + then + Error_Msg_NE ("cannot iterate over&", + N, Base_Type (Etype (Iter_Name))); + return; + end if; elsif not Is_Overloaded (Iterator) then Check_Reverse_Iteration (Etype (Iterator)); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0ef05dd..03cf4bb 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2019-07-23 Ed Schonberg + + * gnat.dg/iter5.adb: Add an expected error. + * gnat.dg/iter6.adb: New testcase. + 2019-07-23 Yannick Moy * gnat.dg/ghost6.adb, gnat.dg/ghost6_pkg.ads: New testcase. diff --git a/gcc/testsuite/gnat.dg/iter5.adb b/gcc/testsuite/gnat.dg/iter5.adb index b17b435..fa21715 100644 --- a/gcc/testsuite/gnat.dg/iter5.adb +++ b/gcc/testsuite/gnat.dg/iter5.adb @@ -4,7 +4,7 @@ with Iter5_Pkg; procedure Iter5 is begin - for The_Filename of Iter5_Pkg.Iterator_For ("C:\Program_Files") loop + for The_Filename of Iter5_Pkg.Iterator_For ("C:\Program_Files") loop -- { dg-error "cannot iterate over \"Item\"" } null; end loop; end Iter5; diff --git a/gcc/testsuite/gnat.dg/iter6.adb b/gcc/testsuite/gnat.dg/iter6.adb new file mode 100644 index 0000000..371352b --- /dev/null +++ b/gcc/testsuite/gnat.dg/iter6.adb @@ -0,0 +1,40 @@ +-- { dg-do compile } + +with Ada.Iterator_Interfaces; + +procedure Iter6 is + package Pkg is + type Item (<>) is limited private; + private + + type Cursor is null record; + + function Constant_Reference (The_Item : aliased Item; + Unused_Index : Cursor) return String + is (""); + + function Has_More (Data : Cursor) return Boolean is (False); + + package List_Iterator_Interfaces is new Ada.Iterator_Interfaces + (Cursor, Has_More); + + function Iterate (The_Item : Item) + return List_Iterator_Interfaces.Forward_Iterator'class + is (raise Program_Error); + + type Item (Name_Length : Natural) is tagged limited record + null; + end record + with + Constant_Indexing => Constant_Reference, + Default_Iterator => Iterate, + Iterator_Element => String; + end Pkg; use Pkg; + + type Item_Ref is access Item; + function F return Item_Ref is (null); +begin + for I of F.all loop -- { dg-error "cannot iterate over \"Item\"" } + null; + end loop; +end; -- 2.7.4