Skip to content

R
riscv-gcc-1
Commit ca1f6b29 by Bob Duff Committed by Arnaud Charlet
Options

sem_prag.adb (No_Return): Give an error if the pragma applies to a body. 

2017-04-25  Bob Duff  <duff@adacore.com>

	* 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  <duff@adacore.com>

	* 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
parent 36357cf3
Showing with 227 additions and 145 deletions
gcc/ada/ChangeLog
2017-04-25 Bob Duff <duff@adacore.com>
* 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 <duff@adacore.com>
* 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 <schonberg@adacore.com> 2017-04-25 Ed Schonberg <schonberg@adacore.com>
* sem_prag.adb (Inherits_Class_Wide_Pre): Cleanup code, handle * sem_prag.adb (Inherits_Class_Wide_Pre): Cleanup code, handle
......
gcc/ada/debug.adb
...@@ -127,7 +127,7 @@ package body Debug is ...@@ -127,7 +127,7 @@ package body Debug is
-- d.G Ignore calls through generic formal parameters for elaboration -- d.G Ignore calls through generic formal parameters for elaboration
-- d.H GNSA mode for ASIS -- d.H GNSA mode for ASIS
-- d.I Do not ignore enum representation clauses in CodePeer mode -- 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.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.L Depend on back end for limited types in if and case expressions
-- d.M Relaxed RM semantics -- d.M Relaxed RM semantics
...@@ -645,6 +645,11 @@ package body Debug is ...@@ -645,6 +645,11 @@ package body Debug is
-- cases being able to change this default might be useful to remove -- cases being able to change this default might be useful to remove
-- some false positives. -- 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 -- d.K Enable generation of contract-only procedures in CodePeer mode and
-- report a warning on subprograms for which the contract-only body -- report a warning on subprograms for which the contract-only body
-- cannot be built. Currently reported on subprograms defined in -- cannot be built. Currently reported on subprograms defined in
......
gcc/ada/exp_ch6.adb
...@@ -158,7 +158,12 @@ package body Exp_Ch6 is ...@@ -158,7 +158,12 @@ package body Exp_Ch6 is
-- the values are not changed for the call, we know immediately that -- the values are not changed for the call, we know immediately that
-- we have an infinite recursion. -- 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 -- 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, -- (view) conversion of the form T (A), where A denotes a variable,
-- we insert the declaration: -- we insert the declaration:
...@@ -190,11 +195,14 @@ package body Exp_Ch6 is ...@@ -190,11 +195,14 @@ package body Exp_Ch6 is
-- --
-- For OUT and IN OUT parameters, add predicate checks after the call -- For OUT and IN OUT parameters, add predicate checks after the call
-- based on the predicates of the actual type. -- based on the predicates of the actual type.
--
-- The parameter N is IN OUT because in some cases, the expansion code procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id);
-- rewrites the call as an expression actions with the call inside. In -- Does the main work of Expand_Call. Post_Call is as for Expand_Actuals
-- this case N is reset to point to the inside call so that the caller
-- can continue processing of this call. 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); procedure Expand_Ctrl_Function_Call (N : Node_Id);
-- N is a function call which returns a controlled object. Transform the -- N is a function call which returns a controlled object. Transform the
...@@ -1146,12 +1154,13 @@ package body Exp_Ch6 is ...@@ -1146,12 +1154,13 @@ package body Exp_Ch6 is
-- Expand_Actuals -- -- 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); Loc : constant Source_Ptr := Sloc (N);
Actual : Node_Id; Actual : Node_Id;
Formal : Entity_Id; Formal : Entity_Id;
N_Node : Node_Id; N_Node : Node_Id;
Post_Call : List_Id;
E_Actual : Entity_Id; E_Actual : Entity_Id;
E_Formal : Entity_Id; E_Formal : Entity_Id;
...@@ -2122,135 +2131,23 @@ package body Exp_Ch6 is ...@@ -2122,135 +2131,23 @@ package body Exp_Ch6 is
Next_Formal (Formal); Next_Formal (Formal);
Next_Actual (Actual); Next_Actual (Actual);
end loop; 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; end Expand_Actuals;
----------------- -----------------
-- Expand_Call -- -- 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 -- This procedure handles expansion of function calls and procedure call
-- statements (i.e. it serves as the body for Expand_N_Function_Call and -- statements (i.e. it serves as the body for Expand_N_Function_Call and
-- Expand_N_Procedure_Call_Statement). Processing for calls includes: -- Expand_N_Procedure_Call_Statement). Processing for calls includes:
...@@ -2267,7 +2164,7 @@ package body Exp_Ch6 is ...@@ -2267,7 +2164,7 @@ package body Exp_Ch6 is
-- for the 'Constrained attribute and for accessibility checks are added -- for the 'Constrained attribute and for accessibility checks are added
-- at this point. -- 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); Loc : constant Source_Ptr := Sloc (N);
Call_Node : Node_Id := N; Call_Node : Node_Id := N;
Extra_Actuals : List_Id := No_List; Extra_Actuals : List_Id := No_List;
...@@ -2625,9 +2522,11 @@ package body Exp_Ch6 is ...@@ -2625,9 +2522,11 @@ package body Exp_Ch6 is
CW_Interface_Formals_Present : Boolean := False; CW_Interface_Formals_Present : Boolean := False;
-- Start of processing for Expand_Call -- Start of processing for Expand_Call_Helper
begin begin
Post_Call := New_List;
-- Expand the function or procedure call if the first actual has a -- Expand the function or procedure call if the first actual has a
-- declared dimension aspect, and the subprogram is declared in one -- declared dimension aspect, and the subprogram is declared in one
-- of the dimension I/O packages. -- of the dimension I/O packages.
...@@ -2817,7 +2716,8 @@ package body Exp_Ch6 is ...@@ -2817,7 +2716,8 @@ package body Exp_Ch6 is
Add_Actual_Parameter (Remove_Head (Extra_Actuals)); Add_Actual_Parameter (Remove_Head (Extra_Actuals));
end loop; end loop;
Expand_Actuals (Call_Node, Subp); Expand_Actuals (Call_Node, Subp, Post_Call);
pragma Assert (Is_Empty_List (Post_Call));
return; return;
end; end;
end if; end if;
...@@ -3666,7 +3566,7 @@ package body Exp_Ch6 is ...@@ -3666,7 +3566,7 @@ package body Exp_Ch6 is
-- At this point we have all the actuals, so this is the point at which -- At this point we have all the actuals, so this is the point at which
-- the various expansion activities for actuals is carried out. -- 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 -- 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 -- on the caller side rather that inside the subprogram to avoid issues
...@@ -3941,11 +3841,12 @@ package body Exp_Ch6 is ...@@ -3941,11 +3841,12 @@ package body Exp_Ch6 is
-- replacing them with an unchecked conversion. Not only is this -- replacing them with an unchecked conversion. Not only is this
-- efficient, but it also avoids order of elaboration problems when -- efficient, but it also avoids order of elaboration problems when
-- address clauses are inlined (address expression elaborated at the -- 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 -- 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 -- 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 if Is_RTE (Subp, RE_To_Address) then
Rewrite (Call_Node, Rewrite (Call_Node,
...@@ -4201,7 +4102,7 @@ package body Exp_Ch6 is ...@@ -4201,7 +4102,7 @@ package body Exp_Ch6 is
Establish_Transient_Scope (Call_Node, Sec_Stack => True); Establish_Transient_Scope (Call_Node, Sec_Stack => True);
end if; end if;
end if; end if;
end Expand_Call; end Expand_Call_Helper;
------------------------------- -------------------------------
-- Expand_Ctrl_Function_Call -- -- Expand_Ctrl_Function_Call --
...@@ -7315,6 +7216,125 @@ package body Exp_Ch6 is ...@@ -7315,6 +7216,125 @@ package body Exp_Ch6 is
end if; end if;
end Freeze_Subprogram; 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 -- -- Is_Null_Procedure --
----------------------- -----------------------
......
gcc/ada/sem_prag.adb
...@@ -7621,7 +7621,7 @@ package body Sem_Prag is ...@@ -7621,7 +7621,7 @@ package body Sem_Prag is
end if; end if;
-- Check that we are not applying this to a specless body. Relax this -- 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) if Is_Subprogram (E)
and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
...@@ -8084,8 +8084,8 @@ package body Sem_Prag is ...@@ -8084,8 +8084,8 @@ package body Sem_Prag is
N_Subprogram_Body N_Subprogram_Body
then then
Error_Pragma Error_Pragma
("pragma% requires separate spec" ("pragma% requires separate spec" &
& " and must come before body"); " and must come before body");
end if; end if;
-- Test result type if given, note that the result type -- Test result type if given, note that the result type
...@@ -18177,6 +18177,29 @@ package body Sem_Prag is ...@@ -18177,6 +18177,29 @@ package body Sem_Prag is
and then Scope (E) = Current_Scope and then Scope (E) = Current_Scope
loop loop
if Ekind_In (E, E_Procedure, E_Generic_Procedure) then 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); Set_No_Return (E);
-- A pragma that applies to a Ghost entity becomes Ghost -- A pragma that applies to a Ghost entity becomes Ghost
...@@ -26125,7 +26148,7 @@ package body Sem_Prag is ...@@ -26125,7 +26148,7 @@ package body Sem_Prag is
raise Program_Error; raise Program_Error;
end if; 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 -- routine may be called with illegal input. If this is the case, do
-- not raise Program_Error. -- not raise Program_Error.
...@@ -28031,7 +28054,7 @@ package body Sem_Prag is ...@@ -28031,7 +28054,7 @@ package body Sem_Prag is
(Item => First (Choices (Clause)), (Item => First (Choices (Clause)),
Is_Input => False); 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 -- routine may be called with illegal input. If this is the case, do
-- not raise Program_Error. -- not raise Program_Error.
...@@ -28105,7 +28128,7 @@ package body Sem_Prag is ...@@ -28105,7 +28128,7 @@ package body Sem_Prag is
end loop; end loop;
end if; 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 -- routine may be called with illegal input. If this is the case, do
-- not raise Program_Error. -- not raise Program_Error.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment