procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[Ada] Missing legality check on iterator over formal container

Browse source 
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
This commit is contained in:
Ed Schonberg 2018-05-23 10:23:02 +00:00 • committed by Pierre-Marie de Rodat
parent fd82aeff6d
commit ac450fb2ab
5 changed files with 77 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
gcc/ada/ChangeLog
View file

@ -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

69
gcc/ada/sem_ch5.adb
View file

@ -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.

4
gcc/testsuite/ChangeLog
View file

@ -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

20
gcc/testsuite/gnat.dg/iter1.adb Normal file
View file

@ -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;

8
gcc/testsuite/gnat.dg/iter1.ads Normal file
View file

@ -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;