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

1 files changed, 1079 insertions, 38 deletions

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 7557a12..9388e66 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -312,6 +312,320 @@ package body Exp_Util is
       end if;
    end Append_Freeze_Actions;
 
+   ------------------------------------
+   -- Build_Allocate_Deallocate_Proc --
+   ------------------------------------
+
+   procedure Build_Allocate_Deallocate_Proc
+     (N           : Node_Id;
+      Is_Allocate : Boolean)
+   is
+      Expr      : constant Node_Id   := Expression (N);
+      Ptr_Typ   : constant Entity_Id := Etype (Expr);
+      Desig_Typ : constant Entity_Id :=
+                    Available_View (Designated_Type (Ptr_Typ));
+
+      function Find_Object (E : Node_Id) return Node_Id;
+      --  Given an arbitrary expression of an allocator, try to find an object
+      --  reference in it, otherwise return the original expression.
+
+      function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean;
+      --  Determine whether subprogram Subp denotes a custom allocate or
+      --  deallocate.
+
+      -----------------
+      -- Find_Object --
+      -----------------
+
+      function Find_Object (E : Node_Id) return Node_Id is
+         Expr   : Node_Id := E;
+         Change : Boolean := True;
+
+      begin
+         pragma Assert (Is_Allocate);
+
+         while Change loop
+            Change := False;
+
+            if Nkind_In (Expr, N_Qualified_Expression,
+                               N_Unchecked_Type_Conversion)
+            then
+               Expr   := Expression (Expr);
+               Change := True;
+
+            elsif Nkind (Expr) = N_Explicit_Dereference then
+               Expr   := Prefix (Expr);
+               Change := True;
+            end if;
+         end loop;
+
+         return Expr;
+      end Find_Object;
+
+      ---------------------------------
+      -- Is_Allocate_Deallocate_Proc --
+      ---------------------------------
+
+      function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
+      begin
+         --  Look for a subprogram body with only one statement which is a
+         --  call to one of the Allocate / Deallocate routines in package
+         --  Ada.Finalization.Heap_Management.
+
+         if Ekind (Subp) = E_Procedure
+           and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
+         then
+            declare
+               HSS  : constant Node_Id :=
+                        Handled_Statement_Sequence (Parent (Parent (Subp)));
+               Proc : Entity_Id;
+
+            begin
+               if Present (Statements (HSS))
+                 and then Nkind (First (Statements (HSS))) =
+                            N_Procedure_Call_Statement
+               then
+                  Proc := Entity (Name (First (Statements (HSS))));
+
+                  return
+                    Is_RTE (Proc, RE_Allocate)
+                      or else Is_RTE (Proc, RE_Deallocate);
+               end if;
+            end;
+         end if;
+
+         return False;
+      end Is_Allocate_Deallocate_Proc;
+
+   --  Start of processing for Build_Allocate_Deallocate_Proc
+
+   begin
+      --  The allocation / deallocation of a non-controlled object does not
+      --  need the machinery created by this routine.
+
+      if not Needs_Finalization (Desig_Typ) then
+         return;
+
+      --  The allocator or free statmenet has already been expanded and already
+      --  has a custom Allocate / Deallocate routine.
+
+      elsif Nkind (Expr) = N_Allocator
+        and then Present (Procedure_To_Call (Expr))
+        and then Is_Allocate_Deallocate_Proc (Procedure_To_Call (Expr))
+      then
+         return;
+      end if;
+
+      declare
+         Loc     : constant Source_Ptr := Sloc (N);
+         Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
+         Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
+         Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
+         Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
+
+         Actuals      : List_Id;
+         Collect_Act  : Node_Id;
+         Collect_Id   : Entity_Id;
+         Collect_Typ  : Entity_Id;
+         Proc_To_Call : Entity_Id;
+
+      begin
+         --  When dealing with an access subtype, use the collection of the
+         --  base type.
+
+         if Ekind (Ptr_Typ) = E_Access_Subtype then
+            Collect_Typ := Base_Type (Ptr_Typ);
+         else
+            Collect_Typ := Ptr_Typ;
+         end if;
+
+         Collect_Id  := Associated_Collection (Collect_Typ);
+         Collect_Act := New_Reference_To (Collect_Id, Loc);
+
+         --  Handle the case where the collection is actually a pointer to a
+         --  collection. This case arises in build-in-place functions.
+
+         if Is_Access_Type (Etype (Collect_Id)) then
+            Collect_Act :=
+              Make_Explicit_Dereference (Loc,
+                Prefix => Collect_Act);
+         end if;
+
+         --  Create the actuals for the call to Allocate / Deallocate
+
+         Actuals := New_List (
+           Collect_Act,
+           New_Reference_To (Addr_Id, Loc),
+           New_Reference_To (Size_Id, Loc),
+           New_Reference_To (Alig_Id, Loc));
+
+         --  Generate a run-time check to determine whether a class-wide object
+         --  is truly controlled.
+
+         if Is_Class_Wide_Type (Desig_Typ)
+           or else Is_Generic_Actual_Type (Desig_Typ)
+         then
+            declare
+               Flag_Id   : constant Entity_Id := Make_Temporary (Loc, 'F');
+               Flag_Expr : Node_Id;
+               Param     : Node_Id;
+               Temp      : Node_Id;
+
+            begin
+               if Is_Allocate then
+                  Temp := Find_Object (Expression (Expr));
+               else
+                  Temp := Expr;
+               end if;
+
+               --  Processing for generic actuals
+
+               if Is_Generic_Actual_Type (Desig_Typ) then
+                  Flag_Expr :=
+                    New_Reference_To (Boolean_Literals
+                      (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
+
+               --  Processing for subtype indications
+
+               elsif Nkind (Temp) in N_Has_Entity
+                 and then Is_Type (Entity (Temp))
+               then
+                  Flag_Expr :=
+                    New_Reference_To (Boolean_Literals
+                      (Needs_Finalization (Entity (Temp))), Loc);
+
+               --  Generate a runtime check to test the controlled state of an
+               --  object for the purposes of allocation / deallocation.
+
+               else
+                  --  The following case arises when allocating through an
+                  --  interface class-wide type, generate:
+                  --
+                  --    Temp.all
+
+                  if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
+                     Param :=
+                       Make_Explicit_Dereference (Loc,
+                         Prefix =>
+                           Relocate_Node (Temp));
+
+                  --  Generate:
+                  --    Temp'Tag
+
+                  else
+                     Param :=
+                       Make_Attribute_Reference (Loc,
+                         Prefix =>
+                           Relocate_Node (Temp),
+                         Attribute_Name => Name_Tag);
+                  end if;
+
+                  --  Generate:
+                  --    Needs_Finalization (Param)
+
+                  Flag_Expr :=
+                    Make_Function_Call (Loc,
+                      Name =>
+                        New_Reference_To (RTE (RE_Needs_Finalization), Loc),
+                      Parameter_Associations => New_List (Param));
+               end if;
+
+               --  Create the temporary which represents the finalization state
+               --  of the expression. Generate:
+               --
+               --    F : constant Boolean := <Flag_Expr>;
+
+               Insert_Action (N,
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => Flag_Id,
+                   Constant_Present => True,
+                   Object_Definition =>
+                     New_Reference_To (Standard_Boolean, Loc),
+                   Expression => Flag_Expr));
+
+               --  The flag acts as the fifth actual
+
+               Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
+            end;
+         end if;
+
+         --  Select the proper routine to call
+
+         if Is_Allocate then
+            Proc_To_Call := RTE (RE_Allocate);
+         else
+            Proc_To_Call := RTE (RE_Deallocate);
+         end if;
+
+         --  Create a custom Allocate / Deallocate routine which has identical
+         --  profile to that of System.Storage_Pools.
+
+         Insert_Action (N,
+           Make_Subprogram_Body (Loc,
+             Specification =>
+
+               --  procedure Pnn
+
+               Make_Procedure_Specification (Loc,
+                 Defining_Unit_Name => Proc_Id,
+                 Parameter_Specifications => New_List (
+
+                  --  P : Root_Storage_Pool
+
+                   Make_Parameter_Specification (Loc,
+                     Defining_Identifier =>
+                       Make_Temporary (Loc, 'P'),
+                     Parameter_Type =>
+                       New_Reference_To (RTE (RE_Root_Storage_Pool), Loc)),
+
+                  --  A : [out] Address
+
+                   Make_Parameter_Specification (Loc,
+                     Defining_Identifier => Addr_Id,
+                     Out_Present => Is_Allocate,
+                     Parameter_Type =>
+                       New_Reference_To (RTE (RE_Address), Loc)),
+
+                  --  S : Storage_Count
+
+                   Make_Parameter_Specification (Loc,
+                     Defining_Identifier => Size_Id,
+                     Parameter_Type =>
+                       New_Reference_To (RTE (RE_Storage_Count), Loc)),
+
+                  --  L : Storage_Count
+
+                   Make_Parameter_Specification (Loc,
+                     Defining_Identifier => Alig_Id,
+                     Parameter_Type =>
+                       New_Reference_To (RTE (RE_Storage_Count), Loc)))),
+
+             Declarations => No_List,
+
+             Handled_Statement_Sequence =>
+               Make_Handled_Sequence_Of_Statements (Loc,
+                 Statements => New_List (
+
+                  --  Allocate / Deallocate
+                  --    (<Ptr_Typ collection>, A, S, L[, F]);
+
+                   Make_Procedure_Call_Statement (Loc,
+                     Name =>
+                       New_Reference_To (Proc_To_Call, Loc),
+                     Parameter_Associations => Actuals)))));
+
+         --  The newly generated Allocate / Deallocate becomes the default
+         --  procedure to call when the back end processes the allocation /
+         --  deallocation.
+
+         if Is_Allocate then
+            Set_Procedure_To_Call (Expr, Proc_Id);
+         else
+            Set_Procedure_To_Call (N, Proc_Id);
+         end if;
+      end;
+   end Build_Allocate_Deallocate_Proc;
+
    ------------------------
    -- Build_Runtime_Call --
    ------------------------
@@ -1351,13 +1665,17 @@ package body Exp_Util is
 
       --  Renamings of class-wide interface types require no equivalent
       --  constrained type declarations because we only need to reference
-      --  the tag component associated with the interface.
+      --  the tag component associated with the interface. The same is
+      --  presumably true for class-wide types in general, so this test
+      --  is broadened to include all class-wide renamings, which also
+      --  avoids cases of unbounded recursion in Remove_Side_Effects.
+      --  (Is this really correct, or are there some cases of class-wide
+      --  renamings that require action in this procedure???)
 
       elsif Present (N)
         and then Nkind (N) = N_Object_Renaming_Declaration
-        and then Is_Interface (Unc_Type)
+        and then Is_Class_Wide_Type (Unc_Type)
       then
-         pragma Assert (Is_Class_Wide_Type (Unc_Type));
          null;
 
       --  In Ada95 nothing to be done if the type of the expression is limited,
@@ -1428,11 +1746,12 @@ package body Exp_Util is
 
          while Present (Init_Call) and then Init_Call /= Rep_Clause loop
             if Nkind (Init_Call) = N_Procedure_Call_Statement
-                 and then Is_Entity_Name (Name (Init_Call))
-                 and then Entity (Name (Init_Call)) = Init_Proc
+              and then Is_Entity_Name (Name (Init_Call))
+              and then Entity (Name (Init_Call)) = Init_Proc
             then
                return Init_Call;
             end if;
+
             Next (Init_Call);
          end loop;
 
@@ -1461,8 +1780,8 @@ package body Exp_Util is
       --  applying to Var).
 
       if No (Init_Call) and then Present (Freeze_Node (Var)) then
