From ca1f6b2991e1864c8db5c9f082c62804467b2a07 Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Tue, 25 Apr 2017 10:39:02 +0000 Subject: [PATCH] sem_prag.adb (No_Return): Give an error if the pragma applies to a body. 2017-04-25 Bob Duff * sem_prag.adb (No_Return): Give an error if the pragma applies to a body. Specialize the error for the specless body case, as is done for (e.g.) pragma Convention. * debug.adb: Add switch -gnatd.J to disable the above legality checks. This is mainly for use in our test suite, to avoid rewriting a lot of illegal (but working) code. It might also be useful to customers. Under this switch, if a pragma No_Return applies to a body, and the procedure raises an exception (as it should), the pragma has no effect. If the procedure does return, execution is erroneous. 2017-04-25 Bob Duff * exp_ch6.adb (Expand_Actuals): This is the root of the problem. It took N as an 'in out' parameter, and in some cases, rewrote N, but then set N to Original_Node(N). So the node returned in N had no Parent. The caller continued processing of this orphaned node. In some cases that caused a crash (e.g. Remove_Side_Effects climbs up Parents in a loop, and trips over the Empty Parent). The solution is to make N an 'in' parameter. Instead of rewriting it, return the list of post-call actions, so the caller can do the rewriting later, after N has been fully processed. (Expand_Call_Helper): Move most of Expand_Call here. It has too many premature 'return' statements, and we want to do the rewriting on return. (Insert_Post_Call_Actions): New procedure to insert the post-call actions in the appropriate place. In the problematic case, that involves rewriting N as an Expression_With_Actions. (Expand_Call): Call the new procedures Expand_Call_Helper and Insert_Post_Call_Actions. From-SVN: r247178 --- gcc/ada/ChangeLog | 34 +++++ gcc/ada/debug.adb | 7 +- gcc/ada/exp_ch6.adb | 296 +++++++++++++++++++++++-------------------- gcc/ada/sem_prag.adb | 35 ++++- 4 files changed, 227 insertions(+), 145 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4ed0c7443b7..c6aec4824d8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,37 @@ +2017-04-25 Bob Duff + + * sem_prag.adb (No_Return): Give an error if the pragma applies + to a body. Specialize the error for the specless body case, + as is done for (e.g.) pragma Convention. + * debug.adb: Add switch -gnatd.J to disable the above legality + checks. This is mainly for use in our test suite, to avoid + rewriting a lot of illegal (but working) code. It might also + be useful to customers. Under this switch, if a pragma No_Return + applies to a body, and the procedure raises an exception (as it + should), the pragma has no effect. If the procedure does return, + execution is erroneous. + +2017-04-25 Bob Duff + + * exp_ch6.adb (Expand_Actuals): This is the + root of the problem. It took N as an 'in out' parameter, and in + some cases, rewrote N, but then set N to Original_Node(N). So + the node returned in N had no Parent. The caller continued + processing of this orphaned node. In some cases that caused a + crash (e.g. Remove_Side_Effects climbs up Parents in a loop, + and trips over the Empty Parent). The solution is to make N an + 'in' parameter. Instead of rewriting it, return the list of + post-call actions, so the caller can do the rewriting later, + after N has been fully processed. + (Expand_Call_Helper): Move most of Expand_Call here. It has + too many premature 'return' statements, and we want to do the + rewriting on return. + (Insert_Post_Call_Actions): New procedure to insert the post-call + actions in the appropriate place. In the problematic case, + that involves rewriting N as an Expression_With_Actions. + (Expand_Call): Call the new procedures Expand_Call_Helper and + Insert_Post_Call_Actions. + 2017-04-25 Ed Schonberg * sem_prag.adb (Inherits_Class_Wide_Pre): Cleanup code, handle diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index beddab31321..b404ac86c1d 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -127,7 +127,7 @@ package body Debug is -- d.G Ignore calls through generic formal parameters for elaboration -- d.H GNSA mode for ASIS -- d.I Do not ignore enum representation clauses in CodePeer mode - -- d.J + -- d.J Relaxed rules for pragma No_Return -- d.K Enable generation of contract-only procedures in CodePeer mode -- d.L Depend on back end for limited types in if and case expressions -- d.M Relaxed RM semantics @@ -645,6 +645,11 @@ package body Debug is -- cases being able to change this default might be useful to remove -- some false positives. + -- d.J Relaxed rules for pragma No_Return. A pragma No_Return is illegal + -- if it applies to a body. This switch disables the legality check + -- for that. If the procedure does in fact return normally, execution + -- is erroneous, and therefore unpredictable. + -- d.K Enable generation of contract-only procedures in CodePeer mode and -- report a warning on subprograms for which the contract-only body -- cannot be built. Currently reported on subprograms defined in diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index e44518f9a7b..c8e719b1321 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -158,7 +158,12 @@ package body Exp_Ch6 is -- the values are not changed for the call, we know immediately that -- we have an infinite recursion. - procedure Expand_Actuals (N : in out Node_Id; Subp : Entity_Id); + procedure Expand_Actuals + (N : Node_Id; Subp : Entity_Id; Post_Call : out List_Id); + -- Return in Post_Call a list of actions to take place after the call. + -- The call will later be rewritten as an Expression_With_Actions, + -- with the Post_Call actions inserted, and the call inside. + -- -- For each actual of an in-out or out parameter which is a numeric -- (view) conversion of the form T (A), where A denotes a variable, -- we insert the declaration: @@ -190,11 +195,14 @@ package body Exp_Ch6 is -- -- For OUT and IN OUT parameters, add predicate checks after the call -- based on the predicates of the actual type. - -- - -- The parameter N is IN OUT because in some cases, the expansion code - -- rewrites the call as an expression actions with the call inside. In - -- this case N is reset to point to the inside call so that the caller - -- can continue processing of this call. + + procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id); + -- Does the main work of Expand_Call. Post_Call is as for Expand_Actuals + + procedure Insert_Post_Call_Actions + (N : Node_Id; Post_Call : List_Id); + -- Insert the Post_Call list (previously produced by + -- Expand_Actuals/Expand_Call_Helper) into the tree. procedure Expand_Ctrl_Function_Call (N : Node_Id); -- N is a function call which returns a controlled object. Transform the @@ -1146,12 +1154,13 @@ package body Exp_Ch6 is -- Expand_Actuals -- -------------------- - procedure Expand_Actuals (N : in out Node_Id; Subp : Entity_Id) is + procedure Expand_Actuals + (N : Node_Id; Subp : Entity_Id; Post_Call : out List_Id) + is Loc : constant Source_Ptr := Sloc (N); Actual : Node_Id; Formal : Entity_Id; N_Node : Node_Id; - Post_Call : List_Id; E_Actual : Entity_Id; E_Formal : Entity_Id; @@ -2122,135 +2131,23 @@ package body Exp_Ch6 is Next_Formal (Formal); Next_Actual (Actual); end loop; - - -- Find right place to put post call stuff if it is present - - if not Is_Empty_List (Post_Call) then - - -- Cases where the call is not a member of a statement list. - -- This includes the case where the call is an actual in another - -- function call or indexing, i.e. an expression context as well. - - if not Is_List_Member (N) - or else Nkind_In (Parent (N), N_Function_Call, N_Indexed_Component) - then - -- In Ada 2012 the call may be a function call in an expression - -- (since OUT and IN OUT parameters are now allowed for such - -- calls). The write-back of (in)-out parameters is handled - -- by the back-end, but the constraint checks generated when - -- subtypes of formal and actual don't match must be inserted - -- in the form of assignments. - - if Ada_Version >= Ada_2012 - and then Nkind (N) = N_Function_Call - then - -- We used to just do handle this by climbing up parents to - -- a non-statement/declaration and then simply making a call - -- to Insert_Actions_After (P, Post_Call), but that doesn't - -- work. If we are in the middle of an expression, e.g. the - -- condition of an IF, this call would insert after the IF - -- statement, which is much too late to be doing the write - -- back. For example: - - -- if Clobber (X) then - -- Put_Line (X'Img); - -- else - -- goto Junk - -- end if; - - -- Now assume Clobber changes X, if we put the write back - -- after the IF, the Put_Line gets the wrong value and the - -- goto causes the write back to be skipped completely. - - -- To deal with this, we replace the call by - - -- do - -- Tnnn : constant function-result-type := function-call; - -- Post_Call actions - -- in - -- Tnnn; - -- end; - - declare - Tnnn : constant Entity_Id := Make_Temporary (Loc, 'T'); - FRTyp : constant Entity_Id := Etype (N); - Name : constant Node_Id := Relocate_Node (N); - - begin - Prepend_To (Post_Call, - Make_Object_Declaration (Loc, - Defining_Identifier => Tnnn, - Object_Definition => New_Occurrence_Of (FRTyp, Loc), - Constant_Present => True, - Expression => Name)); - - Rewrite (N, - Make_Expression_With_Actions (Loc, - Actions => Post_Call, - Expression => New_Occurrence_Of (Tnnn, Loc))); - - -- We don't want to just blindly call Analyze_And_Resolve - -- because that would cause unwanted recursion on the call. - -- So for a moment set the call as analyzed to prevent that - -- recursion, and get the rest analyzed properly, then reset - -- the analyzed flag, so our caller can continue. - - Set_Analyzed (Name, True); - Analyze_And_Resolve (N, FRTyp); - Set_Analyzed (Name, False); - - -- Reset calling argument to point to function call inside - -- the expression with actions so the caller can continue - -- to process the call. In spite of the fact that it is - -- marked Analyzed above, it may be rewritten by Remove_ - -- Side_Effects if validity checks are present, so go back - -- to original call. - - N := Original_Node (Name); - end; - - -- If not the special Ada 2012 case of a function call, then - -- we must have the triggering statement of a triggering - -- alternative or an entry call alternative, and we can add - -- the post call stuff to the corresponding statement list. - - else - declare - P : Node_Id; - - begin - P := Parent (N); - pragma Assert (Nkind_In (P, N_Triggering_Alternative, - N_Entry_Call_Alternative)); - - if Is_Non_Empty_List (Statements (P)) then - Insert_List_Before_And_Analyze - (First (Statements (P)), Post_Call); - else - Set_Statements (P, Post_Call); - end if; - - return; - end; - end if; - - -- Otherwise, normal case where N is in a statement sequence, - -- just put the post-call stuff after the call statement. - - else - Insert_Actions_After (N, Post_Call); - return; - end if; - end if; - - -- The call node itself is re-analyzed in Expand_Call - end Expand_Actuals; ----------------- -- Expand_Call -- ----------------- + procedure Expand_Call (N : Node_Id) is + Post_Call : List_Id; + begin + Expand_Call_Helper (N, Post_Call); + Insert_Post_Call_Actions (N, Post_Call); + end Expand_Call; + + ------------------------ + -- Expand_Call_Helper -- + ------------------------ + -- This procedure handles expansion of function calls and procedure call -- statements (i.e. it serves as the body for Expand_N_Function_Call and -- Expand_N_Procedure_Call_Statement). Processing for calls includes: @@ -2267,7 +2164,7 @@ package body Exp_Ch6 is -- for the 'Constrained attribute and for accessibility checks are added -- at this point. - procedure Expand_Call (N : Node_Id) is + procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id) is Loc : constant Source_Ptr := Sloc (N); Call_Node : Node_Id := N; Extra_Actuals : List_Id := No_List; @@ -2625,9 +2522,11 @@ package body Exp_Ch6 is CW_Interface_Formals_Present : Boolean := False; - -- Start of processing for Expand_Call + -- Start of processing for Expand_Call_Helper begin + Post_Call := New_List; + -- Expand the function or procedure call if the first actual has a -- declared dimension aspect, and the subprogram is declared in one -- of the dimension I/O packages. @@ -2817,7 +2716,8 @@ package body Exp_Ch6 is Add_Actual_Parameter (Remove_Head (Extra_Actuals)); end loop; - Expand_Actuals (Call_Node, Subp); + Expand_Actuals (Call_Node, Subp, Post_Call); + pragma Assert (Is_Empty_List (Post_Call)); return; end; end if; @@ -3666,7 +3566,7 @@ package body Exp_Ch6 is -- At this point we have all the actuals, so this is the point at which -- the various expansion activities for actuals is carried out. - Expand_Actuals (Call_Node, Subp); + Expand_Actuals (Call_Node, Subp, Post_Call); -- Verify that the actuals do not share storage. This check must be done -- on the caller side rather that inside the subprogram to avoid issues @@ -3941,11 +3841,12 @@ package body Exp_Ch6 is -- replacing them with an unchecked conversion. Not only is this -- efficient, but it also avoids order of elaboration problems when -- address clauses are inlined (address expression elaborated at the - -- at the wrong point). + -- wrong point). -- We perform this optimization regardless of whether we are in the -- main unit or in a unit in the context of the main unit, to ensure - -- that tree generated is the same in both cases, for CodePeer use. + -- that the generated tree is the same in both cases, for CodePeer + -- use. if Is_RTE (Subp, RE_To_Address) then Rewrite (Call_Node, @@ -4201,7 +4102,7 @@ package body Exp_Ch6 is Establish_Transient_Scope (Call_Node, Sec_Stack => True); end if; end if; - end Expand_Call; + end Expand_Call_Helper; ------------------------------- -- Expand_Ctrl_Function_Call -- @@ -7315,6 +7216,125 @@ package body Exp_Ch6 is end if; end Freeze_Subprogram; + ------------------------------ + -- Insert_Post_Call_Actions -- + ------------------------------ + + procedure Insert_Post_Call_Actions + (N : Node_Id; Post_Call : List_Id) + is + begin + if Is_Empty_List (Post_Call) then + return; + end if; + + -- Cases where the call is not a member of a statement list. + -- This includes the case where the call is an actual in another + -- function call or indexing, i.e. an expression context as well. + + if not Is_List_Member (N) + or else Nkind_In (Parent (N), N_Function_Call, N_Indexed_Component) + then + -- In Ada 2012 the call may be a function call in an expression + -- (since OUT and IN OUT parameters are now allowed for such + -- calls). The write-back of (in)-out parameters is handled + -- by the back-end, but the constraint checks generated when + -- subtypes of formal and actual don't match must be inserted + -- in the form of assignments. + + if Nkind (Original_Node (N)) = N_Function_Call then + pragma Assert (Ada_Version >= Ada_2012); + -- Functions with '[in] out' parameters are only allowed in Ada + -- 2012. + + -- We used to handle this by climbing up parents to a + -- non-statement/declaration and then simply making a call to + -- Insert_Actions_After (P, Post_Call), but that doesn't work + -- for Ada 2012. If we are in the middle of an expression, e.g. + -- the condition of an IF, this call would insert after the IF + -- statement, which is much too late to be doing the write + -- back. For example: + + -- if Clobber (X) then + -- Put_Line (X'Img); + -- else + -- goto Junk + -- end if; + + -- Now assume Clobber changes X, if we put the write back + -- after the IF, the Put_Line gets the wrong value and the + -- goto causes the write back to be skipped completely. + + -- To deal with this, we replace the call by + + -- do + -- Tnnn : constant function-result-type := function-call; + -- Post_Call actions + -- in + -- Tnnn; + -- end; + + declare + Loc : constant Source_Ptr := Sloc (N); + Tnnn : constant Entity_Id := Make_Temporary (Loc, 'T'); + FRTyp : constant Entity_Id := Etype (N); + Name : constant Node_Id := Relocate_Node (N); + + begin + Prepend_To (Post_Call, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnnn, + Object_Definition => New_Occurrence_Of (FRTyp, Loc), + Constant_Present => True, + Expression => Name)); + + Rewrite (N, + Make_Expression_With_Actions (Loc, + Actions => Post_Call, + Expression => New_Occurrence_Of (Tnnn, Loc))); + + -- We don't want to just blindly call Analyze_And_Resolve + -- because that would cause unwanted recursion on the call. + -- So for a moment set the call as analyzed to prevent that + -- recursion, and get the rest analyzed properly, then reset + -- the analyzed flag, so our caller can continue. + + Set_Analyzed (Name, True); + Analyze_And_Resolve (N, FRTyp); + Set_Analyzed (Name, False); + end; + + -- If not the special Ada 2012 case of a function call, then + -- we must have the triggering statement of a triggering + -- alternative or an entry call alternative, and we can add + -- the post call stuff to the corresponding statement list. + + else + declare + P : Node_Id; + + begin + P := Parent (N); + pragma Assert (Nkind_In (P, N_Triggering_Alternative, + N_Entry_Call_Alternative)); + + if Is_Non_Empty_List (Statements (P)) then + Insert_List_Before_And_Analyze + (First (Statements (P)), Post_Call); + else + Set_Statements (P, Post_Call); + end if; + end; + end if; + + -- Otherwise, normal case where N is in a statement sequence, + -- just put the post-call stuff after the call statement. + + else + Insert_Actions_After (N, Post_Call); + end if; + end Insert_Post_Call_Actions; + ----------------------- -- Is_Null_Procedure -- ----------------------- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 7e13f52ab59..2f65475199b 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -7621,7 +7621,7 @@ package body Sem_Prag is end if; -- Check that we are not applying this to a specless body. Relax this - -- check if Relaxed_RM_Semantics to accomodate other Ada compilers. + -- check if Relaxed_RM_Semantics to accommodate other Ada compilers. if Is_Subprogram (E) and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body @@ -8084,8 +8084,8 @@ package body Sem_Prag is N_Subprogram_Body then Error_Pragma - ("pragma% requires separate spec" - & " and must come before body"); + ("pragma% requires separate spec" & + " and must come before body"); end if; -- Test result type if given, note that the result type @@ -18177,6 +18177,29 @@ package body Sem_Prag is and then Scope (E) = Current_Scope loop if Ekind_In (E, E_Procedure, E_Generic_Procedure) then + -- Check that the pragma is not applied to a body. + -- First check the specless body case, to give a + -- different error message. These checks do not apply + -- if Relaxed_RM_Semantics, to accommodate other Ada + -- compilers. Disable these checks under -gnatd.J. + + if not Debug_Flag_Dot_JJ then + if Nkind (Parent (Declaration_Node (E))) = + N_Subprogram_Body + and then not Relaxed_RM_Semantics + then + Error_Pragma + ("pragma% requires separate spec" & + " and must come before body"); + end if; + + -- Now the "specful" body case + + if Rep_Item_Too_Late (E, N) then + raise Pragma_Exit; + end if; + end if; + Set_No_Return (E); -- A pragma that applies to a Ghost entity becomes Ghost @@ -26125,7 +26148,7 @@ package body Sem_Prag is raise Program_Error; end if; - -- To accomodate partial decoration of disabled SPARK features, this + -- To accommodate partial decoration of disabled SPARK features, this -- routine may be called with illegal input. If this is the case, do -- not raise Program_Error. @@ -28031,7 +28054,7 @@ package body Sem_Prag is (Item => First (Choices (Clause)), Is_Input => False); - -- To accomodate partial decoration of disabled SPARK features, this + -- To accommodate partial decoration of disabled SPARK features, this -- routine may be called with illegal input. If this is the case, do -- not raise Program_Error. @@ -28105,7 +28128,7 @@ package body Sem_Prag is end loop; end if; - -- To accomodate partial decoration of disabled SPARK features, this + -- To accommodate partial decoration of disabled SPARK features, this -- routine may be called with illegal input. If this is the case, do -- not raise Program_Error. -- 2.30.2