From 3c08de34076ffc085e335cc9c89661945823c594 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Mon, 16 Dec 2019 10:34:37 +0000 Subject: [PATCH] [Ada] Prototype implementastion of Ada2020 Map-reduce construct 2019-12-16 Ed Schonberg gcc/ada/ * scng.adb (Scan): In Ada2020, a left-bracket indicates the start of an homogenous aggregate. * par-ch4.adb (P_Reduction_Attribute_Reference): New procedure. (P_Aggregate): Recognize Ada2020 bracket-delimited aggregates. (P_Primary): Ditto. * par-util.adb (Comma_Present): Return false on a right bracket in Ada2020, indicating the end of an aggregate. * snames.ads-tmpl: Introduce Name_Reduce and Attribute Reduce. * sinfo.ads, sinfo.adb (Is_Homogeneous_Aggregate): New flag on aggregates, to designate an Ada2020 array or container aggregate that is bracket-delimited in the source. * sem_attr.adb (Analyze_Attribute): For attribute Reduce, verify that two arguments are present, and verify that the prefix is a stream or an object that is iterable (array or contrainer). (Resolve_Attribute): For attribute Reduce, resolve initial value with the type of the context. Type-checking of element type of prefix is performed after expansion. * exp_attr.adb (Expand_N_Attribute_Reference): For attribute Reduce, expand into a loop: a) If prefix is an aggregate with a single iterated component association, use its iterator specification to construct a loop, b) If prefix is a name, build a loop using an element iterator loop. * scans.ads: Add brackets tokens. From-SVN: r279431 --- gcc/ada/ChangeLog | 26 +++++++++ gcc/ada/exp_attr.adb | 91 +++++++++++++++++++++++++++++++ gcc/ada/par-ch4.adb | 81 +++++++++++++++++++++++++++- gcc/ada/par-util.adb | 5 +- gcc/ada/scans.ads | 5 ++ gcc/ada/scng.adb | 21 +++++++- gcc/ada/sem_attr.adb | 115 ++++++++++++++++++++++++++++++++++++++++ gcc/ada/sinfo.adb | 16 ++++++ gcc/ada/sinfo.ads | 14 +++++ gcc/ada/snames.ads-tmpl | 2 + 10 files changed, 371 insertions(+), 5 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 063043656a0..79d204255dd 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2019-12-16 Ed Schonberg + + * scng.adb (Scan): In Ada2020, a left-bracket indicates the + start of an homogenous aggregate. + * par-ch4.adb (P_Reduction_Attribute_Reference): New procedure. + (P_Aggregate): Recognize Ada2020 bracket-delimited aggregates. + (P_Primary): Ditto. + * par-util.adb (Comma_Present): Return false on a right bracket + in Ada2020, indicating the end of an aggregate. + * snames.ads-tmpl: Introduce Name_Reduce and Attribute Reduce. + * sinfo.ads, sinfo.adb (Is_Homogeneous_Aggregate): New flag on + aggregates, to designate an Ada2020 array or container aggregate + that is bracket-delimited in the source. + * sem_attr.adb (Analyze_Attribute): For attribute Reduce, verify + that two arguments are present, and verify that the prefix is a + stream or an object that is iterable (array or contrainer). + (Resolve_Attribute): For attribute Reduce, resolve initial value + with the type of the context. Type-checking of element type of + prefix is performed after expansion. + * exp_attr.adb (Expand_N_Attribute_Reference): For attribute + Reduce, expand into a loop: a) If prefix is an aggregate with a + single iterated component association, use its iterator + specification to construct a loop, b) If prefix is a name, build + a loop using an element iterator loop. + * scans.ads: Add brackets tokens. + 2019-12-16 Eric Botcazou * gcc-interface/decl.c (gnat_to_gnu_entity): Adjust calls to diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 8c5981a75e6..f35fa73128e 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -5463,6 +5463,97 @@ package body Exp_Attr is Apply_Universal_Integer_Attribute_Checks (N); end if; + ------------ + -- Reduce -- + ------------ + + when Attribute_Reduce => + declare + Loc : constant Source_Ptr := Sloc (N); + E1 : constant Node_Id := First (Expressions (N)); + E2 : constant Node_Id := Next (E1); + Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); + Typ : constant Entity_Id := Etype (N); + New_Loop : Node_Id; + + -- If the prefix is an aggregwte, its unique component is sn + -- Iterated_Element, and we create a loop out of its itertor. + + begin + if Nkind (Prefix (N)) = N_Aggregate then + declare + Stream : constant Node_Id := + First (Component_Associations (Prefix (N))); + Id : constant Node_Id := Defining_Identifier (Stream); + Expr : constant Node_Id := Expression (Stream); + Ch : constant Node_Id := + First (Discrete_Choices (Stream)); + begin + New_Loop := Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Iterator_Specification => Empty, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => New_Copy (Id), + Discrete_Subtype_Definition => + Relocate_Node (Ch))), + End_Label => Empty, + Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Bnn, Loc), + Expression => Make_Function_Call (Loc, + Name => New_Occurrence_Of (Entity (E1), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Bnn, Loc), + Relocate_Node (Expr)))))); + end; + else + -- If the prefix is a name we construct an element iterwtor + -- over it. Its expansion will verify that it is an array + -- or a container with the proper aspects. + + declare + Iter : Node_Id; + Elem : constant Entity_Id := Make_Temporary (Loc, 'E', N); + + begin + Iter := + Make_Iterator_Specification (Loc, + Defining_Identifier => Elem, + Name => Relocate_Node (Prefix (N)), + Subtype_Indication => Empty); + Set_Of_Present (Iter); + + New_Loop := Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Iterator_Specification => Iter, + Loop_Parameter_Specification => Empty), + End_Label => Empty, + Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Bnn, Loc), + Expression => Make_Function_Call (Loc, + Name => New_Occurrence_Of (Entity (E1), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Bnn, Loc), + New_Occurrence_Of (Elem, Loc)))))); + end; + end if; + + Rewrite (N, + Make_Expression_With_Actions (Loc, + Actions => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Bnn, + Object_Definition => + New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (E2)), New_Loop), + Expression => New_Occurrence_Of (Bnn, Loc))); + Analyze_And_Resolve (N, Typ); + end; + ---------- -- Read -- ---------- diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 986d128d933..355aeb87c78 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -81,6 +81,8 @@ package body Ch4 is function P_Primary return Node_Id; function P_Relation return Node_Id; function P_Term return Node_Id; + function P_Reduction_Attribute_Reference (S : Node_Id) + return Node_Id; function P_Binary_Adding_Operator return Node_Kind; function P_Logical_Operator return Node_Kind; @@ -1202,12 +1204,48 @@ package body Ch4 is return Attr_Node; end P_Range_Attribute_Reference; + ------------------------------------- + -- P_Reduction_Attribute_Reference -- + ------------------------------------- + + function P_Reduction_Attribute_Reference (S : Node_Id) + return Node_Id + is + Attr_Node : Node_Id; + Attr_Name : Name_Id; + + begin + Attr_Name := Token_Name; + Scan; -- past Reduce + Attr_Node := New_Node (N_Attribute_Reference, Token_Ptr); + Set_Attribute_Name (Attr_Node, Attr_Name); + if Attr_Name /= Name_Reduce then + Error_Msg ("reduce attribute expected", Prev_Token_Ptr); + end if; + + Set_Prefix (Attr_Node, S); + Set_Expressions (Attr_Node, New_List); + T_Left_Paren; + Append (P_Name, Expressions (Attr_Node)); + T_Comma; + Append (P_Expression, Expressions (Attr_Node)); + T_Right_Paren; + + return Attr_Node; + end P_Reduction_Attribute_Reference; + --------------------------------------- -- 4.1.4 Range Attribute Designator -- --------------------------------------- -- Parsed by P_Range_Attribute_Reference (4.4) + --------------------------------------------- + -- 4.1.4 (2) Reduction_Attribute_Reference -- + --------------------------------------------- + + -- parsed by P_Reduction_Attribute_Reference + -------------------- -- 4.3 Aggregate -- -------------------- @@ -1229,6 +1267,7 @@ package body Ch4 is if Nkind (Aggr_Node) /= N_Aggregate and then Nkind (Aggr_Node) /= N_Extension_Aggregate + and then Ada_Version < Ada_2020 then Error_Msg ("aggregate may not have single positional component", Aggr_Sloc); @@ -1343,7 +1382,21 @@ package body Ch4 is begin Lparen_Sloc := Token_Ptr; - T_Left_Paren; + if Token = Tok_Left_Bracket and then Ada_Version >= Ada_2020 then + Scan; + + -- Special case for null aggregate in Ada2020. + + if Token = Tok_Right_Bracket then + Scan; -- past ] + Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc); + Set_Expressions (Aggregate_Node, New_List); + Set_Is_Homogeneous_Aggregate (Aggregate_Node); + return Aggregate_Node; + end if; + else + T_Left_Paren; + end if; -- Note on parentheses count. For cases like an if expression, the -- parens here really count as real parentheses for the paren count, @@ -1577,6 +1630,14 @@ package body Ch4 is Append (Expr_Node, Expr_List); + elsif Token = Tok_Right_Bracket then + if No (Expr_List) then + Expr_List := New_List; + end if; + + Append (Expr_Node, Expr_List); + exit; + -- Anything else is assumed to be a named association else @@ -1625,7 +1686,19 @@ package body Ch4 is -- All component associations (positional and named) have been scanned - T_Right_Paren; + if Token = Tok_Right_Bracket and then Ada_Version >= Ada_2020 then + Set_Component_Associations (Aggregate_Node, Assoc_List); + Set_Is_Homogeneous_Aggregate (Aggregate_Node); + Scan; -- past right bracket + if Token = Tok_Apostrophe then + Scan; + if Token = Tok_Identifier then + return P_Reduction_Attribute_Reference (Aggregate_Node); + end if; + end if; + else + T_Right_Paren; + end if; if Nkind (Aggregate_Node) /= N_Delta_Aggregate then Set_Expressions (Aggregate_Node, Expr_List); @@ -2623,6 +2696,7 @@ package body Ch4 is -- | STRING_LITERAL | AGGREGATE -- | NAME | QUALIFIED_EXPRESSION -- | ALLOCATOR | (EXPRESSION) | QUANTIFIED_EXPRESSION + -- | REDUCTION_ATTRIBUTE_REFERENCE -- Error recovery: can raise Error_Resync @@ -2715,6 +2789,9 @@ package body Ch4 is return Expr; end; + when Tok_Left_Bracket => + return P_Aggregate; + -- Allocator when Tok_New => diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index 1c32a42e08f..6379c4aa2cb 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -276,8 +276,11 @@ package body Util is -- If we have a right paren, then that is taken as ending the list -- i.e. no comma is present. + -- Ditto for a right bracket in Ada2020. - elsif Token = Tok_Right_Paren then + elsif Token = Tok_Right_Paren + or else (Token = Tok_Right_Bracket and then Ada_Version >= Ada_2020) + then return False; -- If pragmas, then get rid of them and make a recursive call diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads index abee591b2a8..530da548466 100644 --- a/gcc/ada/scans.ads +++ b/gcc/ada/scans.ads @@ -87,11 +87,15 @@ package Scans is -- exception-name". This degrades error recovery slightly, and perhaps -- we could do better, but not worth the effort. + -- Ada2020 introduces square brackets as delimiters for array and + -- container aggregates. + Tok_Raise, -- RAISE Tok_Dot, -- . Namext Tok_Apostrophe, -- ' Namext + Tok_Left_Bracket, -- [ Namest Tok_Left_Paren, -- ( Namext, Consk Tok_Delta, -- DELTA Atkwd, Sterm, Consk @@ -99,6 +103,7 @@ package Scans is Tok_Range, -- RANGE Atkwd, Sterm, Consk Tok_Right_Paren, -- ) Sterm + Tok_Right_Bracket, -- ] Sterm Tok_Comma, -- , Sterm Tok_And, -- AND Logop, Sterm diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index 2d290b89714..d4c1916a13a 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -182,6 +182,7 @@ package body Scng is | Tok_Integer_Literal | Tok_Interface | Tok_Is + | Tok_Left_Bracket | Tok_Left_Paren | Tok_Less | Tok_Less_Equal @@ -204,6 +205,7 @@ package body Scng is | Tok_Rem | Tok_Renames | Tok_Reverse + | Tok_Right_Bracket | Tok_Right_Paren | Tok_Slash | Tok_String_Literal @@ -324,6 +326,7 @@ package body Scng is | Tok_In | Tok_Integer_Literal | Tok_Is + | Tok_Left_Bracket | Tok_Left_Paren | Tok_Less | Tok_Less_Equal @@ -340,6 +343,7 @@ package body Scng is | Tok_Range | Tok_Real_Literal | Tok_Rem + | Tok_Right_Bracket | Tok_Right_Paren | Tok_Slash | Tok_String_Literal @@ -1697,6 +1701,11 @@ package body Scng is if Source (Scan_Ptr + 1) = '"' then goto Scan_Wide_Character; + elsif Ada_Version = Ada_2020 then + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Left_Bracket; + return; + else Error_Msg_S ("illegal character, replaced by ""("""); Scan_Ptr := Scan_Ptr + 1; @@ -2063,6 +2072,7 @@ package body Scng is or else Prev_Token = Tok_Identifier or else Prev_Token = Tok_Project or else Prev_Token = Tok_Right_Paren + or else Prev_Token = Tok_Right_Bracket or else Prev_Token in Token_Class_Literal then Token := Tok_Apostrophe; @@ -2172,11 +2182,18 @@ package body Scng is return; -- Right bracket or right brace, treated as right paren + -- but proper aggregate delimiter in Ada_2020 when ']' | '}' => - Error_Msg_S ("illegal character, replaced by "")"""); + if Ada_Version >= Ada_2020 then + Token := Tok_Right_Bracket; + + else + Error_Msg_S ("illegal character, replaced by "")"""); + Token := Tok_Right_Paren; + end if; + Scan_Ptr := Scan_Ptr + 1; - Token := Tok_Right_Paren; return; -- Slash (can be division operator or first character of not equal) diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index dcc40d27c82..72729ec8fc4 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -25,6 +25,7 @@ with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; +with Aspects; use Aspects; with Atree; use Atree; with Casing; use Casing; with Checks; use Checks; @@ -5497,6 +5498,55 @@ package body Sem_Attr is Check_Discrete_Type; Set_Etype (N, Universal_Integer); + ------------ + -- Reduce -- + ------------ + + when Attribute_Reduce => + Check_E2; + + declare + Stream : constant Node_Id := Prefix (N); + Typ : Entity_Id; + begin + if Nkind (Stream) /= N_Aggregate then + -- Prefix is a name, as for other attributes. + + -- If the object is a function we asume that it is not + -- overloaded. AI12-242 does not suggest an name resulution + -- rule for that case, but can suppose that the expected + -- type of the reduction is the expected type of the + -- component of the prefix. + + Analyze_And_Resolve (Stream); + Typ := Etype (Stream); + + -- Verify that prefix can be iterated upon. + + if Is_Array_Type (Typ) + or else Present (Find_Aspect (Typ, Aspect_Default_Iterator)) + or else Present (Find_Aspect (Typ, Aspect_Iterable)) + then + null; + else + Error_Msg_NE + ("cannot apply reduce to object of type$", N, Typ); + end if; + + elsif Present (Expressions (Stream)) + or else No (Component_Associations (Stream)) + or else Nkind (First (Component_Associations (Stream))) /= + N_Iterated_Component_Association + then + Error_Msg_N + ("Prefix of reduce must be an iterated component", N); + end if; + + Analyze (E1); + Analyze (E2); + Set_Etype (N, Etype (E2)); + end; + ---------- -- Read -- ---------- @@ -8241,6 +8291,7 @@ package body Sem_Attr is | Attribute_Implicit_Dereference | Attribute_Iterator_Element | Attribute_Iterable + | Attribute_Reduce | Attribute_Variable_Indexing => null; @@ -11651,6 +11702,70 @@ package body Sem_Attr is return; end Range_Attribute; + ------------- + -- Reduce -- + ------------- + + when Attribute_Reduce => + declare + E1 : constant Node_Id := First (Expressions (N)); + E2 : constant Node_Id := Next (E1); + Op : Entity_Id := Empty; + + Index : Interp_Index; + It : Interp; + function Proper_Op (Op : Entity_Id) return Boolean; + + --------------- + -- Proper_Op -- + --------------- + + function Proper_Op (Op : Entity_Id) return Boolean is + F1, F2 : Entity_Id; + + begin + F1 := First_Formal (Op); + if No (F1) then + return False; + else + F2 := Next_Formal (F1); + if No (F2) + or else Present (Next_Formal (F2)) + then + return False; + else + return + (Ekind (Op) = E_Operator + and then Scope (Op) = Standard_Standard) + or else Covers (Typ, Etype (Op)); + end if; + end if; + end Proper_Op; + + begin + Resolve (E2, Typ); + if Is_Overloaded (E1) then + Get_First_Interp (E1, Index, It); + while Present (It.Nam) loop + if Proper_Op (It.Nam) then + Op := It.Nam; + Set_Entity (E1, Op); + exit; + end if; + + Get_Next_Interp (Index, It); + end loop; + + elsif Proper_Op (Entity (E1)) then + Op := Entity (E1); + Set_Etype (N, Typ); + end if; + + if No (Op) then + Error_Msg_N ("No visible function for reduction", E1); + end if; + end; + ------------ -- Result -- ------------ diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index b99a32d90ec..41cb8c89e94 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -2010,6 +2010,14 @@ package body Sinfo is return Flag2 (N); end Is_Generic_Contract_Pragma; + function Is_Homogeneous_Aggregate + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate); + return Flag14 (N); + end Is_Homogeneous_Aggregate; + function Is_Ignored (N : Node_Id) return Boolean is begin @@ -5505,6 +5513,14 @@ package body Sinfo is Set_Flag2 (N, Val); end Set_Is_Generic_Contract_Pragma; + procedure Set_Is_Homogeneous_Aggregate + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate); + Set_Flag14 (N, Val); + end Set_Is_Homogeneous_Aggregate; + procedure Set_Is_Ignored (N : Node_Id; Val : Boolean := True) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 5e047726e11..706007b8dd0 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1837,6 +1837,11 @@ package Sinfo is -- Refined_State -- Test_Case + -- Is_Homogeneous_Aggregate (Flag14) + -- A flag set on an Ada2020 aggregate that uses square brackets as + -- delimiters, and thus denotes an array or container aggregate, or + -- the prefix of a reduction attribute. + -- Is_Ignored (Flag9-Sem) -- A flag set in an N_Aspect_Specification or N_Pragma node if there was -- a Check_Policy or Assertion_Policy (or in the case of a Debug_Pragma) @@ -4163,6 +4168,7 @@ package Sinfo is -- Compile_Time_Known_Aggregate (Flag18-Sem) -- Expansion_Delayed (Flag11-Sem) -- Has_Self_Reference (Flag13-Sem) + -- Is_Homogeneous_Aggregate (Flag14) -- plus fields for expression -- Note: this structure is used for both record and array aggregates @@ -9855,6 +9861,9 @@ package Sinfo is function Is_Generic_Contract_Pragma (N : Node_Id) return Boolean; -- Flag2 + function Is_Homogeneous_Aggregate + (N : Node_Id) return Boolean; -- Flag14 + function Is_Ignored (N : Node_Id) return Boolean; -- Flag9 @@ -10967,6 +10976,9 @@ package Sinfo is procedure Set_Is_Generic_Contract_Pragma (N : Node_Id; Val : Boolean := True); -- Flag2 + procedure Set_Is_Homogeneous_Aggregate + (N : Node_Id; Val : Boolean := True); -- Flag14 + procedure Set_Is_Ignored (N : Node_Id; Val : Boolean := True); -- Flag9 @@ -13521,6 +13533,7 @@ package Sinfo is pragma Inline (Is_Finalization_Wrapper); pragma Inline (Is_Folded_In_Parser); pragma Inline (Is_Generic_Contract_Pragma); + pragma Inline (Is_Homogeneous_Aggregate); pragma Inline (Is_Ignored); pragma Inline (Is_Ignored_Ghost_Pragma); pragma Inline (Is_In_Discriminant_Check); @@ -13887,6 +13900,7 @@ package Sinfo is pragma Inline (Set_Is_Finalization_Wrapper); pragma Inline (Set_Is_Folded_In_Parser); pragma Inline (Set_Is_Generic_Contract_Pragma); + pragma Inline (Set_Is_Homogeneous_Aggregate); pragma Inline (Set_Is_Ignored); pragma Inline (Set_Is_Ignored_Ghost_Pragma); pragma Inline (Set_Is_In_Discriminant_Check); diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 985a19ff041..9d8f13ba5af 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -1002,6 +1002,7 @@ package Snames is Name_Priority : constant Name_Id := N + $; -- Ada 05 Name_Range : constant Name_Id := N + $; Name_Range_Length : constant Name_Id := N + $; -- GNAT + Name_Reduce : constant Name_Id := N + $; Name_Ref : constant Name_Id := N + $; -- GNAT Name_Restriction_Set : constant Name_Id := N + $; -- GNAT Name_Result : constant Name_Id := N + $; -- GNAT @@ -1674,6 +1675,7 @@ package Snames is Attribute_Priority, Attribute_Range, Attribute_Range_Length, + Attribute_Reduce, Attribute_Ref, Attribute_Restriction_Set, Attribute_Result, -- 2.30.2