-         Init_Call := Find_Init_Call_In_List
-                        (First (Actions (Freeze_Node (Var))));
+         Init_Call :=
+           Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
       end if;
 
       return Init_Call;
@@ -1701,8 +2020,11 @@ package body Exp_Util is
      (T    : Entity_Id;
       Name : TSS_Name_Type) return Entity_Id
    is
-      Prim : Elmt_Id;
-      Typ  : Entity_Id := T;
+      Inher_Op  : Entity_Id := Empty;
+      Own_Op    : Entity_Id := Empty;
+      Prim_Elmt : Elmt_Id;
+      Prim_Id   : Entity_Id;
+      Typ       : Entity_Id := T;
 
    begin
       if Is_Class_Wide_Type (Typ) then
@@ -1711,18 +2033,31 @@ package body Exp_Util is
 
       Typ := Underlying_Type (Typ);
 
-      Prim := First_Elmt (Primitive_Operations (Typ));
-      while not Is_TSS (Node (Prim), Name) loop
-         Next_Elmt (Prim);
+      --  This search is based on the assertion that the dispatching version
+      --  of the TSS routine always precedes the real primitive.
 
-         --  Raise program error if no primitive found
+      Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+      while Present (Prim_Elmt) loop
+         Prim_Id := Node (Prim_Elmt);
 
