From: Pierre-Marie de Rodat Date: Fri, 15 Dec 2017 13:23:10 +0000 (+0000) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=fc47ef60c5d11d0302a4f4831080fde792430781;p=gcc.git [multiple changes] 2017-12-15 Hristian Kirtchev * sem_prag.adb (Analyze_Initialization_Item): Remove the specialized processing for a null initialization item. Such an item is always illegal. 2017-12-15 Bob Duff * types.ads, types.h, libgnat/a-except.adb, exp_ch11.adb (PE_Build_In_Place_Mismatch): New reason code for raising when the BIPalloc formal parameter is incorrect. This can happen if a compiler bug causes a mismatch of build-in-place between caller and callee. * exp_ch6.adb (Expand_N_Extended_Return_Statement): Use PE_Build_In_Place_Mismatch. 2017-12-15 Ed Schonberg * exp_ch4.ads, exp_ch4.adb (Expand_N_Reduction_Expression): New procedure. * exp_util.adb (Insert_Actions): Handle N_Reduction_Expression. * expander.adb (Expand): Call Expand_N_Reduction_Expression * par-ch4.adb (P_Reduction_Expression): New procedure. (P_Iterated_Component_Assoc_Or_Reduction): New precedure, extension of P_Iterated_Component_Association. (OK_Reduction_Expression_Parameter): New procedure. (P_Aggregate_Or_Paren_Expr): Improve error message for malformed delta aggregate. * sem.adb (Analyze): Call Analyze_Reduction_Expression and Analyze_Reduction_Expression_Parameter * sinfo.ads, sinfo.adb: New node kinds N_Reduction_Expression and N_Reduction_Expression_Parameter. * sem_ch4.ads, sem_ch4.adb (Analyze_Reduction_Expression, Analyze_Reduction_Expression_Parameter): New procedures. * sem_res.adb (Resolve): Handle Reduction_Expression and Reduction_Expression_Parameter * sem_spark.adb: Dummy entries for Reduction_Expression and Reduction_Expression_Parameter * sprint.adb (Sprint_Node_Actual): Print Reduction_Expression, Reduction_Expression_Parameter From-SVN: r255693 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e07fc18135c..528a5e67f33 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,43 @@ +2017-12-15 Hristian Kirtchev + + * sem_prag.adb (Analyze_Initialization_Item): Remove the specialized + processing for a null initialization item. Such an item is always + illegal. + +2017-12-15 Bob Duff + + * types.ads, types.h, libgnat/a-except.adb, exp_ch11.adb + (PE_Build_In_Place_Mismatch): New reason code for raising when the + BIPalloc formal parameter is incorrect. This can happen if a compiler + bug causes a mismatch of build-in-place between caller and callee. + * exp_ch6.adb (Expand_N_Extended_Return_Statement): Use + PE_Build_In_Place_Mismatch. + +2017-12-15 Ed Schonberg + + * exp_ch4.ads, exp_ch4.adb (Expand_N_Reduction_Expression): New + procedure. + * exp_util.adb (Insert_Actions): Handle N_Reduction_Expression. + * expander.adb (Expand): Call Expand_N_Reduction_Expression + * par-ch4.adb (P_Reduction_Expression): New procedure. + (P_Iterated_Component_Assoc_Or_Reduction): New precedure, extension of + P_Iterated_Component_Association. + (OK_Reduction_Expression_Parameter): New procedure. + (P_Aggregate_Or_Paren_Expr): Improve error message for malformed delta + aggregate. + * sem.adb (Analyze): Call Analyze_Reduction_Expression and + Analyze_Reduction_Expression_Parameter + * sinfo.ads, sinfo.adb: New node kinds N_Reduction_Expression and + N_Reduction_Expression_Parameter. + * sem_ch4.ads, sem_ch4.adb (Analyze_Reduction_Expression, + Analyze_Reduction_Expression_Parameter): New procedures. + * sem_res.adb (Resolve): Handle Reduction_Expression and + Reduction_Expression_Parameter + * sem_spark.adb: Dummy entries for Reduction_Expression and + Reduction_Expression_Parameter + * sprint.adb (Sprint_Node_Actual): Print Reduction_Expression, + Reduction_Expression_Parameter + 2017-12-15 Bob Duff * einfo.ads: Comment fix. diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index e2313f29e62..8aca0d2602a 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -5543,20 +5543,20 @@ package body Exp_Aggr is then return False; - -- For an assignment statement we require static matching - -- of bounds. Ditto for an allocator whose qualified - -- expression is a constrained type. If the expression in - -- the allocator is an unconstrained array, we accept an - -- upper bound that is not static, to allow for non-static - -- expressions of the base type. Clearly there are further - -- possibilities (with diminishing returns) for safely - -- building arrays in place here. + -- For an assignment statement we require static matching of + -- bounds. Ditto for an allocator whose qualified expression + -- is a constrained type. If the expression in the allocator + -- is an unconstrained array, we accept an upper bound that + -- is not static, to allow for non-static expressions of the + -- base type. Clearly there are further possibilities (with + -- diminishing returns) for safely building arrays in place + -- here. elsif Nkind (Parent (N)) = N_Assignment_Statement or else Is_Constrained (Etype (Parent (N))) then if not Compile_Time_Known_Value (Aggr_Hi) - or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi) + or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi) then return False; end if; diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 666e380224c..53457af4ec7 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -2126,6 +2126,8 @@ package body Exp_Ch11 is Add_Str_To_Name_Buffer ("PE_All_Guards_Closed"); when PE_Bad_Predicated_Generic_Type => Add_Str_To_Name_Buffer ("PE_Bad_Predicated_Generic_Type"); + when PE_Build_In_Place_Mismatch => + Add_Str_To_Name_Buffer ("PE_Build_In_Place_Mismatch"); when PE_Current_Task_In_Entry_Body => Add_Str_To_Name_Buffer ("PE_Current_Task_In_Entry_Body"); when PE_Duplicated_Entry_Address => diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index aac0c5cced9..c3aa2d2681f 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -10067,6 +10067,77 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, Standard_Boolean); end Expand_N_Quantified_Expression; + ----------------------------------- + -- Expand_N_Reduction_Expression -- + ----------------------------------- + + procedure Expand_N_Reduction_Expression (N : Node_Id) is + Actions : constant List_Id := New_List; + Expr : constant Node_Id := Expression (N); + Iter_Spec : constant Node_Id := Iterator_Specification (N); + Loc : constant Source_Ptr := Sloc (N); + Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N); + Typ : constant Entity_Id := Etype (N); + + Actual : Node_Id; + New_Call : Node_Id; + Reduction_Par : Node_Id; + Result : Entity_Id; + Scheme : Node_Id; + + begin + Result := Make_Temporary (Loc, 'R', N); + New_Call := New_Copy_Tree (Expr); + + if Nkind (New_Call) = N_Function_Call then + Actual := First (Parameter_Associations (New_Call)); + + if Nkind (Actual) /= N_Reduction_Expression_Parameter then + Actual := Next_Actual (Actual); + end if; + + elsif Nkind (New_Call) in N_Binary_Op then + Actual := Left_Opnd (New_Call); + + if Nkind (Actual) /= N_Reduction_Expression_Parameter then + Actual := Right_Opnd (New_Call); + end if; + end if; + + Reduction_Par := Expression (Actual); + + Append_To (Actions, + Make_Object_Declaration (Loc, + Defining_Identifier => Result, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => New_Copy_Tree (Reduction_Par))); + + if Present (Iter_Spec) then + Scheme := + Make_Iteration_Scheme (Loc, + Iterator_Specification => Iter_Spec); + else + Scheme := + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => Loop_Spec); + end if; + + Replace (Actual, New_Occurrence_Of (Result, Loc)); + + Append_To (Actions, + Make_Loop_Statement (Loc, + Iteration_Scheme => Scheme, + Statements => New_List (Make_Assignment_Statement (Loc, + New_Occurrence_Of (Result, Loc), New_Call)), + End_Label => Empty)); + + Rewrite (N, + Make_Expression_With_Actions (Loc, + Expression => New_Occurrence_Of (Result, Loc), + Actions => Actions)); + Analyze_And_Resolve (N, Typ); + end Expand_N_Reduction_Expression; + --------------------------------- -- Expand_N_Selected_Component -- --------------------------------- diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads index abdc470036a..6c92accd9f4 100644 --- a/gcc/ada/exp_ch4.ads +++ b/gcc/ada/exp_ch4.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -68,6 +68,7 @@ package Exp_Ch4 is procedure Expand_N_Or_Else (N : Node_Id); procedure Expand_N_Qualified_Expression (N : Node_Id); procedure Expand_N_Quantified_Expression (N : Node_Id); + procedure Expand_N_Reduction_Expression (N : Node_Id); procedure Expand_N_Selected_Component (N : Node_Id); procedure Expand_N_Slice (N : Node_Id); procedure Expand_N_Type_Conversion (N : Node_Id); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index f207b5b13dd..6199225ca9e 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5362,12 +5362,11 @@ package body Exp_Ch6 is Alloc_Expr => Pool_Allocator)))), -- Raise Program_Error if it's none of the above; - -- this is a compiler bug. ???PE_All_Guards_Closed - -- is bogus; we should have a new code. + -- this is a compiler bug. Else_Statements => New_List ( Make_Raise_Program_Error (Loc, - Reason => PE_All_Guards_Closed))); + Reason => PE_Build_In_Place_Mismatch))); -- If a separate initialization assignment was created -- earlier, append that following the assignment of the diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index a4797c7e6db..f768e201e93 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -7330,6 +7330,8 @@ package body Exp_Util is | N_Real_Literal | N_Real_Range_Specification | N_Record_Definition + | N_Reduction_Expression + | N_Reduction_Expression_Parameter | N_Reference | N_SCIL_Dispatch_Table_Tag_Init | N_SCIL_Dispatching_Call diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index 259618d62e7..1ca94814820 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.adb @@ -435,6 +435,9 @@ package body Expander is when N_Record_Representation_Clause => Expand_N_Record_Representation_Clause (N); + when N_Reduction_Expression => + Expand_N_Reduction_Expression (N); + when N_Requeue_Statement => Expand_N_Requeue_Statement (N); diff --git a/gcc/ada/libgnat/a-except.adb b/gcc/ada/libgnat/a-except.adb index 1b8e625b51e..4500850415a 100644 --- a/gcc/ada/libgnat/a-except.adb +++ b/gcc/ada/libgnat/a-except.adb @@ -432,6 +432,8 @@ package body Ada.Exceptions is (File : System.Address; Line : Integer); procedure Rcheck_PE_Bad_Predicated_Generic_Type (File : System.Address; Line : Integer); + procedure Rcheck_PE_Build_In_Place_Mismatch + (File : System.Address; Line : Integer); procedure Rcheck_PE_Current_Task_In_Entry_Body (File : System.Address; Line : Integer); procedure Rcheck_PE_Duplicated_Entry_Address @@ -520,6 +522,8 @@ package body Ada.Exceptions is "__gnat_rcheck_PE_All_Guards_Closed"); pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type, "__gnat_rcheck_PE_Bad_Predicated_Generic_Type"); + pragma Export (C, Rcheck_PE_Build_In_Place_Mismatch, + "__gnat_rcheck_PE_Build_In_Place_Mismatch"); pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body, "__gnat_rcheck_PE_Current_Task_In_Entry_Body"); pragma Export (C, Rcheck_PE_Duplicated_Entry_Address, @@ -588,6 +592,7 @@ package body Ada.Exceptions is pragma No_Return (Rcheck_PE_Aliased_Parameters); pragma No_Return (Rcheck_PE_All_Guards_Closed); pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type); + pragma No_Return (Rcheck_PE_Build_In_Place_Mismatch); pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body); pragma No_Return (Rcheck_PE_Duplicated_Entry_Address); pragma No_Return (Rcheck_PE_Explicit_Raise); @@ -661,6 +666,7 @@ package body Ada.Exceptions is Rmsg_34 : constant String := "infinite recursion" & NUL; Rmsg_35 : constant String := "object too large" & NUL; Rmsg_36 : constant String := "stream operation not allowed" & NUL; + Rmsg_37 : constant String := "build-in-place mismatch" & NUL; ----------------------- -- Polling Interface -- @@ -1335,6 +1341,13 @@ package body Ada.Exceptions is Raise_Program_Error_Msg (File, Line, Rmsg_19'Address); end Rcheck_PE_Bad_Predicated_Generic_Type; + procedure Rcheck_PE_Build_In_Place_Mismatch + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_37'Address); + end Rcheck_PE_Build_In_Place_Mismatch; + procedure Rcheck_PE_Current_Task_In_Entry_Body (File : System.Address; Line : Integer) is diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 00c7e6178f0..4b5ef456ed9 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -75,7 +75,8 @@ package body Ch4 is function P_Aggregate_Or_Paren_Expr return Node_Id; function P_Allocator return Node_Id; function P_Case_Expression_Alternative return Node_Id; - function P_Iterated_Component_Association return Node_Id; + function P_Iterated_Component_Assoc_Or_Reduction return Node_Id; + function P_Reduction_Expression (Lparen : Boolean) return Node_Id; function P_Record_Or_Array_Component_Association return Node_Id; function P_Factor return Node_Id; function P_Primary return Node_Id; @@ -644,6 +645,9 @@ package body Ch4 is -- case of a name which can be extended in the normal manner. -- This case is handled by LP_State_Name or LP_State_Expr. + -- (Ada2020) : the expression can be a reduction_expression_ + -- psarameter, i.e. a box or < Simple_Expression > + -- Note: if and case expressions (without an extra level of -- parentheses) are permitted in this context). @@ -652,6 +656,10 @@ package body Ch4 is -- If there is at least one occurrence of identifier => (but -- none of the other cases apply), then we have a call. + -- < simple_expression > + -- In Ada 2020 this is a reduction expression parameter that + -- specifies the initial value of the reduction. + -- Test for Id => case if Token = Tok_Identifier then @@ -670,9 +678,27 @@ package body Ch4 is end if; end if; - -- Here we have an expression after all + -- Here we have an expression after all, which may be a reduction + -- expression with a binary operator - Expr_Node := P_Expression_Or_Range_Attribute_If_OK; + if Token = Tok_Less then + Scan; -- past < + + Expr_Node := + New_Node (N_Reduction_Expression_Parameter, Token_Ptr); + Set_Expression (Expr_Node, P_Simple_Expression); + + if Token = Tok_Greater then + Scan; + else + Error_Msg_N + ("malformed reduction expression parameter", Expr_Node); + raise Error_Resync; + end if; + + else + Expr_Node := P_Expression_Or_Range_Attribute_If_OK; + end if; -- Check cases of discrete range for a slice @@ -1399,8 +1425,13 @@ package body Ch4 is elsif Token = Tok_For then Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc); - Expr_Node := P_Iterated_Component_Association; - goto Aggregate; + Expr_Node := P_Iterated_Component_Assoc_Or_Reduction; + + if Nkind (Expr_Node) = N_Reduction_Expression then + return Expr_Node; + else + goto Aggregate; + end if; end if; -- Scan expression, handling box appearing as positional argument @@ -1431,6 +1462,15 @@ package body Ch4 is Aggregate_Node := New_Node (N_Delta_Aggregate, Lparen_Sloc); Set_Expression (Aggregate_Node, Expr_Node); Expr_Node := Empty; + + if Nkind (Aggregate_Node) = N_Delta_Aggregate + and then (Token = Tok_Arrow or else Token = Tok_Others) + then + Error_Msg_SC + ("expect record component association in delta aggregate"); + raise Error_Resync; + end if; + goto Aggregate; else @@ -1613,7 +1653,7 @@ package body Ch4 is Expr_Node := Empty; elsif Token = Tok_For then - Expr_Node := P_Iterated_Component_Association; + Expr_Node := P_Iterated_Component_Assoc_Or_Reduction; else Save_Scan_State (Scan_State); -- at start of expression @@ -1666,7 +1706,7 @@ package body Ch4 is begin if Token = Tok_For then - return P_Iterated_Component_Association; + return P_Iterated_Component_Assoc_Or_Reduction; end if; Assoc_Node := New_Node (N_Component_Association, Token_Ptr); @@ -2827,7 +2867,7 @@ package body Ch4 is end if; else Restore_Scan_State (Scan_State); -- To FOR - Node1 := P_Iterated_Component_Association; + Node1 := P_Iterated_Component_Assoc_Or_Reduction; end if; return Node1; @@ -2854,6 +2894,18 @@ package body Ch4 is Node1 := P_Name; return Node1; + -- Ada2020: reduction expression parameter + + when Tok_Less => + Scan; -- past < + + Node1 := + New_Node (N_Reduction_Expression_Parameter, Token_Ptr); + Set_Expression (Node1, P_Simple_Expression); + + Scan; -- past > + return Node1; + -- Anything else is illegal as the first token of a primary, but -- we test for some common errors, to improve error messages. @@ -3298,33 +3350,195 @@ package body Ch4 is return Case_Alt_Node; end P_Case_Expression_Alternative; - -------------------------------------- - -- P_Iterated_Component_Association -- - -------------------------------------- + --------------------------------------------- + -- P_Iterated_Component_Assoc_Or_Reduction -- + --------------------------------------------- -- ITERATED_COMPONENT_ASSOCIATION ::= -- for DEFINING_IDENTIFIER in DISCRETE_CHOICE_LIST => EXPRESSION - function P_Iterated_Component_Association return Node_Id is + function P_Iterated_Component_Assoc_Or_Reduction return Node_Id is + Expr : Node_Id; + + function OK_Reduction_Expression_Parameter (L : List_Id) return Boolean; + -- Check that if a reduction_expression_Parameter appears, it is a + -- single one. + + --------------------------------------- + -- OK_Reduction_Expression_Parameter -- + --------------------------------------- + + function OK_Reduction_Expression_Parameter + (L : List_Id) return Boolean + is + Actual : Node_Id; + Num : Int := 0; + Seen : Boolean; + + begin + Seen := False; + Actual := First (L); + while Present (Actual) loop + if Nkind (Actual) = N_Reduction_Expression_Parameter then + if Seen then + Error_Msg_N ("only one reduction parameter allowed", Expr); + else + Seen := True; + end if; + end if; + + Num := Num + 1; + Next (Actual); + end loop; + + if Seen and then Num > 2 then + Error_Msg_N ("too many parameters in reduction function", Expr); + end if; + + return Seen; + end OK_Reduction_Expression_Parameter; + + -- Local variables + + Lparen : constant Boolean := Prev_Token = Tok_Left_Paren; Assoc_Node : Node_Id; + State : Saved_Scan_State; + + -- Start of processing for P_Iterated_Component_Assoc_Or_Reduction begin Scan; -- past FOR Assoc_Node := New_Node (N_Iterated_Component_Association, Prev_Token_Ptr); + + Save_Scan_State (State); Set_Defining_Identifier (Assoc_Node, P_Defining_Identifier); - T_In; - Set_Discrete_Choices (Assoc_Node, P_Discrete_Choice_List); - TF_Arrow; - Set_Expression (Assoc_Node, P_Expression); + + if Token = Tok_In then + Scan; -- past in + + Set_Discrete_Choices (Assoc_Node, P_Discrete_Choice_List); + TF_Arrow; + + if Token = Tok_Less then + Restore_Scan_State (State); + return P_Reduction_Expression (Lparen); + else + Expr := P_Expression; + end if; + + if Nkind (Expr) = N_Function_Call + and then OK_Reduction_Expression_Parameter + (Parameter_Associations (Expr)) + then + Restore_Scan_State (State); + return P_Reduction_Expression (Lparen); + + elsif Nkind (Expr) in N_Op + and then + Nkind (Right_Opnd (Expr)) = N_Reduction_Expression_Parameter + then + return P_Reduction_Expression (Lparen); + + elsif Nkind (Expr) in N_Binary_Op + and then + Nkind (Left_Opnd (Expr)) = N_Reduction_Expression_Parameter + then + return P_Reduction_Expression (Lparen); + + elsif Nkind (Expr) = N_Indexed_Component + and then OK_Reduction_Expression_Parameter (Expressions (Expr)) + then + Restore_Scan_State (State); + return P_Reduction_Expression (Lparen); + end if; + + Set_Expression (Assoc_Node, Expr); + if Ada_Version < Ada_2020 then + Error_Msg_SC ("iterated component is an Ada 2020 extension"); + Error_Msg_SC ("\compile with -gnatX"); + end if; + + return Assoc_Node; + + elsif Token = Tok_Of then + Restore_Scan_State (State); + return P_Reduction_Expression (Lparen); + + else + raise Error_Resync; + end if; + end P_Iterated_Component_Assoc_Or_Reduction; + + ---------------------------- + -- P_Reduction_Expression -- + ---------------------------- + + function P_Reduction_Expression (Lparen : Boolean) return Node_Id is + Expr : Node_Id; + I_Spec : Node_Id; + Left_Opnd : Node_Id; + Reduction_Node : Node_Id; + + begin + Reduction_Node := New_Node (N_Reduction_Expression, Prev_Token_Ptr); + + I_Spec := P_Loop_Parameter_Specification; + + if Nkind (I_Spec) = N_Loop_Parameter_Specification then + Set_Loop_Parameter_Specification (Reduction_Node, I_Spec); + else + Set_Iterator_Specification (Reduction_Node, I_Spec); + end if; + + T_Arrow; + if Token = Tok_Less and then False then + Scan; -- past < + + Left_Opnd := New_Node (N_Reduction_Expression_Parameter, Token_Ptr); + Set_Expression (Left_Opnd, P_Simple_Expression); + + Scan; -- past > + + if Token = Tok_Plus then + Set_Expression + (Reduction_Node, New_Op_Node (N_Op_Add, Token_Ptr)); + else + Set_Expression + (Reduction_Node, New_Op_Node (N_Op_Concat, Token_Ptr)); + end if; + + Scan; -- past operstor + Set_Left_Opnd (Expression (Reduction_Node), Left_Opnd); + Set_Right_Opnd (Expression (Reduction_Node), P_Primary); + + else + Expr := P_Expression; + Set_Expression (Reduction_Node, Expr); + + -- if Nkind (Expr) = N_Indexed_Component + -- and then List_Length (Expressions (Expr)) /= 2 + -- then + -- Error_Msg_N + -- ("combiner function call must have two arguments", Expr); + -- end if; + end if; if Ada_Version < Ada_2020 then - Error_Msg_SC ("iterated component is an Ada 2020 extension"); + Error_Msg_SC ("Reduction_Expression is an Ada 2020 extension"); Error_Msg_SC ("\compile with -gnatX"); end if; - return Assoc_Node; - end P_Iterated_Component_Association; + if not (Lparen and then Token = Tok_Right_Paren) then + Error_Msg + ("reduction expression must be parenthesized", + Sloc (Reduction_Node)); + else + Scan; -- past ??? + end if; + + return Reduction_Node; + end P_Reduction_Expression; --------------------- -- P_If_Expression -- @@ -3559,7 +3773,7 @@ package body Ch4 is -- an aggregate. Restore_Scan_State (Scan_State); - Result := P_Iterated_Component_Association; + Result := P_Iterated_Component_Assoc_Or_Reduction; end if; -- No other possibility should exist (caller was supposed to check) diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index c0c89620881..d6e61b09606 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -515,6 +515,12 @@ package body Sem is when N_Record_Representation_Clause => Analyze_Record_Representation_Clause (N); + when N_Reduction_Expression => + Analyze_Reduction_Expression (N); + + when N_Reduction_Expression_Parameter => + Analyze_Reduction_Expression_Parameter (N); + when N_Reference => Analyze_Reference (N); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 5d760c28de0..4791bf8c227 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -4343,6 +4343,79 @@ package body Sem_Ch4 is Check_Function_Writable_Actuals (N); end Analyze_Range; + ----------------------------------- + -- Analyze_Reduction_Expression -- + ----------------------------------- + + procedure Analyze_Reduction_Expression (N : Node_Id) is + Expr : constant Node_Id := Expression (N); + QE_Scop : Entity_Id; + + begin + QE_Scop := New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L'); + Set_Etype (QE_Scop, Standard_Void_Type); + Set_Scope (QE_Scop, Current_Scope); + Set_Parent (QE_Scop, N); + + Push_Scope (QE_Scop); + + -- All constituents are preanalyzed and resolved to avoid untimely + -- generation of various temporaries and types. Full analysis and + -- expansion is carried out when the reduction expression is + -- transformed into an expression with actions. + + if Present (Iterator_Specification (N)) then + Preanalyze (Iterator_Specification (N)); + + else pragma Assert (Present (Loop_Parameter_Specification (N))); + declare + Loop_Par : constant Node_Id := Loop_Parameter_Specification (N); + + begin + Preanalyze (Loop_Par); + + if Nkind (Discrete_Subtype_Definition (Loop_Par)) = N_Function_Call + and then Parent (Loop_Par) /= N + then + -- The parser cannot distinguish between a loop specification + -- and an iterator specification. If after pre-analysis the + -- proper form has been recognized, rewrite the expression to + -- reflect the right kind. This is needed for proper ASIS + -- navigation. If expansion is enabled, the transformation is + -- performed when the expression is rewritten as a loop. + + Set_Iterator_Specification (N, + New_Copy_Tree (Iterator_Specification (Parent (Loop_Par)))); + + Set_Defining_Identifier (Iterator_Specification (N), + Relocate_Node (Defining_Identifier (Loop_Par))); + Set_Name (Iterator_Specification (N), + Relocate_Node (Discrete_Subtype_Definition (Loop_Par))); + Set_Comes_From_Source (Iterator_Specification (N), + Comes_From_Source (Loop_Parameter_Specification (N))); + Set_Loop_Parameter_Specification (N, Empty); + end if; + end; + end if; + + Preanalyze (Expr); + End_Scope; + + Set_Etype (N, Etype (Expr)); + end Analyze_Reduction_Expression; + + -------------------------------------------- + -- Analyze_Reduction_Expression_Parameter -- + -------------------------------------------- + + procedure Analyze_Reduction_Expression_Parameter (N : Node_Id) is + Expr : constant Node_Id := Expression (N); + + begin + Analyze (Expr); + Set_Etype (N, Etype (Expr)); + end Analyze_Reduction_Expression_Parameter; + ----------------------- -- Analyze_Reference -- ----------------------- diff --git a/gcc/ada/sem_ch4.ads b/gcc/ada/sem_ch4.ads index a6105c1d5f1..f10e2bf1262 100644 --- a/gcc/ada/sem_ch4.ads +++ b/gcc/ada/sem_ch4.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -45,6 +45,8 @@ package Sem_Ch4 is procedure Analyze_Qualified_Expression (N : Node_Id); procedure Analyze_Quantified_Expression (N : Node_Id); procedure Analyze_Range (N : Node_Id); + procedure Analyze_Reduction_Expression (N : Node_Id); + procedure Analyze_Reduction_Expression_Parameter (N : Node_Id); procedure Analyze_Reference (N : Node_Id); procedure Analyze_Selected_Component (N : Node_Id); procedure Analyze_Short_Circuit (N : Node_Id); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 163952bb53c..1139a56136e 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -366,13 +366,13 @@ package body Sem_Ch6 is procedure Check_And_Freeze_Type (Typ : Entity_Id) is begin - -- Skip Itypes created by the preanalysis, and itypes - -- whose scope is another type (i.e. component subtypes - -- that depend on a discriminant), + -- Skip Itypes created by the preanalysis, and itypes whose + -- scope is another type (i.e. component subtypes that depend + -- on a discriminant), if Is_Itype (Typ) and then (Scope_Within_Or_Same (Scope (Typ), Def_Id) - or else Is_Type (Scope (Typ))) + or else Is_Type (Scope (Typ))) then return; end if; @@ -5825,12 +5825,10 @@ package body Sem_Ch6 is ------------------------------ procedure Check_Delayed_Subprogram (Designator : Entity_Id) is - F : Entity_Id; - procedure Possible_Freeze (T : Entity_Id); - -- T is the type of either a formal parameter or of the return type. - -- If T is not yet frozen and needs a delayed freeze, then the - -- subprogram itself must be delayed. + -- T is the type of either a formal parameter or of the return type. If + -- T is not yet frozen and needs a delayed freeze, then the subprogram + -- itself must be delayed. --------------------- -- Possible_Freeze -- @@ -5838,12 +5836,13 @@ package body Sem_Ch6 is procedure Possible_Freeze (T : Entity_Id) is Scop : constant Entity_Id := Scope (Designator); + begin - -- If the subprogram appears within a package instance (which - -- may be the wrapper package of a subprogram instance) the - -- freeze node for that package will freeze the subprogram at - -- the proper place, so do not emit a freeze node for the - -- subprogram, given that it may appear in the wrong scope. + -- If the subprogram appears within a package instance (which may be + -- the wrapper package of a subprogram instance) the freeze node for + -- that package will freeze the subprogram at the proper place, so + -- do not emit a freeze node for the subprogram, given that it may + -- appear in the wrong scope. if Ekind (Scop) = E_Package and then not Comes_From_Source (Scop) @@ -5860,9 +5859,12 @@ package body Sem_Ch6 is then Set_Has_Delayed_Freeze (Designator); end if; - end Possible_Freeze; + -- Local variables + + F : Entity_Id; + -- Start of processing for Check_Delayed_Subprogram begin @@ -5872,8 +5874,8 @@ package body Sem_Ch6 is Possible_Freeze (Etype (Designator)); Possible_Freeze (Base_Type (Etype (Designator))); -- needed ??? - -- Need delayed freeze if any of the formal types themselves need - -- a delayed freeze and are not yet frozen. + -- Need delayed freeze if any of the formal types themselves need a + -- delayed freeze and are not yet frozen. F := First_Formal (Designator); while Present (F) loop @@ -5882,17 +5884,19 @@ package body Sem_Ch6 is Next_Formal (F); end loop; - -- Mark functions that return by reference. Note that it cannot be - -- done for delayed_freeze subprograms because the underlying - -- returned type may not be known yet (for private types) + -- Mark functions that return by reference. Note that it cannot be done + -- for delayed_freeze subprograms because the underlying returned type + -- may not be known yet (for private types). if not Has_Delayed_Freeze (Designator) and then Expander_Active then declare Typ : constant Entity_Id := Etype (Designator); Utyp : constant Entity_Id := Underlying_Type (Typ); + begin if Is_Limited_View (Typ) then Set_Returns_By_Ref (Designator); + elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Designator); end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index d342906ad53..d98d9cf04b4 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -2752,10 +2752,6 @@ package body Sem_Prag is -- A list of all initialization items processed so far. This list is -- used to detect duplicate items. - Non_Null_Seen : Boolean := False; - Null_Seen : Boolean := False; - -- Flags used to check the legality of a null initialization list - States_And_Objs : Elist_Id := No_Elist; -- A list of all abstract states and objects declared in the visible -- declarations of the related package. This list is used to detect the @@ -2785,91 +2781,67 @@ package body Sem_Prag is Item_Id : Entity_Id; begin - -- Null initialization list - - if Nkind (Item) = N_Null then - if Null_Seen then - SPARK_Msg_N ("multiple null initializations not allowed", Item); - - elsif Non_Null_Seen then - SPARK_Msg_N - ("cannot mix null and non-null initialization items", Item); - else - Null_Seen := True; - end if; - - -- Initialization item - - else - Non_Null_Seen := True; - - if Null_Seen then - SPARK_Msg_N - ("cannot mix null and non-null initialization items", Item); - end if; - - Analyze (Item); - Resolve_State (Item); + Analyze (Item); + Resolve_State (Item); - if Is_Entity_Name (Item) then - Item_Id := Entity_Of (Item); - - if Present (Item_Id) - and then Ekind_In (Item_Id, E_Abstract_State, - E_Constant, - E_Variable) - then - -- When the initialization item is undefined, it appears as - -- Any_Id. Do not continue with the analysis of the item. + if Is_Entity_Name (Item) then + Item_Id := Entity_Of (Item); - if Item_Id = Any_Id then - null; + if Present (Item_Id) + and then Ekind_In (Item_Id, E_Abstract_State, + E_Constant, + E_Variable) + then + -- When the initialization item is undefined, it appears as + -- Any_Id. Do not continue with the analysis of the item. - -- The state or variable must be declared in the visible - -- declarations of the package (SPARK RM 7.1.5(7)). + if Item_Id = Any_Id then + null; - elsif not Contains (States_And_Objs, Item_Id) then - Error_Msg_Name_1 := Chars (Pack_Id); - SPARK_Msg_NE - ("initialization item & must appear in the visible " - & "declarations of package %", Item, Item_Id); + -- The state or variable must be declared in the visible + -- declarations of the package (SPARK RM 7.1.5(7)). - -- Detect a duplicate use of the same initialization item - -- (SPARK RM 7.1.5(5)). + elsif not Contains (States_And_Objs, Item_Id) then + Error_Msg_Name_1 := Chars (Pack_Id); + SPARK_Msg_NE + ("initialization item & must appear in the visible " + & "declarations of package %", Item, Item_Id); - elsif Contains (Items_Seen, Item_Id) then - SPARK_Msg_N ("duplicate initialization item", Item); + -- Detect a duplicate use of the same initialization item + -- (SPARK RM 7.1.5(5)). - -- The item is legal, add it to the list of processed states - -- and variables. + elsif Contains (Items_Seen, Item_Id) then + SPARK_Msg_N ("duplicate initialization item", Item); - else - Append_New_Elmt (Item_Id, Items_Seen); + -- The item is legal, add it to the list of processed states + -- and variables. - if Ekind (Item_Id) = E_Abstract_State then - Append_New_Elmt (Item_Id, States_Seen); - end if; + else + Append_New_Elmt (Item_Id, Items_Seen); - if Present (Encapsulating_State (Item_Id)) then - Append_New_Elmt (Item_Id, Constits_Seen); - end if; + if Ekind (Item_Id) = E_Abstract_State then + Append_New_Elmt (Item_Id, States_Seen); end if; - -- The item references something that is not a state or object - -- (SPARK RM 7.1.5(3)). - - else - SPARK_Msg_N - ("initialization item must denote object or state", Item); + if Present (Encapsulating_State (Item_Id)) then + Append_New_Elmt (Item_Id, Constits_Seen); + end if; end if; - -- Some form of illegal construct masquerading as a name - -- (SPARK RM 7.1.5(3)). This is a syntax error, always report. + -- The item references something that is not a state or object + -- (SPARK RM 7.1.5(3)). else - Error_Msg_N + SPARK_Msg_N ("initialization item must denote object or state", Item); end if; + + -- Some form of illegal construct masquerading as a name + -- (SPARK RM 7.1.5(3)). This is a syntax error, always report. + + else + Error_Msg_N + ("initialization item must denote object or state", Item); end if; end Analyze_Initialization_Item; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index e48d5e98f5b..969b8bdb070 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2997,6 +2997,13 @@ package body Sem_Res is when N_Real_Literal => Resolve_Real_Literal (N, Ctx_Type); + when N_Reduction_Expression => + null; + -- Resolve (Expression (N), Ctx_Type); + + when N_Reduction_Expression_Parameter => + null; + when N_Reference => Resolve_Reference (N, Ctx_Type); diff --git a/gcc/ada/sem_spark.adb b/gcc/ada/sem_spark.adb index 42517ea0829..d6f8fdc5987 100644 --- a/gcc/ada/sem_spark.adb +++ b/gcc/ada/sem_spark.adb @@ -1376,6 +1376,12 @@ package body Sem_SPARK is Free_Env (Saved_Env); end; + when N_Reduction_Expression => + null; + + when N_Reduction_Expression_Parameter => + null; + -- Analyze the list of associations in the aggregate when N_Aggregate => diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 494b46ab4fa..1790b56ff4c 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1279,6 +1279,8 @@ package body Sinfo is or else NT (N).Nkind = N_Qualified_Expression or else NT (N).Nkind = N_Raise_Expression or else NT (N).Nkind = N_Raise_Statement + or else NT (N).Nkind = N_Reduction_Expression + or else NT (N).Nkind = N_Reduction_Expression_Parameter or else NT (N).Nkind = N_Simple_Return_Statement or else NT (N).Nkind = N_Type_Conversion or else NT (N).Nkind = N_Unchecked_Expression @@ -2223,7 +2225,8 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Iteration_Scheme - or else NT (N).Nkind = N_Quantified_Expression); + or else NT (N).Nkind = N_Quantified_Expression + or else NT (N).Nkind = N_Reduction_Expression); return Node2 (N); end Iterator_Specification; @@ -2353,7 +2356,8 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Iteration_Scheme - or else NT (N).Nkind = N_Quantified_Expression); + or else NT (N).Nkind = N_Quantified_Expression + or else NT (N).Nkind = N_Reduction_Expression); return Node4 (N); end Loop_Parameter_Specification; @@ -4742,6 +4746,8 @@ package body Sinfo is or else NT (N).Nkind = N_Qualified_Expression or else NT (N).Nkind = N_Raise_Expression or else NT (N).Nkind = N_Raise_Statement + or else NT (N).Nkind = N_Reduction_Expression + or else NT (N).Nkind = N_Reduction_Expression_Parameter or else NT (N).Nkind = N_Simple_Return_Statement or else NT (N).Nkind = N_Type_Conversion or else NT (N).Nkind = N_Unchecked_Expression @@ -5686,7 +5692,8 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Iteration_Scheme - or else NT (N).Nkind = N_Quantified_Expression); + or else NT (N).Nkind = N_Quantified_Expression + or else NT (N).Nkind = N_Reduction_Expression); Set_Node2_With_Parent (N, Val); end Set_Iterator_Specification; @@ -5816,7 +5823,8 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Iteration_Scheme - or else NT (N).Nkind = N_Quantified_Expression); + or else NT (N).Nkind = N_Quantified_Expression + or else NT (N).Nkind = N_Reduction_Expression); Set_Node4_With_Parent (N, Val); end Set_Loop_Parameter_Specification; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 87d68ea7190..19585936c49 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -4730,7 +4730,7 @@ package Sinfo is -- since the expander converts case expressions into case statements. --------------------------------- - -- 4.5.9 Quantified Expression -- + -- 4.5.8 Quantified Expression -- --------------------------------- -- QUANTIFIED_EXPRESSION ::= @@ -4749,6 +4749,31 @@ package Sinfo is -- Condition (Node1) -- All_Present (Flag15) + -------------------------------- + -- 4.5.9 Reduction Expression -- + -------------------------------- + + -- REDUCTION_EXPRESSION ::= + -- for LOOP_PARAMETER_SPECIFICATION => COMBINER_FUNCTION_CALL + -- for ITERATOR_SPECIFIATION => COMBINER_FUNCTION_CALL + + -- At most one of (Iterator_Specification, Loop_Parameter_Specification) + -- is present at a time, in which case the other one is empty. + + -- N_Reduction_Expression + -- Sloc points to FOR + -- Iterator_Specification (Node2) + -- Expression (Node3) + -- Loop_Parameter_Specification (Node4) + -- plus fields for expression + + -- COMBINER_FUNCTION_CALL => FUNCTION_CALL + + -- A Combiner_Function_Call is either a function call (including an + -- operator) with one reduction expression parameter, appearing either + -- as a left operand or as the first actual in the parameter list. In + -- a reduction expression this is represented as an expression. + -------------------------- -- 4.6 Type Conversion -- -------------------------- @@ -5608,7 +5633,18 @@ package Sinfo is -- 6.4 Actual Parameter -- --------------------------- - -- EXPLICIT_ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME + -- EXPLICIT_ACTUAL_PARAMETER ::= + -- EXPRESSION | variable_NAME | REDUCTION_EXPRESSION_PARAMETER + + ------------------------------------------ + -- 6.4.6 Reduction_Expression_Parameter -- + ------------------------------------------ + + -- REDUCTION_EXPRESSION_PARAMETER ::= <> | < EXPRESSION > + + -- N_Reduction_Expression_Parameter + -- Expression (Node3) (Set to Empty if no expression present) + -- plus fields for expression --------------------------- -- 6.5 Return Statement -- @@ -8732,6 +8768,8 @@ package Sinfo is N_Null, N_Qualified_Expression, N_Quantified_Expression, + N_Reduction_Expression, + N_Reduction_Expression_Parameter, N_Aggregate, N_Allocator, N_Case_Expression, @@ -12122,6 +12160,20 @@ package Sinfo is 4 => True, -- Loop_Parameter_Specification (Node4) 5 => False), -- Etype (Node5-Sem) + N_Reduction_Expression => + (1 => False, -- unused + 2 => True, -- Iterator_Specification (Node2) + 3 => True, -- Expression (Node3) + 4 => True, -- Loop_Parameter_Specification (Node4) + 5 => False), -- Etype (Node5-Sem) + + N_Reduction_Expression_Parameter => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + N_Allocator => (1 => False, -- Storage_Pool (Node1-Sem) 2 => False, -- Procedure_To_Call (Node2-Sem) diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 428e91a73cd..e8a29933aa1 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -3110,6 +3110,28 @@ package body Sprint is Sprint_Indented_List (Component_Clauses (Node)); Write_Indent_Str ("end record;"); + when N_Reduction_Expression => + Write_Str (" for"); + + if Present (Iterator_Specification (Node)) then + Sprint_Node (Iterator_Specification (Node)); + else + Sprint_Node (Loop_Parameter_Specification (Node)); + end if; + + Write_Str (" => "); + Sprint_Node (Expression (Node)); + null; + + when N_Reduction_Expression_Parameter => + Write_Char ('<'); + + if Present (Expression (Node)) then + Sprint_Node (Expression (Node)); + end if; + + Write_Char ('>'); + when N_Reference => Sprint_Node (Prefix (Node)); Write_Str_With_Col_Check_Sloc ("'reference"); diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 0d8eb06c715..b39797a7da9 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -851,8 +851,7 @@ package Types is -- Note on ordering of references. For the tables in Ada.Exceptions units, -- usually the ordering does not matter, and we use the same ordering as - -- is used here (note the requirement in the ordering here that CE/PE/SE - -- codes be kept together, so the subtype declarations work OK). + -- is used here. type RT_Exception_Code is (CE_Access_Check_Failed, -- 00 @@ -894,9 +893,11 @@ package Types is SE_Explicit_Raise, -- 33 SE_Infinite_Recursion, -- 34 SE_Object_Too_Large, -- 35 - PE_Stream_Operation_Not_Allowed); -- 36 + PE_Stream_Operation_Not_Allowed, -- 36 + PE_Build_In_Place_Mismatch); -- 37 - Last_Reason_Code : constant := 36; + Last_Reason_Code : constant := + RT_Exception_Code'Pos (RT_Exception_Code'Last); -- Last reason code type Reason_Kind is (CE_Reason, PE_Reason, SE_Reason); @@ -937,6 +938,7 @@ package Types is PE_Unchecked_Union_Restriction => PE_Reason, PE_Non_Transportable_Actual => PE_Reason, PE_Stream_Operation_Not_Allowed => PE_Reason, + PE_Build_In_Place_Mismatch => PE_Reason, SE_Empty_Storage_Pool => SE_Reason, SE_Explicit_Raise => SE_Reason, diff --git a/gcc/ada/types.h b/gcc/ada/types.h index 6c14f19e32f..613dfff67a1 100644 --- a/gcc/ada/types.h +++ b/gcc/ada/types.h @@ -373,6 +373,7 @@ typedef Int Mechanism_Type; #define PE_Aliased_Parameters 17 #define PE_All_Guards_Closed 18 #define PE_Bad_Predicated_Generic_Type 19 +#define PE_Build_In_Place_Mismatch 37 #define PE_Current_Task_In_Entry_Body 20 #define PE_Duplicated_Entry_Address 21 #define PE_Explicit_Raise 22 @@ -392,4 +393,4 @@ typedef Int Mechanism_Type; #define SE_Infinite_Recursion 34 #define SE_Object_Too_Large 35 -#define LAST_REASON_CODE 36 +#define LAST_REASON_CODE 37