diff options
Diffstat (limited to 'gcc/ada/exp_ch6.adb')
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 70 |
1 files changed, 24 insertions, 46 deletions
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index d48b8f2..d209ab0 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6250,9 +6250,9 @@ package body Exp_Ch6 is procedure Prepend_Constructor_Procedure_Prologue (Spec_Id : Entity_Id; Body_Id : Entity_Id; L : List_Id); -- If N is the body of a constructor procedure (that is, a procedure - -- named in a Constructor aspect specification for the type of the - -- procedure's first parameter), then prepend and analyze the - -- associated initialization code for that parameter. + -- named T'Constructor where T is the type of the procedure's first + -- parameter), then prepend and analyze the associated initialization + -- code for that parameter. -- This has nothing to do with CPP constructors. ---------------- @@ -6339,16 +6339,10 @@ package body Exp_Ch6 is function First_Param_Type return Entity_Id is (Implementation_Base_Type (Etype (First_Formal (Spec_Id)))); - Is_Constructor_Procedure : constant Boolean := - Nkind (Specification (N)) = N_Procedure_Specification - and then Present (First_Formal (Spec_Id)) - and then Present (Constructor_Name (First_Param_Type)) - and then Chars (Spec_Id) = Chars (Constructor_Name - (First_Param_Type)) - and then Ekind (First_Formal (Spec_Id)) = E_In_Out_Parameter - and then Scope (Spec_Id) = Scope (First_Param_Type); begin - if not Is_Constructor_Procedure then + if not (Nkind (Specification (N)) = N_Procedure_Specification + and then Is_Constructor_Procedure (Spec_Id)) + then return; -- the usual case end if; @@ -6539,7 +6533,8 @@ package body Exp_Ch6 is Attribute_Name => Name_Super), Selector_Name => Make_Identifier (Loc, - Chars (Constructor_Name (Parent_Type)))); + Direct_Attribute_Definition_Name + (Parent_Type, Name_Constructor))); begin Set_Is_Prefixed_Call (Proc_Name); @@ -9096,27 +9091,6 @@ package body Exp_Ch6 is -- tagged, the called function itself must perform the allocation of -- the return object, so we pass parameters indicating that. - -- But that's also the case when the result subtype needs finalization - -- actions because the caller side allocation may result in undesirable - -- finalization. Consider the following example: - -- - -- function Make_Lim_Ctrl return Lim_Ctrl is - -- begin - -- return Result : Lim_Ctrl := raise Program_Error do - -- null; - -- end return; - -- end Make_Lim_Ctrl; - -- - -- Obj : Lim_Ctrl_Ptr := new Lim_Ctrl'(Make_Lim_Ctrl); - -- - -- Even though the size of limited controlled type Lim_Ctrl is known, - -- allocating Obj at the caller side will chain Obj on Lim_Ctrl_Ptr's - -- finalization collection. The subsequent call to Make_Lim_Ctrl will - -- fail during the initialization actions for Result, which means that - -- Result (and Obj by extension) should not be finalized. However Obj - -- will be finalized when access type Lim_Ctrl_Ptr goes out of scope - -- since it is already attached on the its finalization collection. - if Needs_BIP_Alloc_Form (Function_Id) then Temp_Init := Empty; @@ -9281,11 +9255,7 @@ package body Exp_Ch6 is end if; end; - -- When the function has a controlling result, an allocation-form - -- parameter must be passed indicating that the caller is allocating - -- the result object. This is needed because such a function can be - -- called as a dispatching operation and must be treated similarly - -- to functions with unconstrained result subtypes. + -- Add implicit actuals for the BIP formal parameters, if any Add_Unconstrained_Actuals_To_Build_In_Place_Call (Func_Call, @@ -9310,6 +9280,14 @@ package body Exp_Ch6 is Add_Access_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Return_Obj_Actual); + -- If the allocation is done in the caller, create a custom Allocate + -- procedure if need be. + + if not Needs_BIP_Alloc_Form (Function_Id) then + Build_Allocate_Deallocate_Proc + (Declaration_Node (Return_Obj_Access), Mark => Allocator); + end if; + -- Finally, replace the allocator node with a reference to the temp Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc)); @@ -9771,7 +9749,7 @@ package body Exp_Ch6 is -- ensure that the heap allocation can properly chain the object -- and later finalize it when the library unit goes out of scope. - if Needs_BIP_Collection (Func_Call) then + if Needs_BIP_Collection (Function_Id) then Build_Finalization_Collection (Typ => Ptr_Typ, For_Lib_Level => True, @@ -10334,6 +10312,12 @@ package body Exp_Ch6 is Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); begin + -- No need for BIP_Collection if allocation is always done in the caller + + if not Needs_BIP_Alloc_Form (Func_Id) then + return False; + end if; + -- A formal for the finalization collection is needed for build-in-place -- functions whose result type needs finalization or is a tagged type. -- Tagged primitive build-in-place functions need such a formal because @@ -10358,12 +10342,6 @@ package body Exp_Ch6 is Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); begin - -- See Make_Build_In_Place_Call_In_Allocator for the rationale - - if Needs_BIP_Collection (Func_Id) then - return True; - end if; - -- A formal giving the allocation method is needed for build-in-place -- functions whose result type is returned on the secondary stack or -- is a tagged type. Tagged primitive build-in-place functions need |