-         if No (Prim) then
-            raise Program_Error;
+         if Is_TSS (Prim_Id, Name) then
+            if Present (Alias (Prim_Id)) then
+               Inher_Op := Prim_Id;
+            else
+               Own_Op := Prim_Id;
+            end if;
          end if;
+
+         Next_Elmt (Prim_Elmt);
       end loop;
 
-      return Node (Prim);
+      if Present (Own_Op) then
+         return Own_Op;
+      elsif Present (Inher_Op) then
+         return Inher_Op;
+      else
+         raise Program_Error;
+      end if;
    end Find_Prim_Op;
 
    ----------------------------
@@ -1753,6 +2088,34 @@ package body Exp_Util is
       raise Program_Error;
    end Find_Protection_Object;
 
+   --------------------------
+   -- Find_Protection_Type --
+   --------------------------
+
+   function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
+      Comp : Entity_Id;
+      Typ  : Entity_Id := Conc_Typ;
+
+   begin
+      if Is_Concurrent_Type (Typ) then
+         Typ := Corresponding_Record_Type (Typ);
+      end if;
+
+      Comp := First_Component (Typ);
+      while Present (Comp) loop
+         if Chars (Comp) = Name_uObject then
+            return Base_Type (Etype (Comp));
+         end if;
+
+         Next_Component (Comp);
+      end loop;
+
+      --  The corresponding record of a protected type should always have an
+      --  _object field.
+
+      raise Program_Error;
+   end Find_Protection_Type;
+
    ----------------------
    -- Force_Evaluation --
    ----------------------
