@@ -1577,7 +1577,6 @@ package body Contracts is
Decls : List_Id;
Result : Entity_Id)
is
- Actuals : constant List_Id := Empty_List;
Body_Decl : constant Entity_Id := Unit_Declaration_Node (Body_Id);
Loc : constant Source_Ptr := Sloc (Body_Decl);
Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
@@ -1606,11 +1605,11 @@ package body Contracts is
Ret_Type := Etype (Subp_Id);
-- Generate the contracts wrapper by moving the original declarations
- -- and statements within a local subprogram and calling it within
- -- an extended return to preserve the result for the purpose of
- -- evaluating postconditions, contracts, type invariants, etc.
+ -- and statements within a local subprogram, calling it and possibly
+ -- preserving the result for the purpose of evaluating postconditions,
+ -- contracts, type invariants, etc.
- -- Generate:
+ -- In the case of a function, generate:
--
-- function Original_Func (X : in out Integer) return Typ is
-- <prologue renamings>
@@ -1623,13 +1622,25 @@ package body Contracts is
-- end;
--
-- begin
- -- return
- -- Result_Obj : constant Typ := _Wrapped_Statements
- -- do
+ -- declare
+ -- type Axx is access all Typ;
+ -- Rxx : constant Axx := _Wrapped_Statements'reference;
+ -- Result_Obj : Typ renames Rxx.all;
+ --
+ -- begin
-- <postconditions statments>
- -- end return;
+ -- return Rxx.all;
+ -- end;
-- end;
--
+ -- This sequence is recognized by Expand_Simple_Function_Return as a
+ -- tail call, in other words equivalent to "return _Wrapped_Statements;"
+ -- and thus the copy to the anonymous return object is elided, including
+ -- a pair of calls to Adjust/Finalize for types requiring finalization.
+
+ -- 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:
--
-- procedure Original_Proc (X : in out Integer) is
@@ -1680,8 +1691,7 @@ package body Contracts is
Set_Declarations (Body_Decl, Decls);
Set_Handled_Statement_Sequence (Body_Decl,
Make_Handled_Sequence_Of_Statements (Loc,
- End_Label => Make_Identifier (Loc, Chars (Wrapper_Id)),
- Statements => New_List));
+ End_Label => Make_Identifier (Loc, Chars (Wrapper_Id))));
-- Move certain flags which are relevant to the body
@@ -1697,7 +1707,7 @@ package body Contracts is
Set_Has_Pragma_Inline_Always
(Wrapper_Id, Has_Pragma_Inline_Always (Subp_Id));
- -- Generate call to the wrapper
+ -- Prepend a call to the wrapper when the subprogram is a procedure
if No (Ret_Type) or else Ret_Type = Standard_Void_Type then
Prepend_To (Stmts,
@@ -1706,25 +1716,64 @@ 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 function.
+ -- 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
+ -- we cannot call Remove_Side_Effects here because nothing has been
+ -- analyzed yet and we cannot return the renaming itself because
+ -- Expand_Simple_Function_Return expects an explicit dereference.
else
- 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,
- Object_Definition =>
- New_Occurrence_Of (Ret_Type, Loc),
- Expression =>
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (Wrapper_Id, Loc),
- Parameter_Associations => Actuals))),
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts))));
+ declare
+ A_Id : constant Node_Id := Make_Temporary (Loc, 'A');
+ R_Id : constant Node_Id := Make_Temporary (Loc, 'R');
+
+ begin
+ Set_Statements (Handled_Statement_Sequence (Body_Decl), New_List (
+ Make_Block_Statement (Loc,
+
+ Declarations => New_List (
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => A_Id,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Null_Exclusion_Present => True,
+ Subtype_Indication =>
+ New_Occurrence_Of (Ret_Type, Loc))),
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => R_Id,
+ Object_Definition => New_Occurrence_Of (A_Id, Loc),
+ Constant_Present => True,
+ Expression =>
+ Make_Reference (Loc,
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Wrapper_Id, Loc)))),
+
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Result,
+ Subtype_Mark => New_Occurrence_Of (Ret_Type, Loc),
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ New_Occurrence_Of (R_Id, Loc)))),
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts))));
+
+ Append_To (Stmts,
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Explicit_Dereference (Loc,
+ New_Occurrence_Of (R_Id, Loc))));
+
+ -- It is required for Is_Related_To_Func_Return to return True
+ -- that the temporary Rxx be related to the expression of the
+ -- simple return statement built just above.
+
+ Set_Related_Expression (R_Id, Expression (Last (Stmts)));
+ end;
end if;
end Build_Subprogram_Contract_Wrapper;
@@ -3387,16 +3436,16 @@ package body Contracts is
-- <preconditions from body>
-- <contract case conditions>
- -- function _wrapped_statements (...) return ... is
+ -- function _Wrapped_Statements (...) return ... is
-- <source declarations>
-- begin
-- <source statements>
- -- end _wrapped_statements;
+ -- end _Wrapped_Statements;
-- begin
- -- return
- -- Result : ... := _wrapped_statements
- -- do
+ -- declare
+ -- Result : ... renames _Wrapped_Statements;
+ -- begin
-- <refined postconditions from body>
-- <postconditions from body>
-- <postconditions from spec>
@@ -3405,7 +3454,7 @@ package body Contracts is
-- <invariant check of function result>
-- <invariant and predicate checks of parameters
-- return Result;
- -- end return;
+ -- end;
-- end Original_Code;
-- Step 1: augment contracts list with postconditions associated with
@@ -5052,11 +5052,11 @@ package body Exp_Ch6 is
Set_Analyzed (N);
- -- A function which returns a controlled object uses the secondary
- -- stack. Rewrite the call into a temporary which obtains the result of
- -- the function using 'reference.
+ -- Apply the transformation, unless it was already applied manually
- Remove_Side_Effects (N);
+ if Nkind (Par) /= N_Reference then
+ Remove_Side_Effects (N);
+ end if;
-- The side effect removal of the function call produced a temporary.
-- When the context is a case expression, if expression, or expression
@@ -1454,10 +1454,10 @@ package body Sem_Attr is
Subp_Decl := Find_Related_Declaration_Or_Body (Prag);
end if;
- -- 'Old objects appear in extended return statements as part of
- -- the expansion of contract wrappers.
+ -- 'Old objects appear in block statements as part of the expansion
+ -- of contract wrappers.
- if Nkind (Subp_Decl) = N_Extended_Return_Statement then
+ if Nkind (Subp_Decl) = N_Block_Statement then
Subp_Decl := Parent (Parent (Subp_Decl));
end if;