From: Ed Schonberg Date: Wed, 23 May 2018 10:23:02 +0000 (+0000) Subject: [Ada] Missing legality check on iterator over formal container X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=ac450fb2ab71dfd5bc57ea60bc00cc749d7485af;p=gcc.git [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 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 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b3096160b56..e101c99efc8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2018-05-23 Ed Schonberg + + * 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 * 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 2a1f222dfc4..b8a222a0ba3 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 d92394bb33a..f0cd8a2cf4a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-05-23 Ed Schonberg + + * gnat.dg/iter1.adb, gnat.dg/iter1.ads: New testcase. + 2018-05-23 Hristian Kirtchev * 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 00000000000..a0a69cf9018 --- /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 00000000000..8329f756fef --- /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;