From 3c18e32037a4ab02afd22a535a96ac4cc3f88b16 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 31 May 2021 04:59:01 -0400 Subject: [PATCH] [Ada] AI12-0156 Use subtype indication in generalized iterators gcc/ada/ * par-ch5.adb (P_Iterator_Specification): Add support for access definition in loop parameter. * sem_ch5.adb (Check_Subtype_Indication): Renamed... (Check_Subtype_Definition): ... into this and check for conformance on access definitions, and improve error messages. (Analyze_Iterator_Specification): Add support for access definition in loop parameter. --- gcc/ada/par-ch5.adb | 12 +++++-- gcc/ada/sem_ch5.adb | 83 ++++++++++++++++++++++++++++++++++++++------- 2 files changed, 80 insertions(+), 15 deletions(-) diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index 608ebd030e4..1e55181f2fe 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -1741,7 +1741,15 @@ package body Ch5 is if Token = Tok_Colon then Scan; -- past : - Set_Subtype_Indication (Node1, P_Subtype_Indication); + + if Token = Tok_Access then + Error_Msg_Ada_2022_Feature + ("access definition in loop parameter", Token_Ptr); + Set_Subtype_Indication (Node1, P_Access_Definition (False)); + + else + Set_Subtype_Indication (Node1, P_Subtype_Indication); + end if; end if; if Token = Tok_Of then @@ -1761,7 +1769,7 @@ package body Ch5 is Set_Of_Present (Node1); Error_Msg_N ("subtype indication is only legal on an element iterator", - Subtype_Indication (Node1)); + Subtype_Indication (Node1)); else return Error; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index fbb6904b2c5..f9813a5e4fa 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2176,9 +2176,11 @@ 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); + procedure Check_Subtype_Definition (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. + -- In Ada 2022, the subtype indication may be an access definition, + -- if the array or container has elements of an anonymous access type. function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id; -- For containers with Iterator and related aspects, the cursor is @@ -2209,24 +2211,46 @@ package body Sem_Ch5 is end Check_Reverse_Iteration; ------------------------------- - -- Check_Subtype_Indication -- + -- Check_Subtype_Definition -- ------------------------------- - procedure Check_Subtype_Indication (Comp_Type : Entity_Id) is + procedure Check_Subtype_Definition (Comp_Type : Entity_Id) is begin - if Present (Subt) - and then (not Covers (Base_Type ((Bas)), Comp_Type) + if not Present (Subt) then + return; + end if; + + if Is_Anonymous_Access_Type (Entity (Subt)) then + if not Is_Anonymous_Access_Type (Comp_Type) then + Error_Msg_NE + ("component type& is not an anonymous access", + Subt, Comp_Type); + + elsif not Conforming_Types + (Designated_Type (Entity (Subt)), + Designated_Type (Comp_Type), + Fully_Conformant) + then + Error_Msg_NE + ("subtype indication does not match component type&", + Subt, Comp_Type); + end if; + + elsif 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); + Error_Msg_NE + ("subtype indication does not match component type&", + Subt, Comp_Type); else - Error_Msg_N - ("subtype indication does not match element type", Subt); + Error_Msg_NE + ("subtype indication does not match element type&", + Subt, Comp_Type); end if; end if; - end Check_Subtype_Indication; + end Check_Subtype_Definition; --------------------- -- Get_Cursor_Type -- @@ -2288,6 +2312,39 @@ package body Sem_Ch5 is Analyze (Decl); Rewrite (Subt, New_Occurrence_Of (S, Sloc (Subt))); end; + + -- Ada 2022: the subtype definition may be for an anonymous + -- access type. + + elsif Nkind (Subt) = N_Access_Definition then + declare + S : constant Entity_Id := Make_Temporary (Sloc (Subt), 'S'); + Decl : Node_Id; + begin + if Present (Subtype_Mark (Subt)) then + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => S, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Copy_Tree (Subtype_Mark (Subt)))); + + else + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => S, + Type_Definition => + New_Copy_Tree + (Access_To_Subprogram_Definition (Subt))); + end if; + + Insert_Before (Parent (Parent (N)), Decl); + Analyze (Decl); + Freeze_Before (First (Statements (Parent (Parent (N)))), S); + Rewrite (Subt, New_Occurrence_Of (S, Sloc (Subt))); + end; else Analyze (Subt); end if; @@ -2565,7 +2622,7 @@ package body Sem_Ch5 is & "component of a mutable object", N); end if; - Check_Subtype_Indication (Component_Type (Typ)); + Check_Subtype_Definition (Component_Type (Typ)); -- Here we have a missing Range attribute @@ -2615,7 +2672,7 @@ package body Sem_Ch5 is end if; end; - Check_Subtype_Indication (Etype (Def_Id)); + Check_Subtype_Definition (Etype (Def_Id)); -- For a predefined container, the type of the loop variable is -- the Iterator_Element aspect of the container type. @@ -2642,7 +2699,7 @@ package body Sem_Ch5 is Cursor_Type := Get_Cursor_Type (Typ); pragma Assert (Present (Cursor_Type)); - Check_Subtype_Indication (Etype (Def_Id)); + Check_Subtype_Definition (Etype (Def_Id)); -- If the container has a variable indexing aspect, the -- element is a variable and is modifiable in the loop.