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_ch4.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_ch4.adb')
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 818 |
1 files changed, 311 insertions, 507 deletions
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 1487f77..95b23d8 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -44,6 +44,7 @@ with Exp_Util; use Exp_Util; with Exp_VFpt; use Exp_VFpt; with Freeze; use Freeze; with Inline; use Inline; +with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -56,7 +57,6 @@ with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; -with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; @@ -91,6 +91,13 @@ package body Exp_Ch4 is -- If a boolean array assignment can be done in place, build call to -- corresponding library procedure. + procedure Complete_Controlled_Allocation (Temp_Decl : Node_Id); + -- Subsidiary to Expand_N_Allocator and Expand_Allocator_Expression. Formal + -- Temp_Decl is the declaration of a temporary which hold the value of the + -- original allocator. Create a custom Allocate routine for the expression + -- of Temp_Decl. The routine does special processing for anonymous access + -- types. + procedure Displace_Allocator_Pointer (N : Node_Id); -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and -- Expand_Allocator_Expression. Allocating class-wide interface objects @@ -158,14 +165,6 @@ package body Exp_Ch4 is -- routine is to find the real type by looking up the tree. We also -- determine if the operation must be rounded. - function Get_Allocator_Final_List - (N : Node_Id; - T : Entity_Id; - PtrT : Entity_Id) return Entity_Id; - -- If the designated type is controlled, build final_list expression for - -- created object. If context is an access parameter, create a local access - -- type to have a usable finalization list. - function Has_Inferable_Discriminants (N : Node_Id) return Boolean; -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable -- discriminants if it has a constrained nominal type, unless the object @@ -375,6 +374,113 @@ package body Exp_Ch4 is return; end Build_Boolean_Array_Proc_Call; + ------------------------------------ + -- Complete_Controlled_Allocation -- + ------------------------------------ + + procedure Complete_Controlled_Allocation (Temp_Decl : Node_Id) is + pragma Assert (Nkind (Temp_Decl) = N_Object_Declaration); + + Ptr_Typ : constant Entity_Id := Etype (Defining_Identifier (Temp_Decl)); + + function First_Declaration_Of_Current_Unit return Node_Id; + -- Return the current unit's first declaration. If the declaration list + -- is empty, the routine generates a null statement and returns it. + + --------------------------------------- + -- First_Declaration_Of_Current_Unit -- + --------------------------------------- + + function First_Declaration_Of_Current_Unit return Node_Id is + Sem_U : Node_Id := Unit (Cunit (Current_Sem_Unit)); + Decl : Node_Id; + Decls : List_Id; + + begin + if Nkind (Sem_U) = N_Package_Declaration then + Sem_U := Specification (Sem_U); + Decls := Visible_Declarations (Sem_U); + + if No (Decls) then + Decl := Make_Null_Statement (Sloc (Sem_U)); + Decls := New_List (Decl); + Set_Visible_Declarations (Sem_U, Decls); + else + Decl := First (Decls); + end if; + + else + Decls := Declarations (Sem_U); + + if No (Decls) then + Decl := Make_Null_Statement (Sloc (Sem_U)); + Decls := New_List (Decl); + Set_Declarations (Sem_U, Decls); + else + Decl := First (Decls); + end if; + end if; + + return Decl; + end First_Declaration_Of_Current_Unit; + + -- Start of processing for Complete_Controlled_Allocation + + begin + -- Do nothing if the access type may never allocate an object + + if No_Pool_Assigned (Ptr_Typ) then + return; + + -- Access-to-controlled types are not supported on .NET/JVM + + elsif VM_Target /= No_VM then + return; + end if; + + -- Processing for anonymous access-to-controlled types. These access + -- types receive a special collection which appears on the declarations + -- of the enclosing semantic unit. + + if Ekind (Ptr_Typ) = E_Anonymous_Access_Type + and then No (Associated_Collection (Ptr_Typ)) + and then + (not Restriction_Active (No_Nested_Finalization) + or else Is_Library_Level_Entity (Ptr_Typ)) + then + declare + Pool_Id : constant Entity_Id := RTE (RE_Global_Pool_Object); + Scop : Node_Id := Cunit_Entity (Current_Sem_Unit); + + begin + -- Use the scope of the current semantic unit when analyzing + + if Ekind (Scop) = E_Subprogram_Body then + Scop := Corresponding_Spec (Parent (Parent (Parent (Scop)))); + end if; + + Build_Finalization_Collection + (Typ => Ptr_Typ, + Ins_Node => First_Declaration_Of_Current_Unit, + Encl_Scope => Scop); + + -- Decorate the anonymous access type and the allocator node + + Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); + Set_Storage_Pool (Expression (Temp_Decl), Pool_Id); + end; + end if; + + -- Since the temporary object reuses the original allocator, generate a + -- custom Allocate routine for the temporary. + + if Present (Associated_Collection (Ptr_Typ)) then + Build_Allocate_Deallocate_Proc + (N => Temp_Decl, + Is_Allocate => True); + end if; + end Complete_Controlled_Allocation; + -------------------------------- -- Displace_Allocator_Pointer -- -------------------------------- @@ -545,28 +651,30 @@ package body Exp_Ch4 is end if; Insert_Action (N, - Make_Raise_Program_Error (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => - Build_Get_Access_Level (Loc, - Make_Attribute_Reference (Loc, - Prefix => Ref_Node, - Attribute_Name => Name_Tag)), - Right_Opnd => - Make_Integer_Literal (Loc, - Type_Access_Level (PtrT))), - Reason => PE_Accessibility_Check_Failed)); + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => + Build_Get_Access_Level (Loc, + Make_Attribute_Reference (Loc, + Prefix => Ref_Node, + Attribute_Name => Name_Tag)), + Right_Opnd => + Make_Integer_Literal (Loc, + Type_Access_Level (PtrT))), + Reason => PE_Accessibility_Check_Failed)); end if; end Apply_Accessibility_Check; -- Local variables - Indic : constant Node_Id := Subtype_Mark (Expression (N)); - T : constant Entity_Id := Entity (Indic); - Flist : Node_Id; - Node : Node_Id; - Temp : Entity_Id; + Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp); + Indic : constant Node_Id := Subtype_Mark (Expression (N)); + T : constant Entity_Id := Entity (Indic); + Node : Node_Id; + Tag_Assign : Node_Id; + Temp : Entity_Id; + Temp_Decl : Node_Id; TagT : Entity_Id := Empty; -- Type used as source for tag assignment @@ -574,39 +682,37 @@ package body Exp_Ch4 is TagR : Node_Id := Empty; -- Target reference for tag assignment - Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp); - - Tag_Assign : Node_Id; - Tmp_Node : Node_Id; - -- Start of processing for Expand_Allocator_Expression begin - if Is_Tagged_Type (T) or else Needs_Finalization (T) then - + if Is_Tagged_Type (T) + or else Needs_Finalization (T) + then if Is_CPP_Constructor_Call (Exp) then -- Generate: - -- Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn + -- Pnnn : constant ptr_T := new (T); + -- Init (Pnnn.all,...); - -- Allocate the object with no expression + -- Allocate the object without an expression Node := Relocate_Node (N); Set_Expression (Node, New_Reference_To (Etype (Exp), Loc)); -- Avoid its expansion to avoid generating a call to the default - -- C++ constructor + -- C++ constructor. Set_Analyzed (Node); Temp := Make_Temporary (Loc, 'P', N); - Insert_Action (N, + Temp_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Constant_Present => True, Object_Definition => New_Reference_To (PtrT, Loc), - Expression => Node)); + Expression => Node); + Insert_Action (N, Temp_Decl); Apply_Accessibility_Check (Temp); @@ -698,7 +804,6 @@ package body Exp_Ch4 is Make_Attribute_Reference (Loc, Prefix => Exp, Attribute_Name => Name_Address))))); - else Set_Expression (Expression (N), @@ -708,17 +813,18 @@ package body Exp_Ch4 is Analyze_And_Resolve (Expression (N), Entity (Indic)); end if; - -- Keep separate the management of allocators returning interfaces + -- Processing for allocators returning non-interface types if not Is_Interface (Directly_Designated_Type (PtrT)) then if Aggr_In_Place then - Tmp_Node := + Temp_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => New_Reference_To (PtrT, Loc), Expression => Make_Allocator (Loc, - New_Reference_To (Etype (Exp), Loc))); + Expression => + New_Reference_To (Etype (Exp), Loc))); -- Copy the Comes_From_Source flag for the allocator we just -- built, since logically this allocator is a replacement of @@ -726,30 +832,27 @@ package body Exp_Ch4 is -- restriction No_Implicit_Heap_Allocations. Set_Comes_From_Source - (Expression (Tmp_Node), Comes_From_Source (N)); + (Expression (Temp_Decl), Comes_From_Source (N)); - Set_No_Initialization (Expression (Tmp_Node)); - Insert_Action (N, Tmp_Node); + Set_No_Initialization (Expression (Temp_Decl)); + Insert_Action (N, Temp_Decl); - if Needs_Finalization (T) - and then Ekind (PtrT) = E_Anonymous_Access_Type - then - -- Create local finalization list for access parameter - - Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT); - end if; - - Convert_Aggr_In_Allocator (N, Tmp_Node, Exp); + Complete_Controlled_Allocation (Temp_Decl); + Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); else Node := Relocate_Node (N); Set_Analyzed (Node); - Insert_Action (N, + + Temp_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Constant_Present => True, Object_Definition => New_Reference_To (PtrT, Loc), - Expression => Node)); + Expression => Node); + + Insert_Action (N, Temp_Decl); + Complete_Controlled_Allocation (Temp_Decl); end if; -- Ada 2005 (AI-251): Handle allocators whose designated type is an @@ -775,18 +878,19 @@ package body Exp_Ch4 is Insert_Action (N, New_Decl); - -- Inherit the final chain to ensure that the expansion of the - -- aggregate is correct in case of controlled types + -- Inherit the allocation-related attributes from the original + -- access type. - if Needs_Finalization (Directly_Designated_Type (PtrT)) then - Set_Associated_Final_Chain (Def_Id, - Associated_Final_Chain (PtrT)); - end if; + Set_Associated_Collection (Def_Id, + Associated_Collection (PtrT)); + + Set_Associated_Storage_Pool (Def_Id, + Associated_Storage_Pool (PtrT)); -- Declare the object using the previous type declaration if Aggr_In_Place then - Tmp_Node := + Temp_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => New_Reference_To (Def_Id, Loc), @@ -800,30 +904,27 @@ package body Exp_Ch4 is -- of restriction No_Implicit_Heap_Allocations. Set_Comes_From_Source - (Expression (Tmp_Node), Comes_From_Source (N)); - - Set_No_Initialization (Expression (Tmp_Node)); - Insert_Action (N, Tmp_Node); + (Expression (Temp_Decl), Comes_From_Source (N)); - if Needs_Finalization (T) - and then Ekind (PtrT) = E_Anonymous_Access_Type - then - -- Create local finalization list for access parameter + Set_No_Initialization (Expression (Temp_Decl)); + Insert_Action (N, Temp_Decl); - Flist := - Get_Allocator_Final_List (N, Base_Type (T), PtrT); - end if; + Complete_Controlled_Allocation (Temp_Decl); + Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); - Convert_Aggr_In_Allocator (N, Tmp_Node, Exp); else Node := Relocate_Node (N); Set_Analyzed (Node); - Insert_Action (N, + + Temp_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Constant_Present => True, Object_Definition => New_Reference_To (Def_Id, Loc), - Expression => Node)); + Expression => Node); + + Insert_Action (N, Temp_Decl); + Complete_Controlled_Allocation (Temp_Decl); end if; -- Generate an additional object containing the address of the @@ -835,15 +936,18 @@ package body Exp_Ch4 is New_Decl := Make_Object_Declaration (Loc, - Defining_Identifier => Make_Temporary (Loc, 'P'), - Object_Definition => New_Reference_To (PtrT, Loc), - Expression => Unchecked_Convert_To (PtrT, - New_Reference_To (Temp, Loc))); + Defining_Identifier => + Make_Temporary (Loc, 'P'), + Object_Definition => + New_Reference_To (PtrT, Loc), + Expression => + Unchecked_Convert_To (PtrT, + New_Reference_To (Temp, Loc))); Insert_Action (N, New_Decl); - Tmp_Node := New_Decl; - Temp := Defining_Identifier (New_Decl); + Temp_Decl := New_Decl; + Temp := Defining_Identifier (New_Decl); end; end if; @@ -906,77 +1010,43 @@ package body Exp_Ch4 is if Needs_Finalization (DesigT) and then Needs_Finalization (T) then - declare - Attach : Node_Id; - Apool : constant Entity_Id := - Associated_Storage_Pool (PtrT); - - begin - -- If it is an allocation on the secondary stack (i.e. a value - -- returned from a function), the object is attached on the - -- caller side as soon as the call is completed (see - -- Expand_Ctrl_Function_Call) - - if Is_RTE (Apool, RE_SS_Pool) then - declare - F : constant Entity_Id := Make_Temporary (Loc, 'F'); - begin - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => F, - Object_Definition => - New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); - Flist := New_Reference_To (F, Loc); - Attach := Make_Integer_Literal (Loc, 1); - end; - - -- Normal case, not a secondary stack allocation - - else - if Needs_Finalization (T) - and then Ekind (PtrT) = E_Anonymous_Access_Type - then - -- Create local finalization list for access parameter - - Flist := - Get_Allocator_Final_List (N, Base_Type (T), PtrT); - else - Flist := Find_Final_List (PtrT); - end if; - - Attach := Make_Integer_Literal (Loc, 2); - end if; - - -- Generate an Adjust call if the object will be moved. In Ada - -- 2005, the object may be inherently limited, in which case - -- there is no Adjust procedure, and the object is built in - -- place. In Ada 95, the object can be limited but not - -- inherently limited if this allocator came from a return - -- statement (we're allocating the result on the secondary - -- stack). In that case, the object will be moved, so we _do_ - -- want to Adjust. - - if not Aggr_In_Place - and then not Is_Immutably_Limited_Type (T) - then - Insert_Actions (N, - Make_Adjust_Call ( - Ref => + -- Generate an Adjust call if the object will be moved. In Ada + -- 2005, the object may be inherently limited, in which case + -- there is no Adjust procedure, and the object is built in + -- place. In Ada 95, the object can be limited but not + -- inherently limited if this allocator came from a return + -- statement (we're allocating the result on the secondary + -- stack). In that case, the object will be moved, so we _do_ + -- want to Adjust. + + if not Aggr_In_Place + and then not Is_Immutably_Limited_Type (T) + then + Insert_Action (N, + Make_Adjust_Call ( + Obj_Ref => -- An unchecked conversion is needed in the classwide - -- case because the designated type can be an ancestor of - -- the subtype mark of the allocator. + -- case because the designated type can be an ancestor + -- of the subtype mark of the allocator. - Unchecked_Convert_To (T, - Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Temp, Loc))), + Unchecked_Convert_To (T, + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Temp, Loc))), + Typ => T)); + end if; - Typ => T, - Flist_Ref => Flist, - With_Attach => Attach, - Allocator => True)); - end if; - end; + -- Generate: + -- Set_Finalize_Address_Ptr + -- (Collection, <Finalize_Address>'Unrestricted_Access) + + if Present (Associated_Collection (PtrT)) then + Insert_Action (N, + Make_Set_Finalize_Address_Ptr_Call ( + Loc => Loc, + Typ => T, + Ptr_Typ => PtrT)); + end if; end if; Rewrite (N, New_Reference_To (Temp, Loc)); @@ -992,12 +1062,14 @@ package body Exp_Ch4 is elsif Aggr_In_Place then Temp := Make_Temporary (Loc, 'P', N); - Tmp_Node := + Temp_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => New_Reference_To (PtrT, Loc), - Expression => Make_Allocator (Loc, - New_Reference_To (Etype (Exp), Loc))); + Expression => + Make_Allocator (Loc, + Expression => + New_Reference_To (Etype (Exp), Loc))); -- Copy the Comes_From_Source flag for the allocator we just built, -- since logically this allocator is a replacement of the original @@ -1005,11 +1077,14 @@ package body Exp_Ch4 is -- No_Implicit_Heap_Allocations. Set_Comes_From_Source - (Expression (Tmp_Node), Comes_From_Source (N)); + (Expression (Temp_Decl), Comes_From_Source (N)); + + Set_No_Initialization (Expression (Temp_Decl)); + Insert_Action (N, Temp_Decl); + + Complete_Controlled_Allocation (Temp_Decl); + Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); - Set_No_Initialization (Expression (Tmp_Node)); - Insert_Action (N, Tmp_Node); - Convert_Aggr_In_Allocator (N, Tmp_Node, Exp); Rewrite (N, New_Reference_To (Temp, Loc)); Analyze_And_Resolve (N, PtrT); @@ -3108,10 +3183,6 @@ package body Exp_Ch4 is Temp : Entity_Id; Nod : Node_Id; - procedure Complete_Coextension_Finalization; - -- Generate finalization calls for all nested coextensions of N. This - -- routine may allocate list controllers if necessary. - procedure Rewrite_Coextension (N : Node_Id); -- Static coextensions have the same lifetime as the entity they -- constrain. Such occurrences can be rewritten as aliased objects @@ -3123,227 +3194,49 @@ package body Exp_Ch4 is -- This is done without using the attribute (which malfunctions for -- large sizes ???) - --------------------------------------- - -- Complete_Coextension_Finalization -- - --------------------------------------- - - procedure Complete_Coextension_Finalization is - Coext : Node_Id; - Coext_Elmt : Elmt_Id; - Flist : Node_Id; - Ref : Node_Id; - - function Inside_A_Return_Statement (N : Node_Id) return Boolean; - -- Determine whether node N is part of a return statement - - function Needs_Initialization_Call (N : Node_Id) return Boolean; - -- Determine whether node N is a subtype indicator allocator which - -- acts a coextension. Such coextensions need initialization. - - ------------------------------- - -- Inside_A_Return_Statement -- - ------------------------------- - - function Inside_A_Return_Statement (N : Node_Id) return Boolean is - P : Node_Id; - - begin - P := Parent (N); - while Present (P) loop - if Nkind_In - (P, N_Extended_Return_Statement, N_Simple_Return_Statement) - then - return True; - - -- Stop the traversal when we reach a subprogram body - - elsif Nkind (P) = N_Subprogram_Body then - return False; - end if; - - P := Parent (P); - end loop; - - return False; - end Inside_A_Return_Statement; - - ------------------------------- - -- Needs_Initialization_Call -- - ------------------------------- - - function Needs_Initialization_Call (N : Node_Id) return Boolean is - Obj_Decl : Node_Id; - - begin - if Nkind (N) = N_Explicit_Dereference - and then Nkind (Prefix (N)) = N_Identifier - and then Nkind (Parent (Entity (Prefix (N)))) = - N_Object_Declaration - then - Obj_Decl := Parent (Entity (Prefix (N))); - - return - Present (Expression (Obj_Decl)) - and then Nkind (Expression (Obj_Decl)) = N_Allocator - and then Nkind (Expression (Expression (Obj_Decl))) /= - N_Qualified_Expression; - end if; - - return False; - end Needs_Initialization_Call; - - -- Start of processing for Complete_Coextension_Finalization - - begin - -- When a coextension root is inside a return statement, we need to - -- use the finalization chain of the function's scope. This does not - -- apply for controlled named access types because in those cases we - -- can use the finalization chain of the type itself. - - if Inside_A_Return_Statement (N) - and then - (Ekind (PtrT) = E_Anonymous_Access_Type - or else - (Ekind (PtrT) = E_Access_Type - and then No (Associated_Final_Chain (PtrT)))) - then - declare - Decl : Node_Id; - Outer_S : Entity_Id; - S : Entity_Id; - - begin - S := Current_Scope; - while Present (S) and then S /= Standard_Standard loop - if Ekind (S) = E_Function then - Outer_S := Scope (S); - - -- Retrieve the declaration of the body - - Decl := - Parent - (Parent - (Corresponding_Body (Parent (Parent (S))))); - exit; - end if; - - S := Scope (S); - end loop; - - -- Push the scope of the function body since we are inserting - -- the list before the body, but we are currently in the body - -- itself. Override the finalization list of PtrT since the - -- finalization context is now different. - - Push_Scope (Outer_S); - Build_Final_List (Decl, PtrT); - Pop_Scope; - end; - - -- The root allocator may not be controlled, but it still needs a - -- finalization list for all nested coextensions. - - elsif No (Associated_Final_Chain (PtrT)) then - Build_Final_List (N, PtrT); - end if; - - Flist := - Make_Selected_Component (Loc, - Prefix => - New_Reference_To (Associated_Final_Chain (PtrT), Loc), - Selector_Name => Make_Identifier (Loc, Name_F)); - - Coext_Elmt := First_Elmt (Coextensions (N)); - while Present (Coext_Elmt) loop - Coext := Node (Coext_Elmt); - - -- Generate: - -- typ! (coext.all) - - if Nkind (Coext) = N_Identifier then - Ref := - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => New_Reference_To (Etype (Coext), Loc), - Expression => - Make_Explicit_Dereference (Loc, - Prefix => New_Copy_Tree (Coext))); - else - Ref := New_Copy_Tree (Coext); - end if; - - -- No initialization call if not allowed - - Check_Restriction (No_Default_Initialization, N); - - if not Restriction_Active (No_Default_Initialization) then - - -- Generate: - -- initialize (Ref) - -- attach_to_final_list (Ref, Flist, 2) - - if Needs_Initialization_Call (Coext) then - Insert_Actions (N, - Make_Init_Call ( - Ref => Ref, - Typ => Etype (Coext), - Flist_Ref => Flist, - With_Attach => Make_Integer_Literal (Loc, Uint_2))); - - -- Generate: - -- attach_to_final_list (Ref, Flist, 2) - - else - Insert_Action (N, - Make_Attach_Call ( - Obj_Ref => Ref, - Flist_Ref => New_Copy_Tree (Flist), - With_Attach => Make_Integer_Literal (Loc, Uint_2))); - end if; - end if; - - Next_Elmt (Coext_Elmt); - end loop; - end Complete_Coextension_Finalization; - ------------------------- -- Rewrite_Coextension -- ------------------------- procedure Rewrite_Coextension (N : Node_Id) is - Temp : constant Node_Id := Make_Temporary (Loc, 'C'); + Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C'); + Temp_Decl : Node_Id; + Insert_Nod : Node_Id; + begin -- Generate: -- Cnn : aliased Etyp; - Decl : constant Node_Id := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Aliased_Present => True, - Object_Definition => - New_Occurrence_Of (Etyp, Loc)); - Nod : Node_Id; + Temp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (Etyp, Loc)); - begin if Nkind (Expression (N)) = N_Qualified_Expression then - Set_Expression (Decl, Expression (Expression (N))); + Set_Expression (Temp_Decl, Expression (Expression (N))); end if; -- Find the proper insertion node for the declaration - Nod := Parent (N); - while Present (Nod) loop - exit when Nkind (Nod) in N_Statement_Other_Than_Procedure_Call - or else Nkind (Nod) = N_Procedure_Call_Statement - or else Nkind (Nod) in N_Declaration; - Nod := Parent (Nod); + Insert_Nod := Parent (N); + while Present (Insert_Nod) loop + exit when + Nkind (Insert_Nod) in N_Statement_Other_Than_Procedure_Call + or else Nkind (Insert_Nod) = N_Procedure_Call_Statement + or else Nkind (Insert_Nod) in N_Declaration; + + Insert_Nod := Parent (Insert_Nod); end loop; - Insert_Before (Nod, Decl); - Analyze (Decl); + Insert_Before (Insert_Nod, Temp_Decl); + Analyze (Temp_Decl); Rewrite (N, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Temp, Loc), + Prefix => + New_Occurrence_Of (Temp_Id, Loc), Attribute_Name => Name_Unrestricted_Access)); Analyze_And_Resolve (N, PtrT); @@ -3463,7 +3356,7 @@ package body Exp_Ch4 is -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is -- marked as requiring static allocation. - Temp := Make_Temporary (Loc, 'T', Expression (Expression (N))); + Temp := Make_Temporary (Loc, 'T', Expression (Expression (N))); Desig := Subtype_Mark (Expression (N)); -- If context is constrained, use constrained subtype directly, @@ -3505,14 +3398,6 @@ package body Exp_Ch4 is return; end if; - -- The current allocator creates an object which may contain nested - -- coextensions. Use the current allocator's finalization list to - -- generate finalization call for all nested coextensions. - - if Is_Coextension_Root (N) then - Complete_Coextension_Finalization; - end if; - -- Check for size too large, we do this because the back end misses -- proper checks here and can generate rubbish allocation calls when -- we are near the limit. We only do this for the 32-bit address case @@ -3578,21 +3463,27 @@ package body Exp_Ch4 is -- first argument to Init must be converted to the task record type. declare - T : constant Entity_Id := Entity (Expression (N)); - Init : Entity_Id; - Arg1 : Node_Id; - Args : List_Id; - Decls : List_Id; - Decl : Node_Id; - Discr : Elmt_Id; - Flist : Node_Id; - Temp_Decl : Node_Id; - Temp_Type : Entity_Id; - Attach_Level : Uint; + T : constant Entity_Id := Entity (Expression (N)); + Args : List_Id; + Decls : List_Id; + Decl : Node_Id; + Discr : Elmt_Id; + Init : Entity_Id; + Init_Arg1 : Node_Id; + Temp_Decl : Node_Id; + Temp_Type : Entity_Id; begin if No_Initialization (N) then - null; + + -- Even though this might be a simple allocation, create a custom + -- Allocate if the context requires it. + + if Present (Associated_Collection (PtrT)) then + Build_Allocate_Deallocate_Proc + (N => Parent (N), + Is_Allocate => True); + end if; -- Case of no initialization procedure present @@ -3630,10 +3521,12 @@ package body Exp_Ch4 is -- Construct argument list for the initialization routine call - Arg1 := + Init_Arg1 := Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Temp, Loc)); - Set_Assignment_OK (Arg1); + Prefix => + New_Reference_To (Temp, Loc)); + + Set_Assignment_OK (Init_Arg1); Temp_Type := PtrT; -- The initialization procedure expects a specific type. if the @@ -3641,7 +3534,7 @@ package body Exp_Ch4 is -- being allocated has the right specific type. if Is_Class_Wide_Type (Dtyp) then - Arg1 := Unchecked_Convert_To (T, Arg1); + Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1); end if; -- If designated type is a concurrent type or if it is private @@ -3652,27 +3545,29 @@ package body Exp_Ch4 is -- type. if Is_Concurrent_Type (T) then - Arg1 := - Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1); + Init_Arg1 := + Unchecked_Convert_To ( + Corresponding_Record_Type (T), Init_Arg1); elsif Is_Private_Type (T) and then Present (Full_View (T)) and then Is_Concurrent_Type (Full_View (T)) then - Arg1 := + Init_Arg1 := Unchecked_Convert_To - (Corresponding_Record_Type (Full_View (T)), Arg1); + (Corresponding_Record_Type (Full_View (T)), Init_Arg1); elsif Etype (First_Formal (Init)) /= Base_Type (T) then declare Ftyp : constant Entity_Id := Etype (First_Formal (Init)); + begin - Arg1 := OK_Convert_To (Etype (Ftyp), Arg1); - Set_Etype (Arg1, Ftyp); + Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1); + Set_Etype (Init_Arg1, Ftyp); end; end if; - Args := New_List (Arg1); + Args := New_List (Init_Arg1); -- For the task case, pass the Master_Id of the access type as -- the value of the _Master parameter, and _Chain as the value @@ -3786,7 +3681,7 @@ package body Exp_Ch4 is if not Is_Constrained (Typ) and then Present (Discriminant_Default_Value - (First_Discriminant (Typ))) + (First_Discriminant (Typ))) and then (Ada_Version < Ada_2005 or else not Has_Constrained_Partial_View (Typ)) @@ -3844,6 +3739,8 @@ package body Exp_Ch4 is Set_Assignment_OK (Temp_Decl); Insert_Action (N, Temp_Decl, Suppress => All_Checks); + Complete_Controlled_Allocation (Temp_Decl); + -- If the designated type is a task type or contains tasks, -- create block to activate created tasks, and insert -- declaration for Task_Image variable ahead of call. @@ -3868,42 +3765,24 @@ package body Exp_Ch4 is if Needs_Finalization (T) then - -- Postpone the generation of a finalization call for the - -- current allocator if it acts as a coextension. - - if Is_Dynamic_Coextension (N) then - if No (Coextensions (N)) then - Set_Coextensions (N, New_Elmt_List); - end if; + -- Generate: + -- [Deep_]Initialize (Init_Arg1); - Append_Elmt (New_Copy_Tree (Arg1), Coextensions (N)); + Insert_Action (N, + Make_Init_Call ( + Obj_Ref => New_Copy_Tree (Init_Arg1), + Typ => T)); - else - Flist := - Get_Allocator_Final_List (N, Base_Type (T), PtrT); - - -- Anonymous access types created for access parameters - -- are attached to an explicitly constructed controller, - -- which ensures that they can be finalized properly, - -- even if their deallocation might not happen. The list - -- associated with the controller is doubly-linked. For - -- other anonymous access types, the object may end up - -- on the global final list which is singly-linked. - -- Work needed for access discriminants in Ada 2005 ??? - - if Ekind (PtrT) = E_Anonymous_Access_Type then - Attach_Level := Uint_1; - else - Attach_Level := Uint_2; - end if; + -- Generate: + -- Set_Finalize_Address_Ptr + -- (Pool, <Finalize_Address>'Unrestricted_Access) - Insert_Actions (N, - Make_Init_Call ( - Ref => New_Copy_Tree (Arg1), - Typ => T, - Flist_Ref => Flist, - With_Attach => Make_Integer_Literal (Loc, - Intval => Attach_Level))); + if Present (Associated_Collection (PtrT)) then + Insert_Action (N, + Make_Set_Finalize_Address_Ptr_Call ( + Loc => Loc, + Typ => T, + Ptr_Typ => PtrT)); end if; end if; @@ -4169,7 +4048,8 @@ package body Exp_Ch4 is P_Decl := Make_Full_Type_Declaration (Loc, - Defining_Identifier => Make_Temporary (Loc, 'A'), + Defining_Identifier => + Make_Temporary (Loc, 'A'), Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, @@ -9220,9 +9100,7 @@ package body Exp_Ch4 is then return Suitable_Element (Next_Entity (C)); - elsif Chars (C) = Name_uController - or else Chars (C) = Name_uTag - then + elsif Chars (C) = Name_uTag then return Suitable_Element (Next_Entity (C)); elsif Is_Interface (Etype (C)) then @@ -9248,6 +9126,7 @@ package body Exp_Ch4 is Result := New_Reference_To (Standard_True, Loc); C := Suitable_Element (First_Entity (Typ)); + while Present (C) loop declare New_Lhs : Node_Id; @@ -9527,81 +9406,6 @@ package body Exp_Ch4 is end if; end Fixup_Universal_Fixed_Operation; - ------------------------------ - -- Get_Allocator_Final_List -- - ------------------------------ - - function Get_Allocator_Final_List - (N : Node_Id; - T : Entity_Id; - PtrT : Entity_Id) return Entity_Id - is - Loc : constant Source_Ptr := Sloc (N); - - Owner : Entity_Id := PtrT; - -- The entity whose finalization list must be used to attach the - -- allocated object. - - begin - if Ekind (PtrT) = E_Anonymous_Access_Type then - - -- If the context is an access parameter, we need to create a - -- non-anonymous access type in order to have a usable final list, - -- because there is otherwise no pool to which the allocated object - -- can belong. We create both the type and the finalization chain - -- here, because freezing an internal type does not create such a - -- chain. The Final_Chain that is thus created is shared by the - -- access parameter. The access type is tested against the result - -- type of the function to exclude allocators whose type is an - -- anonymous access result type. We freeze the type at once to - -- ensure that it is properly decorated for the back-end, even - -- if the context and current scope is a loop. - - if Nkind (Associated_Node_For_Itype (PtrT)) - in N_Subprogram_Specification - and then - PtrT /= - Etype (Defining_Unit_Name (Associated_Node_For_Itype (PtrT))) - then - Owner := Make_Temporary (Loc, 'J'); - Insert_Action (N, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Owner, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (T, Loc)))); - - Freeze_Before (N, Owner); - Build_Final_List (N, Owner); - Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Owner)); - - -- Ada 2005 (AI-318-02): If the context is a return object - -- declaration, then the anonymous return subtype is defined to have - -- the same accessibility level as that of the function's result - -- subtype, which means that we want the scope where the function is - -- declared. - - elsif Nkind (Associated_Node_For_Itype (PtrT)) = N_Object_Declaration - and then Ekind (Scope (PtrT)) = E_Return_Statement - then - Owner := Scope (Return_Applies_To (Scope (PtrT))); - - -- Case of an access discriminant, or (Ada 2005) of an anonymous - -- access component or anonymous access function result: find the - -- final list associated with the scope of the type. (In the - -- anonymous access component kind, a list controller will have - -- been allocated when freezing the record type, and PtrT has an - -- Associated_Final_Chain attribute designating it.) - - elsif No (Associated_Final_Chain (PtrT)) then - Owner := Scope (PtrT); - end if; - end if; - - return Find_Final_List (Owner); - end Get_Allocator_Final_List; - --------------------------------- -- Has_Inferable_Discriminants -- --------------------------------- |