[Ada] Missing legality check on iterator over formal container

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.

2018-05-23  Ed Schonberg  <schonberg@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.

From-SVN: r260587

5 files changed, 77 insertions, 31 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index b309616..e101c99 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2018-05-23  Ed Schonberg  <schonberg@adacore.com>
+
+	* 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.
+
 2018-05-23  Yannick Moy  <moy@adacore.com>
 
 	* sem_util.adb (Enclosing_Declaration): Fix the case of a named number
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 2a1f222..b8a222a 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/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.
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d92394b..f0cd8a2 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-05-23  Ed Schonberg  <schonberg@adacore.com>
+
+	* gnat.dg/iter1.adb, gnat.dg/iter1.ads: New testcase.
+
 2018-05-23  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* gnat.dg/elab5.adb, gnat.dg/elab5_pkg.adb, gnat.dg/elab5_pkg.ads: New
diff --git a/gcc/testsuite/gnat.dg/iter1.adb b/gcc/testsuite/gnat.dg/iter1.adb
new file mode 100644
index 0000000..a0a69cf
--- /dev/null
+++ b/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;
diff --git a/gcc/testsuite/gnat.dg/iter1.ads b/gcc/testsuite/gnat.dg/iter1.ads
new file mode 100644
index 0000000..8329f75
--- /dev/null
+++ b/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;