diff options
| author | Hristian Kirtchev <kirtchev@adacore.com> | 2011-08-03 14:36:26 +0000 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2011-08-03 16:36:26 +0200 |
| commit | df3e68b121249fad724c7c3f2b71e430dfb91008 (patch) | |
| tree | 3a155e8b2ced397467e576bd84bd23e0fd58fd91 /gcc/ada/exp_ch6.adb | |
| parent | de29d8500c2f9f5f164032ae5c3a5477dcc45c51 (diff) | |
| download | gcc-df3e68b121249fad724c7c3f2b71e430dfb91008.zip gcc-df3e68b121249fad724c7c3f2b71e430dfb91008.tar.gz gcc-df3e68b121249fad724c7c3f2b71e430dfb91008.tar.bz2 | |
a-except.adb, [...] (Raise_From_Controlled_Operation): Rewritten to create the message strings when...
2011-08-03 Hristian Kirtchev <kirtchev@adacore.com>
* a-except.adb, a-except-2005.adb (Raise_From_Controlled_Operation):
Rewritten to create the message strings when the exception is not
raised by an abort during finalization.
* a-except.ads, a-except-2005.ads: Add pragma Export for procedure
Raise_From_Controlled_Operation and update its associated comment.
* a-fihema.ads, a-fihema.adb: New GNAT unit.
Ada.Finalization.Heap_Management provides key functionality
associated with controlled objects on the heap, their creation,
finalization and reclamation. Type Finalization_Collection is
effectively a wrapper which sits ontop of a storage pool and performs
all necessary bookkeeping for all the objects it contains. Each
access-to-controlled or access-to-class-wide type receives a collection
as part of its expansion. The compiler generates buffer code and
invokes Allocate / Deallocate to create and destroy allocated
controlled objects.
* a-finali.adb ("="): Removed.
* a-finali.ads ("="): Removed. Controlled types no longer carry hidden
fields Prev and Next.
* ali.adb (Scan_ALI): Add parsing code to process PF / Has_Finalizer.
A library unit with at least one controlled object on the library level
has a special finalizer which is invoked by the binder. To signal this,
ali files carry field PF.
* ali.ads: New field in type Unit_Record called Has_Finalizer. Add
associated comment on field usage.
* a-tags.adb (Get_RC_Offset): Removed.
(Needs_Finalization): New routine.
* a-tags.ads: Update the structure of the GNAT dispatch tables.
Dispatch tables now carry field Needs_Finalization which provides
runtime indication whether a type is controlled or has controlled
components or both. Remove field RC_Offset.
(Get_RC_Offset): Removed along with its associated pragma Export.
Since tagged types with controlled components no longer carry hidden
field _controller, the special mechanism to retrieve its location is no
longer needed.
(Needs_Finalization): New routine.
* atree.ads, atree.adb (Elist24): New routine.
(Set_Elist24): New routine.
* atree.h: Add a define clause for Elist24.
* bindgen.adb New library-level variable Lib_Final_Built.
(Gen_Adafinal_Ada): Reimplemented. Depending on the restrictions or the
presence of a VM target, the routine generates calls to the proper
library finalization routine.
(Gen_Adainit_Ada): Import Finalize_Library_Objects only on non-VM
targets. Set the correct library finalization routine depending on
whether the library has controlled objects or this is a VM compilation.
(Gen_Finalize_Library_Ada): New routine. This procedure generates calls
to library-level finalizers of compiled units in reverse order of
elaboration. It also produces exception management code and reraises a
potential exception after all units have been finalized.
(Gen_Finalize_Library_C): New routine. This procedure generates calls to
library-level finalizers of compiled units in reverse order of
elaboration.
(Gen_Finalize_Library_Defs_C): New routine. This procedure generates the
definitions of all library-level finalizers available to the compilation
(Gen_Main_Ada): Directly call Adafinal which now contails all target
dependent code.
(Gen_Main_C): Add new local constant Needs_Library_Finalization. Call
System.Standard_Library.Adafinal directly. If the library needs
finalization actions, create the sequence of finalization calls.
(Gen_Output_File_Ada): Alphabetize local variables and constants.
Generate a with clause for System.Soft_Links when compiling for a VM.
Remove the code which imports System.Standard_Library.Adafinal as
Do_Finalize. Generate the library finalization routine.
(Gen_Output_File_C): Add new local constant Needs_Library_Finalization.
If the library needs finalization actions, create all the definitions
of library- level finalizers.
(Has_Finalizer): New routine. Determines whether at least one compiled
unit has a library-level finalizer.
Add type Qualification_Mode.
(Set_Unit_Name): Add a formal which controls the replacement of a dot.
* einfo.adb: New usage of field 15 as Return_Flag.
Remove Finalization_Chain_Entity from the usages of field 19.
Remove Associated_Final_Chain from the usages of field 23.
New usage of field 23 as Associated_Collection.
New usage of field 24 as Finalizer.
New usage of flag 252 as Is_Processed_Transient.
(Associated_Final_Chain): Removed.
(Associated_Collection): New routine.
(Finalization_Chain_Entity): Removed.
(Finalizer): New routine.
(Is_Finalizer): New routine.
(Is_Processed_Transient): New routine.
(Return_Flag): New routine.
(Set_Associated_Final_Chain): Removed.
(Set_Associated_Collection): New routine.
(Set_Finalization_Chain_Entity): Removed.
(Set_Finalizer): New routine.
(Set_Is_Processed_Transient): New routine.
(Set_Return_Flag): New routine.
(Write_Entity_Flags): Include Is_Processed_Transient to the list of
displayed flags.
(Write_Field8_Name): Alphabetize the output.
(Write_Field11_Name): Alphabetize the output.
(Write_Field12_Name): Alphabetize the output.
(Write_Field13_Name): Alphabetize the output.
(Write_Field14_Name): Alphabetize the output.
(Write_Field15_Name): Alphabetize the output.
(Write_Field16_Name): Alphabetize the output.
(Write_Field17_Name): Alphabetize the output.
(Write_Field18_Name): Alphabetize the output.
(Write_Field19_Name): Alphabetize the output. Remove the output of
Finalization_Chain_Entity.
(Write_Field20_Name): Alphabetize the output.
(Write_Field21_Name): Alphabetize the output.
(Write_Field22_Name): Alphabetize the output.
(Write_Field23_Name): Alphabetize the output. Remove the output of
Associated_Final_Chain. Add output for Associated_Collection.
(Write_Field24_Name): Alphabetize the output.
(Write_Field25_Name): Add output for Finalizer.
(Write_Field26_Name): Alphabetize the output.
(Write_Field27_Name): Alphabetize the output.
(Write_Field28_Name): Alphabetize the output.
* einfo.ads: Add new field description for Associated_Collection and
its uses in nodes.
Remove Associated_Final_Chain and its uses in nodes.
Remove Finalization_Chain_Entity and its uses in nodes.
Add new field description for Finalizer and its uses in nodes.
Add new synthesized attribute Is_Finalizer.
Add new flag description for Is_Processed_Transient and its uses in
nodes.
Add new field description for Return_Flag and its uses in nodes.
(Associated_Final_Chain): Removed along with its pragma Inline.
(Associated_Collection): New routine and pragma Inline.
(Finalization_Chain_Entity): Removed along with its pragma Inline.
(Finalizer): New routine and pragma Inline.
(Is_Finalizer): New routine and pragma Inline.
(Is_Processed_Transient): New routine and pragma Inline.
(Return_Flag): New routine and pragma Inline.
(Set_Associated_Final_Chain): Removed along with its pragma Inline.
(Set_Associated_Collection): New routine and pragma Inline.
(Set_Finalization_Chain_Entity): Removed along with its pragma Inline.
(Set_Finalizer): New routine and pragma Inline.
(Set_Is_Processed_Transient): New routine and pragma Inline.
(Set_Return_Flag): New routine and pragma Inline.
* exp_aggr.adb: Alphabetize subprograms.
(Build_Array_Aggr_Code): Remove formal Flist and its associated comment.
(Build_Record_Aggr_Code): Remove formals Flist and Obj along with their
associated comments. Remove local variables External_Final_List and
Attach.
Rename Ctrl_Stuff_Done to Finalization_Done. Rename local variable A to
Ancestor. Remove the retrieval of finalization lists. Update the call to
Make_Adjust_Call.
(Convert_Aggr_In_Allocator): Remove the retrieval of finalization
lists. Update the call to Late_Expansion.
(Convert_Aggr_In_Assignment): Update the call to Late_Expansion.
(Convert_Aggr_In_Object_Decl): Update the call to Late_Expansion.
(Gen_Assign): Remove the retrieval of the finalization list used to
build the assignment. Update the calls to Make_Init_Call and
Make_Adjust_Call.
(Gen_Ctrl_Actions_For_Aggr): Renamed to Generate_Finalization_Actions.
Remove the mechanism to determine attachment levels and finalization
list retrieval. Remove the processing for coextensions.
(Init_Controller): Removed. Controllers no longer exist.
(Late_Expansion): Remove formals Flist and Obj along with their
associated comments. Update the calls to Build_Record_Aggr_Code and
Build_Array_Aggr_Code.
* exp_ch13.adb (Expand_N_Free_Statement): New routine.
(Expand_N_Freeze_Entity): Add special processing for finalizers which
appear in entry bodies, protected subprograms and task bodies.
* exp_ch13.ads (Expand_N_Free_Statement): New routine.
* exp_ch3.adb (Add_Final_Chain): Removed.
(Build_Array_Init_Proc): Alphabetize local variables.
(Build_Assignment): Alphabetize local variables. Update the call to
Maked_Adjust_Call.
(Build_Class_Wide_Master): Rename local variables to better reflect
their role.
(Build_Discriminant_Assignments): Code reformatting.
(Build_Init_Call_Thru): Code reformatting.
(Build_Init_Procedure): Code reformatting. Generate a special version
of Deep_Finalize which is capable of finalizing all initialized
components and ignore the rest.
(Build_Init_Statements): Rename local variables to better reflect their
role.
Reimplement the mechanism to include the creation and update of an index
variable called a "counter". It is used as a bookmark for tracing
initialized and non-initialized components.
(Build_Initialization_Call): Remove local variable Controller_Typ.
Alphabetize all local variables. Remove the initialization of the
record controller and update the call to Make_Init_Call.
(Build_Record_Init_Proc): Rename formal Pe to Rec_Ent.
New local variable Counter.
(Constrain_Array): Alphabetize.
(Expand_Freeze_Array_Type): Create a collection instead of a
finalization list.
(Expand_Freeze_Class_Wide_Type): New routine. Creates TSS primitive
Finalize_Address which is used in conjunction with allocated controlled
objects.
(Expand_N_Object_Declaration): Remove the creation of a finalization
list for anonymous access types. Update the calls to Make_Init_Call and
Make_Adjust_Call.
(Expand_Freeze_Record_Type): Remove local variable Flist. Remove the
retrieval of finalization lists. Remove the expansion of the record
controller. Create TSS primitive Finalize_Address used in conjunction
with controlled objects on the heap. Create finalization collections
for access-to-controlled record components.
(Expand_Record_Controller): Removed.
(Freeze_Type): Remove the freezing of record controllers. Freezing of
class-wide types now requires additional processing. Create
finalization collections for access-to-controlled types.
(Increment_Counter): New routine.
(Make_Counter): New routine.
(Make_Eq_If): Remove the mention of Name_uController.
(Make_Predefined_Primitive_Specs): There is no longer need to skip
types coming from System.Finalization_Root.
(Predef_Deep_Spec): Reimplemented to reflect the new parameter profiles.
(Predefined_Primitive_Bodies): There is no longer need to skip types
coming from System.Finalization_Root.
(Stream_Operation_OK): Do not generate stream routines for
type Ada.Finalization.Heap_Management.Finalization_Collection.
* exp_ch3.ads: Alphabetize subprograms.
* exp_ch4.adb: Remove with and use clause for Sem_Ch8.
Add with and use clause for Lib.
(Complete_Coextension_Finalization): Removed.
(Complete_Controlled_Allocation): New routine. Create a finalization
collection for anonymous access-to-controlled types. Create a custom
Allocate which interfaces with the back end and the machinery in
Heap_Management.
(Expand_Allocator_Expression): Add necessary calls to
Complete_Controlled_Allocation. Remove the retrieval of finalization
lists. Update the calls to Make_Adjust_Call. Generate a call to
Ada.Finalization.Heap_Management.Set_Finalize_Address_Ptr to decorate
the associated collection.
(Expand_N_Allocator): Remove the processing for dynamic coextensions.
Code clean up. Remove the retrieval of finalization lists and
attachment levels.
Update the call to Make_Init_Call. Generate a call to
Ada.Finalization.Heap_Management.Set_Finalize_Address_Ptr to decorate
the associated collection.
(Get_Allocator_Final_List): Removed. Finalization lists are not
available.
(Suitable_Element): Remove the mention of Name_uController.
* exp_ch5.adb: Remove with and use clauses for Ttypes and Uintp.
(Make_Tag_Ctrl_Assignment): Rewritten to simply do a finalization of
the left hand side, carry out the assignment and adjust the left hand
side.
* exp_ch6.adb (Add_Final_List_Actual_To_Build_In_Place_Call): Removed.
(Add_Collection_Actual_To_Build_In_Place_Call): New routine.
(BIP_Formal_Suffix): Rename BIP_Final_List and BIPfinallist to
BIP_Collection and BIPcollection.
(Build_Heap_Allocator): New routine used to allocate the return object
of a build-in-place function onto a collection.
(Expand_Ctrl_Function_Call): Moved from Exp_Ch7.
(Expand_Call): Do not replace direct calls to Deep routines with their
aliases.
(Expand_N_Extended_Return_Statement): Give all variables shorter names
and update their occurrences. Add a special return flag to monitor the
[ab]normal execution of the function. The flag is set right before the
return statement.
Rewrite the mechanism used to allocate a build-in-place return object
on the heap or on a storage pool.
(Is_Direct_Deep_Call): New routine.
(Make_Build_In_Place_Call_In_Allocator): Add a collection to a
build-in-place function call instead of a final list. Build a call to
Set_Finalize_Address_Ptr to decorate the associated collection.
(Make_Build_In_Place_Call_In_Anonymous_Context): Create a temporary in
order to name the build-in-place function call's result for later
finalization. Add a collection to a build-in-place function call
instead of a final list.
(Make_Build_In_Place_Call_In_Assignment): Add a collection to a
build-in-place function call instead of a final list. Remove the code
which moves one final list and transforms it into the actual in a
nested build-in-place call.
(Make_Build_In_Place_Call_In_Object_Declaration): Add a collection to a
build-in-place function call instead of a final list.
(Move_Final_List): Removed.
(Needs_BIP_Collection): New routine.
(Needs_BIP_Final_List): Removed.
* exp_ch6.ads: Replace BIP_Final_List with BIP_Collection in
enumeration type BIP_Formal_Kind.
Update the related comment.
(Needs_BIP_Collection): New routine.
(Needs_BIP_Final_List): Removed.
* exp_ch7.adb: Add with and use clauses for Elists, Exp_Ch6, Stringt
and Ttypes. Remove with and use clauses for Sem_Type. Alphabetize the
majority of subprograms in this unit. Add Name_Finalize_Address to
array Name_Of and TSS_Finalize_Address to array Deep_Name_Of.
(Build_Adjust_Or_Finalize_Statements): Create the adjust or finalization
statements for an array type.
(Build_Adjust_Statements): Create the adjust statements for a record
type.
(Build_Cleanup_Statements): New routine. A procedure which given any
construct containing asynchronous calls, references to _master, or is a
task body, a task allocation or a protected body produces the necessary
runtime calls to clean up these constructs.
(Build_Exception_Handler): New routine.
(Build_Final_List): Removed.
(Build_Finalization_Collection): New routine. A core procedure which
creates a collection to service heap allocated controlled objects
associated with an access-to-controlled type.
(Build_Finalize_Statements): Create the finalization statements for a
record types.
(Build_Finalizer): New routine. A core procedure which given any
construct with declarations and/or statements detects all objects which
need any type of clean up (controlled objects, protected objects) and
generates all necessary code to clean up the said objects in the proper
order.
(Build_Finalizer_Call): New routine.
(Build_Initialize_Statements): Create the initialization statements for
an array type. The generated routine contains code to finalize partially
initialized arrays.
(Build_Object_Declarations): New routine.
(Build_Raise_Statement): New routine.
(Clean_Simple_Protected_Objects): Removed.
(Controller_Component): Removed.
(Enclosing_Function): New routine.
(Expand_Cleanup_Actions): Create a finalizer for a construct which has
either declarations or statements or both.
(Expand_N_Package_Body): Create a finalizer for a non-generic package.
(Expand_N_Package_Declaration): Create a finalizer for a non-generic
package.
(Find_Final_List): Removed.
(Global_Flist_Ref): Removed.
(In_Finalization_Root): Removed.
(Insert_Actions_In_Scope_Around): Determine the range of the transient
scope in terms of tree nodes. Process all transient variables within
that range.
(Make_Adjust_Call): Rewritten. There is no longer an attach call
generated after the adjust.
(Make_Attach_Call): Removed.
(Make_Call): New routine.
(Make_Clean): Removed.
(Make_Deep_Array_Body): Rewritten to simply invoke the appropriate
build routines.
(Make_Deep_Proc): Rewritten to generate the new profile signature used
in Deep routines.
(Make_Deep_Record_Body): Rewritten to simply invoke the appropriate
build routines.
(Make_Final_Call): Modified to simply create a call to either
Deep_Finalize or Finalize.
(Make_Finalize_Address_Body): New routine.
(Make_Finalize_Address_Stmts): New routine. A function which produces
TSS primitive Finalize_Address used in conjunction with heap allocated
controlled objects.
(Make_Handler_For_Ctrl_Operation): Add specialized code for .NET/JVM.
(Make_Init_Call): Rewritten. There is no longer an attach call
generated after initialization.
(Make_Local_Deep_Finalize): New routine.
(Make_Set_Finalize_Address_Ptr_Call): New routine.
(Make_Transient_Block): Remove the finalization list retrieval and
manipulation.
(Needs_Finalization): Moved to Exp_Util.
(Parent_Field_Type): New routine.
(Preprocess_Components): New routine.
(Process_Transient_Objects): New routine.
(Wrap_HSS_In_Block): New routine.
(Wrap_Transient_Declaration): Remove finalization list management and
controller insertion.
(Wrap_Transient_Expression): Code reformatting.
(Wrap_Transient_Statement): Code reformatting.
* exp_ch7.ads (Build_Final_List): Removed.
(Build_Finalization_Collection): New routine.
(Build_Raise_Statement): New routine.
(Controller_Component): Removed.
(Expand_Ctrl_Function_Call): Moved to Exp_Ch6.
(Find_Final_List): Removed.
(In_Finalization_Root): Removed.
(Is_Simple_Protected_Type): Update related comment.
(Make_Adjust_Call): New parameter profile and associated comments.
(Make_Attach_Call): Removed.
(Make_Final_Call): New parameter profile and associated comments.
(Make_Finalize_Address_Body): New routine.
(Make_Init_Call): New parameter profile and associated comments.
(Make_Local_Deep_Finalize): New routine.
(Make_Set_Finalize_Address_Ptr_Call): New routine.
(Needs_Finalization): Moved to Exp_Util.
* exp_ch9.adb (Add_Object_Pointer): Code reformatting.
(Expand_N_Protected_Body): Remove the handling of finalization lists.
(Find_Protection_Type): Moved to Exp_Util.
* exp_disp.adb: Remove with and use clauses for Exp_Ch7.
(Make_DT): Update sequence of dispatch table initialization. Remove the
initialization of field RC_Offset. Add initialization of field Needs_
Finalization.
* exp_intr.adb (Expand_Unc_Deallocation): Code reformatting.
Reimplement how an object is first finalized, then deallocated.
* exp_strm.adb (Build_Record_Or_Elementary_Input_Function):
Code reformatting.
* exp_tss.ads: Add special suffix for TSS primitive Finalize_Address.
Register TSS_Finalize_Address with type TSS_Names.
* exp_util.adb (Build_Allocate_Deallocate_Proc): New routine. This core
procedure provides the interface between an allocation / deallocation
and the support machinery in Ada.Finalization.Heap_Management.
(Find_Init_Call): Code reformatting.
(Find_Init_Call_In_List): Code reformatting.
(Find_Protection_Type): Moved from Exp_Ch9.
(Find_Prim_Op): Reimplement to add preference of recovered primitive.
(Has_Controlled_Coextensions): Removed.
(Has_Controlled_Objects): New routine.
(In_Library_Level_Package_Body): New routine.
(Insert_Action_After): New routine.
(Is_Finalizable_Transient): New routine. This predicate determines
whether an object declaration is one of the many variants of controlled
transients.
(Is_Null_Access_BIP_Func_Call): New routine.
(Is_Non_BIP_Func_Call): New routine.
(Is_Related_To_Func_Return): New routine.
(Needs_Finalization): Moved from Exp_Ch7.
* exp_util.ads (Build_Allocate_Deallocate_Proc): New routine.
(Find_Protection_Type): Moved from Exp_Ch9.
(Has_Controlled_Coextensions): Removed.
(Has_Controlled_Objects): New routine.
(In_Library_Level_Package_Body): New routine.
(Insert_Action_After): New routine.
(Is_Finalizable_Transient): New routine.
(Is_Null_Access_BIP_Func_Call): New routine.
(Is_Non_BIP_Func_Call): New routine.
(Is_Related_To_Func_Return): New routine.
(Needs_Finalization): Moved from Exp_ch7.
* expander.adb (Expand): Add a case for N_Free_Statement.
* freeze.adb (Freeze_All): Replace the generation of a finalization
list with a collection for access-to-controlled types.
(Freeze_Entity): Code reformatting.
(Freeze_Record_Type): Remove the freezing of a record controller
component.
(Freeze_Subprogram): Code reformatting.
* inline.adb (Cleanup_Scopes): Remove the reset of the scope
finalization list.
* lib-writ.adb (Write_Unit_Information): Output "PF" when a package
has a library-level finalizer.
* lib-writ.ads: Add "PF" to the sequence of unit attributes.
* a-filico.ads, a-filico.adb, s-finimp.ads, s-finimp.adb: Removed.
* Makefile.rtl: Remove a-filico and s-finimp from the list of object
files. Add a-fihema to the list of object files.
* par-ch4.adb:
Alphabetize the associations in type Is_Parameterless_Attribute.
* rtsfind.ads: Ada.Finalization_List.Controller and
System.Finalization_Implementation are no longer a GNAT unit.
Update the range of type Ada_Finalization_Child. Remove the following
recoverable entities:
RE_Attach_To_Final_List
RE_Deep_Tag_Attach
RE_Finalize_List
RE_Finalize_One
RE_Finalizable_Ptr_Ptr
RE_Global_Final_List
RE_Limited_Record_Controller
RE_List_Controller
RE_Move_Final_List
RE_Record_Controller
RE_Simple_List_Controller
Add the following recoverable entities:
RE_Add_Offset_To_Address
RE_Allocate
RE_Base_Pool
RE_Deallocate
RE_Exception_Identity
RE_Finalization_Collection
RE_Finalization_Collection_Ptr
RE_Needs_Finalization
RE_Save_Library_Occurrence
RE_Set_Finalize_Address_Ptr
RE_Set_Storage_Pool_Ptr
RE_Storage_Count
* sem_aggr.adb (Resolve_Record_Aggregate): Remove mention of
Name_uController.
* sem_aux.adb (First_Discriminant): Remove mention of Name_uController.
(First_Stored_Discriminant): Remove the mention of Name_uController.
* sem_aux.ads: Comment reformatting.
* sem_ch10.adb (Build_Chain): Signal the class-wide creation machinery
to redecorate an already existing class-wide type.
(Decorate_Tagged_Type): New parameter profile and associated comment.
Create a "shadow class-wide type" for a shadow entity.
* sem_ch11.adb (Analyze_Exception_Handlers): Remove the dubious setting
of the final chain along with the associated comment.
* sem_ch3.adb (Access_Type_Declaration): Add new local variable
Full_Desig and set it to the full view of the designated type.
Initialize the finalization collection to empty.
(Build_Derived_Record_Type): Alphabetize local variables. Code
reformatting.
(Collect_Fixed_Components): Remove the mention of Name_uController.
(Create_Constrained_Components): Remove the mention of Name_uController.
(Make_Class_Wide_Type): Add specialized code to redecorate an existing
class-wide type of a shadow entity.
(Process_Full_View): Update the machinery which marks type
Limited_Controlled's entity as limited.
* sem_ch4.adb (Analyze_One_Call): Code reformatting.
* sem_ch6.adb (Create_Extra_Formals): Do not generate a finalization
list, instead make a collection build-in-place formal.
* sem_ch8.adb (Analyze_Object_Renaming): Look at the available view of
a designated type in order to establish a match between the renaming
and the renamed entity.
(Find_Selected_Component): Add guard to prevent spurious exceptions
from being raised on .NET/JVM.
* sem_disp.adb (Check_Dispatching_Operation): Include Finalize_Address
to the list of primitive that need special processing. Update arrays
C_Names and D_Names.
(Replace_Types): Handle class-wide types.
* sem_elab.adb (Check_A_Call): Since Deep_Initialize now has a
different parameter profile, look at the first formal.
* sem_prag.adb: Remove with and use clauses for Exp_Ch7. Add with and
use clauses for Exp_Util.
* sem_res.adb: Remove with and use clauses for Elists.
(Propagate_Coextensions): Removed.
(Resolve_Allocator): Do not propagate the list of coextensions from one
allocator to another.
* sem_util.adb (Build_Actual_Subtype_Of_Component): Rename variable
Deaccessed_T to Desig_Typ.
(Enter_Name): Remove the mention of Name_uController.
(Gather_Components): Remove the mention of Name_uController.
(Incomplete_Or_Private_View): New routine.
(Is_Coextension_Root): Removed.
(Is_Fully_Initialized_Type): Remove the mention of Name_uController.
* sem_util.ads (Incomplete_Or_Private_View): New routine.
(Is_Coextension_Root): Removed.
* s-finroo.ads: Remove with clause for Ada.Unchecked_Conversion.
Controlled types are now derived from a null tagged record. Remove
types Finalizable_Ptr, Finalizable and Empty_Root_Controlled.
* sinfo.adb (Coextensions): Removed.
(Set_Coextensions): Removed.
* sinfo.ads: Remove Coextensions from the explanation of node fields
and its uses in nodes.
Update the field usage of N_Allocator.
(Coextensions): Removed along with its pragma Inline.
(Set_Coextensions): Removed along with its pragma Inline.
* snames.ads-tmpl: Remove names
Name_uClean
Name_uController
Name_uFinal_List
Name_uLocal_Final_List
Name_Finalization_Root
Name_Next
Name_Prev
Add names
Name_uFinalizer
Name_Finalize_Address
* s-pooglo.adb (Allocate): Add overriding indicator.
(Deallocate): Add overriding indicator.
(Storage_Size): Add overriding indicator.
* s-soflin.adb (Adafinal_NT): Invoke Finalize_Library_Objects rather
than Finalize_Global_List.
(Null_Finalize_Global_List): Removed.
(Save_Library_Occurrence): New routine.
* s-soflin.ads: Remove variable Finalize_Global_List along with its
initialization. Add variable Finalize_Library_Objects along with its
pragma Export. Add variables Library_Exception and
Library_Exception_Set along with their pragma Export.
(Null_Finalize_Global_List): Removed.
(Save_Library_Occurrence): New routine.
* s-tassta.adb (Finalize_Global_Tasks): Call Finalize_Library_Objects
rather than Finalize_Global_List.
* tbuild.adb (Unchecked_Convert_To): Capture and set the parent field
of the constructed node.
From-SVN: r177275
Diffstat (limited to 'gcc/ada/exp_ch6.adb')
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 1096 |
1 files changed, 662 insertions, 434 deletions
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index d09261e..87403a5 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -110,19 +110,14 @@ package body Exp_Ch6 is -- Adds Extra_Actual as a named parameter association for the formal -- Extra_Formal in Subprogram_Call. - procedure Add_Final_List_Actual_To_Build_In_Place_Call - (Function_Call : Node_Id; - Function_Id : Entity_Id; - Acc_Type : Entity_Id; - Sel_Comp : Node_Id := Empty); - -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has - -- controlled parts, add an actual parameter that is a pointer to - -- appropriate finalization list. The finalization list is that of the - -- current scope, except for "new Acc'(F(...))" in which case it's the - -- finalization list of the access type returned by the allocator. Acc_Type - -- is that type in the allocator case; Empty otherwise. If Sel_Comp is - -- not Empty, then it denotes a selected component and the finalization - -- list is obtained from the _controller list of the prefix object. + procedure Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call : Node_Id; + Func_Id : Entity_Id; + Ptr_Typ : Entity_Id := Empty); + -- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs + -- finalization actions, add an actual parameter which is a pointer to the + -- finalization collection of the caller. If Ptr_Typ is left Empty, this + -- will result in an automatic "null" value for the actual. procedure Add_Task_Actuals_To_Build_In_Place_Call (Function_Call : Node_Id; @@ -191,6 +186,11 @@ package body Exp_Ch6 is -- For non-scalar objects that are possibly unaligned, add call by copy -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT). + procedure Expand_Ctrl_Function_Call (N : Node_Id); + -- N is a function call which returns a controlled object. Transform the + -- call into a temporary which retrieves the returned object from the + -- secondary stack using 'reference. + procedure Expand_Inlined_Call (N : Node_Id; Subp : Entity_Id; @@ -340,6 +340,91 @@ package body Exp_Ch6 is (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual); end Add_Alloc_Form_Actual_To_Build_In_Place_Call; + -------------------------------------------------- + -- Add_Collection_Actual_To_Build_In_Place_Call -- + -------------------------------------------------- + + procedure Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call : Node_Id; + Func_Id : Entity_Id; + Ptr_Typ : Entity_Id := Empty) + is + begin + if not Needs_BIP_Collection (Func_Id) then + return; + end if; + + declare + Formal : constant Entity_Id := + Build_In_Place_Formal (Func_Id, BIP_Collection); + Loc : constant Source_Ptr := Sloc (Func_Call); + + Actual : Node_Id; + Desig_Typ : Entity_Id; + + begin + -- Case where the context does not require an actual collection + + if No (Ptr_Typ) then + Actual := Make_Null (Loc); + + else + Desig_Typ := Directly_Designated_Type (Ptr_Typ); + + -- Check for a library-level access type whose designated type has + -- supressed finalization. Such an access types lack a collection. + -- Pass a null actual to the callee in order to signal a missing + -- collection. + + if Is_Library_Level_Entity (Ptr_Typ) + and then Finalize_Storage_Only (Desig_Typ) + then + Actual := Make_Null (Loc); + + -- Types in need of finalization actions + + elsif Needs_Finalization (Desig_Typ) then + + -- The general mechanism of creating finalization collections + -- for anonymous access types is disabled by default, otherwise + -- collections will pop all over the place. Such types use + -- context-specific collections. + + if Ekind (Ptr_Typ) = E_Anonymous_Access_Type + and then No (Associated_Collection (Ptr_Typ)) + then + Build_Finalization_Collection + (Typ => Ptr_Typ, + Ins_Node => Associated_Node_For_Itype (Ptr_Typ), + Encl_Scope => Scope (Ptr_Typ)); + end if; + + -- Access-to-controlled types should always have a collection + + pragma Assert (Present (Associated_Collection (Ptr_Typ))); + + Actual := + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Associated_Collection (Ptr_Typ), Loc), + Attribute_Name => Name_Unrestricted_Access); + + -- Tagged types + + else + Actual := Make_Null (Loc); + end if; + end if; + + Analyze_And_Resolve (Actual, Etype (Formal)); + + -- Build the parameter association for the new actual and add it to + -- the end of the function's actuals. + + Add_Extra_Actual_To_Call (Func_Call, Formal, Actual); + end; + end Add_Collection_Actual_To_Build_In_Place_Call; + ------------------------------ -- Add_Extra_Actual_To_Call -- ------------------------------ @@ -393,79 +478,6 @@ package body Exp_Ch6 is end if; end Add_Extra_Actual_To_Call; - -------------------------------------------------- - -- Add_Final_List_Actual_To_Build_In_Place_Call -- - -------------------------------------------------- - - procedure Add_Final_List_Actual_To_Build_In_Place_Call - (Function_Call : Node_Id; - Function_Id : Entity_Id; - Acc_Type : Entity_Id; - Sel_Comp : Node_Id := Empty) - is - Loc : constant Source_Ptr := Sloc (Function_Call); - Final_List : Node_Id; - Final_List_Actual : Node_Id; - Final_List_Formal : Node_Id; - Is_Ctrl_Result : constant Boolean := - Needs_Finalization - (Underlying_Type (Etype (Function_Id))); - - begin - -- No such extra parameter is needed if there are no controlled parts. - -- The test for Needs_Finalization accounts for class-wide results - -- (which potentially have controlled parts, even if the root type - -- doesn't), and the test for a tagged result type is needed because - -- calls to such a function can in general occur in dispatching - -- contexts, which must be treated the same as a call to class-wide - -- functions. Both of these situations require that a finalization list - -- be passed. - - if not Needs_BIP_Final_List (Function_Id) then - return; - end if; - - -- Locate implicit finalization list parameter in the called function - - Final_List_Formal := Build_In_Place_Formal (Function_Id, BIP_Final_List); - - -- Create the actual which is a pointer to the appropriate finalization - -- list. Acc_Type is present if and only if this call is the - -- initialization of an allocator. Use the Current_Scope or the - -- Acc_Type as appropriate. - - if Present (Acc_Type) - and then (Ekind (Acc_Type) = E_Anonymous_Access_Type - or else - Present (Associated_Final_Chain (Base_Type (Acc_Type)))) - then - Final_List := Find_Final_List (Acc_Type); - - -- If Sel_Comp is present and the function result is controlled, then - -- the finalization list will be obtained from the _controller list of - -- the selected component's prefix object. - - elsif Present (Sel_Comp) and then Is_Ctrl_Result then - Final_List := Find_Final_List (Current_Scope, Sel_Comp); - - else - Final_List := Find_Final_List (Current_Scope); - end if; - - Final_List_Actual := - Make_Attribute_Reference (Loc, - Prefix => Final_List, - Attribute_Name => Name_Unrestricted_Access); - - Analyze_And_Resolve (Final_List_Actual, Etype (Final_List_Formal)); - - -- Build the parameter association for the new actual and add it to the - -- end of the function's actuals. - - Add_Extra_Actual_To_Call - (Function_Call, Final_List_Formal, Final_List_Actual); - end Add_Final_List_Actual_To_Build_In_Place_Call; - --------------------------------------------- -- Add_Task_Actuals_To_Build_In_Place_Call -- --------------------------------------------- @@ -549,8 +561,8 @@ package body Exp_Ch6 is case Kind is when BIP_Alloc_Form => return "BIPalloc"; - when BIP_Final_List => - return "BIPfinallist"; + when BIP_Collection => + return "BIPcollection"; when BIP_Master => return "BIPmaster"; when BIP_Activation_Chain => @@ -1777,6 +1789,10 @@ package body Exp_Ch6 is -- convoluted tree traversal before setting the proper subprogram to be -- called. + function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean; + -- Determine whether Subp denotes a non-dispatching call to a Deep + -- routine. + function New_Value (From : Node_Id) return Node_Id; -- From is the original Expression. New_Value is equivalent to a call -- to Duplicate_Subexpr with an explicit dereference when From is an @@ -1945,6 +1961,42 @@ package body Exp_Ch6 is raise Program_Error; end Inherited_From_Formal; + ------------------------- + -- Is_Direct_Deep_Call -- + ------------------------- + + function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean is + begin + if Is_TSS (Subp, TSS_Deep_Adjust) + or else Is_TSS (Subp, TSS_Deep_Finalize) + or else Is_TSS (Subp, TSS_Deep_Initialize) + then + declare + Actual : Node_Id; + Formal : Node_Id; + + begin + Actual := First (Parameter_Associations (N)); + Formal := First_Formal (Subp); + while Present (Actual) + and then Present (Formal) + loop + if Nkind (Actual) = N_Identifier + and then Is_Controlling_Actual (Actual) + and then Etype (Actual) = Etype (Formal) + then + return True; + end if; + + Next (Actual); + Next_Formal (Formal); + end loop; + end; + end if; + + return False; + end Is_Direct_Deep_Call; + --------------- -- New_Value -- --------------- @@ -2795,6 +2847,7 @@ package body Exp_Ch6 is if Nkind (Call_Node) /= N_Entry_Call_Statement and then No (Controlling_Argument (Call_Node)) and then Present (Parent_Subp) + and then not Is_Direct_Deep_Call (Subp) then if Present (Inherited_From_Formal (Subp)) then Parent_Subp := Inherited_From_Formal (Subp); @@ -3229,12 +3282,12 @@ package body Exp_Ch6 is Expand_Protected_Subprogram_Call (Call_Node, Subp, Scop); end if; - -- Functions returning controlled objects need special attention: - -- if the return type is limited, the context is an initialization - -- and different processing applies. If the call is to a protected - -- function, the expansion above will call Expand_Call recursively. - -- To prevent a double attachment, check that the current call is - -- not a rewriting of a protected function call. + -- Functions returning controlled objects need special attention. If + -- the return type is limited, then the context is initialization and + -- different processing applies. If the call is to a protected function, + -- the expansion above will call Expand_Call recursively. Otherwise the + -- function call is transformed into a temporary which obtains the + -- result from the secondary stack. if Needs_Finalization (Etype (Subp)) then if not Is_Immutably_Limited_Type (Etype (Subp)) @@ -3407,6 +3460,33 @@ package body Exp_Ch6 is end if; end Expand_Call; + ------------------------------- + -- Expand_Ctrl_Function_Call -- + ------------------------------- + + procedure Expand_Ctrl_Function_Call (N : Node_Id) is + begin + -- Optimization, if the returned value (which is on the sec-stack) is + -- returned again, no need to copy/readjust/finalize, we can just pass + -- the value thru (see Expand_N_Simple_Return_Statement), and thus no + -- attachment is needed + + if Nkind (Parent (N)) = N_Simple_Return_Statement then + return; + end if; + + -- Resolution is now finished, make sure we don't start analysis again + -- because of the duplication. + + 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. + + Remove_Side_Effects (N); + end Expand_Ctrl_Function_Call; + -------------------------- -- Expand_Inlined_Call -- -------------------------- @@ -4245,20 +4325,53 @@ package body Exp_Ch6 is 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)); - 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; + Par_Func : constant Entity_Id := + Return_Applies_To (Return_Statement_Entity (N)); + Ret_Obj_Id : constant Entity_Id := + First_Entity (Return_Statement_Entity (N)); + Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id); + + Is_Build_In_Place : constant Boolean := + Is_Build_In_Place_Function (Par_Func); + + Exp : Node_Id; + HSS : Node_Id; + Result : Node_Id; + Return_Stmt : Node_Id; + Stmts : List_Id; + + function Build_Heap_Allocator + (Temp_Id : Entity_Id; + Temp_Typ : Entity_Id; + Func_Id : Entity_Id; + Ret_Typ : Entity_Id; + Alloc_Expr : Node_Id) return Node_Id; + -- Create the statements necessary to allocate a return object on the + -- caller's collection. The collection is available through implicit + -- parameter BIPcollection. + -- + -- if BIPcollection /= null then + -- declare + -- type Ptr_Typ is access Ret_Typ; + -- for Ptr_Typ'Storage_Pool use + -- Base_Pool (BIPcollection.all).all; + -- Local : Ptr_Typ; + -- + -- begin + -- procedure Allocate (...) is + -- begin + -- Ada.Finalization.Heap_Management.Allocate (...); + -- end Allocate; + -- + -- Local := <Alloc_Expr>; + -- Temp_Id := Temp_Typ (Local); + -- end; + -- end if; + -- + -- Temp_Id is the temporary which is used to reference the internally + -- created object in all allocation forms. Temp_Typ is the type of the + -- temporary. Func_Id is the enclosing function. Ret_Typ is the return + -- type of Func_Id. Alloc_Expr is the actual allocator. function Move_Activation_Chain return Node_Id; -- Construct a call to System.Tasking.Stages.Move_Activation_Chain @@ -4267,99 +4380,254 @@ package body Exp_Ch6 is -- 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 + -------------------------- + -- Build_Heap_Allocator -- + -------------------------- + + function Build_Heap_Allocator + (Temp_Id : Entity_Id; + Temp_Typ : Entity_Id; + Func_Id : Entity_Id; + Ret_Typ : Entity_Id; + Alloc_Expr : Node_Id) return Node_Id + is + begin + -- Processing for build-in-place object allocation. This is disabled + -- on .NET/JVM because pools are not supported. + + if VM_Target = No_VM + and then Is_Build_In_Place_Function (Func_Id) + and then Needs_Finalization (Ret_Typ) + then + declare + Collect : constant Entity_Id := + Build_In_Place_Formal (Func_Id, BIP_Collection); + Decls : constant List_Id := New_List; + Stmts : constant List_Id := New_List; + + Local_Id : Entity_Id; + Pool_Id : Entity_Id; + Ptr_Typ : Entity_Id; + + begin + -- Generate: + -- Pool_Id renames Base_Pool (BIPcollection.all).all; + + Pool_Id := Make_Temporary (Loc, 'P'); + + Append_To (Decls, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Pool_Id, + Subtype_Mark => + New_Reference_To (RTE (RE_Root_Storage_Pool), Loc), + Name => + Make_Explicit_Dereference (Loc, + Prefix => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Base_Pool), Loc), + + Parameter_Associations => New_List ( + Make_Explicit_Dereference (Loc, + Prefix => + New_Reference_To (Collect, Loc))))))); + + -- Create an access type which uses the storage pool of the + -- caller's collection. This additional type is necessary + -- because the collection cannot be associated with the type + -- of the temporary. Otherwise the secondary stack allocation + -- will fail. + + -- Generate: + -- type Ptr_Typ is access Ret_Typ; + + Ptr_Typ := Make_Temporary (Loc, 'P'); + + Append_To (Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Reference_To (Ret_Typ, Loc)))); + + -- Perform minor decoration in order to set the collection and + -- the storage pool attributes. + + Set_Ekind (Ptr_Typ, E_Access_Type); + Set_Associated_Collection (Ptr_Typ, Collect); + Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); + + -- Create the temporary, generate: + -- + -- Local_Id : Ptr_Typ; + + Local_Id := Make_Temporary (Loc, 'T'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Id, + Object_Definition => + New_Reference_To (Ptr_Typ, Loc))); + + -- Allocate the object, generate: + -- + -- Local_Id := <Alloc_Expr>; + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Local_Id, Loc), + Expression => Alloc_Expr)); + + -- Generate: + -- Temp_Id := Temp_Typ (Local_Id); + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Temp_Id, Loc), + Expression => + Unchecked_Convert_To (Temp_Typ, + New_Reference_To (Local_Id, Loc)))); + + -- Wrap the allocation in a block. This is further conditioned + -- by checking the caller collection at runtime. A null value + -- indicates a non-existent collection, most likely due to a + -- Finalize_Storage_Only allocation. + + -- Generate: + -- if BIPcollection /= null then + -- declare + -- <Decls> + -- begin + -- <Stmts> + -- end; + -- end if; + + return + Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + New_Reference_To (Collect, Loc), + Right_Opnd => + Make_Null (Loc)), + + Then_Statements => New_List ( + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)))); + end; + + -- For all other cases, generate: + -- + -- Temp_Id := <Alloc_Expr>; + + else + return + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Temp_Id, Loc), + Expression => Alloc_Expr); + end if; + end Build_Heap_Allocator; --------------------------- -- 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; + Chain_Formal : constant Entity_Id := + Build_In_Place_Formal + (Par_Func, BIP_Activation_Chain); + To : constant Node_Id := + New_Reference_To (Chain_Formal, Loc); + Master_Formal : constant Entity_Id := + Build_In_Place_Formal (Par_Func, BIP_Master); + New_Master : constant Node_Id := + New_Reference_To (Master_Formal, Loc); + + Chain_Id : 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); + Chain_Id := First_Entity (Return_Statement_Entity (N)); + while Chars (Chain_Id) /= Name_uChain loop + Chain_Id := Next_Entity (Chain_Id); end loop; From := Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Chain_Entity, Loc), + Prefix => + New_Reference_To (Chain_Id, 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. + -- work, instead of "New_Reference_To (Chain_Id, Loc)" above. return Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Move_Activation_Chain), 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 -- - --------------------- + -- Start of processing for Expand_N_Extended_Return_Statement - function Move_Final_List return Node_Id is - Flist : constant Entity_Id := - Finalization_Chain_Entity (Return_Statement_Entity (N)); + begin + if Nkind (Ret_Obj_Decl) = N_Object_Declaration then + Exp := Expression (Ret_Obj_Decl); + else + Exp := Empty; + end if; - From : constant Node_Id := New_Reference_To (Flist, Loc); + HSS := Handled_Statement_Sequence (N); - Caller_Final_List : constant Entity_Id := - Build_In_Place_Formal - (Parent_Function, BIP_Final_List); + -- If the returned object needs finalization actions, the function must + -- perform the appropriate cleanup should it fail to return. The state + -- of the function itself is tracked through a flag which is coupled + -- with the scope finalizer. There is one flag per each return object + -- in case of multiple returns. - To : constant Node_Id := New_Reference_To (Caller_Final_List, Loc); + if Is_Build_In_Place + and then Needs_Finalization (Etype (Ret_Obj_Id)) + then + declare + Flag_Decl : Node_Id; + Flag_Id : Entity_Id; + Func_Bod : Node_Id; - begin - -- Catch cases where a finalization chain entity has not been - -- associated with the return statement entity. + begin + -- Recover the function body - pragma Assert (Present (Flist)); + Func_Bod := Unit_Declaration_Node (Par_Func); + if Nkind (Func_Bod) = N_Subprogram_Declaration then + Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod))); + end if; - -- Build required call + -- Create a flag to track the function state - 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; + Flag_Id := Make_Temporary (Loc, 'F'); + Set_Return_Flag (Ret_Obj_Id, Flag_Id); - -- Start of processing for Expand_N_Extended_Return_Statement + -- Insert the flag at the beginning of the function declarations, + -- generate: + -- Fnn : Boolean := False; - begin - if Nkind (Return_Object_Decl) = N_Object_Declaration then - Exp := Expression (Return_Object_Decl); - else - Exp := Empty; - end if; + Flag_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Flag_Id, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => + New_Reference_To (Standard_False, Loc)); - Handled_Stm_Seq := Handled_Statement_Sequence (N); + Prepend_To (Declarations (Func_Bod), Flag_Decl); + Analyze (Flag_Decl); + end; + end if; -- Build a simple_return_statement that returns the return object when -- there is a statement sequence, or no expression, or the result will @@ -4367,89 +4635,79 @@ package body Exp_Ch6 is -- 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)) + if Present (HSS) + or else Is_Composite_Type (Etype (Par_Func)) or else No (Exp) then - if No (Handled_Stm_Seq) then - Statements := New_List; + if No (HSS) then + Stmts := 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)); + Stmts := New_List ( + Make_Block_Statement (Loc, + Declarations => New_List, + Handled_Statement_Sequence => HSS)); 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. Note that Needs_Finalization accounts for the case - -- of class-wide types, which which must be assumed to require - -- finalization. + -- 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 then Needs_BIP_Final_List (Parent_Function) - and then - ((Present (Exp) and then Needs_Finalization (Etype (Exp))) - or else - (not Present (Exp) - and then Needs_Finalization (Etype (Return_Object_Entity)))) + and Has_Task (Etype (Par_Func)) then - Append_To (Statements, Move_Final_List); + Append_To (Stmts, Move_Activation_Chain); 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); + -- Update the state of the function right before the object is + -- returned. + + if Is_Build_In_Place + and then Needs_Finalization (Etype (Ret_Obj_Id)) + then + declare + Flag_Id : constant Entity_Id := Return_Flag (Ret_Obj_Id); + + begin + -- Generate: + -- Fnn := True; + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Flag_Id, Loc), + Expression => + New_Reference_To (Standard_True, Loc))); + end; end if; -- Build a simple_return_statement that returns the return object - Return_Stm := + Return_Stmt := Make_Simple_Return_Statement (Loc, - Expression => New_Occurrence_Of (Return_Object_Entity, Loc)); - Append_To (Statements, Return_Stm); + Expression => + New_Occurrence_Of (Ret_Obj_Id, Loc)); + Append_To (Stmts, Return_Stmt); - Handled_Stm_Seq := - Make_Handled_Sequence_Of_Statements (Loc, Statements); + HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts); end if; - -- Case where we build a block + -- Case where we build a return statement block - if Present (Handled_Stm_Seq) then + if Present (HSS) then Result := Make_Block_Statement (Loc, Declarations => Return_Object_Declarations (N), - Handled_Statement_Sequence => Handled_Stm_Seq); + Handled_Statement_Sequence => HSS); -- We set the entity of the new block statement to be that of the -- return statement. This is necessary so that various fields, such @@ -4468,15 +4726,16 @@ package body Exp_Ch6 is -- allocation of the return object. if Is_Build_In_Place - and then - Nkind (Return_Object_Decl) = N_Object_Renaming_Declaration + and then Nkind (Ret_Obj_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)))); + pragma Assert + (Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration + and then Is_Build_In_Place_Function_Call + (Expression (Original_Node (Ret_Obj_Decl)))); + + -- Return the build-in-place result by reference - Set_By_Ref (Return_Stm); -- Return build-in-place results by ref + Set_By_Ref (Return_Stmt); elsif Is_Build_In_Place then @@ -4488,27 +4747,26 @@ package body Exp_Ch6 is -- expanded as separate assignments, then add an assignment -- statement to ensure the return object gets initialized. - -- declare - -- Result : T [:= <expression>]; - -- begin - -- ... + -- declare + -- Result : T [:= <expression>]; + -- begin + -- ... -- is converted to - -- declare - -- Result : T renames FuncRA.all; - -- [Result := <expression;] - -- begin - -- ... + -- declare + -- Result : T renames FuncRA.all; + -- [Result := <expression;] + -- begin + -- ... declare Return_Obj_Id : constant Entity_Id := - Defining_Identifier (Return_Object_Decl); + Defining_Identifier (Ret_Obj_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); + Expression (Ret_Obj_Decl); + Result_Subt : constant Entity_Id := Etype (Par_Func); Constr_Result : constant Boolean := Is_Constrained (Result_Subt); Obj_Alloc_Formal : Entity_Id; @@ -4519,12 +4777,12 @@ package body Exp_Ch6 is begin -- Build-in-place results must be returned by reference - Set_By_Ref (Return_Stm); + Set_By_Ref (Return_Stmt); -- Retrieve the implicit access parameter passed by the caller Object_Access := - Build_In_Place_Formal (Parent_Function, BIP_Object_Access); + Build_In_Place_Formal (Par_Func, BIP_Object_Access); -- If the return object's declaration includes an expression -- and the declaration isn't marked as No_Initialization, then @@ -4543,13 +4801,16 @@ package body Exp_Ch6 is -- interface has no assignment operation). if Present (Return_Obj_Expr) - and then not No_Initialization (Return_Object_Decl) + and then not No_Initialization (Ret_Obj_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)); + 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); @@ -4557,7 +4818,7 @@ package body Exp_Ch6 is Set_Parent (Name (Init_Assignment), Init_Assignment); Set_Parent (Expression (Init_Assignment), Init_Assignment); - Set_Expression (Return_Object_Decl, Empty); + Set_Expression (Ret_Obj_Decl, Empty); if Is_Class_Wide_Type (Etype (Return_Obj_Id)) and then not Is_Class_Wide_Type @@ -4566,8 +4827,7 @@ package body Exp_Ch6 is Rewrite (Expression (Init_Assignment), Make_Type_Conversion (Loc, Subtype_Mark => - New_Occurrence_Of - (Etype (Return_Obj_Id), Loc), + New_Occurrence_Of (Etype (Return_Obj_Id), Loc), Expression => Relocate_Node (Expression (Init_Assignment)))); end if; @@ -4581,7 +4841,7 @@ package body Exp_Ch6 is if Constr_Result and then not Is_Tagged_Type (Underlying_Type (Result_Subt)) then - Insert_After (Return_Object_Decl, Init_Assignment); + Insert_After (Ret_Obj_Decl, Init_Assignment); end if; end if; @@ -4608,7 +4868,7 @@ package body Exp_Ch6 is or else Is_Tagged_Type (Underlying_Type (Result_Subt)) then Obj_Alloc_Formal := - Build_In_Place_Formal (Parent_Function, BIP_Alloc_Form); + Build_In_Place_Formal (Par_Func, BIP_Alloc_Form); declare Ref_Type : Entity_Id; @@ -4616,8 +4876,8 @@ package body Exp_Ch6 is Alloc_Obj_Id : Entity_Id; Alloc_Obj_Decl : Node_Id; Alloc_If_Stmt : Node_Id; - SS_Allocator : Node_Id; Heap_Allocator : Node_Id; + SS_Allocator : Node_Id; begin -- Reuse the itype created for the function's implicit @@ -4625,7 +4885,7 @@ package body Exp_Ch6 is -- access type here, plus it allows assigning the access -- formal directly without applying a conversion. - -- Ref_Type := Etype (Object_Access); + -- Ref_Type := Etype (Object_Access); -- Create an access type designating the function's -- result subtype. @@ -4641,7 +4901,7 @@ package body Exp_Ch6 is Subtype_Indication => New_Reference_To (Return_Obj_Typ, Loc))); - Insert_Before (Return_Object_Decl, Ptr_Type_Decl); + Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl); -- Create an access object that will be initialized to an -- access value denoting the return object, either coming @@ -4654,17 +4914,17 @@ package body Exp_Ch6 is Alloc_Obj_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Alloc_Obj_Id, - Object_Definition => New_Reference_To - (Ref_Type, Loc)); + Object_Definition => + New_Reference_To (Ref_Type, Loc)); - Insert_Before (Return_Object_Decl, Alloc_Obj_Decl); + Insert_Before (Ret_Obj_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) + and then not No_Initialization (Ret_Obj_Decl) then -- Always use the type of the expression for the -- qualified expression, rather than the result type. @@ -4755,10 +5015,10 @@ package body Exp_Ch6 is -- statement, past the point where these flags are -- normally set. - Set_Sec_Stack_Needed_For_Return (Parent_Function); + Set_Sec_Stack_Needed_For_Return (Par_Func); Set_Sec_Stack_Needed_For_Return (Return_Statement_Entity (N)); - Set_Uses_Sec_Stack (Parent_Function); + Set_Uses_Sec_Stack (Par_Func); Set_Uses_Sec_Stack (Return_Statement_Entity (N)); end if; @@ -4780,7 +5040,7 @@ package body Exp_Ch6 is Alloc_If_Stmt := Make_If_Statement (Loc, - Condition => + Condition => Make_Op_Eq (Loc, Left_Opnd => New_Reference_To (Obj_Alloc_Formal, Loc), @@ -4788,45 +5048,42 @@ package body Exp_Ch6 is 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 + + 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))); + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Alloc_Obj_Id, Loc), + Expression => SS_Allocator)))), + + Else_Statements => New_List ( + Build_Heap_Allocator + (Temp_Id => Alloc_Obj_Id, + Temp_Typ => Ref_Type, + Func_Id => Par_Func, + Ret_Typ => Return_Obj_Typ, + Alloc_Expr => Heap_Allocator))); -- If a separate initialization assignment was created -- earlier, append that following the assignment of the @@ -4839,7 +5096,9 @@ package body Exp_Ch6 is if Present (Init_Assignment) then Rewrite (Name (Init_Assignment), Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Alloc_Obj_Id, Loc))); + Prefix => + New_Reference_To (Alloc_Obj_Id, Loc))); + Set_Etype (Name (Init_Assignment), Etype (Return_Obj_Id)); @@ -4848,7 +5107,7 @@ package body Exp_Ch6 is Init_Assignment); end if; - Insert_Before (Return_Object_Decl, Alloc_If_Stmt); + Insert_Before (Ret_Obj_Decl, Alloc_If_Stmt); -- Remember the local access object for use in the -- dereference of the renaming created below. @@ -4863,15 +5122,16 @@ package body Exp_Ch6 is Obj_Acc_Deref := Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Object_Access, Loc)); + Prefix => + New_Reference_To (Object_Access, Loc)); - Rewrite (Return_Object_Decl, + Rewrite (Ret_Obj_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)); + 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; @@ -4880,49 +5140,23 @@ package body Exp_Ch6 is -- 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); - - -- The expansion of the return expression may create a finalization - -- chain to service transient temporaries. The entity of the chain - -- appears as a semantic attribute of the return statement scope. - -- For the chain to be handled properly by Expand_Cleanup_Actions, - -- the return statement is wrapped in a block and reanalyzed. - - if Present - (Finalization_Chain_Entity (Return_Statement_Entity (N))) - then - Result := - Make_Block_Statement (Loc, - Declarations => Return_Object_Declarations (N), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Return_Stm))); - - -- Propagate the return statement scope to the block in order to - -- preserve the various semantic fields. - - Set_Identifier - (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc)); - 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. - - Insert_List_Before (N, Return_Object_Declarations (N)); - - Result := Return_Stm; - end if; + Return_Stmt := Make_Simple_Return_Statement (Loc, Expression => Exp); + Result := Return_Stmt; end if; -- Set the flag to prevent infinite recursion - Set_Comes_From_Extended_Return_Statement (Return_Stm); + Set_Comes_From_Extended_Return_Statement (Return_Stmt); Rewrite (N, Result); Analyze (N); @@ -6557,7 +6791,7 @@ package body Exp_Ch6 is Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)))); while Present (Iface_DT_Ptr) - and then Ekind (Node (Iface_DT_Ptr)) = E_Constant + and then Ekind (Node (Iface_DT_Ptr)) = E_Constant loop pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); @@ -6600,7 +6834,7 @@ package body Exp_Ch6 is pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); -- Skip the tag of the predefined primitives no-thunks dispatch - -- table + -- table. Next_Elmt (Iface_DT_Ptr); pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); @@ -6611,7 +6845,7 @@ package body Exp_Ch6 is -- Local variables - Subp : constant Entity_Id := Entity (N); + Subp : constant Entity_Id := Entity (N); -- Start of processing for Freeze_Subprogram @@ -6862,7 +7096,7 @@ package body Exp_Ch6 is Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); - Add_Final_List_Actual_To_Build_In_Place_Call + Add_Collection_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Acc_Type); Add_Task_Actuals_To_Build_In_Place_Call @@ -6890,14 +7124,13 @@ package body Exp_Ch6 is -- operations. ??? else - -- Pass an allocation parameter indicating that the function should -- allocate its result on the heap. Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Alloc_Form => Global_Heap); - Add_Final_List_Actual_To_Build_In_Place_Call + Add_Collection_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Acc_Type); Add_Task_Actuals_To_Build_In_Place_Call @@ -6910,6 +7143,30 @@ package body Exp_Ch6 is (Func_Call, Function_Id, Return_Object => Empty); end if; + -- If the build-in-place function call returns a controlled object, the + -- finalization collection will require a reference to routine Finalize_ + -- Address of the designated type. Setting this attribute is done in the + -- same manner to expansion of allocators. + + if Needs_Finalization (Result_Subt) then + + -- Controlled types with supressed finalization do not need to + -- associate the address of their Finalize_Address primitives with a + -- collection since they do not need a collection to begin with. + + if Is_Library_Level_Entity (Acc_Type) + and then Finalize_Storage_Only (Result_Subt) + then + null; + + else + Insert_Action (Allocator, + Make_Set_Finalize_Address_Ptr_Call (Loc, + Typ => Etype (Function_Id), + Ptr_Typ => Acc_Type)); + end if; + end if; + -- Finally, replace the allocator node with a reference to the result -- of the function call itself (which will effectively be an access -- to the object created by the allocator). @@ -6970,10 +7227,47 @@ package body Exp_Ch6 is Result_Subt := Etype (Function_Id); + -- If the build-in-place function returns a controlled object, then the + -- object needs to be finalized immediately after the context. Since + -- this case produces a transient scope, the servicing finalizer needs + -- to name the returned object. Create a temporary which is initialized + -- with the function call: + -- + -- Temp_Id : Func_Type := BIP_Func_Call; + -- + -- The initialization expression of the temporary will be rewritten by + -- the expander using the appropriate mechanism in Make_Build_In_Place_ + -- Call_In_Object_Declaration. + + if Needs_Finalization (Result_Subt) then + declare + Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R'); + Temp_Decl : Node_Id; + + begin + -- Reset the guard on the function call since the following does + -- not perform actual call expansion. + + Set_Is_Expanded_Build_In_Place_Call (Func_Call, False); + + Temp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Object_Definition => + New_Reference_To (Result_Subt, Loc), + Expression => + New_Copy_Tree (Function_Call)); + + Insert_Action (Function_Call, Temp_Decl); + + Rewrite (Function_Call, New_Reference_To (Temp_Id, Loc)); + Analyze (Function_Call); + end; + -- When the result subtype is constrained, an object of the subtype is -- declared and an access value designating it is passed as an actual. - if Is_Constrained (Underlying_Type (Result_Subt)) then + elsif Is_Constrained (Underlying_Type (Result_Subt)) then -- Create a temporary object to hold the function result @@ -6999,8 +7293,8 @@ package body Exp_Ch6 is Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); - Add_Final_List_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, Acc_Type => Empty); + Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id); Add_Task_Actuals_To_Build_In_Place_Call (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); @@ -7023,8 +7317,8 @@ package body Exp_Ch6 is Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); - Add_Final_List_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, Acc_Type => Empty); + Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id); Add_Task_Actuals_To_Build_In_Place_Call (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); @@ -7101,16 +7395,8 @@ package body Exp_Ch6 is Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Func_Id, Alloc_Form => Caller_Allocation); - -- If Lhs is a selected component, then pass it along so that its prefix - -- object will be used as the source of the finalization list. - - if Nkind (Lhs) = N_Selected_Component then - Add_Final_List_Actual_To_Build_In_Place_Call - (Func_Call, Func_Id, Acc_Type => Empty, Sel_Comp => Lhs); - else - Add_Final_List_Actual_To_Build_In_Place_Call - (Func_Call, Func_Id, Acc_Type => Empty); - end if; + Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call, Func_Id); Add_Task_Actuals_To_Build_In_Place_Call (Func_Call, Func_Id, Make_Identifier (Loc, Name_uMaster)); @@ -7176,58 +7462,6 @@ package body Exp_Ch6 is else return; end if; - - -- When the target of the assignment is a return object of an enclosing - -- build-in-place function and also requires finalization, the list - -- generated for the assignment must be moved to that of the enclosing - -- function. - - -- function Enclosing_BIP_Function return Ctrl_Typ is - -- begin - -- return (Ctrl_Parent_Part => BIP_Function with ...); - -- end Enclosing_BIP_Function; - - if Is_Return_Object (Target) - and then Needs_Finalization (Etype (Target)) - and then Needs_Finalization (Result_Subt) - then - declare - Obj_List : constant Node_Id := Find_Final_List (Obj_Id); - Encl_List : Node_Id; - Encl_Scop : Entity_Id; - - begin - Encl_Scop := Scope (Target); - - -- Locate the scope of the extended return statement - - while Present (Encl_Scop) - and then Ekind (Encl_Scop) /= E_Return_Statement - loop - Encl_Scop := Scope (Encl_Scop); - end loop; - - -- A return object should always be enclosed by a return statement - -- scope at some level. - - pragma Assert (Present (Encl_Scop)); - - Encl_List := - Make_Attribute_Reference (Loc, - Prefix => - New_Reference_To ( - Finalization_Chain_Entity (Encl_Scop), Loc), - Attribute_Name => Name_Unrestricted_Access); - - -- Generate a call to move final list - - Insert_After_And_Analyze (Obj_Decl, - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Move_Final_List), Loc), - Parameter_Associations => New_List (Obj_List, Encl_List))); - end; - end if; end Make_Build_In_Place_Call_In_Assignment; ---------------------------------------------------- @@ -7377,8 +7611,8 @@ package body Exp_Ch6 is Establish_Transient_Scope (Object_Decl, Sec_Stack => True); end if; - Add_Final_List_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, Acc_Type => Empty); + Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id); if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement and then Has_Task (Result_Subt) @@ -7525,23 +7759,17 @@ package body Exp_Ch6 is end Make_Build_In_Place_Call_In_Object_Declaration; -------------------------- - -- Needs_BIP_Final_List -- + -- Needs_BIP_Collection -- -------------------------- - function Needs_BIP_Final_List (E : Entity_Id) return Boolean is - pragma Assert (Is_Build_In_Place_Function (E)); - Result_Subt : constant Entity_Id := Underlying_Type (Etype (E)); + function Needs_BIP_Collection (Func_Id : Entity_Id) return Boolean is + pragma Assert (Is_Build_In_Place_Function (Func_Id)); + Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); begin - -- We need the BIP_Final_List if the result type needs finalization. We - -- also need it for tagged types, even if not class-wide, because some - -- type extension might need finalization, and all overriding functions - -- must have the same calling conventions. However, if there is a - -- pragma Restrictions (No_Finalization), we never need this parameter. - - return (Needs_Finalization (Result_Subt) - or else Is_Tagged_Type (Underlying_Type (Result_Subt))) - and then not Restriction_Active (No_Finalization); - end Needs_BIP_Final_List; + return + not Restriction_Active (No_Finalization) + and then Needs_Finalization (Func_Typ); + end Needs_BIP_Collection; end Exp_Ch6; |