diff options
Diffstat (limited to 'gcc/ada/exp_ch5.adb')
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 1488 |
1 files changed, 0 insertions, 1488 deletions
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index a28c5ab..6ca2c8c 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -27,7 +27,6 @@ with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; with Einfo; use Einfo; -with Exp_Atag; use Exp_Atag; with Exp_Aggr; use Exp_Aggr; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; @@ -104,16 +103,6 @@ package body Exp_Ch5 is -- clause (this last case is required because holes in the tagged type -- might be filled with components from child types). - procedure Expand_Non_Function_Return (N : Node_Id); - -- Called by Expand_N_Simple_Return_Statement in case we're returning from - -- a procedure body, entry body, accept statement, or extended return - -- statement. Note that all non-function returns are simple return - -- statements. - - procedure Expand_Simple_Function_Return (N : Node_Id); - -- Expand simple return from function. In the case where we are returning - -- from a function body this is called by Expand_N_Simple_Return_Statement. - function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id; -- Generate the necessary code for controlled and tagged assignment, that -- is to say, finalization of the target before, adjustment of the target @@ -2450,728 +2439,6 @@ package body Exp_Ch5 is Adjust_Condition (Condition (N)); end Expand_N_Exit_Statement; - ---------------------------------------- - -- Expand_N_Extended_Return_Statement -- - ---------------------------------------- - - -- If there is a Handled_Statement_Sequence, we rewrite this: - - -- return Result : T := <expression> do - -- <handled_seq_of_stms> - -- end return; - - -- to be: - - -- declare - -- Result : T := <expression>; - -- begin - -- <handled_seq_of_stms> - -- return Result; - -- end; - - -- Otherwise (no Handled_Statement_Sequence), we rewrite this: - - -- return Result : T := <expression>; - - -- to be: - - -- return <expression>; - - -- unless it's build-in-place or there's no <expression>, in which case - -- we generate: - - -- declare - -- Result : T := <expression>; - -- begin - -- return Result; - -- end; - - -- Note that this case could have been written by the user as an extended - -- return statement, or could have been transformed to this from a simple - -- return statement. - - -- That is, we need to have a reified return object if there are statements - -- (which might refer to it) or if we're doing build-in-place (so we can - -- set its address to the final resting place or if there is no expression - -- (in which case default initial values might need to be set). - - procedure Expand_N_Extended_Return_Statement (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - - Return_Object_Entity : constant Entity_Id := - First_Entity (Return_Statement_Entity (N)); - Return_Object_Decl : constant Node_Id := - Parent (Return_Object_Entity); - Parent_Function : constant Entity_Id := - Return_Applies_To (Return_Statement_Entity (N)); - Parent_Function_Typ : constant Entity_Id := Etype (Parent_Function); - Is_Build_In_Place : constant Boolean := - Is_Build_In_Place_Function (Parent_Function); - - Return_Stm : Node_Id; - Statements : List_Id; - Handled_Stm_Seq : Node_Id; - Result : Node_Id; - Exp : Node_Id; - - function Has_Controlled_Parts (Typ : Entity_Id) return Boolean; - -- Determine whether type Typ is controlled or contains a controlled - -- subcomponent. - - function Move_Activation_Chain return Node_Id; - -- Construct a call to System.Tasking.Stages.Move_Activation_Chain - -- with parameters: - -- From current activation chain - -- To activation chain passed in by the caller - -- New_Master master passed in by the caller - - function Move_Final_List return Node_Id; - -- Construct call to System.Finalization_Implementation.Move_Final_List - -- with parameters: - -- - -- From finalization list of the return statement - -- To finalization list passed in by the caller - - -------------------------- - -- Has_Controlled_Parts -- - -------------------------- - - function Has_Controlled_Parts (Typ : Entity_Id) return Boolean is - begin - return - Is_Controlled (Typ) - or else Has_Controlled_Component (Typ); - end Has_Controlled_Parts; - - --------------------------- - -- Move_Activation_Chain -- - --------------------------- - - function Move_Activation_Chain return Node_Id is - Activation_Chain_Formal : constant Entity_Id := - Build_In_Place_Formal - (Parent_Function, BIP_Activation_Chain); - To : constant Node_Id := - New_Reference_To - (Activation_Chain_Formal, Loc); - Master_Formal : constant Entity_Id := - Build_In_Place_Formal - (Parent_Function, BIP_Master); - New_Master : constant Node_Id := - New_Reference_To (Master_Formal, Loc); - - Chain_Entity : Entity_Id; - From : Node_Id; - - begin - Chain_Entity := First_Entity (Return_Statement_Entity (N)); - while Chars (Chain_Entity) /= Name_uChain loop - Chain_Entity := Next_Entity (Chain_Entity); - end loop; - - From := - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Chain_Entity, Loc), - Attribute_Name => Name_Unrestricted_Access); - -- ??? Not clear why "Make_Identifier (Loc, Name_uChain)" doesn't - -- work, instead of "New_Reference_To (Chain_Entity, Loc)" above. - - return - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Move_Activation_Chain), Loc), - Parameter_Associations => New_List (From, To, New_Master)); - end Move_Activation_Chain; - - --------------------- - -- Move_Final_List -- - --------------------- - - function Move_Final_List return Node_Id is - Flist : constant Entity_Id := - Finalization_Chain_Entity (Return_Statement_Entity (N)); - - From : constant Node_Id := New_Reference_To (Flist, Loc); - - Caller_Final_List : constant Entity_Id := - Build_In_Place_Formal - (Parent_Function, BIP_Final_List); - - To : constant Node_Id := New_Reference_To (Caller_Final_List, Loc); - - begin - -- Catch cases where a finalization chain entity has not been - -- associated with the return statement entity. - - pragma Assert (Present (Flist)); - - -- Build required call - - return - Make_If_Statement (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => New_Copy (From), - Right_Opnd => New_Node (N_Null, Loc)), - Then_Statements => - New_List ( - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Move_Final_List), Loc), - Parameter_Associations => New_List (From, To)))); - end Move_Final_List; - - -- Start of processing for Expand_N_Extended_Return_Statement - - begin - if Nkind (Return_Object_Decl) = N_Object_Declaration then - Exp := Expression (Return_Object_Decl); - else - Exp := Empty; - end if; - - Handled_Stm_Seq := Handled_Statement_Sequence (N); - - -- Build a simple_return_statement that returns the return object when - -- there is a statement sequence, or no expression, or the result will - -- be built in place. Note however that we currently do this for all - -- composite cases, even though nonlimited composite results are not yet - -- built in place (though we plan to do so eventually). - - if Present (Handled_Stm_Seq) - or else Is_Composite_Type (Etype (Parent_Function)) - or else No (Exp) - then - if No (Handled_Stm_Seq) then - Statements := New_List; - - -- If the extended return has a handled statement sequence, then wrap - -- it in a block and use the block as the first statement. - - else - Statements := - New_List (Make_Block_Statement (Loc, - Declarations => New_List, - Handled_Statement_Sequence => Handled_Stm_Seq)); - end if; - - -- If control gets past the above Statements, we have successfully - -- completed the return statement. If the result type has controlled - -- parts and the return is for a build-in-place function, then we - -- call Move_Final_List to transfer responsibility for finalization - -- of the return object to the caller. An alternative would be to - -- declare a Success flag in the function, initialize it to False, - -- and set it to True here. Then move the Move_Final_List call into - -- the cleanup code, and check Success. If Success then make a call - -- to Move_Final_List else do finalization. Then we can remove the - -- abort-deferral and the nulling-out of the From parameter from - -- Move_Final_List. Note that the current method is not quite correct - -- in the rather obscure case of a select-then-abort statement whose - -- abortable part contains the return statement. - - -- Check the type of the function to determine whether to move the - -- finalization list. A special case arises when processing a simple - -- return statement which has been rewritten as an extended return. - -- In that case check the type of the returned object or the original - -- expression. - - if Is_Build_In_Place - and then - (Has_Controlled_Parts (Parent_Function_Typ) - or else (Is_Class_Wide_Type (Parent_Function_Typ) - and then - Has_Controlled_Parts (Root_Type (Parent_Function_Typ))) - or else Has_Controlled_Parts (Etype (Return_Object_Entity)) - or else (Present (Exp) - and then Has_Controlled_Parts (Etype (Exp)))) - then - Append_To (Statements, Move_Final_List); - end if; - - -- Similarly to the above Move_Final_List, if the result type - -- contains tasks, we call Move_Activation_Chain. Later, the cleanup - -- code will call Complete_Master, which will terminate any - -- unactivated tasks belonging to the return statement master. But - -- Move_Activation_Chain updates their master to be that of the - -- caller, so they will not be terminated unless the return statement - -- completes unsuccessfully due to exception, abort, goto, or exit. - -- As a formality, we test whether the function requires the result - -- to be built in place, though that's necessarily true for the case - -- of result types with task parts. - - if Is_Build_In_Place and Has_Task (Etype (Parent_Function)) then - Append_To (Statements, Move_Activation_Chain); - end if; - - -- Build a simple_return_statement that returns the return object - - Return_Stm := - Make_Simple_Return_Statement (Loc, - Expression => New_Occurrence_Of (Return_Object_Entity, Loc)); - Append_To (Statements, Return_Stm); - - Handled_Stm_Seq := - Make_Handled_Sequence_Of_Statements (Loc, Statements); - end if; - - -- Case where we build a block - - if Present (Handled_Stm_Seq) then - Result := - Make_Block_Statement (Loc, - Declarations => Return_Object_Declarations (N), - Handled_Statement_Sequence => Handled_Stm_Seq); - - -- We set the entity of the new block statement to be that of the - -- return statement. This is necessary so that various fields, such - -- as Finalization_Chain_Entity carry over from the return statement - -- to the block. Note that this block is unusual, in that its entity - -- is an E_Return_Statement rather than an E_Block. - - Set_Identifier - (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc)); - - -- If the object decl was already rewritten as a renaming, then - -- we don't want to do the object allocation and transformation of - -- of the return object declaration to a renaming. This case occurs - -- when the return object is initialized by a call to another - -- build-in-place function, and that function is responsible for the - -- allocation of the return object. - - if Is_Build_In_Place - and then - Nkind (Return_Object_Decl) = N_Object_Renaming_Declaration - then - pragma Assert (Nkind (Original_Node (Return_Object_Decl)) = - N_Object_Declaration - and then Is_Build_In_Place_Function_Call - (Expression (Original_Node (Return_Object_Decl)))); - - Set_By_Ref (Return_Stm); -- Return build-in-place results by ref - - elsif Is_Build_In_Place then - - -- Locate the implicit access parameter associated with the - -- caller-supplied return object and convert the return - -- statement's return object declaration to a renaming of a - -- dereference of the access parameter. If the return object's - -- declaration includes an expression that has not already been - -- expanded as separate assignments, then add an assignment - -- statement to ensure the return object gets initialized. - - -- declare - -- Result : T [:= <expression>]; - -- begin - -- ... - - -- is converted to - - -- declare - -- Result : T renames FuncRA.all; - -- [Result := <expression;] - -- begin - -- ... - - declare - Return_Obj_Id : constant Entity_Id := - Defining_Identifier (Return_Object_Decl); - Return_Obj_Typ : constant Entity_Id := Etype (Return_Obj_Id); - Return_Obj_Expr : constant Node_Id := - Expression (Return_Object_Decl); - Result_Subt : constant Entity_Id := - Etype (Parent_Function); - Constr_Result : constant Boolean := - Is_Constrained (Result_Subt); - Obj_Alloc_Formal : Entity_Id; - Object_Access : Entity_Id; - Obj_Acc_Deref : Node_Id; - Init_Assignment : Node_Id := Empty; - - begin - -- Build-in-place results must be returned by reference - - Set_By_Ref (Return_Stm); - - -- Retrieve the implicit access parameter passed by the caller - - Object_Access := - Build_In_Place_Formal (Parent_Function, BIP_Object_Access); - - -- If the return object's declaration includes an expression - -- and the declaration isn't marked as No_Initialization, then - -- we need to generate an assignment to the object and insert - -- it after the declaration before rewriting it as a renaming - -- (otherwise we'll lose the initialization). The case where - -- the result type is an interface (or class-wide interface) - -- is also excluded because the context of the function call - -- must be unconstrained, so the initialization will always - -- be done as part of an allocator evaluation (storage pool - -- or secondary stack), never to a constrained target object - -- passed in by the caller. Besides the assignment being - -- unneeded in this case, it avoids problems with trying to - -- generate a dispatching assignment when the return expression - -- is a nonlimited descendant of a limited interface (the - -- interface has no assignment operation). - - if Present (Return_Obj_Expr) - and then not No_Initialization (Return_Object_Decl) - and then not Is_Interface (Return_Obj_Typ) - then - Init_Assignment := - Make_Assignment_Statement (Loc, - Name => New_Reference_To (Return_Obj_Id, Loc), - Expression => Relocate_Node (Return_Obj_Expr)); - Set_Etype (Name (Init_Assignment), Etype (Return_Obj_Id)); - Set_Assignment_OK (Name (Init_Assignment)); - Set_No_Ctrl_Actions (Init_Assignment); - - Set_Parent (Name (Init_Assignment), Init_Assignment); - Set_Parent (Expression (Init_Assignment), Init_Assignment); - - Set_Expression (Return_Object_Decl, Empty); - - if Is_Class_Wide_Type (Etype (Return_Obj_Id)) - and then not Is_Class_Wide_Type - (Etype (Expression (Init_Assignment))) - then - Rewrite (Expression (Init_Assignment), - Make_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of - (Etype (Return_Obj_Id), Loc), - Expression => - Relocate_Node (Expression (Init_Assignment)))); - end if; - - -- In the case of functions where the calling context can - -- determine the form of allocation needed, initialization - -- is done with each part of the if statement that handles - -- the different forms of allocation (this is true for - -- unconstrained and tagged result subtypes). - - if Constr_Result - and then not Is_Tagged_Type (Underlying_Type (Result_Subt)) - then - Insert_After (Return_Object_Decl, Init_Assignment); - end if; - end if; - - -- When the function's subtype is unconstrained, a run-time - -- test is needed to determine the form of allocation to use - -- for the return object. The function has an implicit formal - -- parameter indicating this. If the BIP_Alloc_Form formal has - -- the value one, then the caller has passed access to an - -- existing object for use as the return object. If the value - -- is two, then the return object must be allocated on the - -- secondary stack. Otherwise, the object must be allocated in - -- a storage pool (currently only supported for the global - -- heap, user-defined storage pools TBD ???). We generate an - -- if statement to test the implicit allocation formal and - -- initialize a local access value appropriately, creating - -- allocators in the secondary stack and global heap cases. - -- The special formal also exists and must be tested when the - -- function has a tagged result, even when the result subtype - -- is constrained, because in general such functions can be - -- called in dispatching contexts and must be handled similarly - -- to functions with a class-wide result. - - if not Constr_Result - or else Is_Tagged_Type (Underlying_Type (Result_Subt)) - then - Obj_Alloc_Formal := - Build_In_Place_Formal (Parent_Function, BIP_Alloc_Form); - - declare - Ref_Type : Entity_Id; - Ptr_Type_Decl : Node_Id; - Alloc_Obj_Id : Entity_Id; - Alloc_Obj_Decl : Node_Id; - Alloc_If_Stmt : Node_Id; - SS_Allocator : Node_Id; - Heap_Allocator : Node_Id; - - begin - -- Reuse the itype created for the function's implicit - -- access formal. This avoids the need to create a new - -- access type here, plus it allows assigning the access - -- formal directly without applying a conversion. - - -- Ref_Type := Etype (Object_Access); - - -- Create an access type designating the function's - -- result subtype. - - Ref_Type := Make_Temporary (Loc, 'A'); - - Ptr_Type_Decl := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Ref_Type, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => True, - Subtype_Indication => - New_Reference_To (Return_Obj_Typ, Loc))); - - Insert_Before (Return_Object_Decl, Ptr_Type_Decl); - - -- Create an access object that will be initialized to an - -- access value denoting the return object, either coming - -- from an implicit access value passed in by the caller - -- or from the result of an allocator. - - Alloc_Obj_Id := Make_Temporary (Loc, 'R'); - Set_Etype (Alloc_Obj_Id, Ref_Type); - - Alloc_Obj_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Alloc_Obj_Id, - Object_Definition => New_Reference_To - (Ref_Type, Loc)); - - Insert_Before (Return_Object_Decl, Alloc_Obj_Decl); - - -- Create allocators for both the secondary stack and - -- global heap. If there's an initialization expression, - -- then create these as initialized allocators. - - if Present (Return_Obj_Expr) - and then not No_Initialization (Return_Object_Decl) - then - -- Always use the type of the expression for the - -- qualified expression, rather than the result type. - -- In general we cannot always use the result type - -- for the allocator, because the expression might be - -- of a specific type, such as in the case of an - -- aggregate or even a nonlimited object when the - -- result type is a limited class-wide interface type. - - Heap_Allocator := - Make_Allocator (Loc, - Expression => - Make_Qualified_Expression (Loc, - Subtype_Mark => - New_Reference_To - (Etype (Return_Obj_Expr), Loc), - Expression => - New_Copy_Tree (Return_Obj_Expr))); - - else - -- If the function returns a class-wide type we cannot - -- use the return type for the allocator. Instead we - -- use the type of the expression, which must be an - -- aggregate of a definite type. - - if Is_Class_Wide_Type (Return_Obj_Typ) then - Heap_Allocator := - Make_Allocator (Loc, - Expression => - New_Reference_To - (Etype (Return_Obj_Expr), Loc)); - else - Heap_Allocator := - Make_Allocator (Loc, - Expression => - New_Reference_To (Return_Obj_Typ, Loc)); - end if; - - -- If the object requires default initialization then - -- that will happen later following the elaboration of - -- the object renaming. If we don't turn it off here - -- then the object will be default initialized twice. - - Set_No_Initialization (Heap_Allocator); - end if; - - -- If the No_Allocators restriction is active, then only - -- an allocator for secondary stack allocation is needed. - -- It's OK for such allocators to have Comes_From_Source - -- set to False, because gigi knows not to flag them as - -- being a violation of No_Implicit_Heap_Allocations. - - if Restriction_Active (No_Allocators) then - SS_Allocator := Heap_Allocator; - Heap_Allocator := Make_Null (Loc); - - -- Otherwise the heap allocator may be needed, so we make - -- another allocator for secondary stack allocation. - - else - SS_Allocator := New_Copy_Tree (Heap_Allocator); - - -- The heap allocator is marked Comes_From_Source - -- since it corresponds to an explicit user-written - -- allocator (that is, it will only be executed on - -- behalf of callers that call the function as - -- initialization for such an allocator). This - -- prevents errors when No_Implicit_Heap_Allocations - -- is in force. - - Set_Comes_From_Source (Heap_Allocator, True); - end if; - - -- The allocator is returned on the secondary stack. We - -- don't do this on VM targets, since the SS is not used. - - if VM_Target = No_VM then - Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool)); - Set_Procedure_To_Call - (SS_Allocator, RTE (RE_SS_Allocate)); - - -- The allocator is returned on the secondary stack, - -- so indicate that the function return, as well as - -- the block that encloses the allocator, must not - -- release it. The flags must be set now because the - -- decision to use the secondary stack is done very - -- late in the course of expanding the return - -- statement, past the point where these flags are - -- normally set. - - Set_Sec_Stack_Needed_For_Return (Parent_Function); - Set_Sec_Stack_Needed_For_Return - (Return_Statement_Entity (N)); - Set_Uses_Sec_Stack (Parent_Function); - Set_Uses_Sec_Stack (Return_Statement_Entity (N)); - end if; - - -- Create an if statement to test the BIP_Alloc_Form - -- formal and initialize the access object to either the - -- BIP_Object_Access formal (BIP_Alloc_Form = 0), the - -- result of allocating the object in the secondary stack - -- (BIP_Alloc_Form = 1), or else an allocator to create - -- the return object in the heap (BIP_Alloc_Form = 2). - - -- ??? An unchecked type conversion must be made in the - -- case of assigning the access object formal to the - -- local access object, because a normal conversion would - -- be illegal in some cases (such as converting access- - -- to-unconstrained to access-to-constrained), but the - -- the unchecked conversion will presumably fail to work - -- right in just such cases. It's not clear at all how to - -- handle this. ??? - - Alloc_If_Stmt := - Make_If_Statement (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To (Obj_Alloc_Formal, Loc), - Right_Opnd => - Make_Integer_Literal (Loc, - UI_From_Int (BIP_Allocation_Form'Pos - (Caller_Allocation)))), - Then_Statements => - New_List (Make_Assignment_Statement (Loc, - Name => - New_Reference_To - (Alloc_Obj_Id, Loc), - Expression => - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => - New_Reference_To (Ref_Type, Loc), - Expression => - New_Reference_To - (Object_Access, Loc)))), - Elsif_Parts => - New_List (Make_Elsif_Part (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To - (Obj_Alloc_Formal, Loc), - Right_Opnd => - Make_Integer_Literal (Loc, - UI_From_Int ( - BIP_Allocation_Form'Pos - (Secondary_Stack)))), - Then_Statements => - New_List - (Make_Assignment_Statement (Loc, - Name => - New_Reference_To - (Alloc_Obj_Id, Loc), - Expression => - SS_Allocator)))), - Else_Statements => - New_List (Make_Assignment_Statement (Loc, - Name => - New_Reference_To - (Alloc_Obj_Id, Loc), - Expression => - Heap_Allocator))); - - -- If a separate initialization assignment was created - -- earlier, append that following the assignment of the - -- implicit access formal to the access object, to ensure - -- that the return object is initialized in that case. - -- In this situation, the target of the assignment must - -- be rewritten to denote a dereference of the access to - -- the return object passed in by the caller. - - if Present (Init_Assignment) then - Rewrite (Name (Init_Assignment), - Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Alloc_Obj_Id, Loc))); - Set_Etype - (Name (Init_Assignment), Etype (Return_Obj_Id)); - - Append_To - (Then_Statements (Alloc_If_Stmt), - Init_Assignment); - end if; - - Insert_Before (Return_Object_Decl, Alloc_If_Stmt); - - -- Remember the local access object for use in the - -- dereference of the renaming created below. - - Object_Access := Alloc_Obj_Id; - end; - end if; - - -- Replace the return object declaration with a renaming of a - -- dereference of the access value designating the return - -- object. - - Obj_Acc_Deref := - Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Object_Access, Loc)); - - Rewrite (Return_Object_Decl, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Return_Obj_Id, - Access_Definition => Empty, - Subtype_Mark => New_Occurrence_Of - (Return_Obj_Typ, Loc), - Name => Obj_Acc_Deref)); - - Set_Renamed_Object (Return_Obj_Id, Obj_Acc_Deref); - end; - end if; - - -- Case where we do not build a block - - else - -- We're about to drop Return_Object_Declarations on the floor, so - -- we need to insert it, in case it got expanded into useful code. - -- Remove side effects from expression, which may be duplicated in - -- subsequent checks (see Expand_Simple_Function_Return). - - Insert_List_Before (N, Return_Object_Declarations (N)); - Remove_Side_Effects (Exp); - - -- Build simple_return_statement that returns the expression directly - - Return_Stm := Make_Simple_Return_Statement (Loc, Expression => Exp); - - Result := Return_Stm; - end if; - - -- Set the flag to prevent infinite recursion - - Set_Comes_From_Extended_Return_Statement (Return_Stm); - - Rewrite (N, Result); - Analyze (N); - end Expand_N_Extended_Return_Statement; - ----------------------------- -- Expand_N_Goto_Statement -- ----------------------------- @@ -3671,761 +2938,6 @@ package body Exp_Ch5 is end if; end Expand_N_Loop_Statement; - -------------------------------------- - -- Expand_N_Simple_Return_Statement -- - -------------------------------------- - - procedure Expand_N_Simple_Return_Statement (N : Node_Id) is - begin - -- Defend against previous errors (i.e. the return statement calls a - -- function that is not available in configurable runtime). - - if Present (Expression (N)) - and then Nkind (Expression (N)) = N_Empty - then - return; - end if; - - -- Distinguish the function and non-function cases: - - case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is - - when E_Function | - E_Generic_Function => - Expand_Simple_Function_Return (N); - - when E_Procedure | - E_Generic_Procedure | - E_Entry | - E_Entry_Family | - E_Return_Statement => - Expand_Non_Function_Return (N); - - when others => - raise Program_Error; - end case; - - exception - when RE_Not_Available => - return; - end Expand_N_Simple_Return_Statement; - - -------------------------------- - -- Expand_Non_Function_Return -- - -------------------------------- - - procedure Expand_Non_Function_Return (N : Node_Id) is - pragma Assert (No (Expression (N))); - - Loc : constant Source_Ptr := Sloc (N); - Scope_Id : Entity_Id := - Return_Applies_To (Return_Statement_Entity (N)); - Kind : constant Entity_Kind := Ekind (Scope_Id); - Call : Node_Id; - Acc_Stat : Node_Id; - Goto_Stat : Node_Id; - Lab_Node : Node_Id; - - begin - -- Call _Postconditions procedure if procedure with active - -- postconditions. Here, we use the Postcondition_Proc attribute, which - -- is needed for implicitly-generated returns. Functions never - -- have implicitly-generated returns, and there's no room for - -- Postcondition_Proc in E_Function, so we look up the identifier - -- Name_uPostconditions for function returns (see - -- Expand_Simple_Function_Return). - - if Ekind (Scope_Id) = E_Procedure - and then Has_Postconditions (Scope_Id) - then - pragma Assert (Present (Postcondition_Proc (Scope_Id))); - Insert_Action (N, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (Postcondition_Proc (Scope_Id), Loc))); - end if; - - -- If it is a return from a procedure do no extra steps - - if Kind = E_Procedure or else Kind = E_Generic_Procedure then - return; - - -- If it is a nested return within an extended one, replace it with a - -- return of the previously declared return object. - - elsif Kind = E_Return_Statement then - Rewrite (N, - Make_Simple_Return_Statement (Loc, - Expression => - New_Occurrence_Of (First_Entity (Scope_Id), Loc))); - Set_Comes_From_Extended_Return_Statement (N); - Set_Return_Statement_Entity (N, Scope_Id); - Expand_Simple_Function_Return (N); - return; - end if; - - pragma Assert (Is_Entry (Scope_Id)); - - -- Look at the enclosing block to see whether the return is from an - -- accept statement or an entry body. - - for J in reverse 0 .. Scope_Stack.Last loop - Scope_Id := Scope_Stack.Table (J).Entity; - exit when Is_Concurrent_Type (Scope_Id); - end loop; - - -- If it is a return from accept statement it is expanded as call to - -- RTS Complete_Rendezvous and a goto to the end of the accept body. - - -- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept, - -- Expand_N_Accept_Alternative in exp_ch9.adb) - - if Is_Task_Type (Scope_Id) then - - Call := - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Complete_Rendezvous), Loc)); - Insert_Before (N, Call); - -- why not insert actions here??? - Analyze (Call); - - Acc_Stat := Parent (N); - while Nkind (Acc_Stat) /= N_Accept_Statement loop - Acc_Stat := Parent (Acc_Stat); - end loop; - - Lab_Node := Last (Statements - (Handled_Statement_Sequence (Acc_Stat))); - - Goto_Stat := Make_Goto_Statement (Loc, - Name => New_Occurrence_Of - (Entity (Identifier (Lab_Node)), Loc)); - - Set_Analyzed (Goto_Stat); - - Rewrite (N, Goto_Stat); - Analyze (N); - - -- If it is a return from an entry body, put a Complete_Entry_Body call - -- in front of the return. - - elsif Is_Protected_Type (Scope_Id) then - Call := - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Complete_Entry_Body), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Reference_To - (Find_Protection_Object (Current_Scope), Loc), - Attribute_Name => - Name_Unchecked_Access))); - - Insert_Before (N, Call); - Analyze (Call); - end if; - end Expand_Non_Function_Return; - - ----------------------------------- - -- Expand_Simple_Function_Return -- - ----------------------------------- - - -- The "simple" comes from the syntax rule simple_return_statement. - -- The semantics are not at all simple! - - procedure Expand_Simple_Function_Return (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - - Scope_Id : constant Entity_Id := - Return_Applies_To (Return_Statement_Entity (N)); - -- The function we are returning from - - R_Type : constant Entity_Id := Etype (Scope_Id); - -- The result type of the function - - Utyp : constant Entity_Id := Underlying_Type (R_Type); - - Exp : constant Node_Id := Expression (N); - pragma Assert (Present (Exp)); - - Exptyp : constant Entity_Id := Etype (Exp); - -- The type of the expression (not necessarily the same as R_Type) - - Subtype_Ind : Node_Id; - -- If the result type of the function is class-wide and the - -- expression has a specific type, then we use the expression's - -- type as the type of the return object. In cases where the - -- expression is an aggregate that is built in place, this avoids - -- the need for an expensive conversion of the return object to - -- the specific type on assignments to the individual components. - - begin - if Is_Class_Wide_Type (R_Type) - and then not Is_Class_Wide_Type (Etype (Exp)) - then - Subtype_Ind := New_Occurrence_Of (Etype (Exp), Loc); - else - Subtype_Ind := New_Occurrence_Of (R_Type, Loc); - end if; - - -- For the case of a simple return that does not come from an extended - -- return, in the case of Ada 2005 where we are returning a limited - -- type, we rewrite "return <expression>;" to be: - - -- return _anon_ : <return_subtype> := <expression> - - -- The expansion produced by Expand_N_Extended_Return_Statement will - -- contain simple return statements (for example, a block containing - -- simple return of the return object), which brings us back here with - -- Comes_From_Extended_Return_Statement set. The reason for the barrier - -- checking for a simple return that does not come from an extended - -- return is to avoid this infinite recursion. - - -- The reason for this design is that for Ada 2005 limited returns, we - -- need to reify the return object, so we can build it "in place", and - -- we need a block statement to hang finalization and tasking stuff. - - -- ??? In order to avoid disruption, we avoid translating to extended - -- return except in the cases where we really need to (Ada 2005 for - -- inherently limited). We might prefer to do this translation in all - -- cases (except perhaps for the case of Ada 95 inherently limited), - -- in order to fully exercise the Expand_N_Extended_Return_Statement - -- code. This would also allow us to do the build-in-place optimization - -- for efficiency even in cases where it is semantically not required. - - -- As before, we check the type of the return expression rather than the - -- return type of the function, because the latter may be a limited - -- class-wide interface type, which is not a limited type, even though - -- the type of the expression may be. - - if not Comes_From_Extended_Return_Statement (N) - and then Is_Immutably_Limited_Type (Etype (Expression (N))) - and then Ada_Version >= Ada_05 - and then not Debug_Flag_Dot_L - then - declare - Return_Object_Entity : constant Entity_Id := - Make_Temporary (Loc, 'R', Exp); - Obj_Decl : constant Node_Id := - Make_Object_Declaration (Loc, - Defining_Identifier => Return_Object_Entity, - Object_Definition => Subtype_Ind, - Expression => Exp); - - Ext : constant Node_Id := Make_Extended_Return_Statement (Loc, - Return_Object_Declarations => New_List (Obj_Decl)); - -- Do not perform this high-level optimization if the result type - -- is an interface because the "this" pointer must be displaced. - - begin - Rewrite (N, Ext); - Analyze (N); - return; - end; - end if; - - -- Here we have a simple return statement that is part of the expansion - -- of an extended return statement (either written by the user, or - -- generated by the above code). - - -- Always normalize C/Fortran boolean result. This is not always needed, - -- but it seems a good idea to minimize the passing around of non- - -- normalized values, and in any case this handles the processing of - -- barrier functions for protected types, which turn the condition into - -- a return statement. - - if Is_Boolean_Type (Exptyp) - and then Nonzero_Is_True (Exptyp) - then - Adjust_Condition (Exp); - Adjust_Result_Type (Exp, Exptyp); - end if; - - -- Do validity check if enabled for returns - - if Validity_Checks_On - and then Validity_Check_Returns - then - Ensure_Valid (Exp); - end if; - - -- Check the result expression of a scalar function against the subtype - -- of the function by inserting a conversion. This conversion must - -- eventually be performed for other classes of types, but for now it's - -- only done for scalars. - -- ??? - - if Is_Scalar_Type (Exptyp) then - Rewrite (Exp, Convert_To (R_Type, Exp)); - - -- The expression is resolved to ensure that the conversion gets - -- expanded to generate a possible constraint check. - - Analyze_And_Resolve (Exp, R_Type); - end if; - - -- Deal with returning variable length objects and controlled types - - -- Nothing to do if we are returning by reference, or this is not a - -- type that requires special processing (indicated by the fact that - -- it requires a cleanup scope for the secondary stack case). - - if Is_Immutably_Limited_Type (Exptyp) - or else Is_Limited_Interface (Exptyp) - then - null; - - elsif not Requires_Transient_Scope (R_Type) then - - -- Mutable records with no variable length components are not - -- returned on the sec-stack, so we need to make sure that the - -- backend will only copy back the size of the actual value, and not - -- the maximum size. We create an actual subtype for this purpose. - - declare - Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exptyp)); - Decl : Node_Id; - Ent : Entity_Id; - begin - if Has_Discriminants (Ubt) - and then not Is_Constrained (Ubt) - and then not Has_Unchecked_Union (Ubt) - then - Decl := Build_Actual_Subtype (Ubt, Exp); - Ent := Defining_Identifier (Decl); - Insert_Action (Exp, Decl); - Rewrite (Exp, Unchecked_Convert_To (Ent, Exp)); - Analyze_And_Resolve (Exp); - end if; - end; - - -- Here if secondary stack is used - - else - -- Make sure that no surrounding block will reclaim the secondary - -- stack on which we are going to put the result. Not only may this - -- introduce secondary stack leaks but worse, if the reclamation is - -- done too early, then the result we are returning may get - -- clobbered. - - declare - S : Entity_Id; - begin - S := Current_Scope; - while Ekind (S) = E_Block or else Ekind (S) = E_Loop loop - Set_Sec_Stack_Needed_For_Return (S, True); - S := Enclosing_Dynamic_Scope (S); - end loop; - end; - - -- Optimize the case where the result is a function call. In this - -- case either the result is already on the secondary stack, or is - -- already being returned with the stack pointer depressed and no - -- further processing is required except to set the By_Ref flag to - -- ensure that gigi does not attempt an extra unnecessary copy. - -- (actually not just unnecessary but harmfully wrong in the case - -- of a controlled type, where gigi does not know how to do a copy). - -- To make up for a gcc 2.8.1 deficiency (???), we perform - -- the copy for array types if the constrained status of the - -- target type is different from that of the expression. - - if Requires_Transient_Scope (Exptyp) - and then - (not Is_Array_Type (Exptyp) - or else Is_Constrained (Exptyp) = Is_Constrained (R_Type) - or else CW_Or_Has_Controlled_Part (Utyp)) - and then Nkind (Exp) = N_Function_Call - then - Set_By_Ref (N); - - -- Remove side effects from the expression now so that other parts - -- of the expander do not have to reanalyze this node without this - -- optimization - - Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp)); - - -- For controlled types, do the allocation on the secondary stack - -- manually in order to call adjust at the right time: - - -- type Anon1 is access R_Type; - -- for Anon1'Storage_pool use ss_pool; - -- Anon2 : anon1 := new R_Type'(expr); - -- return Anon2.all; - - -- We do the same for classwide types that are not potentially - -- controlled (by the virtue of restriction No_Finalization) because - -- gigi is not able to properly allocate class-wide types. - - elsif CW_Or_Has_Controlled_Part (Utyp) then - declare - Loc : constant Source_Ptr := Sloc (N); - Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); - Alloc_Node : Node_Id; - Temp : Entity_Id; - - begin - Set_Ekind (Acc_Typ, E_Access_Type); - - Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); - - -- This is an allocator for the secondary stack, and it's fine - -- to have Comes_From_Source set False on it, as gigi knows not - -- to flag it as a violation of No_Implicit_Heap_Allocations. - - Alloc_Node := - Make_Allocator (Loc, - Expression => - Make_Qualified_Expression (Loc, - Subtype_Mark => New_Reference_To (Etype (Exp), Loc), - Expression => Relocate_Node (Exp))); - - -- We do not want discriminant checks on the declaration, - -- given that it gets its value from the allocator. - - Set_No_Initialization (Alloc_Node); - - Temp := Make_Temporary (Loc, 'R', Alloc_Node); - - Insert_List_Before_And_Analyze (N, New_List ( - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Acc_Typ, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => Subtype_Ind)), - - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => New_Reference_To (Acc_Typ, Loc), - Expression => Alloc_Node))); - - Rewrite (Exp, - Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Temp, Loc))); - - Analyze_And_Resolve (Exp, R_Type); - end; - - -- Otherwise use the gigi mechanism to allocate result on the - -- secondary stack. - - else - Check_Restriction (No_Secondary_Stack, N); - Set_Storage_Pool (N, RTE (RE_SS_Pool)); - - -- If we are generating code for the VM do not use - -- SS_Allocate since everything is heap-allocated anyway. - - if VM_Target = No_VM then - Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); - end if; - end if; - end if; - - -- Implement the rules of 6.5(8-10), which require a tag check in the - -- case of a limited tagged return type, and tag reassignment for - -- nonlimited tagged results. These actions are needed when the return - -- type is a specific tagged type and the result expression is a - -- conversion or a formal parameter, because in that case the tag of the - -- expression might differ from the tag of the specific result type. - - if Is_Tagged_Type (Utyp) - and then not Is_Class_Wide_Type (Utyp) - and then (Nkind_In (Exp, N_Type_Conversion, - N_Unchecked_Type_Conversion) - or else (Is_Entity_Name (Exp) - and then Ekind (Entity (Exp)) in Formal_Kind)) - then - -- When the return type is limited, perform a check that the - -- tag of the result is the same as the tag of the return type. - - if Is_Limited_Type (R_Type) then - Insert_Action (Exp, - Make_Raise_Constraint_Error (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => Duplicate_Subexpr (Exp), - Selector_Name => - Make_Identifier (Loc, Chars => Name_uTag)), - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Base_Type (Utyp), Loc), - Attribute_Name => Name_Tag)), - Reason => CE_Tag_Check_Failed)); - - -- If the result type is a specific nonlimited tagged type, then we - -- have to ensure that the tag of the result is that of the result - -- type. This is handled by making a copy of the expression in the - -- case where it might have a different tag, namely when the - -- expression is a conversion or a formal parameter. We create a new - -- object of the result type and initialize it from the expression, - -- which will implicitly force the tag to be set appropriately. - - else - declare - ExpR : constant Node_Id := Relocate_Node (Exp); - Result_Id : constant Entity_Id := - Make_Temporary (Loc, 'R', ExpR); - Result_Exp : constant Node_Id := - New_Reference_To (Result_Id, Loc); - Result_Obj : constant Node_Id := - Make_Object_Declaration (Loc, - Defining_Identifier => Result_Id, - Object_Definition => - New_Reference_To (R_Type, Loc), - Constant_Present => True, - Expression => ExpR); - - begin - Set_Assignment_OK (Result_Obj); - Insert_Action (Exp, Result_Obj); - - Rewrite (Exp, Result_Exp); - Analyze_And_Resolve (Exp, R_Type); - end; - end if; - - -- Ada 2005 (AI-344): If the result type is class-wide, then insert - -- a check that the level of the return expression's underlying type - -- is not deeper than the level of the master enclosing the function. - -- Always generate the check when the type of the return expression - -- is class-wide, when it's a type conversion, or when it's a formal - -- parameter. Otherwise, suppress the check in the case where the - -- return expression has a specific type whose level is known not to - -- be statically deeper than the function's result type. - - -- Note: accessibility check is skipped in the VM case, since there - -- does not seem to be any practical way to implement this check. - - elsif Ada_Version >= Ada_05 - and then Tagged_Type_Expansion - and then Is_Class_Wide_Type (R_Type) - and then not Scope_Suppress (Accessibility_Check) - and then - (Is_Class_Wide_Type (Etype (Exp)) - or else Nkind_In (Exp, N_Type_Conversion, - N_Unchecked_Type_Conversion) - or else (Is_Entity_Name (Exp) - and then Ekind (Entity (Exp)) in Formal_Kind) - or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) > - Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id))) - then - declare - Tag_Node : Node_Id; - - begin - -- Ada 2005 (AI-251): In class-wide interface objects we displace - -- "this" to reference the base of the object --- required to get - -- access to the TSD of the object. - - if Is_Class_Wide_Type (Etype (Exp)) - and then Is_Interface (Etype (Exp)) - and then Nkind (Exp) = N_Explicit_Dereference - then - Tag_Node := - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RTE (RE_Tag_Ptr), - Make_Function_Call (Loc, - Name => New_Reference_To (RTE (RE_Base_Address), Loc), - Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Address), - Duplicate_Subexpr (Prefix (Exp))))))); - else - Tag_Node := - Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr (Exp), - Attribute_Name => Name_Tag); - end if; - - Insert_Action (Exp, - Make_Raise_Program_Error (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => - Build_Get_Access_Level (Loc, Tag_Node), - Right_Opnd => - Make_Integer_Literal (Loc, - Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), - Reason => PE_Accessibility_Check_Failed)); - end; - - -- AI05-0073: If function has a controlling access result, check that - -- the tag of the return value, if it is not null, matches designated - -- type of return type. - - -- The "or else True" needs commenting here ??? - - elsif Ekind (R_Type) = E_Anonymous_Access_Type - and then Has_Controlling_Result (Scope_Id) - then - Insert_Action (N, - Make_Raise_Constraint_Error (Loc, - Condition => - Make_And_Then (Loc, - Left_Opnd => - Make_Op_Ne (Loc, - Left_Opnd => Exp, - Right_Opnd => Make_Null (Loc)), - Right_Opnd => Make_Op_Ne (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => Duplicate_Subexpr (Exp), - Selector_Name => - Make_Identifier (Loc, Chars => Name_uTag)), - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Designated_Type (R_Type), Loc), - Attribute_Name => Name_Tag))), - Reason => CE_Tag_Check_Failed), - Suppress => All_Checks); - end if; - - -- If we are returning an object that may not be bit-aligned, then copy - -- the value into a temporary first. This copy may need to expand to a - -- loop of component operations. - - if Is_Possibly_Unaligned_Slice (Exp) - or else Is_Possibly_Unaligned_Object (Exp) - then - declare - ExpR : constant Node_Id := Relocate_Node (Exp); - Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); - begin - Insert_Action (Exp, - Make_Object_Declaration (Loc, - Defining_Identifier => Tnn, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (R_Type, Loc), - Expression => ExpR), - Suppress => All_Checks); - Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); - end; - end if; - - -- Generate call to postcondition checks if they are present - - if Ekind (Scope_Id) = E_Function - and then Has_Postconditions (Scope_Id) - then - -- We are going to reference the returned value twice in this case, - -- once in the call to _Postconditions, and once in the actual return - -- statement, but we can't have side effects happening twice, and in - -- any case for efficiency we don't want to do the computation twice. - - -- If the returned expression is an entity name, we don't need to - -- worry since it is efficient and safe to reference it twice, that's - -- also true for literals other than string literals, and for the - -- case of X.all where X is an entity name. - - if Is_Entity_Name (Exp) - or else Nkind_In (Exp, N_Character_Literal, - N_Integer_Literal, - N_Real_Literal) - or else (Nkind (Exp) = N_Explicit_Dereference - and then Is_Entity_Name (Prefix (Exp))) - then - null; - - -- Otherwise we are going to need a temporary to capture the value - - else - declare - ExpR : constant Node_Id := Relocate_Node (Exp); - Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); - - begin - -- For a complex expression of an elementary type, capture - -- value in the temporary and use it as the reference. - - if Is_Elementary_Type (R_Type) then - Insert_Action (Exp, - Make_Object_Declaration (Loc, - Defining_Identifier => Tnn, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (R_Type, Loc), - Expression => ExpR), - Suppress => All_Checks); - - Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); - - -- If we have something we can rename, generate a renaming of - -- the object and replace the expression with a reference - - elsif Is_Object_Reference (Exp) then - Insert_Action (Exp, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Tnn, - Subtype_Mark => New_Occurrence_Of (R_Type, Loc), - Name => ExpR), - Suppress => All_Checks); - - Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); - - -- Otherwise we have something like a string literal or an - -- aggregate. We could copy the value, but that would be - -- inefficient. Instead we make a reference to the value and - -- capture this reference with a renaming, the expression is - -- then replaced by a dereference of this renaming. - - else - -- For now, copy the value, since the code below does not - -- seem to work correctly ??? - - Insert_Action (Exp, - Make_Object_Declaration (Loc, - Defining_Identifier => Tnn, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (R_Type, Loc), - Expression => Relocate_Node (Exp)), - Suppress => All_Checks); - - Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); - - -- Insert_Action (Exp, - -- Make_Object_Renaming_Declaration (Loc, - -- Defining_Identifier => Tnn, - -- Access_Definition => - -- Make_Access_Definition (Loc, - -- All_Present => True, - -- Subtype_Mark => New_Occurrence_Of (R_Type, Loc)), - -- Name => - -- Make_Reference (Loc, - -- Prefix => Relocate_Node (Exp))), - -- Suppress => All_Checks); - - -- Rewrite (Exp, - -- Make_Explicit_Dereference (Loc, - -- Prefix => New_Occurrence_Of (Tnn, Loc))); - end if; - end; - end if; - - -- Generate call to _postconditions - - Insert_Action (Exp, - Make_Procedure_Call_Statement (Loc, - Name => Make_Identifier (Loc, Name_uPostconditions), - Parameter_Associations => New_List (Duplicate_Subexpr (Exp)))); - end if; - - -- Ada 2005 (AI-251): If this return statement corresponds with an - -- simple return statement associated with an extended return statement - -- and the type of the returned object is an interface then generate an - -- implicit conversion to force displacement of the "this" pointer. - - if Ada_Version >= Ada_05 - and then Comes_From_Extended_Return_Statement (N) - and then Nkind (Expression (N)) = N_Identifier - and then Is_Interface (Utyp) - and then Utyp /= Underlying_Type (Exptyp) - then - Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp))); - Analyze_And_Resolve (Exp); - end if; - end Expand_Simple_Function_Return; - ------------------------------ -- Make_Tag_Ctrl_Assignment -- ------------------------------ |