@@ -2190,45 +2553,254 @@ package body Exp_Util is
       end if;
    end Get_Stream_Size;
 
-   ---------------------------------
-   -- Has_Controlled_Coextensions --
-   ---------------------------------
+   ---------------------------
+   -- Has_Access_Constraint --
+   ---------------------------
 
-   function Has_Controlled_Coextensions (Typ : Entity_Id) return Boolean is
-      D_Typ : Entity_Id;
-      Discr : Entity_Id;
+   function Has_Access_Constraint (E : Entity_Id) return Boolean is
+      Disc : Entity_Id;
+      T    : constant Entity_Id := Etype (E);
 
    begin
-      --  Only consider record types
+      if Has_Per_Object_Constraint (E)
+        and then Has_Discriminants (T)
+      then
+         Disc := First_Discriminant (T);
+         while Present (Disc) loop
+            if Is_Access_Type (Etype (Disc)) then
+               return True;
+            end if;
+
+            Next_Discriminant (Disc);
+         end loop;
 
-      if not Ekind_In (Typ, E_Record_Type, E_Record_Subtype) then
+         return False;
+      else
          return False;
       end if;
+   end Has_Access_Constraint;
+
+   ----------------------------
+   -- Has_Controlled_Objects --
+   ----------------------------
 
-      if Has_Discriminants (Typ) then
-         Discr := First_Discriminant (Typ);
-         while Present (Discr) loop
-            D_Typ := Etype (Discr);
+   function Has_Controlled_Objects (N : Node_Id) return Boolean is
+      For_Pkg : constant Boolean :=
+                  Nkind_In (N, N_Package_Body, N_Package_Specification);
 
-            if Ekind (D_Typ) = E_Anonymous_Access_Type
+   begin
+      case Nkind (N) is
+         when N_Accept_Statement      |
+              N_Block_Statement       |
+              N_Entry_Body            |
+              N_Package_Body          |
+              N_Protected_Body        |
+              N_Subprogram_Body       |
+              N_Task_Body             =>
+            return Has_Controlled_Objects (Declarations (N), For_Pkg)
+                     or else
+
+                  --  An expanded sequence of statements may introduce
+                  --  controlled objects.
+
+                  (Present (Handled_Statement_Sequence (N))
+                     and then
+                   Has_Controlled_Objects
+                     (Statements (Handled_Statement_Sequence (N)), For_Pkg));
+
+         when N_Package_Specification =>
+            return Has_Controlled_Objects (Visible_Declarations (N), For_Pkg)
+                     or else
+                   Has_Controlled_Objects (Private_Declarations (N), For_Pkg);
+
+         when others                  =>
+            return False;
+      end case;
+   end Has_Controlled_Objects;
+
+   ----------------------------
+   -- Has_Controlled_Objects --
+   ----------------------------
+
+   function Has_Controlled_Objects
+     (L           : List_Id;
+      For_Package : Boolean) return Boolean
+   is
+      Decl    : Node_Id;
+      Expr    : Node_Id;
+      Obj_Id  : Entity_Id;
+      Obj_Typ : Entity_Id;
+      Pack_Id : Entity_Id;
+      Typ     : Entity_Id;
+
+   begin
+      if No (L)
+        or else Is_Empty_List (L)
+      then
+         return False;
+      end if;
+
+      Decl := First (L);
+      while Present (Decl) loop
+
+         --  Regular object declarations
+
+         if Nkind (Decl) = N_Object_Declaration then
+            Obj_Id  := Defining_Identifier (Decl);
+            Obj_Typ := Base_Type (Etype (Obj_Id));
+            Expr    := Expression (Decl);
+
+            --  Bypass any form of processing for objects which have their
+            --  finalization disabled. This applies only to objects at the
+            --  library level.
+
+            if For_Package
+              and then Finalize_Storage_Only (Obj_Typ)
+            then
+               null;
+
+            --  Transient variables are treated separately in order to minimize
+            --  the size of the generated code. See Exp_Ch7.Process_Transient_
+            --  Objects.
+
+            elsif Is_Processed_Transient (Obj_Id) then
+               null;
+
+            --  The object is of the form:
+            --    Obj : Typ [:= Expr];
+            --
+            --  Do not process the incomplete view of a deferred constant
+
+            elsif not Is_Imported (Obj_Id)
+              and then Needs_Finalization (Obj_Typ)
+              and then not (Ekind (Obj_Id) = E_Constant
+                              and then not Has_Completion (Obj_Id))
+            then
+               return True;
+
+            --  The object is of the form:
+            --    Obj : Access_Typ := Non_BIP_Function_Call'reference;
+            --
+            --    Obj : Access_Typ :=
+            --            BIP_Function_Call
+            --              (..., BIPaccess => null, ...)'reference;
+
+            elsif Is_Access_Type (Obj_Typ)
+              and then Needs_Finalization
+                         (Available_View (Designated_Type (Obj_Typ)))
+              and then Present (Expr)
               and then
