From b41c731f0a6e653a41bfe12b0fb29e9067b5fbfd Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 10:19:33 +0200 Subject: [PATCH] [multiple changes] 2017-04-25 Hristian Kirtchev * sem_ch3.adb, exp_util.adb, sem_prag.adb, freeze.adb, sem_util.adb: Minor reformatting. 2017-04-25 Ed Schonberg * scng.adb (Scan): Handle '@' appropriately. * sem_ch5.adb: Code cleanup. From-SVN: r247142 --- gcc/ada/ChangeLog | 10 ++++++++ gcc/ada/exp_util.adb | 5 ++-- gcc/ada/freeze.adb | 61 +++++++++++++++++++++++--------------------- gcc/ada/scng.adb | 3 +++ gcc/ada/sem_ch3.adb | 5 ++-- gcc/ada/sem_ch5.adb | 18 ++++++------- gcc/ada/sem_prag.adb | 23 +++++++++-------- gcc/ada/sem_util.adb | 9 ++++--- 8 files changed, 78 insertions(+), 56 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5f109e192ab..353a2569b21 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2017-04-25 Hristian Kirtchev + + * sem_ch3.adb, exp_util.adb, sem_prag.adb, freeze.adb, sem_util.adb: + Minor reformatting. + +2017-04-25 Ed Schonberg + + * scng.adb (Scan): Handle '@' appropriately. + * sem_ch5.adb: Code cleanup. + 2017-04-25 Ed Schonberg * freeze.adb (Check_Expression_Function): Do not check for the diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 0b8ed616458..cc3be9256c1 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1057,7 +1057,6 @@ package body Exp_Util is Adjust_Sloc : Boolean; Needs_Wrapper : out Boolean) is - function Replace_Entity (N : Node_Id) return Traverse_Result; -- Replace reference to formal of inherited operation or to primitive -- operation of root type, with corresponding entity for derived type, @@ -1102,8 +1101,8 @@ package body Exp_Util is if Present (New_E) then Rewrite (N, New_Occurrence_Of (New_E, Sloc (N))); - -- If the entity is an overridden primitive, we must build - -- a wrapper for the current inherited operation. + -- If the entity is an overridden primitive, we must build a + -- wrapper for the current inherited operation. if Is_Subprogram (New_E) then Needs_Wrapper := True; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index e5167519271..431fb292139 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1404,12 +1404,12 @@ package body Freeze is A_Post : Node_Id; A_Pre : Node_Id; Decls : List_Id; + Needs_Wrapper : Boolean; + New_Prag : Node_Id; Op_Node : Elmt_Id; Par_Prim : Entity_Id; Par_Type : Entity_Id; - New_Prag : Node_Id; Prim : Entity_Id; - Needs_Wrapper : Boolean; begin Op_Node := First_Elmt (Prim_Ops); @@ -1452,8 +1452,6 @@ package body Freeze is -- require a wrapper to handle inherited conditions that call other -- primitives, so that LSP can be verified/enforced. - -- Wrapper construction TBD. - Op_Node := First_Elmt (Prim_Ops); while Present (Op_Node) loop Decls := Empty_List; @@ -1511,34 +1509,34 @@ package body Freeze is -- controlling actuals are conversions to the corresponding type -- in the parent primitive: - -- procedure New_Prim (F1 : T1.; ...) is - -- pragma Check (Precondition, Expr); - -- begin - -- Par_Prim (Par_Type (F1) ..); - -- end; - -- - -- If the primitive is a function the statement is a call. + -- procedure New_Prim (F1 : T1.; ...) is + -- pragma Check (Precondition, Expr); + -- begin + -- Par_Prim (Par_Type (F1) ..); + -- end; + + -- If the primitive is a function the statement is a call declare Loc : constant Source_Ptr := Sloc (R); - Formal : Entity_Id; Actuals : List_Id; + Call : Node_Id; + Formal : Entity_Id; New_F_Spec : Node_Id; New_Formal : Entity_Id; New_Proc : Node_Id; New_Spec : Node_Id; - Call : Node_Id; begin - Actuals := Empty_List; - New_Spec := Build_Overriding_Spec (Par_Prim, R); + Actuals := Empty_List; + New_Spec := Build_Overriding_Spec (Par_Prim, R); Formal := First_Formal (Par_Prim); New_F_Spec := First (Parameter_Specifications (New_Spec)); while Present (Formal) loop New_Formal := Defining_Identifier (New_F_Spec); - -- If controlling argument, add conversion. + -- If controlling argument, add conversion if Etype (Formal) = Par_Type then Append_To (Actuals, @@ -1555,24 +1553,29 @@ package body Freeze is end loop; if Ekind (Par_Prim) = E_Procedure then - Call := Make_Procedure_Call_Statement (Loc, - Parameter_Associations => Actuals, - Name => New_Occurrence_Of (Par_Prim, Loc)); + Call := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Par_Prim, Loc), + Parameter_Associations => Actuals); else - Call := Make_Simple_Return_Statement (Loc, + Call := + Make_Simple_Return_Statement (Loc, Expression => Make_Function_Call (Loc, - Parameter_Associations => Actuals, - Name => New_Occurrence_Of (Par_Prim, Loc))); + Name => + New_Occurrence_Of (Par_Prim, Loc), + Parameter_Associations => Actuals)); end if; - New_Proc := Make_Subprogram_Body (Loc, - Specification => New_Spec, - Declarations => Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Call), - End_Label => Make_Identifier (Loc, Chars (Prim)))); + New_Proc := + Make_Subprogram_Body (Loc, + Specification => New_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Call), + End_Label => Make_Identifier (Loc, Chars (Prim)))); Insert_After (Parent (R), New_Proc); Analyze (New_Proc); diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index a46b80ce64b..137a2c00d83 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -2052,6 +2052,8 @@ package body Scng is -- T'Digits'Img. Strings literals are included for things like -- "abs"'Address. Other literals are included to give better error -- behavior for illegal cases like 123'Img. + -- In Ada2020 a target name (i.e. @) is a valid prefix of an + -- attribute, and functions like a name. if Prev_Token = Tok_Identifier or else Prev_Token = Tok_Right_Paren @@ -2059,6 +2061,7 @@ package body Scng is or else Prev_Token = Tok_Delta or else Prev_Token = Tok_Digits or else Prev_Token = Tok_Project + or else Prev_Token = Tok_At_Sign or else Prev_Token in Token_Class_Literal then Token := Tok_Apostrophe; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 0c3b08eeb87..cc06b92ed33 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -17660,8 +17660,9 @@ package body Sem_Ch3 is end if; while Present (Disc) loop - -- If no further associations return the discriminant, value - -- will be found on the second pass. + + -- If no further associations return the discriminant, value will + -- be found on the second pass. if No (Assoc) then return Result; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index bc7693cb5c4..c5f4732d316 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -570,15 +570,6 @@ package body Sem_Ch5 is Resolve (Rhs, T1); - -- If the right-hand side contains target names, expansion has been - -- disabled to prevent expansion that might move target names out of - -- the context of the assignment statement. Restore the expander mode - -- now so that assignment statement can be properly expanded. - - if Nkind (N) = N_Assignment_Statement and then Has_Target_Names (N) then - Expander_Mode_Restore; - end if; - -- This is the point at which we check for an unset reference Check_Unset_Reference (Rhs); @@ -939,6 +930,15 @@ package body Sem_Ch5 is <> Current_LHS := Empty; Restore_Ghost_Mode (Mode); + + -- If the right-hand side contains target names, expansion has been + -- disabled to prevent expansion that might move target names out of + -- the context of the assignment statement. Restore the expander mode + -- now so that assignment statement can be properly expanded. + + if Nkind (N) = N_Assignment_Statement and then Has_Target_Names (N) then + Expander_Mode_Restore; + end if; end Analyze_Assignment; ----------------------------- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 81101b95419..21c5e07afca 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -27026,9 +27026,6 @@ package body Sem_Prag is Inher_Id : Entity_Id := Empty; Keep_Pragma_Id : Boolean := False) return Node_Id is - Needs_Wrapper : Boolean; - pragma Unreferenced (Needs_Wrapper); - function Suppress_Reference (N : Node_Id) return Traverse_Result; -- Detect whether node N references a formal parameter subject to -- pragma Unreferenced. If this is the case, set Comes_From_Source @@ -27065,11 +27062,14 @@ package body Sem_Prag is -- Local variables - Loc : constant Source_Ptr := Sloc (Prag); - Prag_Nam : constant Name_Id := Pragma_Name (Prag); - Check_Prag : Node_Id; - Msg_Arg : Node_Id; - Nam : Name_Id; + Loc : constant Source_Ptr := Sloc (Prag); + Prag_Nam : constant Name_Id := Pragma_Name (Prag); + Check_Prag : Node_Id; + Msg_Arg : Node_Id; + Nam : Name_Id; + + Needs_Wrapper : Boolean; + pragma Unreferenced (Needs_Wrapper); -- Start of processing for Build_Pragma_Check_Equivalent @@ -27097,8 +27097,11 @@ package body Sem_Prag is -- Build the inherited class-wide condition Build_Class_Wide_Expression - (Check_Prag, Subp_Id, Inher_Id, Adjust_Sloc => True, - Needs_Wrapper => Needs_Wrapper); + (Prag => Check_Prag, + Subp => Subp_Id, + Par_Subp => Inher_Id, + Adjust_Sloc => True, + Needs_Wrapper => Needs_Wrapper); -- If not an inherited condition simply copy the original pragma diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 53410cc7a7a..5ab9b963787 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1596,18 +1596,21 @@ package body Sem_Util is Formal_Spec : Node_Id; Formal_Type : Node_Id; New_Spec : Node_Id; + begin New_Spec := Copy_Subprogram_Spec (Spec); + Formal_Spec := First (Parameter_Specifications (New_Spec)); while Present (Formal_Spec) loop Formal_Type := Parameter_Type (Formal_Spec); + if Is_Entity_Name (Formal_Type) and then Entity (Formal_Type) = Par_Typ then Rewrite (Formal_Type, New_Occurrence_Of (Typ, Loc)); end if; - -- Nothing needs to be done for access parameters. + -- Nothing needs to be done for access parameters Next (Formal_Spec); end loop; @@ -13588,8 +13591,8 @@ package body Sem_Util is -- names. when N_Explicit_Dereference => - return not Nkind_In - (Original_Node (N), N_If_Expression, N_Case_Expression); + return not Nkind_In (Original_Node (N), N_Case_Expression, + N_If_Expression); -- A view conversion of a tagged object is an object reference -- 2.30.2