aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
authorGary Dismukes <dismukes@adacore.com>2023-10-31 19:50:46 +0000
committerMarc Poulhiès <poulhies@adacore.com>2023-11-21 10:57:42 +0100
commitea60a4cd194eeea2d7a63b93b6b01b9c951302da (patch)
treec3f615477dfcdb9c1a4f1e35347aab435318aac3 /gcc
parent35510341fc24eed8fa3cd08171dc560b6d833fb2 (diff)
downloadgcc-ea60a4cd194eeea2d7a63b93b6b01b9c951302da.zip
gcc-ea60a4cd194eeea2d7a63b93b6b01b9c951302da.tar.gz
gcc-ea60a4cd194eeea2d7a63b93b6b01b9c951302da.tar.bz2
ada: Compiler error reporting illegal prefix on legal loop iterator with "in"
During semantic analysis, the compiler fails to determine the cursor type in the case of a generalized iterator loop with "in", in the case where the iterator type has a parent type that is a controlled type (for example) and its ancestor iterator interface type is given after as a progenitor. It also improperly determines the ancestor interface type during expansion (within Expand_Iterator_Loop_Over_Container), for both "in" and "of" iterator forms. The FE was assuming that the iterator interface is simply the parent type of the iterator type, but that type can occur later in the interface list, or be inherited. A new function is added that properly locates a type's iterator interface ancestor, if any, and is called for analysis and expansion. gcc/ada/ * exp_ch5.adb (Expand_Iterator_Loop_Over_Container): Retrieve the iteration type's iteration interface progenitor via Iterator_Interface_Ancestor, in the case of both "in" and "of" iterators. Narrow the scope of Pack, so it's declared and initialized only within the code related to "of" iterators, and change its name to Cont_Type_Pack. Adjust comments. * sem_ch5.adb (Get_Cursor_Type): In the case of a derived type, retrieve the iteration type's iterator interface progenitor (if it exists) via Iterator_Interface_Ancestor rather than assuming that the parent type is the interface progenitor. * sem_util.ads (Iterator_Interface_Ancestor): New function. * sem_util.adb (Iterator_Interface_Ancestor): New function returning a type's associated iterator interface type, if any, by collecting and traversing the type's interfaces.
Diffstat (limited to 'gcc')
-rw-r--r--gcc/ada/exp_ch5.adb42
-rw-r--r--gcc/ada/sem_ch5.adb23
-rw-r--r--gcc/ada/sem_util.adb34
-rw-r--r--gcc/ada/sem_util.ads7
4 files changed, 82 insertions, 24 deletions
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index cd3b02b..d946f6d 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -5158,9 +5158,6 @@ package body Exp_Ch5 is
-- The package in which the iterator interface is instantiated. This is
-- typically an instance within the container package.
- Pack : Entity_Id;
- -- The package in which the container type is declared
-
begin
if Present (Iterator_Filter (I_Spec)) then
pragma Assert (Ada_Version >= Ada_2022);
@@ -5195,15 +5192,6 @@ package body Exp_Ch5 is
-- package Vector_Iterator_Interfaces is new
-- Ada.Iterator_Interfaces (Cursor, Has_Element);
- -- If the container type is a derived type, the cursor type is found in
- -- the package of the ultimate ancestor type.
-
- if Is_Derived_Type (Container_Typ) then
- Pack := Scope (Root_Type (Container_Typ));
- else
- Pack := Scope (Container_Typ);
- end if;
-
if Of_Present (I_Spec) then
Handle_Of : declare
Container_Arg : Node_Id;
@@ -5289,6 +5277,9 @@ package body Exp_Ch5 is
Default_Iter : Entity_Id;
Ent : Entity_Id;
+ Cont_Type_Pack : Entity_Id;
+ -- The package in which the container type is declared
+
Reference_Control_Type : Entity_Id := Empty;
Pseudo_Reference : Entity_Id := Empty;
@@ -5312,11 +5303,14 @@ package body Exp_Ch5 is
Iter_Type := Etype (Default_Iter);
- -- The iterator type, which is a class-wide type, may itself be
- -- derived locally, so the desired instantiation is the scope of
- -- the root type of the iterator type.
+ -- If the container type is a derived type, the cursor type is
+ -- found in the package of the ultimate ancestor type.
- Iter_Pack := Scope (Root_Type (Etype (Iter_Type)));
+ if Is_Derived_Type (Container_Typ) then
+ Cont_Type_Pack := Scope (Root_Type (Container_Typ));
+ else
+ Cont_Type_Pack := Scope (Container_Typ);
+ end if;
-- Find declarations needed for "for ... of" optimization.
-- These declarations come from GNAT sources or sources
@@ -5326,7 +5320,7 @@ package body Exp_Ch5 is
-- Note that we use _Next or _Previous to avoid picking up
-- some arbitrary user-defined Next or Previous.
- Ent := First_Entity (Pack);
+ Ent := First_Entity (Cont_Type_Pack);
while Present (Ent) loop
-- Get_Element_Access function with one parameter called
-- Position.
@@ -5400,6 +5394,11 @@ package body Exp_Ch5 is
Analyze_And_Resolve (Name (I_Spec));
+ -- The desired instantiation is the scope of an iterator interface
+ -- type that is an ancestor of the iterator type.
+
+ Iter_Pack := Scope (Iterator_Interface_Ancestor (Iter_Type));
+
-- Find cursor type in proper iterator package, which is an
-- instantiation of Iterator_Interfaces.
@@ -5469,11 +5468,12 @@ package body Exp_Ch5 is
else
Iter_Type := Etype (Name (I_Spec));
- -- The iterator type, which is a class-wide type, may itself be
- -- derived locally, so the desired instantiation is the scope of
- -- the root type of the iterator type, as in the "of" case.
+ -- The instantiation in which to locate the Has_Element function
+ -- is the scope containing an iterator interface type that is
+ -- an ancestor of the iterator type.
+
+ Iter_Pack := Scope (Iterator_Interface_Ancestor (Iter_Type));
- Iter_Pack := Scope (Root_Type (Etype (Iter_Type)));
Cursor := Id;
end if;
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 72e7d18..de38ddf 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -2113,11 +2113,28 @@ package body Sem_Ch5 is
Ent : Entity_Id;
begin
- -- If iterator type is derived, the cursor is declared in the scope
- -- of the parent type.
+ -- If the iterator type is derived and it has an iterator interface
+ -- type as an ancestor, then the cursor type is declared in the scope
+ -- of that interface type.
if Is_Derived_Type (Typ) then
- Ent := First_Entity (Scope (Etype (Typ)));
+ declare
+ Iter_Iface : constant Entity_Id :=
+ Iterator_Interface_Ancestor (Typ);
+
+ begin
+ if Present (Iter_Iface) then
+ Ent := First_Entity (Scope (Iter_Iface));
+
+ -- If there's not an iterator interface, then retrieve the
+ -- scope associated with the parent type and start from its
+ -- first entity.
+
+ else
+ Ent := First_Entity (Scope (Etype (Typ)));
+ end if;
+ end;
+
else
Ent := First_Entity (Scope (Typ));
end if;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index eb2d83a..423b8d3 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -21496,6 +21496,40 @@ package body Sem_Util is
pragma Assert (No (Actual));
end Iterate_Call_Parameters;
+ --------------------------------
+ -- Iterate_Interface_Ancestor --
+ --------------------------------
+
+ function Iterator_Interface_Ancestor (Typ : Entity_Id) return Entity_Id is
+ begin
+ if Has_Interfaces (Typ) then
+ declare
+ Iface_Elmt : Elmt_Id;
+ Ifaces : Elist_Id;
+ Root_Iface : Entity_Id;
+
+ begin
+ Collect_Interfaces (Typ, Ifaces);
+
+ Iface_Elmt := First_Elmt (Ifaces);
+ while Present (Iface_Elmt) loop
+ Root_Iface := Root_Type (Node (Iface_Elmt));
+
+ if Chars (Root_Iface)
+ in Name_Forward_Iterator | Name_Reversible_Iterator
+ and then In_Predefined_Unit (Root_Iface)
+ then
+ return Root_Iface;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end;
+ end if;
+
+ return Empty;
+ end Iterator_Interface_Ancestor;
+
-------------------------
-- Kill_Current_Values --
-------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index caf6a66..96b4730 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -2480,6 +2480,13 @@ package Sem_Util is
-- Calls Handle_Parameter for each pair of formal and actual parameters of
-- a function, procedure, or entry call.
+ function Iterator_Interface_Ancestor (Typ : Entity_Id) return Entity_Id;
+ -- If Typ has an ancestor that is an iterator interface type declared in
+ -- an instance of Ada.Iterator_Interfaces, then returns that interface
+ -- type. Otherwise returns Empty. (It's not clear what it means if there
+ -- is more than one such ancestor, perhaps coming from multiple instances,
+ -- but this function returns the first such ancestor it finds. ???)
+
procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False);
-- This procedure is called to clear all constant indications from all
-- entities in the current scope and in any parent scopes if the current