-                (Is_Controlled (Designated_Type (D_Typ))
+                (Is_Null_Access_BIP_Func_Call (Expr)
                    or else
-                 Is_Concurrent_Type (Designated_Type (D_Typ)))
+                (Is_Non_BIP_Func_Call (Expr)
+                   and then not Is_Related_To_Func_Return (Obj_Id)))
+            then
+               return True;
+
+            --  Simple protected objects which use type System.Tasking.
+            --  Protected_Objects.Protection to manage their locks should be
+            --  treated as controlled since they require manual cleanup.
+
+            elsif Ekind (Obj_Id) = E_Variable
+              and then
+                (Is_Simple_Protected_Type (Obj_Typ)
+                   or else Has_Simple_Protected_Object (Obj_Typ))
             then
                return True;
             end if;
 
-            Next_Discriminant (Discr);
-         end loop;
-      end if;
+         --  Specific cases of object renamings
+
+         elsif Nkind (Decl) = N_Object_Renaming_Declaration
+           and then Nkind (Name (Decl)) = N_Explicit_Dereference
+           and then Nkind (Prefix (Name (Decl))) = N_Identifier
+         then
+            Obj_Id  := Defining_Identifier (Decl);
+            Obj_Typ := Base_Type (Etype (Obj_Id));
+
+            --  Bypass any form of processing for objects which have their
+            --  finalization disabled. This applies only to objects at the
+            --  library level.
+
+            if For_Package
+              and then Finalize_Storage_Only (Obj_Typ)
+            then
+               null;
+
+            --  Return object of a build-in-place function. This case is
+            --  recognized and marked by the expansion of an extended return
+            --  statement (see Expand_N_Extended_Return_Statement).
+
+            elsif Needs_Finalization (Obj_Typ)
+              and then Is_Return_Object (Obj_Id)
+              and then Present (Return_Flag (Obj_Id))
+            then
+               return True;
+            end if;
+
+         --  Inspect the freeze node of an access-to-controlled type and
+         --  look for a delayed finalization collection. This case arises
+         --  when the freeze actions are inserted at a later time than the
+         --  expansion of the context. Since Build_Finalizer is never called
+         --  on a single construct twice, the collection will be ultimately
+         --  left out and never finalized. This is also needed for freeze
+         --  actions of designated types themselves, since in some cases the
+         --  finalization collection is associated with a designated type's
+         --  freeze node rather than that of the access type (see handling
+         --  for freeze actions in Build_Finalization_Collection).
+
+         elsif Nkind (Decl) = N_Freeze_Entity
+           and then Present (Actions (Decl))
+         then
+            Typ := Entity (Decl);
+
+            if (Is_Access_Type (Typ)
+                  and then not Is_Access_Subprogram_Type (Typ)
+                  and then Needs_Finalization
+                             (Available_View (Designated_Type (Typ))))
+              or else
+               (Is_Type (Typ)
+                  and then Needs_Finalization (Typ))
+            then
+               return True;
+            end if;
+
+         --  Nested package declarations
+
+         elsif Nkind (Decl) = N_Package_Declaration then
+            Pack_Id := Defining_Unit_Name (Specification (Decl));
+
+            if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
+               Pack_Id := Defining_Identifier (Pack_Id);
+            end if;
+
+            if Ekind (Pack_Id) /= E_Generic_Package
+              and then Has_Controlled_Objects (Specification (Decl))
+            then
+               return True;
+            end if;
+
+         --  Nested package bodies
+
+         elsif Nkind (Decl) = N_Package_Body then
+            Pack_Id := Corresponding_Spec (Decl);
+
+            if Ekind (Pack_Id) /= E_Generic_Package
+              and then Has_Controlled_Objects (Decl)
+            then
+               return True;
+            end if;
+         end if;
+
+         Next (Decl);
+      end loop;
 
       return False;
-   end Has_Controlled_Coextensions;
+   end Has_Controlled_Objects;
 
-   ------------------------
-   -- Has_Address_Clause --
-   ------------------------
+   ----------------------------------
+   -- Has_Following_Address_Clause --
+   ----------------------------------
 
    --  Should this function check the private part in a package ???
 
@@ -2279,6 +2851,27 @@ package body Exp_Util is
       return Count;
    end Homonym_Number;
 
+   -----------------------------------
+   -- In_Library_Level_Package_Body --
+   -----------------------------------
+
+   function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is
+   begin
+      --  First determine whether the entity appears at the library level, then
+      --  look at the containing unit.
+
+      if Is_Library_Level_Entity (Id) then
+         declare
+            Container : constant Node_Id := Cunit (Get_Source_Unit (Id));
+
+         begin
+            return Nkind (Unit (Container)) = N_Package_Body;
+         end;
+      end if;
+
+      return False;
+   end In_Library_Level_Package_Body;
+
    ------------------------------
    -- In_Unconditional_Context --
    ------------------------------
