[COMMITED] ada: Further tweak new expansion of contracts

[COMMITED] ada: Further tweak new expansion of contracts

[Marc Poulhiès]

From: Eric Botcazou <ebotcazou@adacore.com>

The original extended return statement is mandatory for functions whose
result type is limited in Ada 2005 and later.

gcc/ada/

	* contracts.adb (Build_Subprogram_Contract_Wrapper): Put back the
	extended return statement if the result type is built-in-place.
	* sem_attr.adb (Analyze_Attribute_Old_Result): Also expect an
	extended return statement.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/contracts.adb | 46 ++++++++++++++++++++++++++++++++++++++++---
 gcc/ada/sem_attr.adb  |  8 +++++---
 2 files changed, 48 insertions(+), 6 deletions(-)

diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index dd573d374c6..a300d739eff 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -30,6 +30,7 @@ with Einfo.Entities; use Einfo.Entities;
 with Einfo.Utils;    use Einfo.Utils;
 with Elists;         use Elists;
 with Errout;         use Errout;
+with Exp_Ch6;        use Exp_Ch6;
 with Exp_Prag;       use Exp_Prag;
 with Exp_Tss;        use Exp_Tss;
 with Exp_Util;       use Exp_Util;
@@ -1609,7 +1610,7 @@ package body Contracts is
       --  preserving the result for the purpose of evaluating postconditions,
       --  contracts, type invariants, etc.
 
-      --  In the case of a function, generate:
+      --  In the case of a regular function, generate:
       --
       --  function Original_Func (X : in out Integer) return Typ is
       --     <prologue renamings>
@@ -1641,7 +1642,27 @@ package body Contracts is
       --  Note that an extended return statement does not yield the same result
       --  because the copy of the return object is not elided by GNAT for now.
 
-      --  Or, in the case of a procedure:
+      --  Or else, in the case of a BIP function, generate:
+
+      --  function Original_Func (X : in out Integer) return Typ is
+      --     <prologue renamings>
+      --     <preconditions>
+      --
+      --     function _Wrapped_Statements return Typ is
+      --        <original declarations>
+      --     begin
+      --        <original statements>
+      --     end;
+      --
+      --  begin
+      --     return
+      --        Result_Obj : constant Typ := _Wrapped_Statements
+      --     do
+      --        <postconditions statments>
+      --     end return;
+      --  end;
+
+      --  Or else, in the case of a procedure, generate:
       --
       --  procedure Original_Proc (X : in out Integer) is
       --     <prologue renamings>
@@ -1657,7 +1678,6 @@ package body Contracts is
       --     _Wrapped_Statements;
       --     <postconditions statments>
       --  end;
-      --
 
       --  Create Identifier
 
@@ -1716,6 +1736,26 @@ package body Contracts is
          Set_Statements
            (Handled_Statement_Sequence (Body_Decl), Stmts);
 
+      --  Generate the post-execution statements and the extended return
+      --  when the subprogram being wrapped is a BIP function.
+
+      elsif Is_Build_In_Place_Result_Type (Ret_Type) then
+         Set_Statements (Handled_Statement_Sequence (Body_Decl), New_List (
+           Make_Extended_Return_Statement (Loc,
+             Return_Object_Declarations => New_List (
+                Make_Object_Declaration (Loc,
+                  Defining_Identifier => Result,
+                  Constant_Present    => True,
+                  Object_Definition   =>
+                    New_Occurrence_Of (Ret_Type, Loc),
+                  Expression          =>
+                    Make_Function_Call (Loc,
+                      Name                   =>
+                        New_Occurrence_Of (Wrapper_Id, Loc)))),
+             Handled_Statement_Sequence =>
+               Make_Handled_Sequence_Of_Statements (Loc,
+                 Statements => Stmts))));
+
       --  Declare a renaming of the result of the call to the wrapper and
       --  append a return of the result of the call when the subprogram is
       --  a function, after manually removing the side effects. Note that
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 0c88be71b94..d27d956a1e7 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -1454,10 +1454,12 @@ package body Sem_Attr is
             Subp_Decl := Find_Related_Declaration_Or_Body (Prag);
          end if;
 
-         --  'Old objects appear in block statements as part of the expansion
-         --  of contract wrappers.
+         --  'Old objects appear in block and extended return statements as
+         --  part of the expansion of contract wrappers.
 
-         if Nkind (Subp_Decl) = N_Block_Statement then
+         if Nkind (Subp_Decl) in N_Block_Statement
+                               | N_Extended_Return_Statement
+         then
             Subp_Decl := Parent (Parent (Subp_Decl));
          end if;
 
-- 
2.25.1