This patch adds a check on an iterator over a GNAT-specific formal container,
when the iterator specification includes a subtype indication that must be
compatible with the element type of the container.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-05-23 Ed Schonberg <schonb...@adacore.com>
gcc/ada/
* sem_ch5.adb (Analyze_Iterator_Specification): If a subtype indication
is present, verify its legality when the domain of iteration is a
GNAT-specific formal container, as is already done for arrays and
predefined containers.
gcc/testsuite/
* gnat.dg/iter1.adb, gnat.dg/iter1.ads: New testcase.--- gcc/ada/sem_ch5.adb
+++ gcc/ada/sem_ch5.adb
@@ -2063,11 +2063,25 @@ package body Sem_Ch5 is
-- indicator, verify that the container type has an Iterate aspect that
-- implements the reversible iterator interface.
+ procedure Check_Subtype_Indication (Comp_Type : Entity_Id);
+ -- If a subtype indication is present, verify that it is consistent
+ -- with the component type of the array or container name.
+
function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id;
-- For containers with Iterator and related aspects, the cursor is
-- obtained by locating an entity with the proper name in the scope
-- of the type.
+ -- Local variables
+
+ Def_Id : constant Node_Id := Defining_Identifier (N);
+ Iter_Name : constant Node_Id := Name (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Subt : constant Node_Id := Subtype_Indication (N);
+
+ Bas : Entity_Id := Empty; -- initialize to prevent warning
+ Typ : Entity_Id;
+
-----------------------------
-- Check_Reverse_Iteration --
-----------------------------
@@ -2091,6 +2105,26 @@ package body Sem_Ch5 is
end if;
end Check_Reverse_Iteration;
+ -------------------------------
+ -- Check_Subtype_Indication --
+ -------------------------------
+
+ procedure Check_Subtype_Indication (Comp_Type : Entity_Id) is
+ begin
+ if Present (Subt)
+ and then (not Covers (Base_Type ((Bas)), Comp_Type)
+ or else not Subtypes_Statically_Match (Bas, Comp_Type))
+ then
+ if Is_Array_Type (Typ) then
+ Error_Msg_N
+ ("subtype indication does not match component type", Subt);
+ else
+ Error_Msg_N
+ ("subtype indication does not match element type", Subt);
+ end if;
+ end if;
+ end Check_Subtype_Indication;
+
---------------------
-- Get_Cursor_Type --
---------------------
@@ -2127,16 +2161,6 @@ package body Sem_Ch5 is
return Etype (Ent);
end Get_Cursor_Type;
- -- Local variables
-
- Def_Id : constant Node_Id := Defining_Identifier (N);
- Iter_Name : constant Node_Id := Name (N);
- Loc : constant Source_Ptr := Sloc (N);
- Subt : constant Node_Id := Subtype_Indication (N);
-
- Bas : Entity_Id := Empty; -- initialize to prevent warning
- Typ : Entity_Id;
-
-- Start of processing for Analyze_Iterator_Specification
begin
@@ -2394,15 +2418,7 @@ package body Sem_Ch5 is
& "component of a mutable object", N);
end if;
- if Present (Subt)
- and then
- (Base_Type (Bas) /= Base_Type (Component_Type (Typ))
- or else
- not Subtypes_Statically_Match (Bas, Component_Type (Typ)))
- then
- Error_Msg_N
- ("subtype indication does not match component type", Subt);
- end if;
+ Check_Subtype_Indication (Component_Type (Typ));
-- Here we have a missing Range attribute
@@ -2452,6 +2468,8 @@ package body Sem_Ch5 is
end if;
end;
+ Check_Subtype_Indication (Etype (Def_Id));
+
-- For a predefined container, The type of the loop variable is
-- the Iterator_Element aspect of the container type.
@@ -2477,18 +2495,7 @@ package body Sem_Ch5 is
Cursor_Type := Get_Cursor_Type (Typ);
pragma Assert (Present (Cursor_Type));
- -- If subtype indication was given, verify that it covers
- -- the element type of the container.
-
- if Present (Subt)
- and then (not Covers (Bas, Etype (Def_Id))
- or else not Subtypes_Statically_Match
- (Bas, Etype (Def_Id)))
- then
- Error_Msg_N
- ("subtype indication does not match element type",
- Subt);
- end if;
+ Check_Subtype_Indication (Etype (Def_Id));
-- If the container has a variable indexing aspect, the
-- element is a variable and is modifiable in the loop.
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/iter1.adb
@@ -0,0 +1,20 @@
+-- { dg-do compile }
+
+with Ada.Text_IO;
+
+package body Iter1 is
+
+ type Table is array (Integer range <>) of Float;
+ My_Table : Table := (1.0, 2.0, 3.0);
+
+ procedure Dummy (L : My_Lists.List) is
+ begin
+ for Item : Boolean of L loop -- { dg-error "subtype indication does not match element type" }
+ Ada.Text_IO.Put_Line (Integer'Image (Item));
+ end loop;
+
+ for Item : Boolean of My_Table loop -- { dg-error "subtype indication does not match component type" }
+ null;
+ end loop;
+ end;
+end Iter1;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/iter1.ads
@@ -0,0 +1,8 @@
+with Ada.Containers.Formal_Doubly_Linked_Lists;
+
+package Iter1 is
+ package My_Lists is new Ada.Containers.Formal_Doubly_Linked_Lists
+ (Element_Type => Integer);
+
+ procedure Dummy (L : My_Lists.List);
+end Iter1;