@@ -2330,6 +2923,18 @@ package body Exp_Util is
       Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
    end Insert_Action;
 
+   -------------------------
+   -- Insert_Action_After --
+   -------------------------
+
+   procedure Insert_Action_After
+     (Assoc_Node : Node_Id;
+      Ins_Action : Node_Id)
+   is
+   begin
+      Insert_Actions_After (Assoc_Node, New_List (Ins_Action));
+   end Insert_Action_After;
+
    --------------------
    -- Insert_Actions --
    --------------------
@@ -3098,6 +3703,277 @@ package body Exp_Util is
       return True;
    end Is_All_Null_Statements;
 
+   ------------------------------
+   -- Is_Finalizable_Transient --
+   ------------------------------
+
+   function Is_Finalizable_Transient
+     (Decl     : Node_Id;
+      Rel_Node : Node_Id) return Boolean
+   is
+      Obj_Id   : constant Entity_Id := Defining_Identifier (Decl);
+      Obj_Typ  : constant Entity_Id := Base_Type (Etype (Obj_Id));
+      Desig    : Entity_Id := Obj_Typ;
+      Has_Rens : Boolean   := True;
+      Ren_Obj  : Entity_Id;
+
+      function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
+      --  Determine whether transient object Trans_Id is initialized either
+      --  by a function call which returns an access type or simply renames
+      --  another pointer.
+
+      function Initialized_By_Aliased_BIP_Func_Call
+        (Trans_Id : Entity_Id) return Boolean;
+      --  Determine whether transient object Trans_Id is initialized by a
+      --  build-in-place function call where the BIPalloc parameter is of
+      --  value 1 and BIPaccess is not null. This case creates an aliasing
+      --  between the returned value and the value denoted by BIPaccess.
+
+      function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
+      --  Determine whether transient object Trans_Id is allocated on the heap
+
+      function Is_Renamed
+        (Trans_Id   : Entity_Id;
+         First_Stmt : Node_Id) return Boolean;
+      --  Determine whether transient object Trans_Id has been renamed in the
+      --  statement list starting from First_Stmt.
+
+      ---------------------------
+      -- Initialized_By_Access --
+      ---------------------------
+
+      function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is
+         Expr : constant Node_Id := Expression (Parent (Trans_Id));
+
+      begin
+         return
+           Present (Expr)
+             and then Nkind (Expr) /= N_Reference
+             and then Is_Access_Type (Etype (Expr));
+      end Initialized_By_Access;
+
+      ------------------------------------------
+      -- Initialized_By_Aliased_BIP_Func_Call --
+      ------------------------------------------
+
+      function Initialized_By_Aliased_BIP_Func_Call
+        (Trans_Id : Entity_Id) return Boolean
+      is
+         Call : Node_Id := Expression (Parent (Trans_Id));
+
+      begin
+         --  Build-in-place calls usually appear in 'reference format
+
+         if Nkind (Call) = N_Reference then
+            Call := Prefix (Call);
+         end if;
+
+         if Is_Build_In_Place_Function_Call (Call) then
+            declare
+               Access_Nam : Name_Id := No_Name;
+               Access_OK  : Boolean := False;
+               Actual     : Node_Id;
+               Alloc_Nam  : Name_Id := No_Name;
+               Alloc_OK   : Boolean := False;
+               Formal     : Node_Id;
+               Func_Id    : Entity_Id;
+               Param      : Node_Id;
+
+            begin
+               --  Examine all parameter associations of the function call
+
+               Param := First (Parameter_Associations (Call));
+               while Present (Param) loop
+                  if Nkind (Param) = N_Parameter_Association
+                    and then Nkind (Selector_Name (Param)) = N_Identifier
+                  then
+                     Actual := Explicit_Actual_Parameter (Param);
+                     Formal := Selector_Name (Param);
+
+                     --  Construct the names of formals BIPaccess and BIPalloc
+                     --  using the function name retrieved from an arbitrary
+                     --  formal.
+
+                     if Access_Nam = No_Name
+                       and then Alloc_Nam = No_Name
+                       and then Present (Entity (Formal))
+                     then
+                        Func_Id := Scope (Entity (Formal));
+
+                        Access_Nam :=
+                          New_External_Name (Chars (Func_Id),
+                            BIP_Formal_Suffix (BIP_Object_Access));
+
+                        Alloc_Nam :=
+                          New_External_Name (Chars (Func_Id),
+                            BIP_Formal_Suffix (BIP_Alloc_Form));
+                     end if;
+
+                     --  A match for BIPaccess => Temp has been found
+
+                     if Chars (Formal) = Access_Nam
+                       and then Nkind (Actual) /= N_Null
+                     then
+                        Access_OK := True;
+                     end if;
+
+                     --  A match for BIPalloc => 1 has been found
+
+                     if Chars (Formal) = Alloc_Nam
+                       and then Nkind (Actual) = N_Integer_Literal
+                       and then Intval (Actual) = Uint_1
+                     then
+                        Alloc_OK := True;
+                     end if;
+                  end if;
+
+                  Next (Param);
+               end loop;
+
+               return Access_OK and then Alloc_OK;
+            end;
+         end if;
+
+         return False;
+      end Initialized_By_Aliased_BIP_Func_Call;
+
+      ------------------
+      -- Is_Allocated --
+      ------------------
+
+      function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
+         Expr : constant Node_Id := Expression (Parent (Trans_Id));
+
+      begin
+         return
+           Is_Access_Type (Etype (Trans_Id))
+             and then Present (Expr)
+             and then Nkind (Expr) = N_Allocator;
+      end Is_Allocated;
+
+      ----------------
+      -- Is_Renamed --
+      ----------------
+
+      function Is_Renamed
+        (Trans_Id   : Entity_Id;
+         First_Stmt : Node_Id) return Boolean
+      is
+         Stmt : Node_Id;
+
+         function Extract_Renamed_Object
+           (Ren_Decl : Node_Id) return Entity_Id;
+         --  Given an object renaming declaration, retrieve the entity of the
+         --  renamed name. Return Empty if the renamed name is anything other
+         --  than a variable or a constant.
+
+         ----------------------------
+         -- Extract_Renamed_Object --
+         ----------------------------
+
+         function Extract_Renamed_Object
+           (Ren_Decl : Node_Id) return Entity_Id
+         is
+            Change  : Boolean;
+            Ren_Obj : Node_Id;
+
+         begin
+            Change  := True;
+            Ren_Obj := Renamed_Object (Defining_Identifier (Ren_Decl));
+
+            while Change loop
+               Change := False;
+
+               if Nkind_In (Ren_Obj, N_Explicit_Dereference,
+                                     N_Indexed_Component,
+                                     N_Selected_Component)
+               then
+                  Ren_Obj := Prefix (Ren_Obj);
+                  Change := True;
+               end if;
+            end loop;
+
+            if Nkind (Ren_Obj) in N_Has_Entity then
+               return Entity (Ren_Obj);
+            end if;
+
+            return Empty;
+         end Extract_Renamed_Object;
+
+      --  Start of processing for Is_Renamed
+
+      begin
+         --  If a previous invocation of this routine has determined that a
+         --  list has no renamings, there is no point in repeating the same
+         --  scan.
+
+         if not Has_Rens then
+            return False;
+         end if;
+
+         --  Assume that the statement list does not have a renaming. This is a
+         --  minor optimization.
+
+         Has_Rens := False;
+
+         Stmt := First_Stmt;
+         while Present (Stmt) loop
+            if Nkind (Stmt) = N_Object_Renaming_Declaration then
+               Has_Rens := True;
+               Ren_Obj  := Extract_Renamed_Object (Stmt);
+
+               if Present (Ren_Obj)
+                 and then Ren_Obj = Trans_Id
+               then
+                  return True;
+               end if;
+            end if;
+
+            Next (Stmt);
+         end loop;
+
+         return False;
+      end Is_Renamed;
+
+   --  Start of processing for Is_Finalizable_Transient
+
+   begin
+      --  Handle access types
+
+      if Is_Access_Type (Desig) then
+         Desig := Available_View (Designated_Type (Desig));
+      end if;
+
+      return
+        Ekind_In (Obj_Id, E_Constant, E_Variable)
+          and then Needs_Finalization (Desig)
+          and then Requires_Transient_Scope (Desig)
+          and then Nkind (Rel_Node) /= N_Simple_Return_Statement
+
+         --  Do not consider transient objects allocated on the heap since they
+         --  are attached to a finalization collection.
+
+          and then not Is_Allocated (Obj_Id)
+
+         --  Do not consider renamed transient objects because the act of
+         --  renaming extends the object's lifetime.
+
+          and then not Is_Renamed (Obj_Id, Decl)
+
+         --  If the transient object is a pointer, check that it is not
+         --  initialized by a function which returns a pointer or acts as a
+         --  renaming of another pointer.
+
+          and then
+            (not Is_Access_Type (Obj_Typ)
+               or else not Initialized_By_Access (Obj_Id))
+
+         --  Do not consider transient objects which act as indirect aliases of
+         --  build-in-place function results.
+
+          and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id);
+   end Is_Finalizable_Transient;
+
    ---------------------------------
    -- Is_Fully_Repped_Tagged_Type --
    ---------------------------------
