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

4 files changed, 227 insertions, 145 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4ed0c74..c6aec48 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,37 @@
+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>
 
 	* sem_prag.adb (Inherits_Class_Wide_Pre): Cleanup code, handle
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index beddab3..b404ac8 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 e44518f..c8e719b 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 7e13f52..2f65475 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.