@@ -3146,6 +4022,90 @@ package body Exp_Util is
    end Is_Library_Level_Tagged_Type;
 
    ----------------------------------
+   -- Is_Null_Access_BIP_Func_Call --
+   ----------------------------------
+
+   function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean is
+      Call : Node_Id := Expr;
+
+   begin
+      --  Build-in-place calls usually appear in 'reference format
+
+      if Nkind (Call) = N_Reference then
+         Call := Prefix (Call);
+      end if;
+
+      if Nkind_In (Call, N_Qualified_Expression,
+                         N_Unchecked_Type_Conversion)
+      then
+         Call := Expression (Call);
+      end if;
+
+      if Is_Build_In_Place_Function_Call (Call) then
+         declare
+            Access_Nam : Name_Id := No_Name;
+            Actual     : Node_Id;
+            Param      : Node_Id;
+            Formal     : Node_Id;
+
+         begin
+            --  Examine all parameter associations of the function call
+
+            Param := First (Parameter_Associations (Call));
+            while Present (Param) loop
+               if Nkind (Param) = N_Parameter_Association
+                 and then Nkind (Selector_Name (Param)) = N_Identifier
+               then
+                  Formal := Selector_Name (Param);
+                  Actual := Explicit_Actual_Parameter (Param);
+
+                  --  Construct the name of formal BIPaccess. It is much easier
+                  --  to extract the name of the function using an arbitrary
+                  --  formal's scope rather than the Name field of Call.
+
+                  if Access_Nam = No_Name
+                    and then Present (Entity (Formal))
+                  then
+                     Access_Nam :=
+                       New_External_Name
+                         (Chars (Scope (Entity (Formal))),
+                          BIP_Formal_Suffix (BIP_Object_Access));
+                  end if;
+
+                  --  A match for BIPaccess => null has been found
+
+                  if Chars (Formal) = Access_Nam
+                    and then Nkind (Actual) = N_Null
+                  then
+                     return True;
+                  end if;
+               end if;
+
+               Next (Param);
+            end loop;
+         end;
+      end if;
+
+      return False;
+   end Is_Null_Access_BIP_Func_Call;
+
+   --------------------------
+   -- Is_Non_BIP_Func_Call --
+   --------------------------
+
+   function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
+   begin
+      --  The expected call is of the format
+      --
+      --    Func_Call'reference
+
+      return
+        Nkind (Expr) = N_Reference
+          and then Nkind (Prefix (Expr)) = N_Function_Call
+          and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
+   end Is_Non_BIP_Func_Call;
+
+   ----------------------------------
    -- Is_Possibly_Unaligned_Object --
    ----------------------------------
 
@@ -3427,6 +4387,20 @@ package body Exp_Util is
       end;
    end Is_Possibly_Unaligned_Slice;
 
+   -------------------------------
+   -- Is_Related_To_Func_Return --
+   -------------------------------
+
+   function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
+      Expr : constant Node_Id := Related_Expression (Id);
+
+   begin
+      return
+        Present (Expr)
+          and then Nkind (Expr) = N_Explicit_Dereference
+          and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
+   end Is_Related_To_Func_Return;
+
    --------------------------------
    -- Is_Ref_To_Bit_Packed_Array --
    --------------------------------
@@ -4341,6 +5315,73 @@ package body Exp_Util is
       end if;
    end May_Generate_Large_Temp;
 
+   ------------------------
+   -- Needs_Finalization --
+   ------------------------
+
+   function Needs_Finalization (T : Entity_Id) return Boolean is
+      function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
+      --  If type is not frozen yet, check explicitly among its components,
+      --  because the Has_Controlled_Component flag is not necessarily set.
+
+      -----------------------------------
+      -- Has_Some_Controlled_Component --
+      -----------------------------------
+
+      function Has_Some_Controlled_Component
+        (Rec : Entity_Id) return Boolean
+      is
+         Comp : Entity_Id;
+
+      begin
+         if Has_Controlled_Component (Rec) then
+            return True;
+
+         elsif not Is_Frozen (Rec) then
+            if Is_Record_Type (Rec) then
+               Comp := First_Entity (Rec);
+
+               while Present (Comp) loop
+                  if not Is_Type (Comp)
+                    and then Needs_Finalization (Etype (Comp))
+                  then
+                     return True;
+                  end if;
+
+                  Next_Entity (Comp);
+               end loop;
+
+               return False;
+
+            elsif Is_Array_Type (Rec) then
+               return Needs_Finalization (Component_Type (Rec));
+
+            else
+               return Has_Controlled_Component (Rec);
+            end if;
+         else
+            return False;
+         end if;
+      end Has_Some_Controlled_Component;
+
+   --  Start of processing for Needs_Finalization
+
+   begin
+      --  Class-wide types must be treated as controlled because they may
+      --  contain an extension that has controlled components
+
+      --  We can skip this if finalization is not available
+
+      return (Is_Class_Wide_Type (T)
+                and then not Restriction_Active (No_Finalization))
+        or else Is_Controlled (T)
+        or else Has_Controlled_Component (T)
+        or else Has_Some_Controlled_Component (T)
+        or else (Is_Concurrent_Type (T)
+                  and then Present (Corresponding_Record_Type (T))
+                  and then Needs_Finalization (Corresponding_Record_Type (T)));
+   end Needs_Finalization;
+
    ----------------------------
    -- Needs_Constant_Address --
    ----------------------------