diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2011-08-03 14:36:26 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2011-08-03 14:36:26 +0000 |
| commit | bb3b440a7d0e1aceaae97e58c98cbc7657ee03d2 (patch) | |
| tree | 3a155e8b2ced397467e576bd84bd23e0fd58fd91 /gcc | |
| parent | 1fbb8a39e0bdd453d365a90bf36e9f266c570921 (diff) | |
| download | gcc-bb3b440a7d0e1aceaae97e58c98cbc7657ee03d2.tar.gz | |
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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@177275 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
73 files changed, 11928 insertions, 7005 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 75eeedc0197..b526c8282c3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,553 @@ +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. + 2011-08-03 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> * link.c: Include "auto-host.h" before system headers. diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index ed7ec12c150..0c8dac0a109 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -150,7 +150,7 @@ GNATRTL_NONTASKING_OBJS= \ a-envvar$(objext) \ a-except$(objext) \ a-exctra$(objext) \ - a-filico$(objext) \ + a-fihema$(objext) \ a-finali$(objext) \ a-flteio$(objext) \ a-fwteio$(objext) \ @@ -490,7 +490,6 @@ GNATRTL_NONTASKING_OBJS= \ s-ficobl$(objext) \ s-fileio$(objext) \ s-filofl$(objext) \ - s-finimp$(objext) \ s-finroo$(objext) \ s-fishfl$(objext) \ s-fore$(objext) \ diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index d7763db6b8c..e69e859b82f 100644 --- a/gcc/ada/a-except-2005.adb +++ b/gcc/ada/a-except-2005.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -880,36 +880,61 @@ package body Ada.Exceptions is procedure Raise_From_Controlled_Operation (X : Ada.Exceptions.Exception_Occurrence) is - Prefix : constant String := "adjust/finalize raised "; - Orig_Msg : constant String := Exception_Message (X); - New_Msg : constant String := Prefix & Exception_Name (X); + Prev_Exc : constant EOA := Get_Current_Excep.all; begin - if Orig_Msg'Length >= Prefix'Length - and then - Orig_Msg (Orig_Msg'First .. Orig_Msg'First + Prefix'Length - 1) = - Prefix - then - -- Message already has proper prefix, just re-reraise PROGRAM_ERROR + -- We're raising an exception during finalization. If the finalization + -- was triggered by an abort, as indicated by Not_Handled_By_Others, + -- then we don't want to raise Program_Error; we want to continue with + -- the Abort_Signal exception. Note that the original exception + -- occurrence that triggered the finalization is saved before calling + -- the Finalize procedures, and then restored afterward, so in the case + -- of abort, the original Abort_Signal will be the current one. - Raise_Exception_No_Defer - (E => Program_Error'Identity, - Message => Orig_Msg); + if Prev_Exc.Id /= null and then Prev_Exc.Id.Not_Handled_By_Others then + Raise_Current_Excep (Prev_Exc.Id); - elsif Orig_Msg = "" then - - -- No message present: just provide our own - - Raise_Exception_No_Defer - (E => Program_Error'Identity, - Message => New_Msg); + -- Otherwise, raise Program_Error else - -- Message present, add informational prefix - - Raise_Exception_No_Defer - (E => Program_Error'Identity, - Message => New_Msg & ": " & Orig_Msg); + declare + Prefix : constant String := "adjust/finalize raised "; + Orig_Msg : constant String := Exception_Message (X); + Orig_Prefix_Length : constant Natural := + Integer'Min (Prefix'Length, Orig_Msg'Length); + Orig_Prefix : String renames Orig_Msg + (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1); + + begin + -- Message already has the proper prefix, just re-reraise + + if Orig_Prefix = Prefix then + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => Orig_Msg); + + else + declare + New_Msg : constant String := Prefix & Exception_Name (X); + + begin + -- No message present, just provide our own + + if Orig_Msg = "" then + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => New_Msg); + + -- Message present, add informational prefix + + else + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => New_Msg & ": " & Orig_Msg); + end if; + end; + end if; + end; end if; end Raise_From_Controlled_Operation; diff --git a/gcc/ada/a-except-2005.ads b/gcc/ada/a-except-2005.ads index 033244dcd92..a17d6558e85 100644 --- a/gcc/ada/a-except-2005.ads +++ b/gcc/ada/a-except-2005.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -232,8 +232,13 @@ private procedure Raise_From_Controlled_Operation (X : Ada.Exceptions.Exception_Occurrence); pragma No_Return (Raise_From_Controlled_Operation); + pragma Export + (Ada, Raise_From_Controlled_Operation, + "__gnat_raise_from_controlled_operation"); -- Raise Program_Error, providing information about X (an exception raised - -- during a controlled operation) in the exception message. + -- during a controlled operation) in the exception message. However, if the + -- finalization was triggered by abort, keep aborting instead of raising + -- Program_Error. procedure Reraise_Occurrence_Always (X : Exception_Occurrence); pragma No_Return (Reraise_Occurrence_Always); diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index e80e264fe0f..2b51c1f1989 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -852,36 +852,61 @@ package body Ada.Exceptions is procedure Raise_From_Controlled_Operation (X : Ada.Exceptions.Exception_Occurrence) is - Prefix : constant String := "adjust/finalize raised "; - Orig_Msg : constant String := Exception_Message (X); - New_Msg : constant String := Prefix & Exception_Name (X); + Prev_Exc : constant EOA := Get_Current_Excep.all; begin - if Orig_Msg'Length >= Prefix'Length - and then - Orig_Msg (Orig_Msg'First .. Orig_Msg'First + Prefix'Length - 1) = - Prefix - then - -- Message already has proper prefix, just re-reraise PROGRAM_ERROR + -- We're raising an exception during finalization. If the finalization + -- was triggered by an abort, as indicated by Not_Handled_By_Others, + -- then we don't want to raise Program_Error; we want to continue with + -- the Abort_Signal exception. Note that the original exception + -- occurrence that triggered the finalization is saved before calling + -- the Finalize procedures, and then restored afterward, so in the case + -- of abort, the original Abort_Signal will be the current one. - Raise_Exception_No_Defer - (E => Program_Error'Identity, - Message => Orig_Msg); + if Prev_Exc.Id /= null and then Prev_Exc.Id.Not_Handled_By_Others then + Raise_Current_Excep (Prev_Exc.Id); - elsif Orig_Msg = "" then - - -- No message present: just provide our own - - Raise_Exception_No_Defer - (E => Program_Error'Identity, - Message => New_Msg); + -- Otherwise, raise Program_Error else - -- Message present, add informational prefix - - Raise_Exception_No_Defer - (E => Program_Error'Identity, - Message => New_Msg & ": " & Orig_Msg); + declare + Prefix : constant String := "adjust/finalize raised "; + Orig_Msg : constant String := Exception_Message (X); + Orig_Prefix_Length : constant Natural := + Integer'Min (Prefix'Length, Orig_Msg'Length); + Orig_Prefix : String renames Orig_Msg + (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1); + + begin + -- Message already has proper prefix, just re-reraise + + if Orig_Prefix = Prefix then + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => Orig_Msg); + + else + declare + New_Msg : constant String := Prefix & Exception_Name (X); + + begin + -- No message present, just provide our own + + if Orig_Msg = "" then + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => New_Msg); + + -- Message present, add informational prefix + + else + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => New_Msg & ": " & Orig_Msg); + end if; + end; + end if; + end; end if; end Raise_From_Controlled_Operation; diff --git a/gcc/ada/a-except.ads b/gcc/ada/a-except.ads index 14aea1dd326..1fa0d1c72d9 100644 --- a/gcc/ada/a-except.ads +++ b/gcc/ada/a-except.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -201,8 +201,13 @@ private procedure Raise_From_Controlled_Operation (X : Ada.Exceptions.Exception_Occurrence); pragma No_Return (Raise_From_Controlled_Operation); - -- Raise Program_Error, providing information about X (an exception - -- raised during a controlled operation) in the exception message. + pragma Export + (Ada, Raise_From_Controlled_Operation, + "__gnat_raise_from_controlled_operation"); + -- Raise Program_Error, providing information about X (an exception raised + -- during a controlled operation) in the exception message. However, if the + -- finalization was triggered by abort, keep aborting instead of raising + -- Program_Error. procedure Reraise_Occurrence_Always (X : Exception_Occurrence); pragma No_Return (Reraise_Occurrence_Always); diff --git a/gcc/ada/a-fihema.adb b/gcc/ada/a-fihema.adb new file mode 100644 index 00000000000..cc800f38086 --- /dev/null +++ b/gcc/ada/a-fihema.adb @@ -0,0 +1,513 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . F I N A L I Z A T I O N . H E A P _ M A N A G E M E N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2011, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +with GNAT.IO; use GNAT.IO; + +with System; use System; +with System.Address_Image; +with System.Storage_Elements; use System.Storage_Elements; +with System.Storage_Pools; use System.Storage_Pools; + +package body Ada.Finalization.Heap_Management is + + Header_Size : constant Storage_Count := Node'Size / Storage_Unit; + Header_Offset : constant Storage_Offset := Header_Size; + + function Address_To_Node_Ptr is + new Ada.Unchecked_Conversion (Address, Node_Ptr); + + procedure Attach (N : Node_Ptr; L : Node_Ptr); + -- Prepend a node to a list + + procedure Detach (N : Node_Ptr); + -- Unhook a node from an arbitrary list + + procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Ptr); + + --------------------------- + -- Add_Offset_To_Address -- + --------------------------- + + function Add_Offset_To_Address + (Addr : System.Address; + Offset : System.Storage_Elements.Storage_Offset) return System.Address + is + begin + return System.Storage_Elements."+" (Addr, Offset); + end Add_Offset_To_Address; + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Collection : in out Finalization_Collection; + Addr : out System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count; + Needs_Header : Boolean := True) + is + begin + -- Allocation of a controlled object + + if Needs_Header then + + -- Do not allow the allocation of controlled objects while the + -- associated collection is being finalized. + + if Collection.Finalization_Started then + raise Program_Error with "allocation after finalization started"; + end if; + + declare + N_Addr : Address; + N_Ptr : Node_Ptr; + + begin + -- Use the underlying pool to allocate enough space for the object + -- and the list header. The returned address points to the list + -- header. + + Allocate + (Collection.Base_Pool.all, + N_Addr, + Storage_Size + Header_Size, + Alignment); + + -- Map the allocated memory into a Node record. This converts the + -- top of the allocated bits into a list header. + + N_Ptr := Address_To_Node_Ptr (N_Addr); + Attach (N_Ptr, Collection.Objects); + + -- Move the address from Prev to the start of the object. This + -- operation effectively hides the list header. + + Addr := N_Addr + Header_Offset; + end; + + -- Allocation of a non-controlled object + + else + Allocate + (Collection.Base_Pool.all, + Addr, + Storage_Size, + Alignment); + end if; + end Allocate; + + ------------ + -- Attach -- + ------------ + + procedure Attach (N : Node_Ptr; L : Node_Ptr) is + begin + L.Next.Prev := N; + N.Next := L.Next; + L.Next := N; + N.Prev := L; + end Attach; + + --------------- + -- Base_Pool -- + --------------- + + function Base_Pool + (Collection : Finalization_Collection) return Any_Storage_Pool_Ptr + is + begin + return Collection.Base_Pool; + end Base_Pool; + + ---------------- + -- Deallocate -- + ---------------- + + procedure Deallocate + (Collection : in out Finalization_Collection; + Addr : System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count; + Has_Header : Boolean := True) + is + begin + -- Deallocation of a controlled object + + if Has_Header then + declare + N_Addr : Address; + N_Ptr : Node_Ptr; + + begin + -- Move the address from the object to the beginning of the list + -- header. + + N_Addr := Addr - Header_Offset; + + -- Converts the bits preceding the object into a list header + + N_Ptr := Address_To_Node_Ptr (N_Addr); + Detach (N_Ptr); + + -- Use the underlying pool to destroy the object along with the + -- list header. + + Deallocate + (Collection.Base_Pool.all, + N_Addr, + Storage_Size + Header_Size, + Alignment); + end; + + -- Deallocation of a non-controlled object + + else + Deallocate + (Collection.Base_Pool.all, + Addr, + Storage_Size, + Alignment); + end if; + end Deallocate; + + ------------ + -- Detach -- + ------------ + + procedure Detach (N : Node_Ptr) is + begin + if N.Prev /= null + and then N.Next /= null + then + N.Prev.Next := N.Next; + N.Next.Prev := N.Prev; + N.Prev := null; + N.Next := null; + end if; + end Detach; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize + (Collection : in out Finalization_Collection) + is + function Head (L : Node_Ptr) return Node_Ptr; + -- Return the node which comes after the dummy head + + function Is_Dummy_Head (N : Node_Ptr) return Boolean; + -- Determine whether a node acts as a dummy head. Such nodes do not + -- have an actual "object" attached to them and point to themselves. + + function Is_Empty_List (L : Node_Ptr) return Boolean; + -- Determine whether a list is empty + + function Node_Ptr_To_Address (N : Node_Ptr) return Address; + -- Not the reverse of Address_To_Node_Ptr. Return the address of the + -- object following the list header. + + ---------- + -- Head -- + ---------- + + function Head (L : Node_Ptr) return Node_Ptr is + begin + return L.Next; + end Head; + + ------------------- + -- Is_Dummy_Head -- + ------------------- + + function Is_Dummy_Head (N : Node_Ptr) return Boolean is + begin + -- To be a dummy head, the node must point to itself in both + -- directions. + + return + N.Next /= null + and then N.Next = N + and then N.Prev /= null + and then N.Prev = N; + end Is_Dummy_Head; + + ------------------- + -- Is_Empty_List -- + ------------------- + + function Is_Empty_List (L : Node_Ptr) return Boolean is + begin + return L = null or else Is_Dummy_Head (L); + end Is_Empty_List; + + ------------------------- + -- Node_Ptr_To_Address -- + ------------------------- + + function Node_Ptr_To_Address (N : Node_Ptr) return Address is + begin + return N.all'Address + Header_Offset; + end Node_Ptr_To_Address; + + Curr_Ptr : Node_Ptr; + Ex_Occur : Exception_Occurrence; + Next_Ptr : Node_Ptr; + Raised : Boolean := False; + + -- Start of processing for Finalize + + begin + -- Lock the collection to prevent any allocations while the objects are + -- being finalized. The collection remains locked because the associated + -- access type is about to go out of scope. + + Collection.Finalization_Started := True; + + while not Is_Empty_List (Collection.Objects) loop + + -- Find the real head of the collection, skipping the dummy head + + Curr_Ptr := Head (Collection.Objects); + + -- If the dummy head is the only remaining node, all real objects + -- have already been detached and finalized. + + if Is_Dummy_Head (Curr_Ptr) then + exit; + end if; + + -- Store the next node now since the detachment will destroy the + -- reference to it. + + Next_Ptr := Curr_Ptr.Next; + + -- Remove the current node from the list + + Detach (Curr_Ptr); + + -- ??? Kludge: Don't do anything until the proper place to set + -- primitive Finalize_Address has been determined. + + if Collection.Finalize_Address /= null then + begin + Collection.Finalize_Address (Node_Ptr_To_Address (Curr_Ptr)); + + exception + when Fin_Except : others => + if not Raised then + Raised := True; + Save_Occurrence (Ex_Occur, Fin_Except); + end if; + end; + end if; + + Curr_Ptr := Next_Ptr; + end loop; + + -- Deallocate the dummy head + + Free (Collection.Objects); + + -- If the finalization of a particular node raised an exception, reraise + -- it after the remainder of the list has been finalized. + + if Raised then + Reraise_Occurrence (Ex_Occur); + end if; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + overriding procedure Initialize + (Collection : in out Finalization_Collection) + is + begin + Collection.Objects := new Node; + + -- The dummy head must point to itself in both directions + + Collection.Objects.Next := Collection.Objects; + Collection.Objects.Prev := Collection.Objects; + end Initialize; + + ---------- + -- pcol -- + ---------- + + procedure pcol (Collection : Finalization_Collection) is + Head_Seen : Boolean := False; + N_Ptr : Node_Ptr; + + begin + -- Output the basic contents of the collection + + -- Collection: 0x123456789 + -- Base_Pool : null <or> 0x123456789 + -- Fin_Addr : null <or> 0x123456789 + -- Fin_Start : TRUE <or> FALSE + + Put ("Collection: "); + Put_Line (Address_Image (Collection'Address)); + + Put ("Base_Pool : "); + if Collection.Base_Pool = null then + Put_Line (" null"); + else + Put_Line (Address_Image (Collection.Base_Pool'Address)); + end if; + + Put ("Fin_Addr : "); + if Collection.Finalize_Address = null then + Put_Line ("null"); + else + Put_Line (Address_Image (Collection.Finalize_Address'Address)); + end if; + + Put ("Fin_Start : "); + Put_Line (Collection.Finalization_Started'Img); + + -- Output all chained elements. The format is the following: + + -- ^ <or> ? <or> null + -- |Header: 0x123456789 (dummy head) + -- | Prev: 0x123456789 + -- | Next: 0x123456789 + -- V + + -- ^ - the current element points back to the correct element + -- ? - the current element points back to an erroneous element + -- n - the current element points back to null + + -- Header - the address of the list header + -- Prev - the address of the list header which the current element + -- - points back to + -- Next - the address of the list header which the current element + -- - points to + -- (dummy head) - present if dummy head + + N_Ptr := Collection.Objects; + + while N_Ptr /= null loop + Put_Line ("V"); + + -- The current node is the head. If we have already traversed the + -- chain, the head will be encountered again since the chain is + -- circular. + + if N_Ptr = Collection.Objects then + if Head_Seen then + exit; + else + Head_Seen := True; + end if; + end if; + + -- The current element points back to null. This should never happen + -- since the list is circular. + + if N_Ptr.Prev = null then + Put_Line ("null (ERROR)"); + + -- The current element points back to the correct element + + elsif N_Ptr.Prev.Next = N_Ptr then + Put_Line ("^"); + + -- The current element points back to an erroneous element + + else + Put_Line ("? (ERROR)"); + end if; + + -- Output the header and fields + + Put ("|Header: "); + Put (Address_Image (N_Ptr.all'Address)); + + -- Detect the dummy head + + if N_Ptr = Collection.Objects then + Put_Line (" (dummy head)"); + else + Put_Line (""); + end if; + + Put ("| Prev: "); + if N_Ptr.Prev = null then + Put_Line ("null"); + else + Put_Line (Address_Image (N_Ptr.Prev.all'Address)); + end if; + + Put ("| Next: "); + if N_Ptr.Next = null then + Put_Line ("null"); + else + Put_Line (Address_Image (N_Ptr.Next.all'Address)); + end if; + + N_Ptr := N_Ptr.Next; + end loop; + end pcol; + + ------------------------------ + -- Set_Finalize_Address_Ptr -- + ------------------------------ + + procedure Set_Finalize_Address_Ptr + (Collection : in out Finalization_Collection; + Proc_Ptr : Finalize_Address_Ptr) + is + begin + Collection.Finalize_Address := Proc_Ptr; + end Set_Finalize_Address_Ptr; + + -------------------------- + -- Set_Storage_Pool_Ptr -- + -------------------------- + + procedure Set_Storage_Pool_Ptr + (Collection : in out Finalization_Collection; + Pool_Ptr : Any_Storage_Pool_Ptr) + is + begin + Collection.Base_Pool := Pool_Ptr; + end Set_Storage_Pool_Ptr; + +end Ada.Finalization.Heap_Management; diff --git a/gcc/ada/a-fihema.ads b/gcc/ada/a-fihema.ads new file mode 100644 index 00000000000..028d77189a2 --- /dev/null +++ b/gcc/ada/a-fihema.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . F I N A L I Z A T I O N . H E A P _ M A N A G E M E N T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2011, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; +with System.Storage_Elements; +with System.Storage_Pools; + +package Ada.Finalization.Heap_Management is + + -- A reference to any derivation of Root_Storage_Pool. Since this type may + -- not be used to allocate objects, its storage size is zero. + + type Any_Storage_Pool_Ptr is + access System.Storage_Pools.Root_Storage_Pool'Class; + for Any_Storage_Pool_Ptr'Storage_Size use 0; + + -- ??? Comment needed on overall mechanism + + type Finalization_Collection is + new Ada.Finalization.Limited_Controlled with private; + + type Finalization_Collection_Ptr is access all Finalization_Collection; + for Finalization_Collection_Ptr'Storage_Size use 0; + + -- A reference used to describe primitive Finalize_Address + + type Finalize_Address_Ptr is access procedure (Obj : System.Address); + + -- Since RTSfind cannot contain names of the form RE_"+", the following + -- routine serves as a wrapper around System.Storage_Elements."+". + + function Add_Offset_To_Address + (Addr : System.Address; + Offset : System.Storage_Elements.Storage_Offset) return System.Address; + + procedure Allocate + (Collection : in out Finalization_Collection; + Addr : out System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count; + Needs_Header : Boolean := True); + -- Allocate a chunk of memory described by Storage_Size and Alignment on + -- Collection's underlying storage pool. Return the address of the chunk. + -- The routine creates a list header which precedes the chunk of memory is + -- flag Needs_Header is set. If allocated, the header is attached to the + -- Collection's objects. The interface to this routine is provided by + -- Build_Allocate_Deallocate_Proc. + + function Base_Pool + (Collection : Finalization_Collection) return Any_Storage_Pool_Ptr; + -- Return a reference to the underlying storage pool of Collection + + procedure Deallocate + (Collection : in out Finalization_Collection; + Addr : System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count; + Has_Header : Boolean := True); + -- Deallocate a chunk of memory described by Storage_Size and Alignment + -- from Collection's underlying storage pool. The beginning of the memory + -- chunk is designated by Addr. The routine detaches and destroys the + -- preceding list header if flag Has_Header is set. The interface to this + -- routine is provided by Build_Allocate_Deallocate_Proc. + + overriding procedure Finalize + (Collection : in out Finalization_Collection); + -- Traverse the objects of Collection, invoking Finalize_Address on eanch + -- of them. In the end, the routine destroys its dummy head and tail. + + overriding procedure Initialize + (Collection : in out Finalization_Collection); + -- Create a new Collection by allocating a dummy head and tal + + procedure Set_Finalize_Address_Ptr + (Collection : in out Finalization_Collection; + Proc_Ptr : Finalize_Address_Ptr); + -- Set the finalization address routine of a finalization collection + + procedure Set_Storage_Pool_Ptr + (Collection : in out Finalization_Collection; + Pool_Ptr : Any_Storage_Pool_Ptr); + -- Set the underlying storage pool of a finalization collection + +private + -- Homogeneous collection types + + type Node; + type Node_Ptr is access all Node; + pragma No_Strict_Aliasing (Node_Ptr); + + type Node is record + Prev : Node_Ptr; + Next : Node_Ptr; + end record; + + type Finalization_Collection is + new Ada.Finalization.Limited_Controlled with + record + Base_Pool : Any_Storage_Pool_Ptr; + -- All objects and node headers are allocated on this underlying pool, + -- the collection is simply a wrapper around it. + + Objects : Node_Ptr; + -- The head of a doubly linked list + + Finalize_Address : Finalize_Address_Ptr; + -- A reference to a routine which finalizes an object denoted by its + -- address. The collection must be homogenious since the same routine + -- will be invoked for every allocated object when the pool is + -- finalized. + + Finalization_Started : Boolean := False; + -- When the finalization of a collection takes place, any allocations on + -- the same collection are prohibited and the action must raise Program_ + -- Error. + end record; + + procedure pcol (Collection : Finalization_Collection); + -- Output the contents of a collection in a readable form. Intended for + -- debugging purposes. + +end Ada.Finalization.Heap_Management; diff --git a/gcc/ada/a-filico.adb b/gcc/ada/a-filico.adb deleted file mode 100644 index f6bd78dd23e..00000000000 --- a/gcc/ada/a-filico.adb +++ /dev/null @@ -1,80 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- A D A . F I N A L I Z A T I O N . L I S T _ C O N T R O L L E R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Finalization_Implementation; -package body Ada.Finalization.List_Controller is - - package SFI renames System.Finalization_Implementation; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out List_Controller) is - use type SFR.Finalizable_Ptr; - - Last_Ptr : constant SFR.Finalizable_Ptr := Object.Last'Unchecked_Access; - - begin - -- First take note of the fact that finalization of this collection has - -- started. - - Object.F := SFI.Collection_Finalization_Started; - - -- Then finalize all the objects. Note that finalization can call - -- Unchecked_Deallocation on other objects in the same collection, - -- which will cause them to be removed from the list if we have not - -- gotten to them yet. However, allocation in the collection will raise - -- Program_Error, due to the above Collection_Finalization_Started. - - while Object.First.Next /= Last_Ptr loop - SFI.Finalize_One (Object.First.Next.all); - end loop; - end Finalize; - - procedure Finalize (Object : in out Simple_List_Controller) is - begin - SFI.Finalize_List (Object.F); - Object.F := null; - end Finalize; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Object : in out List_Controller) is - begin - Object.F := Object.First'Unchecked_Access; - Object.First.Next := Object.Last 'Unchecked_Access; - Object.Last.Prev := Object.First'Unchecked_Access; - end Initialize; - -end Ada.Finalization.List_Controller; diff --git a/gcc/ada/a-filico.ads b/gcc/ada/a-filico.ads deleted file mode 100644 index 566d0dfd109..00000000000 --- a/gcc/ada/a-filico.ads +++ /dev/null @@ -1,102 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- A D A . F I N A L I Z A T I O N . L I S T _ C O N T R O L L E R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Finalization_Root; - -package Ada.Finalization.List_Controller is - pragma Elaborate_Body; - - package SFR renames System.Finalization_Root; - - ---------------------------- - -- Simple_List_Controller -- - ---------------------------- - - type Simple_List_Controller is new Ada.Finalization.Limited_Controlled - with record - F : SFR.Finalizable_Ptr; - end record; - -- Used by the compiler to carry a list of temporary objects that - -- needs to be finalized after having being used. This list is - -- embedded in a controlled type so that if an exception is raised - -- while those temporaries are still in use, they will be reclaimed - -- by the normal finalization mechanism. - - overriding procedure Finalize (Object : in out Simple_List_Controller); - - --------------------- - -- List_Controller -- - --------------------- - - -- Management of a bidirectional linked heterogeneous list of - -- dynamically Allocated objects. To simplify the management of the - -- linked list, the First and Last elements are statically part of the - -- original List controller: - -- - -- +------------+ - -- | --|-->-- - -- +------------+ - -- |--<-- | record with ctrl components - -- |------------| +----------+ - -- +--|-- L | | | - -- | |------------| | | - -- | |+--------+ | +--------+ |+--------+| - -- +->|| prev | F|---<---|-- |----<---||-- ||--<--+ - -- ||--------| i| |--------| ||--------|| | - -- || next | r|--->---| --|---->---|| --||--------+ - -- |+--------+ s| |--------| ||--------|| | | - -- | t| | ctrl | || || | | - -- | | : : |+--------+| | | - -- | | : object : |rec | | | - -- | | : : |controller| | | - -- | | | | | | | v - -- |+--------+ | +--------+ +----------+ | | - -- || prev -|-L|--------------------->--------------------+ | - -- ||--------| a| | - -- || next | s|-------------------<-------------------------+ - -- |+--------+ t| - -- | | - -- +------------+ - - type List_Controller is new Ada.Finalization.Limited_Controlled - with record - F : SFR.Finalizable_Ptr; - First, - Last : aliased SFR.Root_Controlled; - end record; - -- Controls the chains of dynamically allocated controlled - -- objects makes sure that they get finalized upon exit from - -- the access type that defined them - - overriding procedure Initialize (Object : in out List_Controller); - overriding procedure Finalize (Object : in out List_Controller); - -end Ada.Finalization.List_Controller; diff --git a/gcc/ada/a-finali.adb b/gcc/ada/a-finali.adb index 5dae78e1225..dc2cdf78891 100644 --- a/gcc/ada/a-finali.adb +++ b/gcc/ada/a-finali.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,19 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Finalization_Root; use System.Finalization_Root; - package body Ada.Finalization is - --------- - -- "=" -- - --------- - - overriding function "=" (A, B : Controlled) return Boolean is - begin - return Empty_Root_Controlled (A) = Empty_Root_Controlled (B); - end "="; - ------------ -- Adjust -- ------------ diff --git a/gcc/ada/a-finali.ads b/gcc/ada/a-finali.ads index 9e81722bc96..d5cada210e2 100644 --- a/gcc/ada/a-finali.ads +++ b/gcc/ada/a-finali.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -61,9 +61,9 @@ private type Controlled is abstract new SFR.Root_Controlled with null record; - overriding function "=" (A, B : Controlled) return Boolean; - -- Need to be defined explicitly because we don't want to compare the - -- hidden pointers. + -- In order to simplify the implementation, the mechanism in Process_Full_ + -- View ensures that the full view is limited even though the parent type + -- is not. type Limited_Controlled is abstract new SFR.Root_Controlled with null record; diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index 7a5f7bce071..3473b4d5f99 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -529,19 +529,6 @@ package body Ada.Tags is end if; end Get_Offset_Index; - ------------------- - -- Get_RC_Offset -- - ------------------- - - function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is - TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); - TSD : constant Type_Specific_Data_Ptr := - To_Type_Specific_Data_Ptr (TSD_Ptr.all); - begin - return TSD.RC_Offset; - end Get_RC_Offset; - --------------------- -- Get_Tagged_Kind -- --------------------- @@ -769,6 +756,19 @@ package body Ada.Tags is end if; end Offset_To_Top; + ------------------------ + -- Needs_Finalization -- + ------------------------ + + function Needs_Finalization (T : Tag) return Boolean is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + return TSD.Needs_Finalization; + end Needs_Finalization; + ----------------- -- Parent_Size -- ----------------- diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 3d415a05c32..99ee5aa1aec 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -108,7 +108,7 @@ private -- +-------------------+ -- | type_is_abstract | -- +-------------------+ - -- | rec ctrler offset | + -- | needs finalization| -- +-------------------+ -- | Ifaces_Table ---> Interface Data -- +-------------------+ +------------+ @@ -288,9 +288,8 @@ private Type_Is_Abstract : Boolean; -- True if the type is abstract (Ada 2012: AI05-0173) - RC_Offset : SSE.Storage_Offset; - -- Controller Offset: Used to give support to tagged controlled objects - -- (see Get_Deep_Controller at s-finimp) + Needs_Finalization : Boolean; + -- Used to dynamically check whether an object is controlled or not Size_Func : Size_Ptr; -- Pointer to the subprogram computing the _size of the object. Used by @@ -455,15 +454,6 @@ private -- Ada 2005 (AI-251): Return a primitive operation's kind given a dispatch -- table T and a position of a primitive operation in T. - function Get_RC_Offset (T : Tag) return SSE.Storage_Offset; - -- Return the Offset of the implicit record controller when the object - -- has controlled components, returns zero if no controlled components. - - pragma Export (Ada, Get_RC_Offset, "ada__tags__get_rc_offset"); - -- This procedure is used in s-finimp to compute the deep routines. It is - -- exported manually in order to avoid completely changing the organization - -- of the run time. - function Get_Tagged_Kind (T : Tag) return Tagged_Kind; -- Ada 2005 (AI-345): Given a pointer to either a primary or a secondary -- dispatch table, return the tagged kind of a type in the context of @@ -490,6 +480,11 @@ private -- of the tagged type has discriminants this value is stored in a record -- component just immediately after the tag component. + function Needs_Finalization (T : Tag) return Boolean; + -- A helper routine used in conjunction with finalization collections which + -- service class-wide types. The function dynamically determines whether an + -- object is controlled or has controlled components. + function Parent_Size (Obj : System.Address; T : Tag) return SSE.Storage_Count; diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 026837c7afa..e998aeee0aa 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -1443,6 +1443,7 @@ package body ALI is UL.Body_Needed_For_SAL := False; UL.Elaborate_Body_Desirable := False; UL.Optimize_Alignment := 'O'; + UL.Has_Finalizer := False; if Debug_Flag_U then Write_Str (" ----> reading unit "); @@ -1628,12 +1629,14 @@ package body ALI is Fatal_Error_Ignore; end if; - -- PR/PU/PK parameters + -- PF/PR/PU/PK parameters elsif C = 'P' then C := Getc; - if C = 'R' then + if C = 'F' then + Units.Table (Units.Last).Has_Finalizer := True; + elsif C = 'R' then Units.Table (Units.Last).Preelab := True; elsif C = 'U' then Units.Table (Units.Last).Pure := True; diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index ab15ca11f3f..0a808179fde 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -24,8 +24,8 @@ ------------------------------------------------------------------------------ -- This package defines the internal data structures used for representation --- of Ada Library Information (ALI) acquired from the ALI files generated --- by the front end. +-- of Ada Library Information (ALI) acquired from the ALI files generated by +-- the front end. with Casing; use Casing; with Gnatvsn; use Gnatvsn; @@ -372,6 +372,9 @@ package ALI is Optimize_Alignment : Character; -- Optimize_Alignment setting. Set to L/S/T/O for OL/OS/OT/OO present + Has_Finalizer : Boolean; + -- Indicates whether a package body or a spec has a library-level + -- finalization routine. end record; package Units is new Table.Table ( diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index bb678a5b9cb..0df415d859f 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -2552,6 +2552,17 @@ package body Atree is end if; end Elist23; + function Elist24 (N : Node_Id) return Elist_Id is + pragma Assert (Nkind (N) in N_Entity); + Value : constant Union_Id := Nodes.Table (N + 4).Field6; + begin + if Value = 0 then + return No_Elist; + else + return Elist_Id (Value); + end if; + end Elist24; + function Elist25 (N : Node_Id) return Elist_Id is pragma Assert (Nkind (N) in N_Entity); Value : constant Union_Id := Nodes.Table (N + 4).Field7; @@ -4756,6 +4767,12 @@ package body Atree is Nodes.Table (N + 3).Field10 := Union_Id (Val); end Set_Elist23; + procedure Set_Elist24 (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Field6 := Union_Id (Val); + end Set_Elist24; + procedure Set_Elist25 (N : Node_Id; Val : Elist_Id) is begin pragma Assert (Nkind (N) in N_Entity); diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 2f88bb40daa..6538a19cf6c 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1138,6 +1138,9 @@ package Atree is function Elist23 (N : Node_Id) return Elist_Id; pragma Inline (Elist23); + function Elist24 (N : Node_Id) return Elist_Id; + pragma Inline (Elist24); + function Elist25 (N : Node_Id) return Elist_Id; pragma Inline (Elist25); @@ -2207,6 +2210,9 @@ package Atree is procedure Set_Elist23 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist23); + procedure Set_Elist24 (N : Node_Id; Val : Elist_Id); + pragma Inline (Set_Elist24); + procedure Set_Elist25 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist25); diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h index cc4e9b1e3ed..31df7e9c54f 100644 --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.h @@ -440,6 +440,7 @@ extern Node_Id Current_Error_Node; #define Elist18(N) Field18 (N) #define Elist21(N) Field21 (N) #define Elist23(N) Field23 (N) +#define Elist24(N) Field24 (N) #define Elist25(N) Field25 (N) #define Elist26(N) Field26 (N) diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 5d1928df2c0..eeec4708bc0 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -71,6 +71,8 @@ package body Bindgen is -- to do this unconditionally, since it drags in the System.Restrictions -- unit unconditionally, which is unpleasand, especially for ZFP etc.) + Lib_Final_Built : Boolean := False; + ---------------------------------- -- Interface_State Pragma Table -- ---------------------------------- @@ -249,14 +251,23 @@ package body Bindgen is -- Generate sequence of elaboration calls (C code case) procedure Gen_Elab_Order_Ada; - -- Generate comments showing elaboration order chosen (Ada case) + -- Generate comments showing elaboration order chosen (Ada code case) procedure Gen_Elab_Order_C; - -- Generate comments showing elaboration order chosen (C case) + -- Generate comments showing elaboration order chosen (C code case) procedure Gen_Elab_Defs_C; -- Generate sequence of definitions for elaboration routines (C code case) + procedure Gen_Finalize_Library_Ada; + -- Generate a sequence of finalization calls to elaborated packages (Ada) + + procedure Gen_Finalize_Library_C; + -- Generate a sequence of finalization calls to elaborated packages (C) + + procedure Gen_Finalize_Library_Defs_C; + -- Generate a sequence of defininitions for package finalizers (C case) + procedure Gen_Main_Ada; -- Generate procedure main (Ada code case) @@ -309,6 +320,10 @@ package body Bindgen is -- the encoding method used for the main program source. If there is no -- main program source (-z switch used), returns brackets ('b'). + function Has_Finalizer return Boolean; + -- Determine whether the current unit has at least one library-level + -- finalizer. + function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean; -- Compare linker options, when sorting, first according to -- Is_Internal_File (internal files come later) and then by @@ -358,10 +373,13 @@ package body Bindgen is -- the characters of S. The caller must ensure that these characters do -- in fact exist in the Statement_Buffer. - procedure Set_Unit_Name; - -- Given a unit name in the Name_Buffer, copies it to Statement_Buffer, - -- starting at the Last + 1 position, and updating last past the value. - -- changing periods to double underscores, and updating Last appropriately. + type Qualification_Mode is (Dollar_Sign, Dot, Double_Underscores); + + procedure Set_Unit_Name (Mode : Qualification_Mode := Double_Underscores); + -- Given a unit name in the Name_Buffer, copy it into Statement_Buffer, + -- starting at the Last + 1 position and update Last past the value. + -- Depending on parameter Mode, a dot (.) can be qualified into double + -- underscores (__), a dollar sign ($) or left as is. procedure Set_Unit_Number (U : Unit_Id); -- Sets unit number (first unit is 1, leading zeroes output to line @@ -401,25 +419,33 @@ package body Bindgen is procedure Gen_Adafinal_Ada is begin - WBI (""); WBI (" procedure " & Ada_Final_Name.all & " is"); - WBI (" begin"); - -- If compiling for the JVM, we directly call Adafinal because - -- we don't import it via Do_Finalize (see Gen_Output_File_Ada). + -- Do nothing if finalization is disabled - if VM_Target /= No_VM then - WBI (" System.Standard_Library.Adafinal;"); + if Cumulative_Restrictions.Set (No_Finalization) then + WBI (" begin"); + WBI (" null;"); - -- If there is no finalization, there is nothing to do + -- General case + + elsif VM_Target = No_VM then + WBI (" procedure s_stalib_adafinal;"); + WBI (" pragma Import (C, s_stalib_adafinal, " & + """system__standard_library__adafinal"");"); + WBI (" begin"); + WBI (" s_stalib_adafinal;"); + + -- Pragma Import C cannot be used on virtual machine targets, therefore + -- call the runtime finalization routine directly. - elsif Cumulative_Restrictions.Set (No_Finalization) then - WBI (" null;"); else - WBI (" Do_Finalize;"); + WBI (" begin"); + WBI (" System.Standard_Library.Adafinal;"); end if; WBI (" end " & Ada_Final_Name.all & ";"); + WBI (""); end Gen_Adafinal_Ada; -------------------- @@ -638,6 +664,18 @@ package body Bindgen is WBI (" pragma Import (C, Handler_Installed, " & """__gnat_handler_installed"");"); + -- The import of the soft link which performs library-level object + -- finalization is not needed for VM targets. Regular Ada is used in + -- that case. + + if VM_Target = No_VM then + WBI (""); + WBI (" type No_Param_Proc is access procedure;"); + WBI (" Finalize_Library_Objects : No_Param_Proc;"); + WBI (" pragma Import (C, Finalize_Library_Objects, " & + """__gnat_finalize_library_objects"");"); + end if; + -- Import entry point for environment feature enable/disable -- routine, and indication that it's been called previously. @@ -888,6 +926,34 @@ package body Bindgen is WBI (" Initialize_Stack_Limit;"); end if; + -- Attach Finalize_Library to the right softlink + + if not Suppress_Standard_Library_On_Target then + WBI (""); + + if VM_Target = No_VM then + if Lib_Final_Built then + Set_String (" Finalize_Library_Objects := "); + Set_String ("Finalize_Library'access;"); + else + Set_String (" Finalize_Library_Objects := null;"); + end if; + + -- On VM targets use regular Ada to set the soft link + + else + if Lib_Final_Built then + Set_String (" System.Soft_Links.Finalize_Library_Objects"); + Set_String (" := Finalize_Library'access;"); + else + Set_String (" System.Soft_Links.Finalize_Library_Objects"); + Set_String (" := null;"); + end if; + end if; + + Write_Statement_Buffer; + end if; + -- Generate elaboration calls WBI (""); @@ -913,6 +979,7 @@ package body Bindgen is end if; WBI (" end " & Ada_Init_Name.all & ";"); + WBI (""); end Gen_Adainit_Ada; ------------------- @@ -1200,6 +1267,7 @@ package body Bindgen is WBI (""); Gen_Elab_Calls_C; WBI ("}"); + WBI (""); end Gen_Adainit_C; ------------------------ @@ -1450,6 +1518,8 @@ package body Bindgen is procedure Gen_Elab_Defs_C is begin + WBI ("/* BEGIN ELABORATION DEFINITIONS */"); + for E in Elab_Order.First .. Elab_Order.Last loop -- Generate declaration of elaboration procedure if elaboration @@ -1464,9 +1534,7 @@ package body Bindgen is Set_String (" (void);"); Write_Statement_Buffer; end if; - end loop; - WBI (""); end Gen_Elab_Defs_C; @@ -1476,7 +1544,6 @@ package body Bindgen is procedure Gen_Elab_Order_Ada is begin - WBI (""); WBI (" -- BEGIN ELABORATION ORDER"); for J in Elab_Order.First .. Elab_Order.Last loop @@ -1487,6 +1554,7 @@ package body Bindgen is end loop; WBI (" -- END ELABORATION ORDER"); + WBI (""); end Gen_Elab_Order_Ada; ---------------------- @@ -1495,7 +1563,6 @@ package body Bindgen is procedure Gen_Elab_Order_C is begin - WBI (""); WBI ("/* BEGIN ELABORATION ORDER"); for J in Elab_Order.First .. Elab_Order.Last loop @@ -1505,16 +1572,319 @@ package body Bindgen is end loop; WBI (" END ELABORATION ORDER */"); + WBI (""); end Gen_Elab_Order_C; + ------------------------------ + -- Gen_Finalize_Library_Ada -- + ------------------------------ + + procedure Gen_Finalize_Library_Ada is + Count : Int := 1; + U : Unit_Record; + Uspec : Unit_Record; + Unum : Unit_Id; + + begin + for E in reverse Elab_Order.First .. Elab_Order.Last loop + Unum := Elab_Order.Table (E); + U := Units.Table (Unum); + + -- We are only interested in non-generic packages + + if U.Unit_Kind = 'p' + and then U.Has_Finalizer + and then not U.Is_Generic + and then not U.No_Elab + then + if not Lib_Final_Built then + Lib_Final_Built := True; + + WBI (" procedure Finalize_Library is"); + + -- The following flag is used to check for library-level + -- exceptions raised during finalization. The symbol comes + -- from System.Soft_Links. VM targets use regular Ada to + -- reference the entity. + + if VM_Target = No_VM then + WBI (" LE_Set : Boolean;"); + + Set_String (" pragma Import (Ada, LE_Set, "); + Set_String ("""__gnat_library_exception_set"");"); + Write_Statement_Buffer; + end if; + + WBI (" begin"); + end if; + + -- Generate: + -- declare + -- procedure F<Count>; + + Set_String (" declare"); + Write_Statement_Buffer; + + Set_String (" procedure F"); + Set_Int (Count); + Set_Char (';'); + Write_Statement_Buffer; + + -- Generate: + -- pragma Import (CIL, F<Count>, "xx.yy_pkg.Finalize[B/S]"); + -- -- for .NET targets + + -- pragma Import (Java, F<Count>, "xx$yy.Finalize[B/S]"); + -- -- for JVM targets + + -- pragma Import (Ada, F<Count>, "xx__yy__Finalize[B/S]"); + -- -- for default targets + + if VM_Target = CLI_Target then + Set_String (" pragma Import (CIL, F"); + elsif VM_Target = JVM_Target then + Set_String (" pragma Import (Java, F"); + else + Set_String (" pragma Import (Ada, F"); + end if; + + Set_Int (Count); + Set_String (", """); + + -- Dealing with package bodies is a little complicated. In such + -- cases we must retrieve the package spec since it contains the + -- spec of the body finalizer. + + if U.Utype = Is_Body then + Unum := Unum + 1; + Uspec := Units.Table (Unum); + else + Uspec := U; + end if; + + Get_Name_String (Uspec.Uname); + + -- Perform name construction + + -- .NET xx.yy_pkg.finalize + + if VM_Target = CLI_Target then + Set_Unit_Name (Mode => Dot); + Set_String ("_pkg.finalize"); + + -- JVM xx$yy.finalize + + elsif VM_Target = JVM_Target then + Set_Unit_Name (Mode => Dollar_Sign); + Set_String (".finalize"); + + -- Default xx__yy__finalize + + else + Set_Unit_Name; + Set_String ("__finalize"); + end if; + + -- Package spec processing + + if U.Utype = Is_Spec + or else U.Utype = Is_Spec_Only + then + Set_Char ('S'); + + -- Package body processing + + else + Set_Char ('B'); + end if; + + Set_String (""");"); + Write_Statement_Buffer; + + WBI (" begin"); + + -- Generate: + -- F<Count>; + -- end; + + Set_String (" F"); + Set_Int (Count); + Set_Char (';'); + Write_Statement_Buffer; + WBI (" end;"); + + Count := Count + 1; + end if; + end loop; + + if Lib_Final_Built then + + -- It is possible that the finalization of a library-level object + -- raised an exception. In that case import the actual exception + -- and the routine necessary to raise it. + + if VM_Target = No_VM then + WBI (" if LE_Set then"); + WBI (" declare"); + WBI (" LE : Ada.Exceptions.Exception_Occurrence;"); + + Set_String (" pragma Import (Ada, LE, "); + Set_String ("""__gnat_library_exception"");"); + Write_Statement_Buffer; + + Set_String (" procedure Raise_Controlled "); + Set_String ("(E : Ada.Exceptions.Exception_Occurrence);"); + Write_Statement_Buffer; + + Set_String (" pragma Import (Ada, Raise_Controlled, "); + Set_String ("""__gnat_raise_from_controlled_operation"");"); + Write_Statement_Buffer; + + WBI (" begin"); + WBI (" Raise_Controlled (LE);"); + WBI (" end;"); + + -- VM-specific code, use regular Ada to produce the desired behavior + + else + WBI (" if System.Soft_Links.Library_Exception_Set then"); + + Set_String (" Ada.Exceptions.Reraise_Occurrence ("); + Set_String ("System.Soft_Links.Library_Exception);"); + Write_Statement_Buffer; + end if; + + WBI (" end if;"); + WBI (" end Finalize_Library;"); + WBI (""); + end if; + end Gen_Finalize_Library_Ada; + + ---------------------------- + -- Gen_Finalize_Library_C -- + ---------------------------- + + procedure Gen_Finalize_Library_C is + U : Unit_Record; + Uspec : Unit_Record; + Unum : Unit_Id; + + begin + WBI (" /* BEGIN FINALIZE */"); + + for E in reverse Elab_Order.First .. Elab_Order.Last loop + Unum := Elab_Order.Table (E); + U := Units.Table (Unum); + + -- We are only interested in non-generic packages + + if U.Unit_Kind = 'p' + and then U.Has_Finalizer + and then not U.Is_Generic + and then not U.No_Elab + then + Set_String (" "); + + -- Dealing with package bodies is a little complicated. In such + -- cases we must retrieve the package spec since it contains the + -- spec of the body finalizer. + + if U.Utype = Is_Body then + Unum := Unum + 1; + Uspec := Units.Table (Unum); + else + Uspec := U; + end if; + + Get_Name_String (Uspec.Uname); + Set_Unit_Name; + Set_String ("__finalize"); + + -- Package spec processing + + if U.Utype = Is_Spec + or else U.Utype = Is_Spec_Only + then + Set_Char ('S'); + + -- Package body processing + + else + Set_Char ('B'); + end if; + + Set_String (" ();"); + + Write_Statement_Buffer; + end if; + end loop; + + WBI (" /* END FINALIZE */"); + WBI (""); + end Gen_Finalize_Library_C; + + --------------------------------- + -- Gen_Finalize_Library_Defs_C -- + --------------------------------- + + procedure Gen_Finalize_Library_Defs_C is + U : Unit_Record; + Uspec : Unit_Record; + Unum : Unit_Id; + + begin + WBI ("/* BEGIN FINALIZE DEFINITIONS */"); + + for E in reverse Elab_Order.First .. Elab_Order.Last loop + Unum := Elab_Order.Table (E); + U := Units.Table (Unum); + + -- We are only interested in non-generic packages + + if U.Unit_Kind = 'p' + and then U.Has_Finalizer + and then not U.Is_Generic + and then not U.No_Elab + then + -- Dealing with package bodies is a little complicated. In such + -- cases we must retrieve the package spec since it contains the + -- spec of the body finalizer. + + if U.Utype = Is_Body then + Unum := Unum + 1; + Uspec := Units.Table (Unum); + else + Uspec := U; + end if; + + Set_String ("extern void "); + Get_Name_String (Uspec.Uname); + Set_Unit_Name; + Set_String ("__finalize"); + + if U.Utype = Is_Spec + or else U.Utype = Is_Spec_Only + then + Set_Char ('S'); + else + Set_Char ('B'); + end if; + + Set_String (" (void);"); + Write_Statement_Buffer; + end if; + end loop; + + WBI ("/* END FINALIZE DEFINITIONS */"); + WBI (""); + end Gen_Finalize_Library_Defs_C; + ------------------ -- Gen_Main_Ada -- ------------------ procedure Gen_Main_Ada is begin - WBI (""); - if Exit_Status_Supported_On_Target then Set_String (" function "); else @@ -1558,11 +1928,11 @@ package body Bindgen is -- Initialize and Finalize if not Cumulative_Restrictions.Set (No_Finalization) then - WBI (" procedure initialize (Addr : System.Address);"); - WBI (" pragma Import (C, initialize, ""__gnat_initialize"");"); + WBI (" procedure Initialize (Addr : System.Address);"); + WBI (" pragma Import (C, Initialize, ""__gnat_initialize"");"); WBI (""); - WBI (" procedure finalize;"); - WBI (" pragma Import (C, finalize, ""__gnat_finalize"");"); + WBI (" procedure Finalize;"); + WBI (" pragma Import (C, Finalize, ""__gnat_finalize"");"); end if; -- If we want to analyze the stack, we have to import corresponding @@ -1711,15 +2081,7 @@ package body Bindgen is -- Adafinal call is skipped if no finalization if not Cumulative_Restrictions.Set (No_Finalization) then - - -- If compiling for the JVM, we directly call Adafinal because - -- we don't import it via Do_Finalize (see Gen_Output_File_Ada). - - if VM_Target = No_VM then - WBI (" Do_Finalize;"); - else - WBI (" System.Standard_Library.Adafinal;"); - end if; + WBI (" adafinal;"); end if; -- Prints the result of static stack analysis @@ -1747,6 +2109,7 @@ package body Bindgen is end if; WBI (" end;"); + WBI (""); end Gen_Main_Ada; ---------------- @@ -1754,6 +2117,8 @@ package body Bindgen is ---------------- procedure Gen_Main_C is + Needs_Library_Finalization : constant Boolean := Has_Finalizer; + begin if Exit_Status_Supported_On_Target then WBI ("#include <stdlib.h>"); @@ -1890,9 +2255,10 @@ package body Bindgen is -- Call adafinal if finalization active - if not Cumulative_Restrictions.Set (No_Finalization) then - WBI (" "); - WBI (" system__standard_library__adafinal ();"); + if not Cumulative_Restrictions.Set (No_Finalization) + and then Needs_Library_Finalization + then + Gen_Finalize_Library_C; end if; -- Outputs the dynamic stack measurement if needed @@ -1943,6 +2309,7 @@ package body Bindgen is end if; WBI ("}"); + WBI (""); end Gen_Main_C; ------------------------------ @@ -2013,7 +2380,6 @@ package body Bindgen is -- Start of processing for Gen_Object_Files_Options begin - WBI (""); Write_Info_Ada_C ("-- ", "/* ", " BEGIN Object file/option list"); if Object_List_Filename /= null then @@ -2268,16 +2634,18 @@ package body Bindgen is procedure Gen_Output_File_Ada (Filename : String) is + Ada_Main : constant String := Get_Ada_Main_Name; + -- Name to be used for generated Ada main program. See the body of + -- function Get_Ada_Main_Name for details on the form of the name. + + Needs_Library_Finalization : constant Boolean := Has_Finalizer; + Bfiles : Name_Id; -- Name of generated bind file (spec) Bfileb : Name_Id; -- Name of generated bind file (body) - Ada_Main : constant String := Get_Ada_Main_Name; - -- Name to be used for generated Ada main program. See the body of - -- function Get_Ada_Main_Name for details on the form of the name. - begin -- Create spec first @@ -2327,15 +2695,14 @@ package body Bindgen is Resolve_Binder_Options; - if VM_Target /= No_VM then - if not Suppress_Standard_Library_On_Target then - - -- Usually, adafinal is called using a pragma Import C. Since - -- Import C doesn't have the same semantics for JGNAT, we use - -- standard Ada. + -- Usually, adafinal is called using a pragma Import C. Since Import C + -- doesn't have the same semantics for JGNAT, we use standard Ada. - WBI ("with System.Standard_Library;"); - end if; + if VM_Target /= No_VM + and then not Suppress_Standard_Library_On_Target + then + WBI ("with System.Soft_Links;"); + WBI ("with System.Standard_Library;"); end if; WBI ("package " & Ada_Main & " is"); @@ -2544,27 +2911,14 @@ package body Bindgen is WBI ("with System.Restrictions;"); end if; + if Needs_Library_Finalization then + WBI ("with Ada.Exceptions;"); + end if; + WBI (""); WBI ("package body " & Ada_Main & " is"); WBI (" pragma Warnings (Off);"); - -- Import the finalization procedure only if finalization active - - if not Cumulative_Restrictions.Set (No_Finalization) then - - -- In the Java case, pragma Import C cannot be used, so the standard - -- Ada constructs will be used instead. - - if VM_Target = No_VM then - WBI (""); - WBI (" procedure Do_Finalize;"); - WBI - (" pragma Import (C, Do_Finalize, " & - """system__standard_library__adafinal"");"); - WBI (""); - end if; - end if; - if not Suppress_Standard_Library_On_Target then -- Generate Priority_Specific_Dispatching pragma string @@ -2592,14 +2946,18 @@ package body Bindgen is WBI (""); end if; - Gen_Adainit_Ada; - -- Generate the adafinal routine unless there is no finalization to do if not Cumulative_Restrictions.Set (No_Finalization) then Gen_Adafinal_Ada; + + if Needs_Library_Finalization then + Gen_Finalize_Library_Ada; + end if; end if; + Gen_Adainit_Ada; + if Bind_Main_Program and then VM_Target = No_VM then -- When suppressing the standard library then generate dummy body @@ -2631,6 +2989,9 @@ package body Bindgen is ----------------------- procedure Gen_Output_File_C (Filename : String) is + + Needs_Library_Finalization : constant Boolean := Has_Finalizer; + Bfile : Name_Id; pragma Warnings (Off, Bfile); -- Name of generated bind file (not referenced) @@ -2722,6 +3083,10 @@ package body Bindgen is Gen_Elab_Defs_C; + if Needs_Library_Finalization then + Gen_Finalize_Library_Defs_C; + end if; + -- Imported variables used only when we have a runtime if not Suppress_Standard_Library_On_Target then @@ -3283,6 +3648,33 @@ package body Bindgen is end if; end Get_WC_Encoding; + ------------------- + -- Has_Finalizer -- + ------------------- + + function Has_Finalizer return Boolean is + U : Unit_Record; + Unum : Unit_Id; + + begin + for E in reverse Elab_Order.First .. Elab_Order.Last loop + Unum := Elab_Order.Table (E); + U := Units.Table (Unum); + + -- We are only interested in non-generic packages + + if U.Unit_Kind = 'p' + and then U.Has_Finalizer + and then not U.Is_Generic + and then not U.No_Elab + then + return True; + end if; + end loop; + + return False; + end Has_Finalizer; + ---------------------- -- Lt_Linker_Option -- ---------------------- @@ -3508,13 +3900,19 @@ package body Bindgen is -- Set_Unit_Name -- ------------------- - procedure Set_Unit_Name is + procedure Set_Unit_Name (Mode : Qualification_Mode := Double_Underscores) is begin for J in 1 .. Name_Len - 2 loop - if Name_Buffer (J) /= '.' then - Set_Char (Name_Buffer (J)); + if Name_Buffer (J) = '.' then + if Mode = Double_Underscores then + Set_String ("__"); + elsif Mode = Dot then + Set_Char ('.'); + else + Set_Char ('$'); + end if; else - Set_String ("__"); + Set_Char (Name_Buffer (J)); end if; end loop; end Set_Unit_Name; diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index ff07cfc4d1f..9478ae3a0fb 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -123,6 +123,7 @@ package body Einfo is -- Extra_Formal Node15 -- Lit_Indexes Node15 -- Related_Instance Node15 + -- Return_Flag Node15 -- Scale_Value Uint15 -- Storage_Size_Variable Node15 -- String_Literal_Low_Bound Node15 @@ -160,7 +161,6 @@ package body Einfo is -- Body_Entity Node19 -- Corresponding_Discriminant Node19 - -- Finalization_Chain_Entity Node19 -- Parent_Subtype Node19 -- Related_Array_Object Node19 -- Size_Check_Code Node19 @@ -195,7 +195,7 @@ package body Einfo is -- Scope_Depth_Value Uint22 -- Shared_Var_Procs_Instance Node22 - -- Associated_Final_Chain Node23 + -- Associated_Collection Node23 -- CR_Discriminant Node23 -- Entry_Cancel_Parameter Node23 -- Enum_Pos_To_Rep Node23 @@ -207,6 +207,7 @@ package body Einfo is -- Protection_Object Node23 -- Stored_Constraint Elist23 + -- Finalizer Node24 -- Related_Expression Node24 -- Spec_PPC_List Node24 @@ -519,7 +520,7 @@ package body Einfo is -- Has_Predicates Flag250 -- Body_Is_In_ALFA Flag251 - -- (unused) Flag252 + -- Is_Processed_Transient Flag252 -- (unused) Flag253 -- (unused) Flag254 @@ -582,7 +583,7 @@ package body Einfo is function Actual_Subtype (Id : E) return E is begin pragma Assert - (Ekind_In (Id, E_Constant, E_Variable, E_Generic_In_Out_Parameter) + (Ekind_In (Id, E_Constant, E_Variable, E_Generic_In_Out_Parameter) or else Is_Formal (Id)); return Node17 (Id); end Actual_Subtype; @@ -610,11 +611,11 @@ package body Einfo is return Uint14 (Id); end Alignment; - function Associated_Final_Chain (Id : E) return E is + function Associated_Collection (Id : E) return E is begin pragma Assert (Is_Access_Type (Id)); return Node23 (Id); - end Associated_Final_Chain; + end Associated_Collection; function Associated_Formal_Package (Id : E) return E is begin @@ -1058,9 +1059,9 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind_In (Id, E_Entry_Family, - E_Subprogram_Body, - E_Subprogram_Type)); + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); return Node28 (Id); end Extra_Formals; @@ -1070,17 +1071,20 @@ package body Einfo is return Flag229 (Base_Type (Id)); end Can_Use_Internal_Rep; - function Finalization_Chain_Entity (Id : E) return E is - begin - return Node19 (Id); - end Finalization_Chain_Entity; - function Finalize_Storage_Only (Id : E) return B is begin pragma Assert (Is_Type (Id)); return Flag158 (Base_Type (Id)); end Finalize_Storage_Only; + function Finalizer (Id : E) return E is + begin + pragma Assert + (Ekind (Id) = E_Package + or else Ekind (Id) = E_Package_Body); + return Node24 (Id); + end Finalizer; + function First_Entity (Id : E) return E is begin return Node17 (Id); @@ -1987,7 +1991,7 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind_In (Id, E_Generic_Function, E_Generic_Procedure)); + or else Ekind_In (Id, E_Generic_Function, E_Generic_Procedure)); return Flag218 (Id); end Is_Primitive; @@ -2014,6 +2018,12 @@ package body Einfo is return Flag245 (Id); end Is_Private_Primitive; + function Is_Processed_Transient (Id : E) return B is + begin + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + return Flag252 (Id); + end Is_Processed_Transient; + function Is_Public (Id : E) return B is begin pragma Assert (Nkind (Id) in N_Entity); @@ -2265,7 +2275,7 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind_In (Id, E_Subprogram_Type, E_Entry_Family)); + or else Ekind_In (Id, E_Subprogram_Type, E_Entry_Family)); return Flag22 (Id); end Needs_No_Actuals; @@ -2543,6 +2553,12 @@ package body Einfo is return Flag213 (Id); end Requires_Overriding; + function Return_Flag (Id : E) return N is + begin + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + return Node15 (Id); + end Return_Flag; + function Return_Present (Id : E) return B is begin return Flag54 (Id); @@ -3033,11 +3049,11 @@ package body Einfo is Set_Elist16 (Id, V); end Set_Access_Disp_Table; - procedure Set_Associated_Final_Chain (Id : E; V : E) is + procedure Set_Associated_Collection (Id : E; V : E) is begin pragma Assert (Is_Access_Type (Id)); Set_Node23 (Id, V); - end Set_Associated_Final_Chain; + end Set_Associated_Collection; procedure Set_Associated_Formal_Package (Id : E; V : E) is begin @@ -3058,7 +3074,7 @@ package body Einfo is procedure Set_Actual_Subtype (Id : E; V : E) is begin pragma Assert - (Ekind_In (Id, E_Constant, E_Variable, E_Generic_In_Out_Parameter) + (Ekind_In (Id, E_Constant, E_Variable, E_Generic_In_Out_Parameter) or else Is_Formal (Id)); Set_Node17 (Id, V); end Set_Actual_Subtype; @@ -3078,11 +3094,11 @@ package body Einfo is procedure Set_Alignment (Id : E; V : U) is begin pragma Assert (Is_Type (Id) - or else Is_Formal (Id) - or else Ekind_In (Id, E_Loop_Parameter, - E_Constant, - E_Exception, - E_Variable)); + or else Is_Formal (Id) + or else Ekind_In (Id, E_Loop_Parameter, + E_Constant, + E_Exception, + E_Variable)); Set_Uint14 (Id, V); end Set_Alignment; @@ -3114,8 +3130,8 @@ package body Einfo is begin pragma Assert (Ekind (Id) = E_Package - or else Is_Subprogram (Id) - or else Is_Generic_Unit (Id)); + or else Is_Subprogram (Id) + or else Is_Generic_Unit (Id)); Set_Flag40 (Id, V); end Set_Body_Needed_For_SAL; @@ -3267,6 +3283,7 @@ package body Einfo is begin pragma Assert (Is_Subprogram (Id) or else Ekind_In (Id, E_Package, E_Package_Body)); + Set_Flag50 (Id, V); end Set_Delay_Subprogram_Descriptors; @@ -3509,9 +3526,9 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind_In (Id, E_Entry_Family, - E_Subprogram_Body, - E_Subprogram_Type)); + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); Set_Node28 (Id, V); end Set_Extra_Formals; @@ -3522,17 +3539,20 @@ package body Einfo is Set_Flag229 (Id, V); end Set_Can_Use_Internal_Rep; - procedure Set_Finalization_Chain_Entity (Id : E; V : E) is - begin - Set_Node19 (Id, V); - end Set_Finalization_Chain_Entity; - procedure Set_Finalize_Storage_Only (Id : E; V : B := True) is begin pragma Assert (Is_Type (Id) and then Is_Base_Type (Id)); Set_Flag158 (Id, V); end Set_Finalize_Storage_Only; + procedure Set_Finalizer (Id : E; V : E) is + begin + pragma Assert + (Ekind (Id) = E_Package + or else Ekind (Id) = E_Package_Body); + Set_Node24 (Id, V); + end Set_Finalizer; + procedure Set_First_Entity (Id : E; V : E) is begin Set_Node17 (Id, V); @@ -3565,7 +3585,7 @@ package body Einfo is procedure Set_First_Private_Entity (Id : E; V : E) is begin pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package) - or else Ekind (Id) in Concurrent_Kind); + or else Ekind (Id) in Concurrent_Kind); Set_Node16 (Id, V); end Set_First_Private_Entity; @@ -3589,7 +3609,7 @@ package body Einfo is begin pragma Assert (Is_Type (Id) - or else Ekind (Id) = E_Package); + or else Ekind (Id) = E_Package); Set_Flag159 (Id, V); end Set_From_With_Type; @@ -4068,8 +4088,8 @@ package body Einfo is begin pragma Assert (Is_Internal (Id) - and then Is_Hidden (Id) - and then (Ekind_In (Id, E_Procedure, E_Function))); + and then Is_Hidden (Id) + and then (Ekind_In (Id, E_Procedure, E_Function))); Set_Node25 (Id, V); end Set_Interface_Alias; @@ -4167,7 +4187,6 @@ package body Einfo is begin pragma Assert ((not V) or else (Is_Array_Type (Id) and then Is_Base_Type (Id))); - Set_Flag122 (Id, V); end Set_Is_Bit_Packed_Array; @@ -4490,7 +4509,7 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind_In (Id, E_Generic_Function, E_Generic_Procedure)); + or else Ekind_In (Id, E_Generic_Function, E_Generic_Procedure)); Set_Flag218 (Id, V); end Set_Is_Primitive; @@ -4517,6 +4536,12 @@ package body Einfo is Set_Flag245 (Id, V); end Set_Is_Private_Primitive; + procedure Set_Is_Processed_Transient (Id : E; V : B := True) is + begin + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + Set_Flag252 (Id, V); + end Set_Is_Processed_Transient; + procedure Set_Is_Public (Id : E; V : B := True) is begin pragma Assert (Nkind (Id) in N_Entity); @@ -4581,10 +4606,10 @@ package body Einfo is begin pragma Assert (Is_Type (Id) - or else Ekind_In (Id, E_Exception, - E_Variable, - E_Constant, - E_Void)); + or else Ekind_In (Id, E_Exception, + E_Variable, + E_Constant, + E_Void)); Set_Flag28 (Id, V); end Set_Is_Statically_Allocated; @@ -4773,7 +4798,7 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind_In (Id, E_Subprogram_Type, E_Entry_Family)); + or else Ekind_In (Id, E_Subprogram_Type, E_Entry_Family)); Set_Flag22 (Id, V); end Set_Needs_No_Actuals; @@ -5064,6 +5089,12 @@ package body Einfo is Set_Flag213 (Id, V); end Set_Requires_Overriding; + procedure Set_Return_Flag (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + Set_Node15 (Id, V); + end Set_Return_Flag; + procedure Set_Return_Present (Id : E; V : B := True) is begin Set_Flag54 (Id, V); @@ -5315,7 +5346,7 @@ package body Einfo is procedure Set_Wrapped_Entity (Id : E; V : E) is begin pragma Assert (Ekind_In (Id, E_Function, E_Procedure) - and then Is_Primitive_Wrapper (Id)); + and then Is_Primitive_Wrapper (Id)); Set_Node27 (Id, V); end Set_Wrapped_Entity; @@ -5810,9 +5841,9 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind_In (Id, E_Entry_Family, - E_Subprogram_Body, - E_Subprogram_Type)); + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); if Ekind (Id) = E_Enumeration_Literal then return Empty; @@ -5838,9 +5869,9 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind_In (Id, E_Entry_Family, - E_Subprogram_Body, - E_Subprogram_Type)); + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); if Ekind (Id) = E_Enumeration_Literal then return Empty; @@ -6267,7 +6298,7 @@ package body Einfo is function Is_Discriminal (Id : E) return B is begin return (Ekind_In (Id, E_Constant, E_In_Parameter) - and then Present (Discriminal_Link (Id))); + and then Present (Discriminal_Link (Id))); end Is_Discriminal; ---------------------- @@ -6321,6 +6352,16 @@ package body Einfo is and then Is_Entity_Attribute_Name (Attribute_Name (N))); end Is_Entity_Name; + ------------------ + -- Is_Finalizer -- + ------------------ + + function Is_Finalizer (Id : E) return B is + begin + return Ekind (Id) = E_Procedure + and then Chars (Id) = Name_uFinalizer; + end Is_Finalizer; + ----------------------------------- -- Is_Package_Or_Generic_Package -- ----------------------------------- @@ -6367,7 +6408,7 @@ package body Einfo is function Is_Prival (Id : E) return B is begin return (Ekind_In (Id, E_Constant, E_Variable) - and then Present (Prival_Link (Id))); + and then Present (Prival_Link (Id))); end Is_Prival; ---------------------------- @@ -6498,7 +6539,7 @@ package body Einfo is function Is_Wrapper_Package (Id : E) return B is begin return (Ekind (Id) = E_Package - and then Present (Related_Instance (Id))); + and then Present (Related_Instance (Id))); end Is_Wrapper_Package; ----------------- @@ -6718,7 +6759,7 @@ package body Einfo is D := Next_Entity (D); if No (D) or else (Ekind (D) /= E_Discriminant - and then not Is_Itype (D)) + and then not Is_Itype (D)) then return Empty; end if; @@ -7529,6 +7570,7 @@ package body Einfo is W ("Is_Private_Composite", Flag107 (Id)); W ("Is_Private_Descendant", Flag53 (Id)); W ("Is_Private_Primitive", Flag245 (Id)); + W ("Is_Processed_Transient", Flag252 (Id)); W ("Is_Public", Flag10 (Id)); W ("Is_Pure", Flag44 (Id)); W ("Is_Pure_Unit_Access_Type", Flag189 (Id)); @@ -7761,23 +7803,26 @@ package body Einfo is procedure Write_Field8_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Component | - E_Discriminant => - Write_Str ("Normalized_First_Bit"); - - when Formal_Kind | - E_Function | - E_Subprogram_Body => - Write_Str ("Mechanism"); - when Type_Kind => Write_Str ("Associated_Node_For_Itype"); + when E_Package => + Write_Str ("Dependent_Instances"); + when E_Loop => Write_Str ("First_Exit_Statement"); - when E_Package => - Write_Str ("Dependent_Instances"); + when E_Variable => + Write_Str ("Hiding_Loop_Variable"); + + when Formal_Kind | + E_Function | + E_Subprogram_Body => + Write_Str ("Mechanism"); + + when E_Component | + E_Discriminant => + Write_Str ("Normalized_First_Bit"); when E_Procedure => Write_Str ("Postcondition_Proc"); @@ -7785,9 +7830,6 @@ package body Einfo is when E_Return_Statement => Write_Str ("Return_Applies_To"); - when E_Variable => - Write_Str ("Hiding_Loop_Variable"); - when others => Write_Str ("Field8??"); end case; @@ -7803,6 +7845,9 @@ package body Einfo is when Type_Kind => Write_Str ("Class_Wide_Type"); + when Object_Kind => + Write_Str ("Current_Value"); + when E_Function | E_Generic_Function | E_Generic_Package | @@ -7811,9 +7856,6 @@ package body Einfo is E_Procedure => Write_Str ("Renaming_Map"); - when Object_Kind => - Write_Str ("Current_Value"); - when others => Write_Str ("Field9??"); end case; @@ -7863,21 +7905,25 @@ package body Einfo is procedure Write_Field11_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Formal_Kind => - Write_Str ("Entry_Component"); + when E_Block => + Write_Str ("Block_Node"); when E_Component | E_Discriminant => Write_Str ("Component_Bit_Offset"); - when E_Constant => - Write_Str ("Full_View"); + when Formal_Kind => + Write_Str ("Entry_Component"); when E_Enumeration_Literal => Write_Str ("Enumeration_Pos"); - when E_Block => - Write_Str ("Block_Node"); + when Type_Kind | + E_Constant => + Write_Str ("Full_View"); + + when E_Generic_Package => + Write_Str ("Generic_Homonym"); when E_Function | E_Procedure | @@ -7885,12 +7931,6 @@ package body Einfo is E_Entry_Family => Write_Str ("Protected_Body_Subprogram"); - when E_Generic_Package => - Write_Str ("Generic_Homonym"); - - when Type_Kind => - Write_Str ("Full_View"); - when others => Write_Str ("Field11??"); end case; @@ -7903,6 +7943,9 @@ package body Einfo is procedure Write_Field12_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Package => + Write_Str ("Associated_Formal_Package"); + when Entry_Kind => Write_Str ("Barrier_Function"); @@ -7925,9 +7968,6 @@ package body Einfo is E_Procedure => Write_Str ("Next_Inlined_Subprogram"); - when E_Package => - Write_Str ("Associated_Formal_Package"); - when others => Write_Str ("Field12??"); end case; @@ -7940,9 +7980,6 @@ package body Einfo is procedure Write_Field13_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Type_Kind => - Write_Str ("RM_Size"); - when E_Component | E_Discriminant => Write_Str ("Component_Clause"); @@ -7961,15 +7998,18 @@ package body Einfo is Write_Str ("Field13??"); end if; - when Formal_Kind | - E_Variable => - Write_Str ("Extra_Accessibility"); - when E_Procedure | E_Package | Generic_Unit_Kind => Write_Str ("Elaboration_Entity"); + when Formal_Kind | + E_Variable => + Write_Str ("Extra_Accessibility"); + + when Type_Kind => + Write_Str ("RM_Size"); + when others => Write_Str ("Field13??"); end case; @@ -7990,14 +8030,14 @@ package body Einfo is E_Loop_Parameter => Write_Str ("Alignment"); - when E_Component | - E_Discriminant => - Write_Str ("Normalized_Position"); - when E_Function | E_Procedure => Write_Str ("First_Optional_Parameter"); + when E_Component | + E_Discriminant => + Write_Str ("Normalized_Position"); + when E_Package | E_Generic_Package => Write_Str ("Shadow_Entities"); @@ -8014,29 +8054,25 @@ package body Einfo is procedure Write_Field15_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Access_Kind | - Task_Kind => - Write_Str ("Storage_Size_Variable"); - - when E_Component => - Write_Str ("DT_Entry_Count"); - - when Decimal_Fixed_Point_Kind => - Write_Str ("Scale_Value"); - when E_Discriminant => Write_Str ("Discriminant_Number"); - when Formal_Kind => - Write_Str ("Extra_Formal"); + when E_Component => + Write_Str ("DT_Entry_Count"); when E_Function | E_Procedure => Write_Str ("DT_Position"); + when E_Protected_Type => + Write_Str ("Entry_Bodies_Array"); + when Entry_Kind => Write_Str ("Entry_Parameters_Type"); + when Formal_Kind => + Write_Str ("Extra_Formal"); + when Enumeration_Kind => Write_Str ("Lit_Indexes"); @@ -8044,8 +8080,16 @@ package body Einfo is E_Package_Body => Write_Str ("Related_Instance"); - when E_Protected_Type => - Write_Str ("Entry_Bodies_Array"); + when E_Constant | + E_Variable => + Write_Str ("Return_Flag"); + + when Decimal_Fixed_Point_Kind => + Write_Str ("Scale_Value"); + + when Access_Kind | + Task_Kind => + Write_Str ("Storage_Size_Variable"); when E_String_Literal_Subtype => Write_Str ("String_Literal_Low_Bound"); @@ -8062,36 +8106,36 @@ package body Einfo is procedure Write_Field16_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Component => - Write_Str ("Entry_Formal"); + when E_Record_Type | + E_Record_Type_With_Private => + Write_Str ("Access_Disp_Table"); + + when E_Record_Subtype | + E_Class_Wide_Subtype => + Write_Str ("Cloned_Subtype"); when E_Function | E_Procedure => Write_Str ("DTC_Entity"); + when E_Component => + Write_Str ("Entry_Formal"); + when E_Package | E_Generic_Package | Concurrent_Kind => Write_Str ("First_Private_Entity"); - when E_Record_Type | - E_Record_Type_With_Private => - Write_Str ("Access_Disp_Table"); + when Enumeration_Kind => + Write_Str ("Lit_Strings"); when E_String_Literal_Subtype => Write_Str ("String_Literal_Length"); - when Enumeration_Kind => - Write_Str ("Lit_Strings"); - when E_Variable | E_Out_Parameter => Write_Str ("Unset_Reference"); - when E_Record_Subtype | - E_Class_Wide_Subtype => - Write_Str ("Cloned_Subtype"); - when others => Write_Str ("Field16??"); end case; @@ -8104,12 +8148,15 @@ package body Einfo is procedure Write_Field17_Name (Id : Entity_Id) is begin case Ekind (Id) is + when Formal_Kind | + E_Constant | + E_Generic_In_Out_Parameter | + E_Variable => + Write_Str ("Actual_Subtype"); + when Digits_Kind => Write_Str ("Digits_Value"); - when E_Component => - Write_Str ("Prival"); - when E_Discriminant => Write_Str ("Discriminal"); @@ -8147,12 +8194,6 @@ package body Einfo is when Modular_Integer_Kind => Write_Str ("Modulus"); - when Formal_Kind | - E_Constant | - E_Generic_In_Out_Parameter | - E_Variable => - Write_Str ("Actual_Subtype"); - when E_Incomplete_Type => Write_Str ("Non_Limited_View"); @@ -8161,6 +8202,9 @@ package body Einfo is Write_Str ("Non_Limited_View"); end if; + when E_Component => + Write_Str ("Prival"); + when others => Write_Str ("Field17??"); end case; @@ -8185,6 +8229,14 @@ package body Einfo is when E_Subprogram_Body => Write_Str ("Corresponding_Protected_Entry"); + when Concurrent_Kind => + Write_Str ("Corresponding_Record_Type"); + + when E_Label | + E_Loop | + E_Block => + Write_Str ("Enclosing_Scope"); + when E_Entry_Index_Parameter => Write_Str ("Entry_Index_Constant"); @@ -8198,6 +8250,10 @@ package body Einfo is when Fixed_Point_Kind => Write_Str ("Delta_Value"); + when Incomplete_Or_Private_Kind | + E_Record_Subtype => + Write_Str ("Private_Dependents"); + when Object_Kind => Write_Str ("Renamed_Object"); @@ -8208,18 +8264,6 @@ package body Einfo is E_Generic_Package => Write_Str ("Renamed_Entity"); - when Incomplete_Or_Private_Kind | - E_Record_Subtype => - Write_Str ("Private_Dependents"); - - when Concurrent_Kind => - Write_Str ("Corresponding_Record_Type"); - - when E_Label | - E_Loop | - E_Block => - Write_Str ("Enclosing_Scope"); - when others => Write_Str ("Field18??"); end case; @@ -8232,28 +8276,24 @@ package body Einfo is procedure Write_Field19_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Package | + E_Generic_Package => + Write_Str ("Body_Entity"); + + when E_Discriminant => + Write_Str ("Corresponding_Discriminant"); + + when E_Record_Type => + Write_Str ("Parent_Subtype"); + when E_Array_Type | E_Array_Subtype => Write_Str ("Related_Array_Object"); - when E_Block | - Concurrent_Kind | - E_Function | - E_Procedure | - E_Return_Statement | - Entry_Kind => - Write_Str ("Finalization_Chain_Entity"); - - when E_Constant | E_Variable => + when E_Constant | + E_Variable => Write_Str ("Size_Check_Code"); - when E_Discriminant => - Write_Str ("Corresponding_Discriminant"); - - when E_Package | - E_Generic_Package => - Write_Str ("Body_Entity"); - when E_Package_Body | Formal_Kind => Write_Str ("Spec_Entity"); @@ -8261,9 +8301,6 @@ package body Einfo is when Private_Kind => Write_Str ("Underlying_Full_View"); - when E_Record_Type => - Write_Str ("Parent_Subtype"); - when others => Write_Str ("Field19??"); end case; @@ -8289,10 +8326,6 @@ package body Einfo is when E_Component => Write_Str ("Discriminant_Checking_Func"); - when E_Constant | - E_Variable => - Write_Str ("Prival_Link"); - when E_Discriminant => Write_Str ("Discriminant_Default_Value"); @@ -8318,6 +8351,10 @@ package body Einfo is E_Subprogram_Type => Write_Str ("Last_Entity"); + when E_Constant | + E_Variable => + Write_Str ("Prival_Link"); + when Scalar_Kind => Write_Str ("Scalar_Range"); @@ -8336,14 +8373,11 @@ package body Einfo is procedure Write_Field21_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Constant | - E_Exception | - E_Function | - E_Generic_Function | - E_Procedure | - E_Generic_Procedure | - E_Variable => - Write_Str ("Interface_Name"); + when Entry_Kind => + Write_Str ("Accept_Address"); + + when E_In_Parameter => + Write_Str ("Default_Expr_Function"); when Concurrent_Kind | Incomplete_Or_Private_Kind | @@ -8352,19 +8386,22 @@ package body Einfo is E_Record_Subtype => Write_Str ("Discriminant_Constraint"); - when Entry_Kind => - Write_Str ("Accept_Address"); - - when Fixed_Point_Kind => - Write_Str ("Small_Value"); - - when E_In_Parameter => - Write_Str ("Default_Expr_Function"); + when E_Constant | + E_Exception | + E_Function | + E_Generic_Function | + E_Procedure | + E_Generic_Procedure | + E_Variable => + Write_Str ("Interface_Name"); when Array_Kind | Modular_Integer_Kind => Write_Str ("Original_Array_Type"); + when Fixed_Point_Kind => + Write_Str ("Small_Value"); + when others => Write_Str ("Field21??"); end case; @@ -8383,6 +8420,9 @@ package body Einfo is when Array_Kind => Write_Str ("Component_Size"); + when E_Record_Type => + Write_Str ("Corresponding_Remote_Type"); + when E_Component | E_Discriminant => Write_Str ("Original_Record_Component"); @@ -8393,12 +8433,17 @@ package body Einfo is when E_Exception => Write_Str ("Exception_Code"); + when E_Record_Type_With_Private | + E_Record_Subtype_With_Private | + E_Private_Type | + E_Private_Subtype | + E_Limited_Private_Type | + E_Limited_Private_Subtype => + Write_Str ("Private_View"); + when Formal_Kind => Write_Str ("Protected_Formal"); - when E_Record_Type => - Write_Str ("Corresponding_Remote_Type"); - when E_Block | E_Entry | E_Entry_Family | @@ -8416,14 +8461,6 @@ package body Einfo is E_Task_Type => Write_Str ("Scope_Depth_Value"); - when E_Record_Type_With_Private | - E_Record_Subtype_With_Private | - E_Private_Type | - E_Private_Subtype | - E_Limited_Private_Type | - E_Limited_Private_Subtype => - Write_Str ("Private_View"); - when E_Variable => Write_Str ("Shared_Var_Procs_Instance"); @@ -8440,17 +8477,14 @@ package body Einfo is begin case Ekind (Id) is when Access_Kind => - Write_Str ("Associated_Final_Chain"); + Write_Str ("Associated_Collection"); - when Array_Kind => - Write_Str ("Packed_Array_Type"); + when E_Discriminant => + Write_Str ("CR_Discriminant"); when E_Block => Write_Str ("Entry_Cancel_Parameter"); - when E_Discriminant => - Write_Str ("CR_Discriminant"); - when E_Enumeration_Type => Write_Str ("Enum_Pos_To_Rep"); @@ -8463,6 +8497,12 @@ package body Einfo is E_Generic_Procedure => Write_Str ("Inner_Instances"); + when Array_Kind => + Write_Str ("Packed_Array_Type"); + + when Entry_Kind => + Write_Str ("Protection_Object"); + when Concurrent_Kind | Incomplete_Or_Private_Kind | Class_Wide_Kind | @@ -8487,9 +8527,6 @@ package body Einfo is Write_Str ("Limited_View"); end if; - when Entry_Kind => - Write_Str ("Protection_Object"); - when others => Write_Str ("Field23??"); end case; @@ -8502,12 +8539,18 @@ package body Einfo is procedure Write_Field24_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Subprogram_Kind => - Write_Str ("Spec_PPC_List"); + when E_Package | + E_Package_Body => + Write_Str ("Finalizer"); - when E_Variable | E_Constant | Type_Kind => + when E_Constant | + E_Variable | + Type_Kind => Write_Str ("Related_Expression"); + when Subprogram_Kind => + Write_Str ("Spec_PPC_List"); + when others => Write_Str ("Field24???"); end case; @@ -8520,6 +8563,9 @@ package body Einfo is procedure Write_Field25_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Variable => + Write_Str ("Debug_Renaming_Link"); + when E_Component => Write_Str ("DT_Offset_To_Top_Func"); @@ -8536,9 +8582,6 @@ package body Einfo is when Task_Kind => Write_Str ("Task_Body_Procedure"); - when E_Variable => - Write_Str ("Debug_Renaming_Link"); - when E_Entry | E_Entry_Family => Write_Str ("PPC_Wrapper"); @@ -8560,6 +8603,15 @@ package body Einfo is procedure Write_Field26_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Record_Type | + E_Record_Type_With_Private => + Write_Str ("Dispatch_Table_Wrappers"); + + when E_In_Out_Parameter | + E_Out_Parameter | + E_Variable => + Write_Str ("Last_Assignment"); + when E_Access_Subprogram_Type => Write_Str ("Original_Access_Type"); @@ -8567,6 +8619,13 @@ package body Einfo is E_Package => Write_Str ("Package_Instantiation"); + when E_Component | + E_Constant => + Write_Str ("Related_Type"); + + when Task_Kind => + Write_Str ("Relative_Deadline_Variable"); + when E_Procedure | E_Function => if Ekind (Id) = E_Procedure @@ -8577,18 +8636,6 @@ package body Einfo is Write_Str ("Overridden_Operation"); end if; - when E_Record_Type | - E_Record_Type_With_Private => - Write_Str ("Dispatch_Table_Wrappers"); - - when E_In_Out_Parameter | - E_Out_Parameter | - E_Variable => - Write_Str ("Last_Assignment"); - - when Task_Kind => - Write_Str ("Relative_Deadline_Variable"); - when others => Write_Str ("Field26??"); end case; @@ -8601,6 +8648,10 @@ package body Einfo is procedure Write_Field27_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Package | + Type_Kind => + Write_Str ("Current_Use_Clause"); + when E_Component | E_Constant | E_Variable => @@ -8609,9 +8660,6 @@ package body Einfo is when E_Procedure => Write_Str ("Wrapped_Entity"); - when E_Package | Type_Kind => - Write_Str ("Current_Use_Clause"); - when others => Write_Str ("Field27??"); end case; @@ -8624,7 +8672,9 @@ package body Einfo is procedure Write_Field28_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Procedure | E_Function | E_Entry => + when E_Procedure | + E_Function | + E_Entry => Write_Str ("Extra_Formals"); when E_Record_Type => diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index e05834c428d..3fa37519701 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -427,6 +427,12 @@ package Einfo is -- definition clause with an (obsolescent) mod clause is converted -- into an attribute definition clause for this purpose. +-- Associated_Collection (Node23) +-- Present in non-subprogram access type entities. Contains the entity of +-- the finalization collection on which dynamically allocated objects +-- referenced by the access type are stored. Empty when the access type +-- cannot reference a controlled object. + -- Associated_Formal_Package (Node12) -- Present in packages that are the actuals of formal_packages. Points -- to the entity in the declaration for the formal package. @@ -450,12 +456,6 @@ package Einfo is -- only in the root type, since derived types must have the same pool -- as the parent type. --- Associated_Final_Chain (Node23) --- Present in simple and general access type entities. References the --- List_Controller object that holds the finalization chain on which --- are attached dynamically allocated objects referenced by the access --- type. Empty when the access type cannot reference a controlled object. - -- Barrier_Function (Node12) -- Present in protected entries and entry families. This is the -- subprogram declaration for the body of the function that returns @@ -521,6 +521,37 @@ package Einfo is -- ??? This is also set on some access types, eg the Etype of the -- anonymous access type of a controlling formal. +-- Can_Use_Internal_Rep (Flag229) [base type only] +-- Present in Access_Subprogram_Kind nodes. This flag is set by the +-- front end and used by the back end. False means that the back end +-- must represent the type in the same way as Convention-C types (and +-- other foreign-convention types). On many targets, this means that +-- the back end will use dynamically generated trampolines for nested +-- subprograms. True means that the back end can represent the type in +-- some internal way. On the aforementioned targets, this means that the +-- back end will not use dynamically generated trampolines. This flag +-- must be False if Has_Foreign_Convention is True; otherwise, the front +-- end is free to set the policy. +-- +-- Setting this False in all cases corresponds to the traditional back +-- end strategy, where all access-to-subprogram types are represented the +-- same way, independent of the Convention. See also +-- Always_Compatible_Rep in Targparm. +-- +-- Efficiency note: On targets that use dynamically generated +-- trampolines, False generally favors efficiency of top-level +-- subprograms, whereas True generally favors efficiency of nested +-- ones. On other targets, this flag has little or no effect on +-- efficiency. The front end should take this into account. In +-- particular, pragma Favor_Top_Level gives a hint that the flag should +-- be False. +-- +-- Note: We considered using Convention-C for this purpose, but we need +-- this separate flag, because Convention-C implies that for +-- P'[Unrestricted_]Access, P also have convention C. Sometimes we want +-- to have Can_Use_Internal_Rep False for an access type, but allow P to +-- have convention Ada. + -- Chars (Name1) -- Present in all entities. This field contains an entry into the names -- table that has the character string of the identifier, character @@ -1111,49 +1142,6 @@ package Einfo is -- must be retrieved through the entity designed by this field instead of -- being computed. --- Can_Use_Internal_Rep (Flag229) [base type only] --- Present in Access_Subprogram_Kind nodes. This flag is set by the --- front end and used by the back end. False means that the back end --- must represent the type in the same way as Convention-C types (and --- other foreign-convention types). On many targets, this means that --- the back end will use dynamically generated trampolines for nested --- subprograms. True means that the back end can represent the type in --- some internal way. On the aforementioned targets, this means that the --- back end will not use dynamically generated trampolines. This flag --- must be False if Has_Foreign_Convention is True; otherwise, the front --- end is free to set the policy. --- --- Setting this False in all cases corresponds to the traditional back --- end strategy, where all access-to-subprogram types are represented the --- same way, independent of the Convention. See also --- Always_Compatible_Rep in Targparm. --- --- Efficiency note: On targets that use dynamically generated --- trampolines, False generally favors efficiency of top-level --- subprograms, whereas True generally favors efficiency of nested --- ones. On other targets, this flag has little or no effect on --- efficiency. The front end should take this into account. In --- particular, pragma Favor_Top_Level gives a hint that the flag should --- be False. --- --- Note: We considered using Convention-C for this purpose, but we need --- this separate flag, because Convention-C implies that for --- P'[Unrestricted_]Access, P also have convention C. Sometimes we want --- to have Can_Use_Internal_Rep False for an access type, but allow P to --- have convention Ada. - --- Finalization_Chain_Entity (Node19) --- Present in scopes that can have finalizable entities (blocks, --- functions, procedures, tasks, entries, return statements). When this --- field is empty it means that there are no finalization actions to --- perform on exit of the scope. When this field contains 'Error', it --- means that no finalization actions should happen at this level and --- the finalization chain of a parent scope shall be used (??? this is --- an improper use of 'Error' and should be changed). Otherwise it --- contains an entity of type Finalizable_Ptr that is the head of the --- list of objects to finalize on exit. See "Finalization Management" --- section in exp_ch7.adb for more details. - -- Finalize_Storage_Only (Flag158) [base type only] -- Present in all types. Set on direct controlled types to which a -- valid Finalize_Storage_Only pragma applies. This flag is also set on @@ -1163,6 +1151,11 @@ package Einfo is -- the Finalize_Storage_Only pragma is required at each level of -- derivation. +-- Finalizer (Node24) +-- Applies to package declarations and bodies. Contains the entity of the +-- library-level program which finalizes all package-level controlled +-- objects. + -- First_Component (synthesized) -- Applies to record types. Returns the first component by following the -- chain of declared entities for the record until a component is found @@ -1564,13 +1557,6 @@ package Einfo is -- control wrapping of the body in Exp_Ch6 to ensure that the program -- error exception is correctly raised in this case at runtime. --- Has_Up_Level_Access (Flag215) --- Present in E_Variable and E_Constant entities. Set if the entity --- is a local variable declared in a subprogram p and is accessed in --- a subprogram nested inside p. Currently this flag is only set when --- VM_Target /= No_VM, for efficiency, since only the .NET back-end --- makes use of it to generate proper code for up-level references. - -- Has_Nested_Block_With_Handler (Flag101) -- Present in scope entities. Set if there is a nested block within the -- scope that has an exception handler and the two scopes are in the @@ -1838,6 +1824,13 @@ package Einfo is -- on the partial view, to insure that discriminants are properly -- inherited in certain contexts. +-- Has_Up_Level_Access (Flag215) +-- Present in E_Variable and E_Constant entities. Set if the entity +-- is a local variable declared in a subprogram p and is accessed in +-- a subprogram nested inside p. Currently this flag is only set when +-- VM_Target /= No_VM, for efficiency, since only the .NET back-end +-- makes use of it to generate proper code for up-level references. + -- Has_Volatile_Components (Flag87) [implementation base type only] -- Present in all types and objects. Set only for an array type or array -- object if a valid pragma Volatile_Components or a valid pragma @@ -2185,6 +2178,10 @@ package Einfo is -- and variables, but that may well change later on. Exceptions can only -- be exported in the OpenVMS and Java VM implementations of GNAT. +-- Is_Finalizer (synthesized) +-- Applies to all entities, true for procedures containing finalization +-- code to process local or library level objects. + -- Is_First_Subtype (Flag70) -- Present in all entities. True for first subtypes (RM 3.2.1(6)), -- i.e. the entity in the type declaration that introduced the type. @@ -2618,6 +2615,12 @@ package Einfo is -- Applies to all entities, true for private types and subtypes, -- as well as for record with private types as subtypes +-- Is_Processed_Transient (Flag252) +-- Present in entities of variables and constants. Set when a transient +-- object needs to be finalized and it has already been processed by the +-- transient scope machinery. This flag signals the general finalization +-- mechanism to ignore the transient object. + -- Is_Protected_Component (synthesized) -- Applicable to all entities, true if the entity denotes a private -- component of a protected type. @@ -3480,6 +3483,12 @@ package Einfo is -- is True only for implicitly declare subprograms; it is not set on the -- parent type's subprogram. See also Is_Abstract_Subprogram. +-- Return_Flag (Node15) +-- Applies to variables and constants. Set for objects which act as the +-- return value of an extended return statement. The node contains the +-- entity of a locally declared flag which controls the finalization of +-- the return object should the function fail. + -- Return_Present (Flag54) -- Present in function and generic function entities. Set if the -- function contains a return statement (used for error checking). @@ -3869,7 +3878,40 @@ package Einfo is -- Wrapped_Entity (Node27) -- Present in functions and procedures which have been classified as --- Is_Primitive_Wrapper. Set to the entity being wrapped. +-- Is_Primitive_Wrapper. Set to the entity being wrapper. + +-------------------------------------- +-- Delayed Freezing and Elaboration -- +-------------------------------------- + +-- The flag Has_Delayed_Freeze indicates that an entity carries an explicit +-- freeze node, which appears later in the expanded tree. + +-- a) The flag is used by the front-end to trigger expansion actions +-- which include the generation of that freeze node. Typically this happens at +-- the end of the current compilation unit, or before the first subprogram +-- body is encountered in the current unit. See files freeze and exp_ch13 for +-- details on the actions triggered by a freeze node, which include the +-- construction of initialization procedures and dispatch tables. + +-- b) The flag is used by the backend to defer elaboration of the entity until +-- its freeze node is seen. In the absence of an explicit freeze node, an +-- entity is frozen (and elaborated) at the point of declaration. + +-- For object declarations, the flag is set when an address clause for the +-- object is encountered. Legality checks on the address expression only +-- take place at the freeze point of the object. + +-- Most types have an explicit freeze node, because they cannot be elaborated +-- until all representation and operational items that apply to them have been +-- analyzed. Private types and incomplete types have the flag set as well, as +-- do task and protected types. + +-- Implicit base types created for type derivations, as well as classwide +-- types created for all tagged types, have the flag set. + +-- If a subprogram has an access parameter whose designated type is incomplete +-- the subprogram has the flag set. ------------------ -- Access Kinds -- @@ -4903,8 +4945,8 @@ package Einfo is -- Storage_Size_Variable (Node15) (base type only) -- Master_Id (Node17) -- Directly_Designated_Type (Node20) - -- Associated_Storage_Pool (Node22) (root type only) - -- Associated_Final_Chain (Node23) + -- Associated_Storage_Pool (Node22) (base type only) + -- Associated_Collection (Node23) (base type only) -- Has_Pragma_Controlled (Flag27) (base type only) -- Has_Storage_Size_Clause (Flag23) (base type only) -- Is_Access_Constant (Flag69) @@ -4932,6 +4974,7 @@ package Einfo is -- E_Anonymous_Access_Type -- Storage_Size_Variable (Node15) ??? is this needed ??? -- Directly_Designated_Type (Node20) + -- Associated_Collection (Node23) -- (plus type attributes) -- E_Array_Type @@ -4955,7 +4998,6 @@ package Einfo is -- Block_Node (Node11) -- First_Entity (Node17) -- Last_Entity (Node20) - -- Finalization_Chain_Entity (Node19) -- Scope_Depth_Value (Uint22) -- Entry_Cancel_Parameter (Node23) -- Delay_Cleanups (Flag114) @@ -5011,6 +5053,7 @@ package Einfo is -- Full_View (Node11) -- Esize (Uint12) -- Alignment (Uint14) + -- Return_Flag (Node15) (constants only) -- Actual_Subtype (Node17) -- Renamed_Object (Node18) -- Size_Check_Code (Node19) (constants only) @@ -5027,6 +5070,7 @@ package Einfo is -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) + -- Is_Processed_Transient (Flag252) (constants only) -- Is_Return_Object (Flag209) -- Is_True_Constant (Flag163) -- Is_Volatile (Flag16) @@ -5079,7 +5123,6 @@ package Einfo is -- Entry_Parameters_Type (Node15) -- First_Entity (Node17) -- Alias (Node18) (for entry only. Empty) - -- Finalization_Chain_Entity (Node19) -- Last_Entity (Node20) -- Accept_Address (Elist21) -- Scope_Depth_Value (Uint22) @@ -5178,7 +5221,6 @@ package Einfo is -- First_Entity (Node17) -- Alias (Node18) (non-generic case only) -- Renamed_Entity (Node18) (generic case only) - -- Finalization_Chain_Entity (Node19) -- Last_Entity (Node20) -- Interface_Name (Node21) -- Scope_Depth_Value (Uint22) @@ -5239,7 +5281,7 @@ package Einfo is -- Master_Id (Node17) -- Directly_Designated_Type (Node20) -- Associated_Storage_Pool (Node22) (root type only) - -- Associated_Final_Chain (Node23) + -- Associated_Collection (Node23) -- (plus type attributes) -- E_Generic_In_Parameter @@ -5377,6 +5419,7 @@ package Einfo is -- Generic_Renamings (Elist23) (for an instance) -- Inner_Instances (Elist23) (generic case only) -- Limited_View (Node23) (non-generic/instance) + -- Finalizer (Node24) (non-generic case only) -- Current_Use_Clause (Node27) -- Package_Instantiation (Node26) -- Delay_Subprogram_Descriptors (Flag50) @@ -5408,6 +5451,7 @@ package Einfo is -- Spec_Entity (Node19) -- Last_Entity (Node20) -- Scope_Depth_Value (Uint22) + -- Finalizer (Node24) (non-generic case only) -- Scope_Depth (synth) -- Delay_Subprogram_Descriptors (Flag50) -- Has_Subprogram_Descriptor (Flag93) @@ -5441,7 +5485,6 @@ package Einfo is -- First_Entity (Node17) -- Alias (Node18) (non-generic case only) -- Renamed_Entity (Node18) (generic case only) - -- Finalization_Chain_Entity (Node19) -- Last_Entity (Node20) -- Interface_Name (Node21) -- Scope_Depth_Value (Uint22) @@ -5493,6 +5536,7 @@ package Einfo is -- Address_Clause (synth) -- First_Formal (synth) -- First_Formal_With_Extras (synth) + -- Is_Finalizer (synth) -- Last_Formal (synth) -- Number_Formals (synth) @@ -5508,7 +5552,6 @@ package Einfo is -- First_Private_Entity (Node16) -- First_Entity (Node17) -- Corresponding_Record_Type (Node18) - -- Finalization_Chain_Entity (Node19) -- Last_Entity (Node20) -- Discriminant_Constraint (Elist21) -- Scope_Depth_Value (Uint22) @@ -5581,7 +5624,6 @@ package Einfo is -- E_Return_Statement -- Return_Applies_To (Node8) - -- Finalization_Chain_Entity (Node19) -- E_Signed_Integer_Type -- E_Signed_Integer_Subtype @@ -5634,7 +5676,6 @@ package Einfo is -- First_Private_Entity (Node16) -- First_Entity (Node17) -- Corresponding_Record_Type (Node18) - -- Finalization_Chain_Entity (Node19) -- Last_Entity (Node20) -- Discriminant_Constraint (Elist21) -- Scope_Depth_Value (Uint22) @@ -5657,6 +5698,7 @@ package Einfo is -- Esize (Uint12) -- Extra_Accessibility (Node13) -- Alignment (Uint14) + -- Return_Flag (Node15) (transient object only) -- Unset_Reference (Node16) -- Actual_Subtype (Node17) -- Renamed_Object (Node18) @@ -5678,6 +5720,7 @@ package Einfo is -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) + -- Is_Processed_Transient (Flag252) -- Is_Safe_To_Reevaluate (Flag249) -- Is_Shared_Passive (Flag60) -- Is_True_Constant (Flag163) @@ -5932,7 +5975,7 @@ package Einfo is function Address_Taken (Id : E) return B; function Alias (Id : E) return E; function Alignment (Id : E) return U; - function Associated_Final_Chain (Id : E) return E; + function Associated_Collection (Id : E) return E; function Associated_Formal_Package (Id : E) return E; function Associated_Node_For_Itype (Id : E) return N; function Associated_Storage_Pool (Id : E) return E; @@ -6008,8 +6051,8 @@ package Einfo is function Extra_Formal (Id : E) return E; function Extra_Formals (Id : E) return E; function Can_Use_Internal_Rep (Id : E) return B; - function Finalization_Chain_Entity (Id : E) return E; function Finalize_Storage_Only (Id : E) return B; + function Finalizer (Id : E) return E; function First_Entity (Id : E) return E; function First_Exit_Statement (Id : E) return N; function First_Index (Id : E) return N; @@ -6047,6 +6090,7 @@ package Einfo is function Has_Enumeration_Rep_Clause (Id : E) return B; function Has_Exit (Id : E) return B; function Has_External_Tag_Rep_Clause (Id : E) return B; + function Has_Forward_Instantiation (Id : E) return B; function Has_Fully_Qualified_Name (Id : E) return B; function Has_Gigi_Rep_Item (Id : E) return B; function Has_Homonym (Id : E) return B; @@ -6058,8 +6102,6 @@ package Einfo is function Has_Master_Entity (Id : E) return B; function Has_Missing_Return (Id : E) return B; function Has_Nested_Block_With_Handler (Id : E) return B; - function Has_Forward_Instantiation (Id : E) return B; - function Has_Up_Level_Access (Id : E) return B; function Has_Non_Standard_Rep (Id : E) return B; function Has_Object_Size_Clause (Id : E) return B; function Has_Per_Object_Constraint (Id : E) return B; @@ -6099,6 +6141,7 @@ package Einfo is function Has_Thunks (Id : E) return B; function Has_Unchecked_Union (Id : E) return B; function Has_Unknown_Discriminants (Id : E) return B; + function Has_Up_Level_Access (Id : E) return B; function Has_Volatile_Components (Id : E) return B; function Has_Xref_Entry (Id : E) return B; function Hiding_Loop_Variable (Id : E) return E; @@ -6177,6 +6220,7 @@ package Einfo is function Is_Private_Composite (Id : E) return B; function Is_Private_Descendant (Id : E) return B; function Is_Private_Primitive (Id : E) return B; + function Is_Processed_Transient (Id : E) return B; function Is_Public (Id : E) return B; function Is_Pure (Id : E) return B; function Is_Pure_Unit_Access_Type (Id : E) return B; @@ -6271,6 +6315,7 @@ package Einfo is function Renamed_Object (Id : E) return N; function Renaming_Map (Id : E) return U; function Requires_Overriding (Id : E) return B; + function Return_Flag (Id : E) return E; function Return_Present (Id : E) return B; function Return_Applies_To (Id : E) return N; function Returns_By_Ref (Id : E) return B; @@ -6402,6 +6447,7 @@ package Einfo is function Is_Constant_Object (Id : E) return B; function Is_Discriminal (Id : E) return B; function Is_Dynamic_Scope (Id : E) return B; + function Is_Finalizer (Id : E) return B; function Is_Package_Or_Generic_Package (Id : E) return B; function Is_Prival (Id : E) return B; function Is_Protected_Component (Id : E) return B; @@ -6519,7 +6565,7 @@ package Einfo is procedure Set_Address_Taken (Id : E; V : B := True); procedure Set_Alias (Id : E; V : E); procedure Set_Alignment (Id : E; V : U); - procedure Set_Associated_Final_Chain (Id : E; V : E); + procedure Set_Associated_Collection (Id : E; V : E); procedure Set_Associated_Formal_Package (Id : E; V : E); procedure Set_Associated_Node_For_Itype (Id : E; V : N); procedure Set_Associated_Storage_Pool (Id : E; V : E); @@ -6593,8 +6639,8 @@ package Einfo is procedure Set_Extra_Formal (Id : E; V : E); procedure Set_Extra_Formals (Id : E; V : E); procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True); - procedure Set_Finalization_Chain_Entity (Id : E; V : E); procedure Set_Finalize_Storage_Only (Id : E; V : B := True); + procedure Set_Finalizer (Id : E; V : E); procedure Set_First_Entity (Id : E; V : E); procedure Set_First_Exit_Statement (Id : E; V : N); procedure Set_First_Index (Id : E; V : N); @@ -6632,6 +6678,7 @@ package Einfo is procedure Set_Has_Enumeration_Rep_Clause (Id : E; V : B := True); procedure Set_Has_Exit (Id : E; V : B := True); procedure Set_Has_External_Tag_Rep_Clause (Id : E; V : B := True); + procedure Set_Has_Forward_Instantiation (Id : E; V : B := True); procedure Set_Has_Fully_Qualified_Name (Id : E; V : B := True); procedure Set_Has_Gigi_Rep_Item (Id : E; V : B := True); procedure Set_Has_Homonym (Id : E; V : B := True); @@ -6642,8 +6689,6 @@ package Einfo is procedure Set_Has_Master_Entity (Id : E; V : B := True); procedure Set_Has_Missing_Return (Id : E; V : B := True); procedure Set_Has_Nested_Block_With_Handler (Id : E; V : B := True); - procedure Set_Has_Forward_Instantiation (Id : E; V : B := True); - procedure Set_Has_Up_Level_Access (Id : E; V : B := True); procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True); procedure Set_Has_Object_Size_Clause (Id : E; V : B := True); procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True); @@ -6684,6 +6729,7 @@ package Einfo is procedure Set_Has_Thunks (Id : E; V : B := True); procedure Set_Has_Unchecked_Union (Id : E; V : B := True); procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True); + procedure Set_Has_Up_Level_Access (Id : E; V : B := True); procedure Set_Has_Volatile_Components (Id : E; V : B := True); procedure Set_Has_Xref_Entry (Id : E; V : B := True); procedure Set_Hiding_Loop_Variable (Id : E; V : E); @@ -6768,6 +6814,7 @@ package Einfo is procedure Set_Is_Private_Composite (Id : E; V : B := True); procedure Set_Is_Private_Descendant (Id : E; V : B := True); procedure Set_Is_Private_Primitive (Id : E; V : B := True); + procedure Set_Is_Processed_Transient (Id : E; V : B := True); procedure Set_Is_Public (Id : E; V : B := True); procedure Set_Is_Pure (Id : E; V : B := True); procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True); @@ -6862,6 +6909,7 @@ package Einfo is procedure Set_Renamed_Object (Id : E; V : N); procedure Set_Renaming_Map (Id : E; V : U); procedure Set_Requires_Overriding (Id : E; V : B := True); + procedure Set_Return_Flag (Id : E; V : E); procedure Set_Return_Present (Id : E; V : B := True); procedure Set_Return_Applies_To (Id : E; V : N); procedure Set_Returns_By_Ref (Id : E; V : B := True); @@ -7213,7 +7261,7 @@ package Einfo is pragma Inline (Address_Taken); pragma Inline (Alias); pragma Inline (Alignment); - pragma Inline (Associated_Final_Chain); + pragma Inline (Associated_Collection); pragma Inline (Associated_Formal_Package); pragma Inline (Associated_Node_For_Itype); pragma Inline (Associated_Storage_Pool); @@ -7289,7 +7337,7 @@ package Einfo is pragma Inline (Extra_Formal); pragma Inline (Extra_Formals); pragma Inline (Can_Use_Internal_Rep); - pragma Inline (Finalization_Chain_Entity); + pragma Inline (Finalizer); pragma Inline (First_Entity); pragma Inline (First_Exit_Statement); pragma Inline (First_Index); @@ -7326,6 +7374,7 @@ package Einfo is pragma Inline (Has_Enumeration_Rep_Clause); pragma Inline (Has_Exit); pragma Inline (Has_External_Tag_Rep_Clause); + pragma Inline (Has_Forward_Instantiation); pragma Inline (Has_Fully_Qualified_Name); pragma Inline (Has_Gigi_Rep_Item); pragma Inline (Has_Homonym); @@ -7336,7 +7385,6 @@ package Einfo is pragma Inline (Has_Master_Entity); pragma Inline (Has_Missing_Return); pragma Inline (Has_Nested_Block_With_Handler); - pragma Inline (Has_Forward_Instantiation); pragma Inline (Has_Non_Standard_Rep); pragma Inline (Has_Object_Size_Clause); pragma Inline (Has_Per_Object_Constraint); @@ -7495,6 +7543,7 @@ package Einfo is pragma Inline (Is_Private_Descendant); pragma Inline (Is_Private_Primitive); pragma Inline (Is_Private_Type); + pragma Inline (Is_Processed_Transient); pragma Inline (Is_Protected_Type); pragma Inline (Is_Public); pragma Inline (Is_Pure); @@ -7598,6 +7647,7 @@ package Einfo is pragma Inline (Renamed_Object); pragma Inline (Renaming_Map); pragma Inline (Requires_Overriding); + pragma Inline (Return_Flag); pragma Inline (Return_Present); pragma Inline (Return_Applies_To); pragma Inline (Returns_By_Ref); @@ -7655,7 +7705,7 @@ package Einfo is pragma Inline (Set_Address_Taken); pragma Inline (Set_Alias); pragma Inline (Set_Alignment); - pragma Inline (Set_Associated_Final_Chain); + pragma Inline (Set_Associated_Collection); pragma Inline (Set_Associated_Formal_Package); pragma Inline (Set_Associated_Node_For_Itype); pragma Inline (Set_Associated_Storage_Pool); @@ -7730,7 +7780,7 @@ package Einfo is pragma Inline (Set_Extra_Formal); pragma Inline (Set_Extra_Formals); pragma Inline (Set_Can_Use_Internal_Rep); - pragma Inline (Set_Finalization_Chain_Entity); + pragma Inline (Set_Finalizer); pragma Inline (Set_First_Entity); pragma Inline (Set_First_Exit_Statement); pragma Inline (Set_First_Index); @@ -7767,6 +7817,7 @@ package Einfo is pragma Inline (Set_Has_Enumeration_Rep_Clause); pragma Inline (Set_Has_Exit); pragma Inline (Set_Has_External_Tag_Rep_Clause); + pragma Inline (Set_Has_Forward_Instantiation); pragma Inline (Set_Has_Fully_Qualified_Name); pragma Inline (Set_Has_Gigi_Rep_Item); pragma Inline (Set_Has_Homonym); @@ -7777,7 +7828,6 @@ package Einfo is pragma Inline (Set_Has_Master_Entity); pragma Inline (Set_Has_Missing_Return); pragma Inline (Set_Has_Nested_Block_With_Handler); - pragma Inline (Set_Has_Forward_Instantiation); pragma Inline (Set_Has_Non_Standard_Rep); pragma Inline (Set_Has_Object_Size_Clause); pragma Inline (Set_Has_Per_Object_Constraint); @@ -7903,6 +7953,7 @@ package Einfo is pragma Inline (Set_Is_Private_Composite); pragma Inline (Set_Is_Private_Descendant); pragma Inline (Set_Is_Private_Primitive); + pragma Inline (Set_Is_Processed_Transient); pragma Inline (Set_Is_Public); pragma Inline (Set_Is_Pure); pragma Inline (Set_Is_Pure_Unit_Access_Type); @@ -7995,6 +8046,7 @@ package Einfo is pragma Inline (Set_Renamed_Object); pragma Inline (Set_Renaming_Map); pragma Inline (Set_Requires_Overriding); + pragma Inline (Set_Return_Flag); pragma Inline (Set_Return_Present); pragma Inline (Set_Return_Applies_To); pragma Inline (Set_Returns_By_Ref); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 27602cd64a6..a38eb597f08 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -73,6 +73,14 @@ package body Exp_Aggr is type Case_Table_Type is array (Nat range <>) of Case_Bounds; -- Table type used by Check_Case_Choices procedure + function Has_Default_Init_Comps (N : Node_Id) return Boolean; + -- N is an aggregate (record or array). Checks the presence of default + -- initialization (<>) in any component (Ada 2005: AI-287). + + function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean; + -- Returns true if N is an aggregate used to initialize the components + -- of an statically allocated dispatch table. + function Must_Slide (Obj_Type : Entity_Id; Typ : Entity_Id) return Boolean; @@ -93,18 +101,29 @@ package body Exp_Aggr is -- statement of variant part will usually be small and probably in near -- sorted order. - function Has_Default_Init_Comps (N : Node_Id) return Boolean; - -- N is an aggregate (record or array). Checks the presence of default - -- initialization (<>) in any component (Ada 2005: AI-287). - - function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean; - -- Returns true if N is an aggregate used to initialize the components - -- of an statically allocated dispatch table. - ------------------------------------------------------ -- Local subprograms for Record Aggregate Expansion -- ------------------------------------------------------ + function Build_Record_Aggr_Code + (N : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id; + Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id; + -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the + -- aggregate. Target is an expression containing the location on which the + -- component by component assignments will take place. Returns the list of + -- assignments plus all other adjustments needed for tagged and controlled + -- types. Is_Limited_Ancestor_Expansion indicates that the function has + -- been called recursively to expand the limited ancestor to avoid copying + -- it. + + procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id); + -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the + -- aggregate (which can only be a record type, this procedure is only used + -- for record types). Transform the given aggregate into a sequence of + -- assignments performed component by component. + procedure Expand_Record_Aggregate (N : Node_Id; Orig_Tag : Node_Id := Empty; @@ -122,37 +141,6 @@ package body Exp_Aggr is -- Parent_Expr is the ancestor part of the original extension -- aggregate - procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id); - -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the - -- aggregate (which can only be a record type, this procedure is only used - -- for record types). Transform the given aggregate into a sequence of - -- assignments performed component by component. - - function Build_Record_Aggr_Code - (N : Node_Id; - Typ : Entity_Id; - Lhs : Node_Id; - Flist : Node_Id := Empty; - Obj : Entity_Id := Empty; - Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id; - -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the - -- aggregate. Target is an expression containing the location on which the - -- component by component assignments will take place. Returns the list of - -- assignments plus all other adjustments needed for tagged and controlled - -- types. Flist is an expression representing the finalization list on - -- which to attach the controlled components if any. Obj is present in the - -- object declaration and dynamic allocation cases, it contains an entity - -- that allows to know if the value being created needs to be attached to - -- the final list in case of pragma Finalize_Storage_Only. - -- - -- ??? - -- The meaning of the Obj formal is extremely unclear. *What* entity - -- should be passed? For the object declaration case we may guess that - -- this is the object being declared, but what about the allocator case? - -- - -- Is_Limited_Ancestor_Expansion indicates that the function has been - -- called recursively to expand the limited ancestor to avoid copying it. - function Has_Mutable_Components (Typ : Entity_Id) return Boolean; -- Return true if one of the component is of a discriminated type with -- defaults. An aggregate for a type with mutable components must be @@ -185,6 +173,35 @@ package body Exp_Aggr is -- appear in a non-static context. Even if the component value is static, -- such an aggregate must be expanded into an assignment. + function Backend_Processing_Possible (N : Node_Id) return Boolean; + -- This function checks if array aggregate N can be processed directly + -- by the backend. If this is the case True is returned. + + function Build_Array_Aggr_Code + (N : Node_Id; + Ctype : Entity_Id; + Index : Node_Id; + Into : Node_Id; + Scalar_Comp : Boolean; + Indexes : List_Id := No_List) return List_Id; + -- This recursive routine returns a list of statements containing the + -- loops and assignments that are needed for the expansion of the array + -- aggregate N. + -- + -- N is the (sub-)aggregate node to be expanded into code. This node has + -- been fully analyzed, and its Etype is properly set. + -- + -- Index is the index node corresponding to the array sub-aggregate N + -- + -- Into is the target expression into which we are copying the aggregate. + -- Note that this node may not have been analyzed yet, and so the Etype + -- field may not be set. + -- + -- Scalar_Comp is True if the component type of the aggregate is scalar + -- + -- Indexes is the current list of expressions used to index the object we + -- are writing into. + procedure Convert_Array_Aggr_In_Allocator (Decl : Node_Id; Aggr : Node_Id; @@ -218,60 +235,16 @@ package body Exp_Aggr is -- This is the top-level routine to perform array aggregate expansion. -- N is the N_Aggregate node to be expanded. - function Backend_Processing_Possible (N : Node_Id) return Boolean; - -- This function checks if array aggregate N can be processed directly - -- by the backend. If this is the case True is returned. - - function Build_Array_Aggr_Code - (N : Node_Id; - Ctype : Entity_Id; - Index : Node_Id; - Into : Node_Id; - Scalar_Comp : Boolean; - Indexes : List_Id := No_List; - Flist : Node_Id := Empty) return List_Id; - -- This recursive routine returns a list of statements containing the - -- loops and assignments that are needed for the expansion of the array - -- aggregate N. - -- - -- N is the (sub-)aggregate node to be expanded into code. This node - -- has been fully analyzed, and its Etype is properly set. - -- - -- Index is the index node corresponding to the array sub-aggregate N. - -- - -- Into is the target expression into which we are copying the aggregate. - -- Note that this node may not have been analyzed yet, and so the Etype - -- field may not be set. - -- - -- Scalar_Comp is True if the component type of the aggregate is scalar. - -- - -- Indexes is the current list of expressions used to index the - -- object we are writing into. - -- - -- Flist is an expression representing the finalization list on which - -- to attach the controlled components if any. - - function Number_Of_Choices (N : Node_Id) return Nat; - -- Returns the number of discrete choices (not including the others choice - -- if present) contained in (sub-)aggregate N. - function Late_Expansion (N : Node_Id; Typ : Entity_Id; - Target : Node_Id; - Flist : Node_Id := Empty; - Obj : Entity_Id := Empty) return List_Id; - -- N is a nested (record or array) aggregate that has been marked with - -- 'Delay_Expansion'. Typ is the expected type of the aggregate and Target - -- is a (duplicable) expression that will hold the result of the aggregate - -- expansion. Flist is the finalization list to be used to attach - -- controlled components. 'Obj' when non empty, carries the original - -- object being initialized in order to know if it needs to be attached to - -- the previous parameter which may not be the case in the case where - -- Finalize_Storage_Only is set. Basically this procedure is used to - -- implement top-down expansions of nested aggregates. This is necessary - -- for avoiding temporaries at each level as well as for propagating the - -- right internal finalization list. + Target : Node_Id) return List_Id; + -- This routine implements top-down expansion of nested aggregates. In + -- doing so, it avoids the generation of temporaries at each level. N is a + -- nested (record or array) aggregate that has been marked with 'Delay_ + -- Expansion'. Typ is the expected type of the aggregate. Target is a + -- (duplicable) expression that will hold the result of the aggregate + -- expansion. function Make_OK_Assignment_Statement (Sloc : Source_Ptr; @@ -282,6 +255,10 @@ package body Exp_Aggr is -- use this routine. This is needed to deal with assignments to -- initialized constants that are done in place. + function Number_Of_Choices (N : Node_Id) return Nat; + -- Returns the number of discrete choices (not including the others choice + -- if present) contained in (sub-)aggregate N. + function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean; -- Given an array aggregate, this function handles the case of a packed -- array aggregate with all constant values, where the aggregate can be @@ -700,8 +677,7 @@ package body Exp_Aggr is Index : Node_Id; Into : Node_Id; Scalar_Comp : Boolean; - Indexes : List_Id := No_List; - Flist : Node_Id := Empty) return List_Id + Indexes : List_Id := No_List) return List_Id is Loc : constant Source_Ptr := Sloc (N); Index_Base : constant Entity_Id := Base_Type (Etype (Index)); @@ -938,7 +914,6 @@ package body Exp_Aggr is function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is L : constant List_Id := New_List; - F : Entity_Id; A : Node_Id; New_Indexes : List_Id; @@ -989,21 +964,6 @@ package body Exp_Aggr is Append_To (New_Indexes, Ind); - if Present (Flist) then - F := New_Copy_Tree (Flist); - - elsif Present (Etype (N)) and then Needs_Finalization (Etype (N)) then - if Is_Entity_Name (Into) - and then Present (Scope (Entity (Into))) - then - F := Find_Final_List (Scope (Entity (Into))); - else - F := Find_Final_List (Current_Scope); - end if; - else - F := Empty; - end if; - if Present (Next_Index (Index)) then return Add_Loop_Actions ( @@ -1013,8 +973,7 @@ package body Exp_Aggr is Index => Next_Index (Index), Into => Into, Scalar_Comp => Scalar_Comp, - Indexes => New_Indexes, - Flist => F)); + Indexes => New_Indexes)); end if; -- If we get here then we are at a bottom-level (sub-)aggregate @@ -1120,8 +1079,7 @@ package body Exp_Aggr is else return Add_Loop_Actions ( - Late_Expansion ( - Expr_Q, Etype (Expr_Q), Indexed_Comp, F)); + Late_Expansion (Expr_Q, Etype (Expr_Q), Indexed_Comp)); end if; end if; end if; @@ -1155,12 +1113,10 @@ package body Exp_Aggr is end if; if Needs_Finalization (Ctype) then - Append_List_To (L, + Append_To (L, Make_Init_Call ( - Ref => New_Copy_Tree (Indexed_Comp), - Typ => Ctype, - Flist_Ref => Find_Final_List (Current_Scope), - With_Attach => Make_Integer_Literal (Loc, 1))); + Obj_Ref => New_Copy_Tree (Indexed_Comp), + Typ => Ctype)); end if; else @@ -1252,12 +1208,10 @@ package body Exp_Aggr is and then Is_Controlled (Component_Type (Comp_Type)) and then Nkind (Expr) = N_Aggregate) then - Append_List_To (L, + Append_To (L, Make_Adjust_Call ( - Ref => New_Copy_Tree (Indexed_Comp), - Typ => Comp_Type, - Flist_Ref => F, - With_Attach => Make_Integer_Literal (Loc, 1))); + Obj_Ref => New_Copy_Tree (Indexed_Comp), + Typ => Comp_Type)); end if; end if; @@ -1780,9 +1734,7 @@ package body Exp_Aggr is (N : Node_Id; Typ : Entity_Id; Lhs : Node_Id; - Flist : Node_Id := Empty; - Obj : Entity_Id := Empty; - Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id + Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id is Loc : constant Source_Ptr := Sloc (N); L : constant List_Id := New_List; @@ -1792,14 +1744,11 @@ package body Exp_Aggr is Instr : Node_Id; Ref : Node_Id; Target : Entity_Id; - F : Node_Id; Comp_Type : Entity_Id; Selector : Entity_Id; Comp_Expr : Node_Id; Expr_Q : Node_Id; - Internal_Final_List : Node_Id := Empty; - -- If this is an internal aggregate, the External_Final_List is an -- expression for the controller record of the enclosing type. @@ -1807,15 +1756,13 @@ package body Exp_Aggr is -- expression will appear in several calls to attach to the finali- -- zation list, and it must not be shared. - External_Final_List : Node_Id; Ancestor_Is_Expression : Boolean := False; Ancestor_Is_Subtype_Mark : Boolean := False; Init_Typ : Entity_Id := Empty; - Attach : Node_Id; - Ctrl_Stuff_Done : Boolean := False; - -- True if Gen_Ctrl_Actions_For_Aggr has already been called; calls + Finalization_Done : Boolean := False; + -- True if Generate_Finalization_Actions has already been called; calls -- after the first do nothing. function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id; @@ -1835,7 +1782,7 @@ package body Exp_Aggr is -- Return true if Agg_Bounds are equal or within Typ_Bounds. It is -- assumed that both bounds are integer ranges. - procedure Gen_Ctrl_Actions_For_Aggr; + procedure Generate_Finalization_Actions; -- Deal with the various controlled type data structure initializations -- (but only if it hasn't been done already). @@ -1843,17 +1790,6 @@ package body Exp_Aggr is -- Returns the first discriminant association in the constraint -- associated with T, if any, otherwise returns Empty. - function Init_Controller - (Target : Node_Id; - Typ : Entity_Id; - F : Node_Id; - Attach : Node_Id; - Init_Pr : Boolean) return List_Id; - -- Returns the list of statements necessary to initialize the internal - -- controller of the (possible) ancestor typ into target and attach it - -- to finalization list F. Init_Pr conditions the call to the init proc - -- since it may already be done due to ancestor initialization. - procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id); -- If Typ is derived, and constrains discriminants of the parent type, -- these discriminants are not components of the aggregate, and must be @@ -2064,103 +2000,6 @@ package body Exp_Aggr is return Empty; end Get_Constraint_Association; - --------------------- - -- Init_Controller -- - --------------------- - - function Init_Controller - (Target : Node_Id; - Typ : Entity_Id; - F : Node_Id; - Attach : Node_Id; - Init_Pr : Boolean) return List_Id - is - L : constant List_Id := New_List; - Ref : Node_Id; - RC : RE_Id; - Target_Type : Entity_Id; - - begin - -- Generate: - -- init-proc (target._controller); - -- initialize (target._controller); - -- Attach_to_Final_List (target._controller, F); - - Ref := - Make_Selected_Component (Loc, - Prefix => Convert_To (Typ, New_Copy_Tree (Target)), - Selector_Name => Make_Identifier (Loc, Name_uController)); - Set_Assignment_OK (Ref); - - -- Ada 2005 (AI-287): Give support to aggregates of limited types. - -- If the type is intrinsically limited the controller is limited as - -- well. If it is tagged and limited then so is the controller. - -- Otherwise an untagged type may have limited components without its - -- full view being limited, so the controller is not limited. - - if Nkind (Target) = N_Identifier then - Target_Type := Etype (Target); - - elsif Nkind (Target) = N_Selected_Component then - Target_Type := Etype (Selector_Name (Target)); - - elsif Nkind (Target) = N_Unchecked_Type_Conversion then - Target_Type := Etype (Target); - - elsif Nkind (Target) = N_Unchecked_Expression - and then Nkind (Expression (Target)) = N_Indexed_Component - then - Target_Type := Etype (Prefix (Expression (Target))); - - else - Target_Type := Etype (Target); - end if; - - -- If the target has not been analyzed yet, as will happen with - -- delayed expansion, use the given type (either the aggregate type - -- or an ancestor) to determine limitedness. - - if No (Target_Type) then - Target_Type := Typ; - end if; - - if (Is_Tagged_Type (Target_Type)) - and then Is_Limited_Type (Target_Type) - then - RC := RE_Limited_Record_Controller; - - elsif Is_Immutably_Limited_Type (Target_Type) then - RC := RE_Limited_Record_Controller; - - else - RC := RE_Record_Controller; - end if; - - if Init_Pr then - Append_List_To (L, - Build_Initialization_Call (Loc, - Id_Ref => Ref, - Typ => RTE (RC), - In_Init_Proc => Within_Init_Proc)); - end if; - - Append_To (L, - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To ( - Find_Prim_Op (RTE (RC), Name_Initialize), Loc), - Parameter_Associations => - New_List (New_Copy_Tree (Ref)))); - - Append_To (L, - Make_Attach_Call ( - Obj_Ref => New_Copy_Tree (Ref), - Flist_Ref => F, - With_Attach => Attach)); - - return L; - end Init_Controller; - ------------------------------- -- Init_Hidden_Discriminants -- ------------------------------- @@ -2222,254 +2061,40 @@ package body Exp_Aggr is and then Nkind (High_Bound (Bounds)) = N_Integer_Literal; end Is_Int_Range_Bounds; - ------------------------------- - -- Gen_Ctrl_Actions_For_Aggr -- - ------------------------------- - - procedure Gen_Ctrl_Actions_For_Aggr is - Alloc : Node_Id := Empty; + ----------------------------------- + -- Generate_Finalization_Actions -- + ----------------------------------- + procedure Generate_Finalization_Actions is begin -- Do the work only the first time this is called - if Ctrl_Stuff_Done then + if Finalization_Done then return; end if; - Ctrl_Stuff_Done := True; - - if Present (Obj) - and then Finalize_Storage_Only (Typ) - and then - (Is_Library_Level_Entity (Obj) - or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) = - Standard_True) - - -- why not Is_True (Expr_Value (RTE (RE_Garbaage_Collected) ??? - then - Attach := Make_Integer_Literal (Loc, 0); - - elsif Nkind (Parent (N)) = N_Qualified_Expression - and then Nkind (Parent (Parent (N))) = N_Allocator - then - Alloc := Parent (Parent (N)); - Attach := Make_Integer_Literal (Loc, 2); - - else - Attach := Make_Integer_Literal (Loc, 1); - end if; + Finalization_Done := True; -- Determine the external finalization list. It is either the -- finalization list of the outer-scope or the one coming from - -- an outer aggregate. When the target is not a temporary, the + -- an outer aggregate. When the target is not a temporary, the -- proper scope is the scope of the target rather than the -- potentially transient current scope. - if Needs_Finalization (Typ) then - - -- The current aggregate belongs to an allocator which creates - -- an object through an anonymous access type or acts as the root - -- of a coextension chain. - - if Present (Alloc) - and then - (Is_Coextension_Root (Alloc) - or else Ekind (Etype (Alloc)) = E_Anonymous_Access_Type) - then - if No (Associated_Final_Chain (Etype (Alloc))) then - Build_Final_List (Alloc, Etype (Alloc)); - end if; - - External_Final_List := - Make_Selected_Component (Loc, - Prefix => - New_Reference_To ( - Associated_Final_Chain (Etype (Alloc)), Loc), - Selector_Name => Make_Identifier (Loc, Name_F)); - - elsif Present (Flist) then - External_Final_List := New_Copy_Tree (Flist); - - elsif Is_Entity_Name (Target) - and then Present (Scope (Entity (Target))) - then - External_Final_List := - Find_Final_List (Scope (Entity (Target))); - - else - External_Final_List := Find_Final_List (Current_Scope); - end if; - else - External_Final_List := Empty; - end if; - - -- Initialize and attach the outer object in the is_controlled case - - if Is_Controlled (Typ) then - if Ancestor_Is_Subtype_Mark then - Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); - Set_Assignment_OK (Ref); - Append_To (L, - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To - (Find_Prim_Op (Init_Typ, Name_Initialize), Loc), - Parameter_Associations => New_List (New_Copy_Tree (Ref)))); - end if; - - if not Has_Controlled_Component (Typ) then - Ref := New_Copy_Tree (Target); - Set_Assignment_OK (Ref); - - -- This is an aggregate of a coextension. Do not produce a - -- finalization call, but rather attach the reference of the - -- aggregate to its coextension chain. - - if Present (Alloc) - and then Is_Dynamic_Coextension (Alloc) - then - if No (Coextensions (Alloc)) then - Set_Coextensions (Alloc, New_Elmt_List); - end if; - - Append_Elmt (Ref, Coextensions (Alloc)); - else - Append_To (L, - Make_Attach_Call ( - Obj_Ref => Ref, - Flist_Ref => New_Copy_Tree (External_Final_List), - With_Attach => Attach)); - end if; - end if; - end if; - - -- In the Has_Controlled component case, all the intermediate - -- controllers must be initialized. - - if Has_Controlled_Component (Typ) - and not Is_Limited_Ancestor_Expansion + if Is_Controlled (Typ) + and then Ancestor_Is_Subtype_Mark then - declare - Inner_Typ : Entity_Id; - Outer_Typ : Entity_Id; - At_Root : Boolean; - - begin - -- Find outer type with a controller - - Outer_Typ := Base_Type (Typ); - while Outer_Typ /= Init_Typ - and then not Has_New_Controlled_Component (Outer_Typ) - loop - Outer_Typ := Etype (Outer_Typ); - end loop; - - -- Attach it to the outer record controller to the external - -- final list. - - if Outer_Typ = Init_Typ then - Append_List_To (L, - Init_Controller ( - Target => Target, - Typ => Outer_Typ, - F => External_Final_List, - Attach => Attach, - Init_Pr => False)); - - At_Root := True; - Inner_Typ := Init_Typ; - - else - Append_List_To (L, - Init_Controller ( - Target => Target, - Typ => Outer_Typ, - F => External_Final_List, - Attach => Attach, - Init_Pr => True)); - - Inner_Typ := Etype (Outer_Typ); - At_Root := - not Is_Tagged_Type (Typ) or else Inner_Typ = Outer_Typ; - end if; - - -- The outer object has to be attached as well - - if Is_Controlled (Typ) then - Ref := New_Copy_Tree (Target); - Set_Assignment_OK (Ref); - Append_To (L, - Make_Attach_Call ( - Obj_Ref => Ref, - Flist_Ref => New_Copy_Tree (External_Final_List), - With_Attach => New_Copy_Tree (Attach))); - end if; - - -- Initialize the internal controllers for tagged types with - -- more than one controller. - - while not At_Root and then Inner_Typ /= Init_Typ loop - if Has_New_Controlled_Component (Inner_Typ) then - F := - Make_Selected_Component (Loc, - Prefix => - Convert_To (Outer_Typ, New_Copy_Tree (Target)), - Selector_Name => - Make_Identifier (Loc, Name_uController)); - F := - Make_Selected_Component (Loc, - Prefix => F, - Selector_Name => Make_Identifier (Loc, Name_F)); - - Append_List_To (L, - Init_Controller ( - Target => Target, - Typ => Inner_Typ, - F => F, - Attach => Make_Integer_Literal (Loc, 1), - Init_Pr => True)); - Outer_Typ := Inner_Typ; - end if; - - -- Stop at the root - - At_Root := Inner_Typ = Etype (Inner_Typ); - Inner_Typ := Etype (Inner_Typ); - end loop; - - -- If not done yet attach the controller of the ancestor part - - if Outer_Typ /= Init_Typ - and then Inner_Typ = Init_Typ - and then Has_Controlled_Component (Init_Typ) - then - F := - Make_Selected_Component (Loc, - Prefix => Convert_To (Outer_Typ, New_Copy_Tree (Target)), - Selector_Name => - Make_Identifier (Loc, Name_uController)); - F := - Make_Selected_Component (Loc, - Prefix => F, - Selector_Name => Make_Identifier (Loc, Name_F)); - - Attach := Make_Integer_Literal (Loc, 1); - Append_List_To (L, - Init_Controller ( - Target => Target, - Typ => Init_Typ, - F => F, - Attach => Attach, - Init_Pr => False)); - - -- Note: Init_Pr is False because the ancestor part has - -- already been initialized either way (by default, if - -- given by a type name, otherwise from the expression). - - end if; - end; + Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); + Set_Assignment_OK (Ref); + + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (Find_Prim_Op (Init_Typ, Name_Initialize), Loc), + Parameter_Associations => New_List (New_Copy_Tree (Ref)))); end if; - end Gen_Ctrl_Actions_For_Aggr; + end Generate_Finalization_Actions; function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result; -- If default expression of a component mentions a discriminant of the @@ -2574,21 +2199,23 @@ package body Exp_Aggr is if Nkind (N) = N_Extension_Aggregate then declare - A : constant Node_Id := Ancestor_Part (N); - Assign : List_Id; + Ancestor : constant Node_Id := Ancestor_Part (N); + Assign : List_Id; begin -- If the ancestor part is a subtype mark "T", we generate - -- init-proc (T(tmp)); if T is constrained and - -- init-proc (S(tmp)); where S applies an appropriate - -- constraint if T is unconstrained + -- init-proc (T (tmp)); if T is constrained and + -- init-proc (S (tmp)); where S applies an appropriate + -- constraint if T is unconstrained - if Is_Entity_Name (A) and then Is_Type (Entity (A)) then + if Is_Entity_Name (Ancestor) + and then Is_Type (Entity (Ancestor)) + then Ancestor_Is_Subtype_Mark := True; - if Is_Constrained (Entity (A)) then - Init_Typ := Entity (A); + if Is_Constrained (Entity (Ancestor)) then + Init_Typ := Entity (Ancestor); -- For an ancestor part given by an unconstrained type mark, -- create a subtype constrained by appropriate corresponding @@ -2597,9 +2224,9 @@ package body Exp_Aggr is -- be used to generate the correct default value for the -- ancestor part. - elsif Has_Discriminants (Entity (A)) then + elsif Has_Discriminants (Entity (Ancestor)) then declare - Anc_Typ : constant Entity_Id := Entity (A); + Anc_Typ : constant Entity_Id := Entity (Ancestor); Anc_Constr : constant List_Id := New_List; Discrim : Entity_Id; Disc_Value : Node_Id; @@ -2650,17 +2277,17 @@ package body Exp_Aggr is or else Has_Task (Base_Type (Init_Typ)))); - if Is_Constrained (Entity (A)) - and then Has_Discriminants (Entity (A)) + if Is_Constrained (Entity (Ancestor)) + and then Has_Discriminants (Entity (Ancestor)) then - Check_Ancestor_Discriminants (Entity (A)); + Check_Ancestor_Discriminants (Entity (Ancestor)); end if; end if; -- Handle calls to C++ constructors - elsif Is_CPP_Constructor_Call (A) then - Init_Typ := Etype (A); + elsif Is_CPP_Constructor_Call (Ancestor) then + Init_Typ := Etype (Ancestor); Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); Set_Assignment_OK (Ref); @@ -2670,7 +2297,7 @@ package body Exp_Aggr is Typ => Init_Typ, In_Init_Proc => Within_Init_Proc, With_Default_Init => Has_Default_Init_Comps (N), - Constructor_Ref => A)); + Constructor_Ref => Ancestor)); -- Ada 2005 (AI-287): If the ancestor part is an aggregate of -- limited type, a recursive call expands the ancestor. Note that @@ -2681,9 +2308,9 @@ package body Exp_Aggr is -- transformed into an explicit dereference) or a qualification -- of one such. - elsif Is_Limited_Type (Etype (A)) - and then Nkind_In (Unqualify (A), N_Aggregate, - N_Extension_Aggregate) + elsif Is_Limited_Type (Etype (Ancestor)) + and then Nkind_In (Unqualify (Ancestor), N_Aggregate, + N_Extension_Aggregate) then Ancestor_Is_Expression := True; @@ -2691,20 +2318,18 @@ package body Exp_Aggr is -- controlled subcomponents of the ancestor part will be -- attached to it. - Gen_Ctrl_Actions_For_Aggr; + Generate_Finalization_Actions; Append_List_To (L, Build_Record_Aggr_Code ( - N => Unqualify (A), - Typ => Etype (Unqualify (A)), - Lhs => Target, - Flist => Flist, - Obj => Obj, + N => Unqualify (Ancestor), + Typ => Etype (Unqualify (Ancestor)), + Lhs => Target, Is_Limited_Ancestor_Expansion => True)); -- If the ancestor part is an expression "E", we generate - -- T(tmp) := E; + -- T (tmp) := E; -- In Ada 2005, this includes the case of a (possibly qualified) -- limited function call. The assignment will turn into a @@ -2713,16 +2338,16 @@ package body Exp_Aggr is else Ancestor_Is_Expression := True; - Init_Typ := Etype (A); + Init_Typ := Etype (Ancestor); -- If the ancestor part is an aggregate, force its full -- expansion, which was delayed. - if Nkind_In (Unqualify (A), N_Aggregate, - N_Extension_Aggregate) + if Nkind_In (Unqualify (Ancestor), N_Aggregate, + N_Extension_Aggregate) then - Set_Analyzed (A, False); - Set_Analyzed (Expression (A), False); + Set_Analyzed (Ancestor, False); + Set_Analyzed (Expression (Ancestor), False); end if; Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); @@ -2735,7 +2360,7 @@ package body Exp_Aggr is Assign := New_List ( Make_OK_Assignment_Statement (Loc, Name => Ref, - Expression => A)); + Expression => Ancestor)); Set_No_Ctrl_Actions (First (Assign)); -- Assign the tag now to make sure that the dispatching call in @@ -2775,16 +2400,13 @@ package body Exp_Aggr is -- Call Adjust manually - if Needs_Finalization (Etype (A)) - and then not Is_Limited_Type (Etype (A)) + if Needs_Finalization (Etype (Ancestor)) + and then not Is_Limited_Type (Etype (Ancestor)) then - Append_List_To (Assign, + Append_To (Assign, Make_Adjust_Call ( - Ref => New_Copy_Tree (Ref), - Typ => Etype (A), - Flist_Ref => New_Reference_To ( - RTE (RE_Global_Final_List), Loc), - With_Attach => Make_Integer_Literal (Loc, 0))); + Obj_Ref => New_Copy_Tree (Ref), + Typ => Etype (Ancestor))); end if; Append_To (L, @@ -2946,7 +2568,7 @@ package body Exp_Aggr is and then Has_Non_Null_Base_Init_Proc (Etype (Selector)) then if Ekind (Selector) /= E_Discriminant then - Gen_Ctrl_Actions_For_Aggr; + Generate_Finalization_Actions; end if; -- Ada 2005 (AI-287): If the component type has tasks then @@ -2997,7 +2619,7 @@ package body Exp_Aggr is -- controllers. Their position may depend on the discriminants. if Ekind (Selector) /= E_Discriminant then - Gen_Ctrl_Actions_For_Aggr; + Generate_Finalization_Actions; end if; Comp_Type := Underlying_Type (Etype (Selector)); @@ -3012,30 +2634,6 @@ package body Exp_Aggr is Expr_Q := Expression (Comp); end if; - -- The controller is the one of the parent type defining the - -- component (in case of inherited components). - - if Needs_Finalization (Comp_Type) then - Internal_Final_List := - Make_Selected_Component (Loc, - Prefix => Convert_To - (Scope (Original_Record_Component (Selector)), - New_Copy_Tree (Target)), - Selector_Name => Make_Identifier (Loc, Name_uController)); - - Internal_Final_List := - Make_Selected_Component (Loc, - Prefix => Internal_Final_List, - Selector_Name => Make_Identifier (Loc, Name_F)); - - -- The internal final list can be part of a constant object - - Set_Assignment_OK (Internal_Final_List); - - else - Internal_Final_List := Empty; - end if; - -- Now either create the assignment or generate the code for the -- inner aggregate top-down. @@ -3114,7 +2712,7 @@ package body Exp_Aggr is Append_List_To (L, Late_Expansion (Expr_Q, Comp_Type, - New_Reference_To (TmpE, Loc), Internal_Final_List)); + New_Reference_To (TmpE, Loc))); -- Slide @@ -3122,23 +2720,13 @@ package body Exp_Aggr is Make_Assignment_Statement (Loc, Name => New_Copy_Tree (Comp_Expr), Expression => New_Reference_To (TmpE, Loc))); - - -- Do not pass the original aggregate to Gigi as is, - -- since it will potentially clobber the front or the end - -- of the array. Setting the expression to empty is safe - -- since all aggregates are expanded into assignments. - - if Present (Obj) then - Set_Expression (Parent (Obj), Empty); - end if; end; -- Normal case (sliding not required) else Append_List_To (L, - Late_Expansion (Expr_Q, Comp_Type, Comp_Expr, - Internal_Final_List)); + Late_Expansion (Expr_Q, Comp_Type, Comp_Expr)); end if; -- Expr_Q is not delayed aggregate @@ -3183,21 +2771,16 @@ package body Exp_Aggr is Append_To (L, Instr); end if; - -- Adjust and Attach the component to the proper controller - - -- Adjust (tmp.comp); - -- Attach_To_Final_List (tmp.comp, - -- comp_typ (tmp)._record_controller.f) + -- Generate: + -- Adjust (tmp.comp); if Needs_Finalization (Comp_Type) and then not Is_Limited_Type (Comp_Type) then - Append_List_To (L, + Append_To (L, Make_Adjust_Call ( - Ref => New_Copy_Tree (Comp_Expr), - Typ => Comp_Type, - Flist_Ref => Internal_Final_List, - With_Attach => Make_Integer_Literal (Loc, 1))); + Obj_Ref => New_Copy_Tree (Comp_Expr), + Typ => Comp_Type)); end if; end if; @@ -3320,7 +2903,7 @@ package body Exp_Aggr is -- If the controllers have not been initialized yet (by lack of non- -- discriminant components), let's do it now. - Gen_Ctrl_Actions_For_Aggr; + Generate_Finalization_Actions; return L; end Build_Record_Aggr_Code; @@ -3343,40 +2926,7 @@ package body Exp_Aggr is Make_Explicit_Dereference (Loc, New_Reference_To (Temp, Loc))); - Access_Type : constant Entity_Id := Etype (Temp); - Flist : Entity_Id; - begin - -- If the allocator is for an access discriminant, there is no - -- finalization list for the anonymous access type, and the eventual - -- finalization of the object is handled through the coextension - -- mechanism. If the enclosing object is not dynamically allocated, - -- the access discriminant is itself placed on the stack. Otherwise, - -- some other finalization list is used (see exp_ch4.adb). - - -- Decl has been inserted in the code ahead of the allocator, using - -- Insert_Actions. We use Insert_Actions below as well, to ensure that - -- subsequent insertions are done in the proper order. Using (for - -- example) Insert_Actions_After to place the expanded aggregate - -- immediately after Decl may lead to out-of-order references if the - -- allocator has generated a finalization list, as when the designated - -- object is controlled and there is an open transient scope. - - if Ekind (Access_Type) = E_Anonymous_Access_Type - and then Nkind (Associated_Node_For_Itype (Access_Type)) = - N_Discriminant_Specification - then - Flist := Empty; - - elsif Needs_Finalization (Typ) then - Flist := Find_Final_List (Access_Type); - - -- Otherwise there are no controlled actions to be performed. - - else - Flist := Empty; - end if; - if Is_Array_Type (Typ) then Convert_Array_Aggr_In_Allocator (Decl, Aggr, Occ); @@ -3386,14 +2936,7 @@ package body Exp_Aggr is Init_Stmts : List_Id; begin - Init_Stmts := - Late_Expansion - (Aggr, Typ, Occ, - Flist, - Associated_Final_Chain (Base_Type (Access_Type))); - - -- ??? Dubious actual for Obj: expect 'the original object being - -- initialized' + Init_Stmts := Late_Expansion (Aggr, Typ, Occ); if Has_Task (Typ) then Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts); @@ -3404,14 +2947,7 @@ package body Exp_Aggr is end; else - Insert_Actions (Alloc, - Late_Expansion - (Aggr, Typ, Occ, Flist, - Associated_Final_Chain (Base_Type (Access_Type)))); - - -- ??? Dubious actual for Obj: expect 'the original object being - -- initialized' - + Insert_Actions (Alloc, Late_Expansion (Aggr, Typ, Occ)); end if; end Convert_Aggr_In_Allocator; @@ -3429,10 +2965,7 @@ package body Exp_Aggr is Aggr := Expression (Aggr); end if; - Insert_Actions_After (N, - Late_Expansion - (Aggr, Typ, Occ, - Find_Final_List (Typ, New_Copy_Tree (Occ)))); + Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ)); end Convert_Aggr_In_Assignment; --------------------------------- @@ -3551,7 +3084,7 @@ package body Exp_Aggr is Is_Controlled (Typ) or else Has_Controlled_Component (Typ)); end if; - Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ, Obj => Obj)); + Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ)); Set_No_Initialization (N); Initialize_Discriminants (N, Typ); end Convert_Aggr_In_Object_Decl; @@ -3688,8 +3221,8 @@ package body Exp_Aggr is and then Nkind (Parent (N)) = N_Assignment_Statement then Target_Expr := New_Copy_Tree (Name (Parent (N))); - Insert_Actions - (Parent (N), Build_Record_Aggr_Code (N, Typ, Target_Expr)); + Insert_Actions (Parent (N), + Build_Record_Aggr_Code (N, Typ, Target_Expr)); Rewrite (Parent (N), Make_Null_Statement (Loc)); else @@ -6169,13 +5702,11 @@ package body Exp_Aggr is function Late_Expansion (N : Node_Id; Typ : Entity_Id; - Target : Node_Id; - Flist : Node_Id := Empty; - Obj : Entity_Id := Empty) return List_Id + Target : Node_Id) return List_Id is begin if Is_Record_Type (Etype (N)) then - return Build_Record_Aggr_Code (N, Typ, Target, Flist, Obj); + return Build_Record_Aggr_Code (N, Typ, Target); else pragma Assert (Is_Array_Type (Etype (N))); return @@ -6185,8 +5716,7 @@ package body Exp_Aggr is Index => First_Index (Typ), Into => Target, Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)), - Indexes => No_List, - Flist => Flist); + Indexes => No_List); end if; end Late_Expansion; diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index a0250ec1797..d2143c19387 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -205,6 +205,77 @@ package body Exp_Ch13 is end case; end Expand_N_Attribute_Definition_Clause; + ----------------------------- + -- Expand_N_Free_Statement -- + ----------------------------- + + procedure Expand_N_Free_Statement (N : Node_Id) is + Expr : constant Node_Id := Expression (N); + Typ : Entity_Id := Etype (Expr); + + begin + -- Use the base type to perform the collection check + + if Ekind (Typ) = E_Access_Subtype then + Typ := Etype (Typ); + end if; + + -- Handle private access types + + if Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + then + Typ := Full_View (Typ); + end if; + + -- Do not create a custom Deallocate when freeing an object with + -- suppressed finalization. In such cases the object is never attached + -- to a collection, so it does not need to be detached. Use a regular + -- free statement instead. + + if No (Associated_Collection (Typ)) then + return; + end if; + + -- Use a temporary to store the result of a complex expression. Perform + -- the following transformation: + -- + -- Free (Complex_Expression); + -- + -- Temp : constant Type_Of_Expression := Complex_Expression; + -- Free (Temp); + + if Nkind (Expr) /= N_Identifier then + declare + Expr_Typ : constant Entity_Id := Etype (Expr); + Loc : constant Source_Ptr := Sloc (N); + New_Expr : Node_Id; + Temp_Id : Entity_Id; + + begin + Temp_Id := Make_Temporary (Loc, 'T'); + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Object_Definition => + New_Reference_To (Expr_Typ, Loc), + Expression => + Relocate_Node (Expr))); + + New_Expr := New_Reference_To (Temp_Id, Loc); + Set_Etype (New_Expr, Expr_Typ); + + Set_Expression (N, New_Expr); + end; + end if; + + -- Create a custom Deallocate for a controlled object. This routine + -- ensures that the hidden list header will be deallocated along with + -- the actual object. + + Build_Allocate_Deallocate_Proc (N, Is_Allocate => False); + end Expand_N_Free_Statement; + ---------------------------- -- Expand_N_Freeze_Entity -- ---------------------------- @@ -324,7 +395,39 @@ package body Exp_Ch13 is if In_Other_Scope then Push_Scope (E_Scope); - Install_Visible_Declarations (E_Scope); + + -- Finalizers are little odd in terms of freezing. The spec of the + -- procedure appears in the declarations while the body appears in + -- the statement part of a single construct. Since the finalizer must + -- be called by the At_End handler of the construct, the spec is + -- manually frozen right after its declaration. The only side effect + -- of this action appears in contexts where the construct is not in + -- its final resting place. These contexts are: + + -- * Entry bodies - The declarations and statements are moved to + -- the procedure equivalen of the entry. + -- * Protected subprograms - The declarations and statements are + -- moved to the non-protected version of the subprogram. + -- * Task bodies - The declarations and statements are moved to the + -- task body procedure. + + -- Visible declarations do not need to be installed in these three + -- cases since it does not make semantic sense to do so. All entities + -- referenced by a finalizer are visible and already resolved, plus + -- the enclosing scope may not have visible declarations at all. + + if Ekind (E) = E_Procedure + and then Is_Finalizer (E) + and then + (Is_Entry (E_Scope) + or else (Is_Subprogram (E_Scope) + and then Is_Protected_Type (Scope (E_Scope))) + or else Is_Task_Type (E_Scope)) + then + null; + else + Install_Visible_Declarations (E_Scope); + end if; if Is_Package_Or_Generic_Package (E_Scope) or else Is_Protected_Type (E_Scope) or else diff --git a/gcc/ada/exp_ch13.ads b/gcc/ada/exp_ch13.ads index 4090d8ac8ef..484fe641910 100644 --- a/gcc/ada/exp_ch13.ads +++ b/gcc/ada/exp_ch13.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -30,6 +30,7 @@ with Types; use Types; package Exp_Ch13 is procedure Expand_N_Attribute_Definition_Clause (N : Node_Id); + procedure Expand_N_Free_Statement (N : Node_Id); procedure Expand_N_Freeze_Entity (N : Node_Id); procedure Expand_N_Record_Representation_Clause (N : Node_Id); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index f4e103facc5..682ae94a18d 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -77,10 +77,6 @@ package body Exp_Ch3 is -- Local Subprograms -- ----------------------- - function Add_Final_Chain (Def_Id : Entity_Id) return Entity_Id; - -- Add the declaration of a finalization list to the freeze actions for - -- Def_Id, and return its defining identifier. - procedure Adjust_Discriminants (Rtype : Entity_Id); -- This is used when freezing a record type. It attempts to construct -- more restrictive subtypes for discriminants so that the max size of @@ -132,9 +128,9 @@ package body Exp_Ch3 is -- declaration of the designated type that contains tasks. The renaming -- declaration is inserted before N, and after the Master declaration. - procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id); + procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id); -- Build record initialization procedure. N is the type declaration - -- node, and Pe is the corresponding entity for the record type. + -- node, and Rec_Ent is the corresponding entity for the record type. procedure Build_Slice_Assignment (Typ : Entity_Id); -- Build assignment procedure for one-dimensional arrays of controlled @@ -171,17 +167,16 @@ package body Exp_Ch3 is -- the value of the access to the Dispatch table. This procedure is only -- called on root type, the _Tag field being inherited by the descendants. - procedure Expand_Record_Controller (T : Entity_Id); - -- T must be a record type that Has_Controlled_Component. Add a field - -- _controller of type Record_Controller or Limited_Record_Controller - -- in the record T. - procedure Expand_Freeze_Array_Type (N : Node_Id); -- Freeze an array type. Deals with building the initialization procedure, -- creating the packed array type for a packed array and also with the -- creation of the controlling procedures for the controlled case. The -- argument N is the N_Freeze_Entity node for the type. + procedure Expand_Freeze_Class_Wide_Type (N : Node_Id); + -- Freeze a class-wide type. Build routine Finalize_Address for the purpose + -- of finalizing controlled derivations from the class-wide's root type. + procedure Expand_Freeze_Enumeration_Type (N : Node_Id); -- Freeze enumeration type with non-standard representation. Builds the -- array and function needed to convert between enumeration pos and @@ -370,28 +365,6 @@ package body Exp_Ch3 is -- the generation of these operations, as a useful optimization or for -- certification purposes. - --------------------- - -- Add_Final_Chain -- - --------------------- - - function Add_Final_Chain (Def_Id : Entity_Id) return Entity_Id is - Loc : constant Source_Ptr := Sloc (Def_Id); - Flist : Entity_Id; - - begin - Flist := - Make_Defining_Identifier (Loc, - New_External_Name (Chars (Def_Id), 'L')); - - Append_Freeze_Action (Def_Id, - Make_Object_Declaration (Loc, - Defining_Identifier => Flist, - Object_Definition => - New_Reference_To (RTE (RE_List_Controller), Loc))); - - return Flist; - end Add_Final_Chain; - -------------------------- -- Adjust_Discriminants -- -------------------------- @@ -554,10 +527,10 @@ package body Exp_Ch3 is procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is Loc : constant Source_Ptr := Sloc (Nod); Comp_Type : constant Entity_Id := Component_Type (A_Type); - Index_List : List_Id; - Proc_Id : Entity_Id; Body_Stmts : List_Id; Has_Default_Init : Boolean; + Index_List : List_Id; + Proc_Id : Entity_Id; function Init_Component return List_Id; -- Create one statement to initialize one array component, designated @@ -809,12 +782,12 @@ package body Exp_Ch3 is ----------------------------- procedure Build_Class_Wide_Master (T : Entity_Id) is - Loc : constant Source_Ptr := Sloc (T); - M_Id : Entity_Id; - Decl : Node_Id; - P : Node_Id; - Par : Node_Id; - Scop : Entity_Id; + Loc : constant Source_Ptr := Sloc (T); + Master_Id : Entity_Id; + Master_Scope : Entity_Id; + Name_Id : Node_Id; + Related_Node : Node_Id; + Ren_Decl : Node_Id; begin -- Nothing to do if there is no task hierarchy @@ -823,77 +796,107 @@ package body Exp_Ch3 is return; end if; - -- Find declaration that created the access type: either a type - -- declaration, or an object declaration with an access definition, + -- Find the declaration that created the access type. It is either a + -- type declaration, or an object declaration with an access definition, -- in which case the type is anonymous. if Is_Itype (T) then - P := Associated_Node_For_Itype (T); + Related_Node := Associated_Node_For_Itype (T); else - P := Parent (T); + Related_Node := Parent (T); end if; - Scop := Find_Master_Scope (T); + Master_Scope := Find_Master_Scope (T); - -- Nothing to do if we already built a master entity for this scope + -- Nothing to do if the master scope already contains a _master entity. + -- The only exception to this is the following scenario: - if not Has_Master_Entity (Scop) then + -- Source_Scope + -- Transient_Scope_1 + -- _master - -- First build the master entity - -- _Master : constant Master_Id := Current_Master.all; - -- and insert it just before the current declaration. + -- Transient_Scope_2 + -- use of master - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uMaster), - Constant_Present => True, - Object_Definition => New_Reference_To (Standard_Integer, Loc), - Expression => - Make_Explicit_Dereference (Loc, - New_Reference_To (RTE (RE_Current_Master), Loc))); + -- In this case the source scope is marked as having the master entity + -- even though the actual declaration appears inside an inner scope. If + -- the second transient scope requires a _master, it cannot use the one + -- already declared because the entity is not visible. - Set_Has_Master_Entity (Scop); - Insert_Action (P, Decl); - Analyze (Decl); + Name_Id := Make_Identifier (Loc, Name_uMaster); - -- Now mark the containing scope as a task master. Masters - -- associated with return statements are already marked at - -- this stage (see Analyze_Subprogram_Body). + if not Has_Master_Entity (Master_Scope) + or else No (Current_Entity_In_Scope (Name_Id)) + then + declare + Master_Decl : Node_Id; - if Ekind (Current_Scope) /= E_Return_Statement then - Par := P; - while Nkind (Par) /= N_Compilation_Unit loop - Par := Parent (Par); + begin + Set_Has_Master_Entity (Master_Scope); - -- If we fall off the top, we are at the outer level, and the - -- environment task is our effective master, so nothing to mark. + -- Generate: + -- _master : constant Integer := Current_Master.all; + + Master_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uMaster), + Constant_Present => True, + Object_Definition => + New_Reference_To (Standard_Integer, Loc), + Expression => + Make_Explicit_Dereference (Loc, + New_Reference_To (RTE (RE_Current_Master), Loc))); - if Nkind_In - (Par, N_Task_Body, N_Block_Statement, N_Subprogram_Body) - then - Set_Is_Task_Master (Par, True); - exit; - end if; - end loop; - end if; - end if; + Insert_Action (Related_Node, Master_Decl); + Analyze (Master_Decl); - -- Now define the renaming of the master_id + -- Mark the containing scope as a task master. Masters associated + -- with return statements are already marked at this stage (see + -- Analyze_Subprogram_Body). - M_Id := + if Ekind (Current_Scope) /= E_Return_Statement then + declare + Par : Node_Id := Related_Node; + + begin + while Nkind (Par) /= N_Compilation_Unit loop + Par := Parent (Par); + + -- If we fall off the top, we are at the outer level, and + -- the environment task is our effective master, so + -- nothing to mark. + + if Nkind_In (Par, N_Block_Statement, + N_Subprogram_Body, + N_Task_Body) + then + Set_Is_Task_Master (Par); + exit; + end if; + end loop; + end; + end if; + end; + end if; + + Master_Id := Make_Defining_Identifier (Loc, New_External_Name (Chars (T), 'M')); - Decl := + -- Generate: + -- Mnn renames _master; + + Ren_Decl := Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => M_Id, + Defining_Identifier => Master_Id, Subtype_Mark => New_Reference_To (Standard_Integer, Loc), - Name => Make_Identifier (Loc, Name_uMaster)); - Insert_Before (P, Decl); - Analyze (Decl); + Name => Name_Id); - Set_Master_Id (T, M_Id); + Insert_Before (Related_Node, Ren_Decl); + Analyze (Ren_Decl); + + Set_Master_Id (T, Master_Id); exception when RE_Not_Available => @@ -1422,9 +1425,8 @@ package body Exp_Ch3 is Res : constant List_Id := New_List; Arg : Node_Id; Args : List_Id; - Controller_Typ : Entity_Id; - Decl : Node_Id; Decls : List_Id; + Decl : Node_Id; Discr : Entity_Id; First_Arg : Node_Id; Full_Init_Type : Entity_Id; @@ -1656,41 +1658,10 @@ package body Exp_Ch3 is and then Nkind (Id_Ref) = N_Selected_Component then if Chars (Selector_Name (Id_Ref)) /= Name_uParent then - Append_List_To (Res, - Make_Init_Call ( - Ref => New_Copy_Tree (First_Arg), - Typ => Typ, - Flist_Ref => - Find_Final_List (Typ, New_Copy_Tree (First_Arg)), - With_Attach => Make_Integer_Literal (Loc, 1))); - - -- If the enclosing type is an extension with new controlled - -- components, it has his own record controller. If the parent - -- also had a record controller, attach it to the new one. - - -- Build_Init_Statements relies on the fact that in this specific - -- case the last statement of the result is the attach call to - -- the controller. If this is changed, it must be synchronized. - - elsif Present (Enclos_Type) - and then Has_New_Controlled_Component (Enclos_Type) - and then Has_Controlled_Component (Typ) - then - if Is_Immutably_Limited_Type (Typ) then - Controller_Typ := RTE (RE_Limited_Record_Controller); - else - Controller_Typ := RTE (RE_Record_Controller); - end if; - - Append_List_To (Res, + Append_To (Res, Make_Init_Call ( - Ref => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (First_Arg), - Selector_Name => Make_Identifier (Loc, Name_uController)), - Typ => Controller_Typ, - Flist_Ref => Find_Final_List (Typ, New_Copy_Tree (First_Arg)), - With_Attach => Make_Integer_Literal (Loc, 1))); + Obj_Ref => New_Copy_Tree (First_Arg), + Typ => Typ)); end if; end if; @@ -1764,29 +1735,32 @@ package body Exp_Ch3 is -- Build_Record_Init_Proc -- ---------------------------- - procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is - Loc : Source_Ptr := Sloc (N); - Discr_Map : constant Elist_Id := New_Elmt_List; - Proc_Id : Entity_Id; - Rec_Type : Entity_Id; - Set_Tag : Entity_Id := Empty; + procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id) is + Decls : constant List_Id := New_List; + Discr_Map : constant Elist_Id := New_Elmt_List; + Counter : Int := 0; + Loc : Source_Ptr := Sloc (N); + Proc_Id : Entity_Id; + Rec_Type : Entity_Id; + Set_Tag : Entity_Id := Empty; function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id; - -- Build a assignment statement node which assigns to record component - -- its default expression if defined. The assignment left hand side is - -- marked Assignment_OK so that initialization of limited private - -- records works correctly, Return also the adjustment call for - -- controlled objects + -- Build an assignment statement which assigns the default expression + -- to its corresponding record component if defined. The left hand side + -- of the assignment is marked Assignment_OK so that initialization of + -- limited private records works correctly. This routine may also build + -- an adjustment call if the component is controlled. procedure Build_Discriminant_Assignments (Statement_List : List_Id); - -- If the record has discriminants, adds assignment statements to - -- statement list to initialize the discriminant values from the + -- If the record has discriminants, add assignment statements to + -- Statement_List to initialize the discriminant values from the -- arguments of the initialization procedure. function Build_Init_Statements (Comp_List : Node_Id) return List_Id; -- Build a list representing a sequence of statements which initialize -- components of the given component list. This may involve building - -- case statements for the variant parts. + -- case statements for the variant parts. Append any locally declared + -- objects on list Decls. function Build_Init_Call_Thru (Parameters : List_Id) return List_Id; -- Given a non-tagged type-derivation that declares discriminants, @@ -1798,9 +1772,9 @@ package body Exp_Ch3 is -- -- we make the _init_proc of D be -- - -- procedure _init_proc(X : D; D1 : Integer) is + -- procedure _init_proc (X : D; D1 : Integer) is -- begin - -- _init_proc( R(X), 1, D1); + -- _init_proc (R (X), 1, D1); -- end _init_proc; -- -- This function builds the call statement in this _init_proc. @@ -1813,13 +1787,12 @@ package body Exp_Ch3 is procedure Build_Init_Procedure; -- Build the tree corresponding to the procedure specification and body - -- of the initialization procedure (by calling all the preceding - -- auxiliary routines), and install it as the _init TSS. + -- of the initialization procedure and install it as the _init TSS. procedure Build_Offset_To_Top_Functions; -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec - -- and body of the Offset_To_Top function that is generated when the - -- parent of a type with discriminants has secondary dispatch tables. + -- and body of Offset_To_Top, a function used in conjuction with types + -- having secondary dispatch tables. procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id); -- Add range checks to components of discriminated records. S is a @@ -1828,37 +1801,17 @@ package body Exp_Ch3 is function Component_Needs_Simple_Initialization (T : Entity_Id) return Boolean; - -- Determines if a component needs simple initialization, given its type - -- T. This is the same as Needs_Simple_Initialization except for the - -- following difference: the types Tag and Interface_Tag, that are - -- access types which would normally require simple initialization to - -- null, do not require initialization as components, since they are - -- explicitly initialized by other means. - - procedure Constrain_Array - (SI : Node_Id; - Check_List : List_Id); - -- Called from Build_Record_Checks. - -- Apply a list of index constraints to an unconstrained array type. - -- The first parameter is the entity for the resulting subtype. - -- Check_List is a list to which the check actions are appended. - - procedure Constrain_Index - (Index : Node_Id; - S : Node_Id; - Check_List : List_Id); - -- Process an index constraint in a constrained array declaration. - -- The constraint can be a subtype name, or a range with or without - -- an explicit subtype mark. The index is the corresponding index of the - -- unconstrained array. S is the range expression. Check_List is a list - -- to which the check actions are appended (called from - -- Build_Record_Checks). + -- Determine if a component needs simple initialization, given its type + -- T. This routine is the same as Needs_Simple_Initialization except for + -- components of type Tag and Interface_Tag. These two access types do + -- not require initialization since they are explicitly initialized by + -- other means. function Parent_Subtype_Renaming_Discrims return Boolean; -- Returns True for base types N that rename discriminants, else False function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean; - -- Determines whether a record initialization procedure needs to be + -- Determine whether a record initialization procedure needs to be -- generated for the given record type. ---------------------- @@ -1866,10 +1819,10 @@ package body Exp_Ch3 is ---------------------- function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is - Exp : Node_Id := N; - Lhs : Node_Id; Typ : constant Entity_Id := Underlying_Type (Etype (Id)); + Exp : Node_Id := N; Kind : Node_Kind := Nkind (N); + Lhs : Node_Id; Res : List_Id; begin @@ -1886,7 +1839,7 @@ package body Exp_Ch3 is -- the expression being given by such an attribute, but does not -- cover uses nested within an initial value expression. Nested -- uses are unlikely to occur in practice, but are theoretically - -- possible. It is not clear how to handle them without fully + -- possible.) It is not clear how to handle them without fully -- traversing the expression. ??? if Kind = N_Attribute_Reference @@ -1899,7 +1852,8 @@ package body Exp_Ch3 is then Exp := Make_Attribute_Reference (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), + Prefix => + Make_Identifier (Loc, Name_uInit), Attribute_Name => Name_Unrestricted_Access); end if; @@ -1921,12 +1875,15 @@ package body Exp_Ch3 is -- Suppress the tag adjustment when VM_Target because VM tags are -- represented implicitly in objects. - if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then + if Is_Tagged_Type (Typ) + and then Tagged_Type_Expansion + then Append_To (Res, Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Lhs, New_Scope => Proc_Id), + Prefix => + New_Copy_Tree (Lhs, New_Scope => Proc_Id), Selector_Name => New_Reference_To (First_Tag_Component (Typ), Loc)), @@ -1950,17 +1907,10 @@ package body Exp_Ch3 is and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)) and then not Is_Immutably_Limited_Type (Typ) then - declare - Ref : constant Node_Id := - New_Copy_Tree (Lhs, New_Scope => Proc_Id); - begin - Append_List_To (Res, - Make_Adjust_Call ( - Ref => Ref, - Typ => Etype (Id), - Flist_Ref => Find_Final_List (Etype (Id), Ref), - With_Attach => Make_Integer_Literal (Loc, 1))); - end; + Append_To (Res, + Make_Adjust_Call ( + Obj_Ref => New_Copy_Tree (Lhs), + Typ => Etype (Id))); end if; return Res; @@ -1975,15 +1925,14 @@ package body Exp_Ch3 is ------------------------------------ procedure Build_Discriminant_Assignments (Statement_List : List_Id) is - D : Entity_Id; Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type); + D : Entity_Id; begin if Has_Discriminants (Rec_Type) and then not Is_Unchecked_Union (Rec_Type) then D := First_Discriminant (Rec_Type); - while Present (D) loop -- Don't generate the assignment for discriminants in derived @@ -1991,8 +1940,8 @@ package body Exp_Ch3 is -- ancestor discriminant. This initialization will be done -- when initializing the _parent field of the derived record. - if Is_Tagged and then - Present (Corresponding_Discriminant (D)) + if Is_Tagged + and then Present (Corresponding_Discriminant (D)) then null; @@ -2024,10 +1973,10 @@ package body Exp_Ch3 is First_Discr_Param : Node_Id; - Parent_Discr : Entity_Id; - First_Arg : Node_Id; - Args : List_Id; Arg : Node_Id; + Args : List_Id; + First_Arg : Node_Id; + Parent_Discr : Entity_Id; Res : List_Id; begin @@ -2080,12 +2029,12 @@ package body Exp_Ch3 is -- directly. declare - Discr_Value : Elmt_Id := - First_Elmt - (Stored_Constraint (Rec_Type)); - Discr : Entity_Id := First_Stored_Discriminant (Uparent_Type); + + Discr_Value : Elmt_Id := + First_Elmt (Stored_Constraint (Rec_Type)); + begin while Original_Record_Component (Parent_Discr) /= Discr loop Next_Stored_Discriminant (Discr); @@ -2118,10 +2067,11 @@ package body Exp_Ch3 is end if; Res := - New_List ( - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Parent_Proc, Loc), - Parameter_Associations => Args)); + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Parent_Proc, Loc), + Parameter_Associations => Args)); return Res; end Build_Init_Call_Thru; @@ -2159,9 +2109,11 @@ package body Exp_Ch3 is Set_Defining_Unit_Name (Spec_Node, Func_Id); Set_Parameter_Specifications (Spec_Node, New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), - In_Present => True, - Parameter_Type => New_Reference_To (Rec_Type, Loc)))); + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + In_Present => True, + Parameter_Type => + New_Reference_To (Rec_Type, Loc)))); Set_Result_Definition (Spec_Node, New_Reference_To (RTE (RE_Storage_Offset), Loc)); @@ -2202,9 +2154,9 @@ package body Exp_Ch3 is -- Local variables - Ifaces_Comp_List : Elist_Id; - Iface_Comp_Elmt : Elmt_Id; Iface_Comp : Node_Id; + Iface_Comp_Elmt : Elmt_Id; + Ifaces_Comp_List : Elist_Id; -- Start of processing for Build_Offset_To_Top_Functions @@ -2349,13 +2301,13 @@ package body Exp_Ch3 is -------------------------- procedure Build_Init_Procedure is + Body_Stmts : List_Id; Body_Node : Node_Id; Handled_Stmt_Node : Node_Id; + Init_Tags_List : List_Id; Parameters : List_Id; Proc_Spec_Node : Node_Id; - Body_Stmts : List_Id; Record_Extension_Node : Node_Id; - Init_Tags_List : List_Id; begin Body_Stmts := New_List; @@ -2380,23 +2332,22 @@ package body Exp_Ch3 is Append_To (Parameters, Make_Parameter_Specification (Loc, Defining_Identifier => Set_Tag, - Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), - Expression => New_Occurrence_Of (Standard_True, Loc))); + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc), + Expression => + New_Occurrence_Of (Standard_True, Loc))); end if; Set_Parameter_Specifications (Proc_Spec_Node, Parameters); Set_Specification (Body_Node, Proc_Spec_Node); - Set_Declarations (Body_Node, New_List); - - if Parent_Subtype_Renaming_Discrims then + Set_Declarations (Body_Node, Decls); - -- N is a Derived_Type_Definition that renames the parameters - -- of the ancestor type. We initialize it by expanding our - -- discriminants and call the ancestor _init_proc with a - -- type-converted object + -- N is a Derived_Type_Definition that renames the parameters of the + -- ancestor type. We initialize it by expanding our discriminants and + -- call the ancestor _init_proc with a type-converted object. - Append_List_To (Body_Stmts, - Build_Init_Call_Thru (Parameters)); + if Parent_Subtype_Renaming_Discrims then + Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters)); elsif Nkind (Type_Definition (N)) = N_Record_Definition then Build_Discriminant_Assignments (Body_Stmts); @@ -2407,11 +2358,11 @@ package body Exp_Ch3 is Component_List (Type_Definition (N)))); end if; - else - -- N is a Derived_Type_Definition with a possible non-empty - -- extension. The initialization of a type extension consists - -- in the initialization of the components in the extension. + -- N is a Derived_Type_Definition with a possible non-empty + -- extension. The initialization of a type extension consists in the + -- initialization of the components in the extension. + else Build_Discriminant_Assignments (Body_Stmts); Record_Extension_Node := @@ -2626,7 +2577,48 @@ package body Exp_Ch3 is Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc); Set_Statements (Handled_Stmt_Node, Body_Stmts); - Set_Exception_Handlers (Handled_Stmt_Node, No_List); + + -- Generate: + -- Local_DF_Id (_init, C1, ..., CN); + -- raise; + + if Counter > 0 + and then Needs_Finalization (Rec_Type) + and then not Is_Abstract_Type (Rec_Type) + and then not Restriction_Active (No_Exception_Propagation) + then + declare + Local_DF_Id : Entity_Id; + + begin + -- Create a local version of Deep_Finalize which has indication + -- of partial initialization state. + + Local_DF_Id := Make_Temporary (Loc, 'F'); + + Append_To (Decls, + Make_Local_Deep_Finalize (Rec_Type, Local_DF_Id)); + + Set_Exception_Handlers (Handled_Stmt_Node, New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List ( + Make_Others_Choice (Loc)), + + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Local_DF_Id, Loc), + + Parameter_Associations => New_List ( + Make_Identifier (Loc, Name_uInit), + New_Reference_To (Standard_False, Loc))), + + Make_Raise_Statement (Loc))))); + end; + else + Set_Exception_Handlers (Handled_Stmt_Node, Empty_List); + end if; + Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node); if not Debug_Generated_Code then @@ -2662,48 +2654,73 @@ package body Exp_Ch3 is --------------------------- function Build_Init_Statements (Comp_List : Node_Id) return List_Id is - Check_List : constant List_Id := New_List; - Alt_List : List_Id; - Decl : Node_Id; - Id : Entity_Id; - Names : Node_Id; - Statement_List : List_Id; - Stmts : List_Id; - Typ : Entity_Id; - Variant : Node_Id; - - Per_Object_Constraint_Components : Boolean; - - function Has_Access_Constraint (E : Entity_Id) return Boolean; - -- Components with access discriminants that depend on the current - -- instance must be initialized after all other components. - - --------------------------- - -- Has_Access_Constraint -- - --------------------------- - - function Has_Access_Constraint (E : Entity_Id) return Boolean is - Disc : Entity_Id; - T : constant Entity_Id := Etype (E); + Checks : constant List_Id := New_List; + Actions : List_Id := No_List; + Counter_Id : Entity_Id := Empty; + Decl : Node_Id; + Has_POC : Boolean; + Id : Entity_Id; + Names : Node_Id; + Stmts : List_Id; + Typ : Entity_Id; + + procedure Increment_Counter; + -- Generate an "increment by one" statement for the current counter + -- and append it to the list Stmts. + + procedure Make_Counter; + -- Create a new counter for the current component list. The routine + -- creates a new defining Id, adds an object declaration and sets + -- the Id generator for the next variant. + + ----------------------- + -- Increment_Counter -- + ----------------------- + + procedure Increment_Counter is + begin + -- Generate: + -- Counter := Counter + 1; + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Counter_Id, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => + New_Reference_To (Counter_Id, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, 1)))); + end Increment_Counter; + + ------------------ + -- Make_Counter -- + ------------------ + + procedure Make_Counter is begin - 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; + -- Increment the Id generator - Next_Discriminant (Disc); - end loop; + Counter := Counter + 1; - return False; - else - return False; - end if; - end Has_Access_Constraint; + -- Create the entity and declaration + + Counter_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name ('C', Counter)); + + -- Generate: + -- Cnn : Integer := 0; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Counter_Id, + Object_Definition => + New_Reference_To (Standard_Integer, Loc), + Expression => + Make_Integer_Literal (Loc, 0))); + end Make_Counter; -- Start of processing for Build_Init_Statements @@ -2712,7 +2729,7 @@ package body Exp_Ch3 is return New_List (Make_Null_Statement (Loc)); end if; - Statement_List := New_List; + Stmts := New_List; -- Loop through visible declarations of task types and protected -- types moving any expanded code from the spec to the body of the @@ -2745,7 +2762,7 @@ package body Exp_Ch3 is or else Nkind (N2) in N_Raise_xxx_Error or else Nkind (N2) = N_Procedure_Call_Statement then - Append_To (Statement_List, + Append_To (Stmts, New_Copy_Tree (N2, New_Scope => Proc_Id)); Rewrite (N2, Make_Null_Statement (Sloc (N2))); Analyze (N2); @@ -2760,32 +2777,35 @@ package body Exp_Ch3 is -- components have per object constraints, and no explicit initia- -- lization. - Per_Object_Constraint_Components := False; + Has_POC := False; - -- First step : regular components + -- First pass : regular components Decl := First_Non_Pragma (Component_Items (Comp_List)); while Present (Decl) loop Loc := Sloc (Decl); Build_Record_Checks - (Subtype_Indication (Component_Definition (Decl)), Check_List); + (Subtype_Indication (Component_Definition (Decl)), Checks); Id := Defining_Identifier (Decl); Typ := Etype (Id); + -- Leave any processing of per-object constrained component for + -- the second pass. + if Has_Access_Constraint (Id) and then No (Expression (Decl)) then - -- Skip processing for now and ask for a second pass + Has_POC := True; - Per_Object_Constraint_Components := True; + -- Regular component cases else - -- Case of explicit initialization + -- Explicit initialization if Present (Expression (Decl)) then if Is_CPP_Constructor_Call (Expression (Decl)) then - Stmts := + Actions := Build_Initialization_Call (Loc, Id_Ref => @@ -2799,65 +2819,59 @@ package body Exp_Ch3 is Discr_Map => Discr_Map, Constructor_Ref => Expression (Decl)); else - Stmts := Build_Assignment (Id, Expression (Decl)); + Actions := Build_Assignment (Id, Expression (Decl)); end if; - -- Case of composite component with its own Init_Proc + -- Composite component with its own Init_Proc elsif not Is_Interface (Typ) and then Has_Non_Null_Base_Init_Proc (Typ) then - Stmts := + Actions := Build_Initialization_Call (Loc, - Id_Ref => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => New_Occurrence_Of (Id, Loc)), - Typ => Typ, + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uInit), + Selector_Name => + New_Occurrence_Of (Id, Loc)), + Typ, In_Init_Proc => True, Enclos_Type => Rec_Type, Discr_Map => Discr_Map); Clean_Task_Names (Typ, Proc_Id); - -- Case of component needing simple initialization + -- Simple initialization elsif Component_Needs_Simple_Initialization (Typ) then - Stmts := + Actions := Build_Assignment (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))); -- Nothing needed for this case else - Stmts := No_List; + Actions := No_List; end if; - if Present (Check_List) then - Append_List_To (Statement_List, Check_List); + if Present (Checks) then + Append_List_To (Stmts, Checks); end if; - if Present (Stmts) then - - -- Add the initialization of the record controller before - -- the _Parent field is attached to it when the attachment - -- can occur. It does not work to simply initialize the - -- controller first: it must be initialized after the parent - -- if the parent holds discriminants that can be used to - -- compute the offset of the controller. We assume here that - -- the last statement of the initialization call is the - -- attachment of the parent (see Build_Initialization_Call) - - if Chars (Id) = Name_uController - and then Rec_Type /= Etype (Rec_Type) - and then Has_Controlled_Component (Etype (Rec_Type)) - and then Has_New_Controlled_Component (Rec_Type) - and then Present (Last (Statement_List)) + if Present (Actions) then + Append_List_To (Stmts, Actions); + + -- Preserve the initialization state in the current counter + + if Chars (Id) /= Name_uParent + and then Needs_Finalization (Typ) then - Insert_List_Before (Last (Statement_List), Stmts); - else - Append_List_To (Statement_List, Stmts); + if No (Counter_Id) then + Make_Counter; + end if; + + Increment_Counter; end if; end if; end if; @@ -2871,8 +2885,8 @@ package body Exp_Ch3 is -- components) is initialized, because the initialization of these -- components may reference the enclosing concurrent object. - -- For a task record type, add the task create call and calls - -- to bind any interrupt (signal) entries. + -- For a task record type, add the task create call and calls to bind + -- any interrupt (signal) entries. if Is_Task_Record_Type (Rec_Type) then @@ -2880,20 +2894,22 @@ package body Exp_Ch3 is -- been preallocated. if Restricted_Profile then - Append_To (Statement_List, + Append_To (Stmts, Make_Assignment_Statement (Loc, - Name => Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), - Expression => Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => Make_Identifier (Loc, Name_uATCB)), - Attribute_Name => Name_Unchecked_Access))); + Name => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uATCB)), + Attribute_Name => Name_Unchecked_Access))); end if; - Append_To (Statement_List, Make_Task_Create_Call (Rec_Type)); + Append_To (Stmts, Make_Task_Create_Call (Rec_Type)); -- Generate the statements which map a string entry name to a -- task entry index. Note that the task may not have entries. @@ -2902,7 +2918,7 @@ package body Exp_Ch3 is Names := Build_Entry_Names (Rec_Type); if Present (Names) then - Append_To (Statement_List, Names); + Append_To (Stmts, Names); end if; end if; @@ -2911,8 +2927,8 @@ package body Exp_Ch3 is Corresponding_Concurrent_Type (Rec_Type); Task_Decl : constant Node_Id := Parent (Task_Type); Task_Def : constant Node_Id := Task_Definition (Task_Decl); - Vis_Decl : Node_Id; Ent : Entity_Id; + Vis_Decl : Node_Id; begin if Present (Task_Def) then @@ -2927,10 +2943,11 @@ package body Exp_Ch3 is Ent := Entity (Name (Vis_Decl)); if Ekind (Ent) = E_Entry then - Append_To (Statement_List, + Append_To (Stmts, Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To ( - RTE (RE_Bind_Interrupt_To_Entry), Loc), + Name => + New_Reference_To (RTE ( + RE_Bind_Interrupt_To_Entry), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => @@ -2954,7 +2971,7 @@ package body Exp_Ch3 is -- Make_Initialize_Protection. if Is_Protected_Record_Type (Rec_Type) then - Append_List_To (Statement_List, + Append_List_To (Stmts, Make_Initialize_Protection (Rec_Type)); -- Generate the statements which map a string entry name to a @@ -2965,15 +2982,14 @@ package body Exp_Ch3 is Names := Build_Entry_Names (Rec_Type); if Present (Names) then - Append_To (Statement_List, Names); + Append_To (Stmts, Names); end if; end if; end if; - if Per_Object_Constraint_Components then - - -- Second pass: components with per-object constraints + -- Second pass: components with per-object constraints + if Has_POC then Decl := First_Non_Pragma (Component_Items (Comp_List)); while Present (Decl) loop Loc := Sloc (Decl); @@ -2984,7 +3000,7 @@ package body Exp_Ch3 is and then No (Expression (Decl)) then if Has_Non_Null_Base_Init_Proc (Typ) then - Append_List_To (Statement_List, + Append_List_To (Stmts, Build_Initialization_Call (Loc, Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uInit), @@ -2996,8 +3012,19 @@ package body Exp_Ch3 is Clean_Task_Names (Typ, Proc_Id); + -- Preserve the initialization state in the current + -- counter. + + if Needs_Finalization (Typ) then + if No (Counter_Id) then + Make_Counter; + end if; + + Increment_Counter; + end if; + elsif Component_Needs_Simple_Initialization (Typ) then - Append_List_To (Statement_List, + Append_List_To (Stmts, Build_Assignment (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)))); end if; @@ -3010,40 +3037,46 @@ package body Exp_Ch3 is -- Process the variant part if Present (Variant_Part (Comp_List)) then - Alt_List := New_List; - Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); - while Present (Variant) loop - Loc := Sloc (Variant); - Append_To (Alt_List, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => - New_Copy_List (Discrete_Choices (Variant)), - Statements => - Build_Init_Statements (Component_List (Variant)))); - Next_Non_Pragma (Variant); - end loop; + declare + Variant_Alts : constant List_Id := New_List; + Variant : Node_Id; - -- The expression of the case statement which is a reference - -- to one of the discriminants is replaced by the appropriate - -- formal parameter of the initialization procedure. + begin + Variant := + First_Non_Pragma (Variants (Variant_Part (Comp_List))); + while Present (Variant) loop + Loc := Sloc (Variant); + Append_To (Variant_Alts, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_Copy_List (Discrete_Choices (Variant)), + Statements => + Build_Init_Statements (Component_List (Variant)))); + Next_Non_Pragma (Variant); + end loop; - Append_To (Statement_List, - Make_Case_Statement (Loc, - Expression => - New_Reference_To (Discriminal ( - Entity (Name (Variant_Part (Comp_List)))), Loc), - Alternatives => Alt_List)); + -- The expression of the case statement which is a reference + -- to one of the discriminants is replaced by the appropriate + -- formal parameter of the initialization procedure. + + Append_To (Stmts, + Make_Case_Statement (Loc, + Expression => + New_Reference_To (Discriminal ( + Entity (Name (Variant_Part (Comp_List)))), Loc), + Alternatives => Variant_Alts)); + end; end if; -- If no initializations when generated for component declarations - -- corresponding to this Statement_List, append a null statement - -- to the Statement_List to make it a valid Ada tree. + -- corresponding to this Stmts, append a null statement to Stmts to + -- to make it a valid Ada tree. - if Is_Empty_List (Statement_List) then - Append (New_Node (N_Null_Statement, Loc), Statement_List); + if Is_Empty_List (Stmts) then + Append (New_Node (N_Null_Statement, Loc), Stmts); end if; - return Statement_List; + return Stmts; exception when RE_Not_Available => @@ -3057,6 +3090,89 @@ package body Exp_Ch3 is procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is Subtype_Mark_Id : Entity_Id; + procedure Constrain_Array + (SI : Node_Id; + Check_List : List_Id); + -- Apply a list of index constraints to an unconstrained array type. + -- The first parameter is the entity for the resulting subtype. + -- Check_List is a list to which the check actions are appended. + + --------------------- + -- Constrain_Array -- + --------------------- + + procedure Constrain_Array + (SI : Node_Id; + Check_List : List_Id) + is + C : constant Node_Id := Constraint (SI); + Number_Of_Constraints : Nat := 0; + Index : Node_Id; + S, T : Entity_Id; + + procedure Constrain_Index + (Index : Node_Id; + S : Node_Id; + Check_List : List_Id); + -- Process an index constraint in a constrained array declaration. + -- The constraint can be either a subtype name or a range with or + -- without an explicit subtype mark. Index is the corresponding + -- index of the unconstrained array. S is the range expression. + -- Check_List is a list to which the check actions are appended. + + --------------------- + -- Constrain_Index -- + --------------------- + + procedure Constrain_Index + (Index : Node_Id; + S : Node_Id; + Check_List : List_Id) + is + T : constant Entity_Id := Etype (Index); + + begin + if Nkind (S) = N_Range then + Process_Range_Expr_In_Decl (S, T, Check_List); + end if; + end Constrain_Index; + + -- Start of processing for Constrain_Array + + begin + T := Entity (Subtype_Mark (SI)); + + if Ekind (T) in Access_Kind then + T := Designated_Type (T); + end if; + + S := First (Constraints (C)); + + while Present (S) loop + Number_Of_Constraints := Number_Of_Constraints + 1; + Next (S); + end loop; + + -- In either case, the index constraint must provide a discrete + -- range for each index of the array type and the type of each + -- discrete range must be the same as that of the corresponding + -- index. (RM 3.6.1) + + S := First (Constraints (C)); + Index := First_Index (T); + Analyze (Index); + + -- Apply constraints to each index type + + for J in 1 .. Number_Of_Constraints loop + Constrain_Index (Index, S, Check_List); + Next (Index); + Next (S); + end loop; + end Constrain_Array; + + -- Start of processing for Build_Record_Checks + begin if Nkind (S) = N_Subtype_Indication then Find_Type (Subtype_Mark (S)); @@ -3092,69 +3208,6 @@ package body Exp_Ch3 is and then not Is_RTE (T, RE_Interface_Tag); end Component_Needs_Simple_Initialization; - --------------------- - -- Constrain_Array -- - --------------------- - - procedure Constrain_Array - (SI : Node_Id; - Check_List : List_Id) - is - C : constant Node_Id := Constraint (SI); - Number_Of_Constraints : Nat := 0; - Index : Node_Id; - S, T : Entity_Id; - - begin - T := Entity (Subtype_Mark (SI)); - - if Ekind (T) in Access_Kind then - T := Designated_Type (T); - end if; - - S := First (Constraints (C)); - - while Present (S) loop - Number_Of_Constraints := Number_Of_Constraints + 1; - Next (S); - end loop; - - -- In either case, the index constraint must provide a discrete - -- range for each index of the array type and the type of each - -- discrete range must be the same as that of the corresponding - -- index. (RM 3.6.1) - - S := First (Constraints (C)); - Index := First_Index (T); - Analyze (Index); - - -- Apply constraints to each index type - - for J in 1 .. Number_Of_Constraints loop - Constrain_Index (Index, S, Check_List); - Next (Index); - Next (S); - end loop; - - end Constrain_Array; - - --------------------- - -- Constrain_Index -- - --------------------- - - procedure Constrain_Index - (Index : Node_Id; - S : Node_Id; - Check_List : List_Id) - is - T : constant Entity_Id := Etype (Index); - - begin - if Nkind (S) = N_Range then - Process_Range_Expr_In_Decl (S, T, Check_List); - end if; - end Constrain_Index; - -------------------------------------- -- Parent_Subtype_Renaming_Discrims -- -------------------------------------- @@ -3164,14 +3217,14 @@ package body Exp_Ch3 is Dp : Entity_Id; begin - if Base_Type (Pe) /= Pe then + if Base_Type (Rec_Ent) /= Rec_Ent then return False; end if; - if Etype (Pe) = Pe - or else not Has_Discriminants (Pe) - or else Is_Constrained (Pe) - or else Is_Tagged_Type (Pe) + if Etype (Rec_Ent) = Rec_Ent + or else not Has_Discriminants (Rec_Ent) + or else Is_Constrained (Rec_Ent) + or else Is_Tagged_Type (Rec_Ent) then return False; end if; @@ -3179,17 +3232,19 @@ package body Exp_Ch3 is -- If there are no explicit stored discriminants we have inherited -- the root type discriminants so far, so no renamings occurred. - if First_Discriminant (Pe) = First_Stored_Discriminant (Pe) then + if First_Discriminant (Rec_Ent) = + First_Stored_Discriminant (Rec_Ent) + then return False; end if; -- Check if we have done some trivial renaming of the parent -- discriminants, i.e. something like -- - -- type DT (X1,X2: int) is new PT (X1,X2); + -- type DT (X1, X2: int) is new PT (X1, X2); - De := First_Discriminant (Pe); - Dp := First_Discriminant (Etype (Pe)); + De := First_Discriminant (Rec_Ent); + Dp := First_Discriminant (Etype (Rec_Ent)); while Present (De) loop pragma Assert (Present (Dp)); @@ -3399,7 +3454,7 @@ package body Exp_Ch3 is Build_Offset_To_Top_Functions; Build_CPP_Init_Procedure; Build_Init_Procedure; - Set_Is_Public (Proc_Id, Is_Public (Pe)); + Set_Is_Public (Proc_Id, Is_Public (Rec_Ent)); -- The initialization of protected records is not worth inlining. -- In addition, when compiled for another unit for inlining purposes, @@ -4067,7 +4122,6 @@ package body Exp_Ch3 is Append_List_To (Stmts, Make_Eq_Case (Typ, Comps, A)); - end; -- Normal case (not unchecked union) @@ -4569,21 +4623,6 @@ package body Exp_Ch3 is Build_Master_Entity (Def_Id); end if; - -- Build a list controller for declarations where the type is anonymous - -- access and the designated type is controlled. Only declarations from - -- source files receive such controllers in order to provide the same - -- lifespan for any potential coextensions that may be associated with - -- the object. Finalization lists of internal controlled anonymous - -- access objects are already handled in Expand_N_Allocator. - - if Comes_From_Source (N) - and then Ekind (Typ) = E_Anonymous_Access_Type - and then Is_Controlled (Directly_Designated_Type (Typ)) - and then No (Associated_Final_Chain (Typ)) - then - Build_Final_List (N, Typ); - end if; - -- Default initialization required, and no expression present if No (Expr) then @@ -4617,12 +4656,10 @@ package body Exp_Ch3 is elsif not Abort_Allowed or else not Comes_From_Source (N) then - Insert_Actions_After (Init_After, + Insert_Action_After (Init_After, Make_Init_Call ( - Ref => New_Occurrence_Of (Def_Id, Loc), - Typ => Base_Type (Typ), - Flist_Ref => Find_Final_List (Def_Id), - With_Attach => Make_Integer_Literal (Loc, 1))); + Obj_Ref => New_Occurrence_Of (Def_Id, Loc), + Typ => Base_Type (Typ))); -- Abort allowed @@ -4642,12 +4679,10 @@ package body Exp_Ch3 is -- requires some code reorganization... declare - L : constant List_Id := - Make_Init_Call - (Ref => New_Occurrence_Of (Def_Id, Loc), - Typ => Base_Type (Typ), - Flist_Ref => Find_Final_List (Def_Id), - With_Attach => Make_Integer_Literal (Loc, 1)); + L : constant List_Id := New_List ( + Make_Init_Call ( + Obj_Ref => New_Occurrence_Of (Def_Id, Loc), + Typ => Base_Type (Typ))); Blk : constant Node_Id := Make_Block_Statement (Loc, @@ -5072,12 +5107,10 @@ package body Exp_Ch3 is and then not Is_Immutably_Limited_Type (Typ) and then not Rewrite_As_Renaming then - Insert_Actions_After (Init_After, + Insert_Action_After (Init_After, Make_Adjust_Call ( - Ref => New_Reference_To (Def_Id, Loc), - Typ => Base_Type (Typ), - Flist_Ref => Find_Final_List (Def_Id), - With_Attach => Make_Integer_Literal (Loc, 1))); + Obj_Ref => New_Reference_To (Def_Id, Loc), + Typ => Base_Type (Typ))); end if; -- For tagged types, when an init value is given, the tag has to @@ -5336,146 +5369,6 @@ package body Exp_Ch3 is end loop; end Expand_Previous_Access_Type; - ------------------------------ - -- Expand_Record_Controller -- - ------------------------------ - - -- Need some more comments in this body ??? - - procedure Expand_Record_Controller (T : Entity_Id) is - Def : Node_Id := Type_Definition (Parent (T)); - Comp_List : Node_Id; - Comp_Decl : Node_Id; - Loc : Source_Ptr; - First_Comp : Node_Id; - Controller_Type : Entity_Id; - Ent : Entity_Id; - - begin - if Nkind (Def) = N_Derived_Type_Definition then - Def := Record_Extension_Part (Def); - end if; - - if Null_Present (Def) then - Set_Component_List (Def, - Make_Component_List (Sloc (Def), - Component_Items => Empty_List, - Variant_Part => Empty, - Null_Present => True)); - end if; - - Comp_List := Component_List (Def); - - if Null_Present (Comp_List) - or else Is_Empty_List (Component_Items (Comp_List)) - then - Loc := Sloc (Comp_List); - else - Loc := Sloc (First (Component_Items (Comp_List))); - end if; - - if Is_Immutably_Limited_Type (T) then - Controller_Type := RTE (RE_Limited_Record_Controller); - else - Controller_Type := RTE (RE_Record_Controller); - end if; - - Ent := Make_Defining_Identifier (Loc, Name_uController); - - Comp_Decl := - Make_Component_Declaration (Loc, - Defining_Identifier => Ent, - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => New_Reference_To (Controller_Type, Loc))); - - if Null_Present (Comp_List) - or else Is_Empty_List (Component_Items (Comp_List)) - then - Set_Component_Items (Comp_List, New_List (Comp_Decl)); - Set_Null_Present (Comp_List, False); - - else - -- The controller cannot be placed before the _Parent field since - -- gigi lays out field in order and _parent must be first to preserve - -- the polymorphism of tagged types. - - First_Comp := First (Component_Items (Comp_List)); - - if not Is_Tagged_Type (T) then - Insert_Before (First_Comp, Comp_Decl); - - -- if T is a tagged type, place controller declaration after parent - -- field and after eventual tags of interface types. - - else - while Present (First_Comp) - and then - (Chars (Defining_Identifier (First_Comp)) = Name_uParent - or else Is_Tag (Defining_Identifier (First_Comp)) - - -- Ada 2005 (AI-251): The following condition covers secondary - -- tags but also the adjacent component containing the offset - -- to the base of the object (component generated if the parent - -- has discriminants --- see Add_Interface_Tag_Components). - -- This is required to avoid the addition of the controller - -- between the secondary tag and its adjacent component. - - or else Present - (Related_Type - (Defining_Identifier (First_Comp)))) - loop - Next (First_Comp); - end loop; - - -- An empty tagged extension might consist only of the parent - -- component. Otherwise insert the controller before the first - -- component that is neither parent nor tag. - - if Present (First_Comp) then - Insert_Before (First_Comp, Comp_Decl); - else - Append (Comp_Decl, Component_Items (Comp_List)); - end if; - end if; - end if; - - Push_Scope (T); - Analyze (Comp_Decl); - Set_Ekind (Ent, E_Component); - Init_Component_Location (Ent); - - -- Move the _controller entity ahead in the list of internal entities - -- of the enclosing record so that it is selected instead of a - -- potentially inherited one. - - declare - E : constant Entity_Id := Last_Entity (T); - Comp : Entity_Id; - - begin - pragma Assert (Chars (E) = Name_uController); - - Set_Next_Entity (E, First_Entity (T)); - Set_First_Entity (T, E); - - Comp := Next_Entity (E); - while Next_Entity (Comp) /= E loop - Next_Entity (Comp); - end loop; - - Set_Next_Entity (Comp, Empty); - Set_Last_Entity (T, Comp); - end; - - End_Scope; - - exception - when RE_Not_Available => - return; - end Expand_Record_Controller; - ------------------------ -- Expand_Tagged_Root -- ------------------------ @@ -5557,9 +5450,9 @@ package body Exp_Ch3 is ------------------------------ procedure Expand_Freeze_Array_Type (N : Node_Id) is - Typ : constant Entity_Id := Entity (N); + Typ : constant Entity_Id := Entity (N); Comp_Typ : constant Entity_Id := Component_Type (Typ); - Base : constant Entity_Id := Base_Type (Typ); + Base : constant Entity_Id := Base_Type (Typ); begin if not Is_Bit_Packed_Array (Typ) then @@ -5619,10 +5512,12 @@ package body Exp_Ch3 is Build_Slice_Assignment (Typ); end if; + -- ??? This may not be necessary after all + elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type and then Needs_Finalization (Directly_Designated_Type (Comp_Typ)) then - Set_Associated_Final_Chain (Comp_Typ, Add_Final_Chain (Typ)); + Build_Finalization_Collection (Comp_Typ); end if; end if; @@ -5641,6 +5536,75 @@ package body Exp_Ch3 is end if; end Expand_Freeze_Array_Type; + ----------------------------------- + -- Expand_Freeze_Class_Wide_Type -- + ----------------------------------- + + procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is + Typ : constant Entity_Id := Entity (N); + Root : constant Entity_Id := Root_Type (Typ); + + function Is_C_Derivation (Typ : Entity_Id) return Boolean; + -- Given a type, determine whether it is derived from a C or C++ root + + --------------------- + -- Is_C_Derivation -- + --------------------- + + function Is_C_Derivation (Typ : Entity_Id) return Boolean is + T : Entity_Id := Typ; + + begin + loop + if Is_CPP_Class (T) + or else Convention (T) = Convention_C + or else Convention (T) = Convention_CPP + then + return True; + end if; + + exit when T = Etype (T); + + T := Etype (T); + end loop; + + return False; + end Is_C_Derivation; + + -- Start of processing for Expand_Freeze_Class_Wide_Type + + begin + -- Do not create TSS routine Finalize_Address for concurrent class-wide + -- types. Ignore C, C++, CIL and Java types since it is assumed that the + -- non-Ada side will handle their destruction. + + if Is_Concurrent_Type (Root) + or else Is_C_Derivation (Root) + or else Convention (Typ) = Convention_CIL + or else Convention (Typ) = Convention_CPP + or else Convention (Typ) = Convention_Java + then + return; + + -- Do not create TSS routine Finalize_Address when dispatching calls are + -- disabled since the core of the routine is a dispatching call. + + elsif Restriction_Active (No_Dispatching_Calls) then + return; + + -- Do not create TSS routine Finalize_Address for .NET/JVM because these + -- targets do not support address arithmetic and unchecked conversions. + + elsif VM_Target /= No_VM then + return; + end if; + + -- Generate the body of Finalize_Address. This routine is accessible + -- through the TSS mechanism. + + Make_Finalize_Address_Body (Typ); + end Expand_Freeze_Class_Wide_Type; + ------------------------------------ -- Expand_Freeze_Enumeration_Type -- ------------------------------------ @@ -5957,10 +5921,6 @@ package body Exp_Ch3 is Comp_Typ : Entity_Id; Predef_List : List_Id; - Flist : Entity_Id := Empty; - -- Finalization list allocated for the case of a type with anonymous - -- access components whose designated type is potentially controlled. - Renamed_Eq : Node_Id := Empty; -- Defining unit name for the predefined equality function in the case -- where the type has a primitive operation that is a renaming of @@ -6045,15 +6005,6 @@ package body Exp_Ch3 is and then Is_Controlled (Comp_Typ))) then Set_Has_Controlled_Component (Def_Id); - - elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Needs_Finalization (Directly_Designated_Type (Comp_Typ)) - then - if No (Flist) then - Flist := Add_Final_Chain (Def_Id); - end if; - - Set_Associated_Final_Chain (Comp_Typ, Flist); end if; Next_Component (Comp); @@ -6153,7 +6104,7 @@ package body Exp_Ch3 is null; -- Do not add the spec of the predefined primitives if we are - -- compiling under restriction No_Dispatching_Calls + -- compiling under restriction No_Dispatching_Calls. elsif not Restriction_Active (No_Dispatching_Calls) then Make_Predefined_Primitive_Specs @@ -6197,13 +6148,6 @@ package body Exp_Ch3 is Set_All_DT_Position (Def_Id); end if; - -- Add the controlled component before the freezing actions - -- referenced in those actions. - - if Has_New_Controlled_Component (Def_Id) then - Expand_Record_Controller (Def_Id); - end if; - -- Create and decorate the tags. Suppress their creation when -- VM_Target because the dispatching mechanism is handled -- internally by the VMs. @@ -6229,8 +6173,7 @@ package body Exp_Ch3 is and then Present (Underlying_Record_View (Def_Id)) then declare - Rep : constant Entity_Id := - Underlying_Record_View (Def_Id); + Rep : constant Entity_Id := Underlying_Record_View (Def_Id); begin Set_Access_Disp_Table (Rep, Access_Disp_Table (Def_Id)); @@ -6263,7 +6206,7 @@ package body Exp_Ch3 is -- Freeze rest of primitive operations. There is no need to handle -- the predefined primitives if we are compiling under restriction - -- No_Dispatching_Calls + -- No_Dispatching_Calls. if not Restriction_Active (No_Dispatching_Calls) then Append_Freeze_Actions @@ -6339,10 +6282,6 @@ package body Exp_Ch3 is end if; if Has_Controlled_Component (Def_Id) then - if No (Controller_Component (Def_Id)) then - Expand_Record_Controller (Def_Id); - end if; - Build_Controlling_Procs (Def_Id); end if; @@ -6388,6 +6327,11 @@ package body Exp_Ch3 is elsif not Restriction_Active (No_Dispatching_Calls) then Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); Append_Freeze_Actions (Def_Id, Predef_List); + + -- Create the body of Finalize_Address, a helper routine used in + -- conjunction with controlled objects on the heap. + + Make_Finalize_Address_Body (Def_Id); end if; -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden @@ -6420,6 +6364,29 @@ package body Exp_Ch3 is end loop; end; end if; + + -- Processing for components of anonymous access type that designate + -- a controlled type. + + Comp := First_Component (Def_Id); + while Present (Comp) loop + Comp_Typ := Etype (Comp); + + if Ekind (Comp_Typ) = E_Anonymous_Access_Type + and then Needs_Finalization (Directly_Designated_Type (Comp_Typ)) + + -- Avoid self-references + + and then Directly_Designated_Type (Comp_Typ) /= Def_Id + then + Build_Finalization_Collection + (Typ => Comp_Typ, + Ins_Node => Parent (Def_Id), + Encl_Scope => Scope (Def_Id)); + end if; + + Next_Component (Comp); + end loop; end Expand_Freeze_Record_Type; ------------------------------ @@ -6505,74 +6472,8 @@ package body Exp_Ch3 is if Ekind (Def_Id) = E_Record_Type then Expand_Freeze_Record_Type (N); - -- The subtype may have been declared before the type was frozen. If - -- the type has controlled components it is necessary to create the - -- entity for the controller explicitly because it did not exist at - -- the point of the subtype declaration. Only the entity is needed, - -- the back-end will obtain the layout from the type. This is only - -- necessary if this is constrained subtype whose component list is - -- not shared with the base type. - - elsif Ekind (Def_Id) = E_Record_Subtype - and then Has_Discriminants (Def_Id) - and then Last_Entity (Def_Id) /= Last_Entity (Base_Type (Def_Id)) - and then Present (Controller_Component (Def_Id)) - then - declare - Old_C : constant Entity_Id := Controller_Component (Def_Id); - New_C : Entity_Id; - - begin - if Scope (Old_C) = Base_Type (Def_Id) then - - -- The entity is the one in the parent. Create new one - - New_C := New_Copy (Old_C); - Set_Parent (New_C, Parent (Old_C)); - Push_Scope (Def_Id); - Enter_Name (New_C); - End_Scope; - end if; - end; - - if Is_Itype (Def_Id) - and then Is_Record_Type (Underlying_Type (Scope (Def_Id))) - then - -- The freeze node is only used to introduce the controller, - -- the back-end has no use for it for a discriminated - -- component. - - Set_Freeze_Node (Def_Id, Empty); - Set_Has_Delayed_Freeze (Def_Id, False); - Result := True; - end if; - - -- Similar process if the controller of the subtype is not present - -- but the parent has it. This can happen with constrained - -- record components where the subtype is an itype. - - elsif Ekind (Def_Id) = E_Record_Subtype - and then Is_Itype (Def_Id) - and then No (Controller_Component (Def_Id)) - and then Present (Controller_Component (Etype (Def_Id))) - then - declare - Old_C : constant Entity_Id := - Controller_Component (Etype (Def_Id)); - New_C : constant Entity_Id := New_Copy (Old_C); - - begin - Set_Next_Entity (New_C, First_Entity (Def_Id)); - Set_First_Entity (Def_Id, New_C); - - -- The freeze node is only used to introduce the controller, - -- the back-end has no use for it for a discriminated - -- component. - - Set_Freeze_Node (Def_Id, Empty); - Set_Has_Delayed_Freeze (Def_Id, False); - Result := True; - end; + elsif Is_Class_Wide_Type (Def_Id) then + Expand_Freeze_Class_Wide_Type (N); end if; -- Freeze processing for array types @@ -6717,7 +6618,7 @@ package body Exp_Ch3 is elsif Present (Associated_Storage_Pool (Def_Id)) then -- Nothing to do the associated storage pool has been attached - -- when analyzing the rep. clause + -- when analyzing the representation clause. null; end if; @@ -6740,8 +6641,8 @@ package body Exp_Ch3 is null; elsif (Needs_Finalization (Desig_Type) - and then Convention (Desig_Type) /= Convention_Java - and then Convention (Desig_Type) /= Convention_CIL) + and then Convention (Desig_Type) /= Convention_Java + and then Convention (Desig_Type) /= Convention_CIL) or else (Is_Incomplete_Or_Private_Type (Desig_Type) and then No (Full_View (Desig_Type)) @@ -6751,26 +6652,22 @@ package body Exp_Ch3 is -- afford this unnecessary overhead that would generates a -- loop in the expansion scheme... - and then not In_Runtime (Def_Id) + and then not In_Runtime (Def_Id) -- Another exception is if Restrictions (No_Finalization) -- is active, since then we know nothing is controlled. - and then not Restriction_Active (No_Finalization)) + and then not Restriction_Active (No_Finalization)) -- If the designated type is not frozen yet, its controlled -- status must be retrieved explicitly. - or else (Is_Array_Type (Desig_Type) - and then not Is_Frozen (Desig_Type) - and then Needs_Finalization (Component_Type (Desig_Type))) - - -- The designated type has controlled anonymous access - -- discriminants. - - or else Has_Controlled_Coextensions (Desig_Type) + or else + (Is_Array_Type (Desig_Type) + and then not Is_Frozen (Desig_Type) + and then Needs_Finalization (Component_Type (Desig_Type))) then - Set_Associated_Final_Chain (Def_Id, Add_Final_Chain (Def_Id)); + Build_Finalization_Collection (Def_Id); end if; end; @@ -8069,10 +7966,7 @@ package body Exp_Ch3 is -- components would be incorrect because the wrong entities for -- discriminants could be picked up in the private type case. - if Field_Name /= Name_uTag - and then - Field_Name /= Name_uController - then + if Field_Name /= Name_uTag then Evolve_Or_Else (Cond, Make_Op_Ne (Loc, Left_Opnd => @@ -8203,10 +8097,10 @@ package body Exp_Ch3 is is Loc : constant Source_Ptr := Sloc (Tag_Typ); Res : constant List_Id := New_List; - Prim : Elmt_Id; + Eq_Name : Name_Id := Name_Op_Eq; Eq_Needed : Boolean; Eq_Spec : Node_Id; - Eq_Name : Name_Id := Name_Op_Eq; + Prim : Elmt_Id; function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean; -- Returns true if Prim is a renaming of an unresolved predefined @@ -8520,49 +8414,28 @@ package body Exp_Ch3 is end if; end if; - -- Specs for finalization actions that may be required in case a future - -- extension contain a controlled element. We generate those only for - -- root tagged types where they will get dummy bodies or when the type - -- has controlled components and their body must be generated. It is - -- also impossible to provide those for tagged types defined within - -- s-finimp since it would involve circularity problems + -- All tagged types receive their own Deep_Adjust and Deep_Finalize + -- regardless of whether they are controlled or contain controlled + -- components. - if In_Finalization_Root (Tag_Typ) then - null; + -- Do not generate the routines if finalization is disabled - -- We also skip these if finalization is not available - - elsif Restriction_Active (No_Finalization) then + if Restriction_Active (No_Finalization) then null; - -- Skip these for CIL Value types, where finalization is not available + -- Finalization is not available for CIL value types elsif Is_Value_Type (Tag_Typ) then null; - elsif Etype (Tag_Typ) = Tag_Typ - or else Needs_Finalization (Tag_Typ) - - -- Ada 2005 (AI-251): We must also generate these subprograms if - -- the immediate ancestor is an interface to ensure the correct - -- initialization of its dispatch table. - - or else (not Is_Interface (Tag_Typ) - and then Is_Interface (Etype (Tag_Typ))) - - -- Ada 205 (AI-251): We must also generate these subprograms if - -- the parent of an nonlimited interface is a limited interface - - or else (Is_Interface (Tag_Typ) - and then not Is_Limited_Interface (Tag_Typ) - and then Is_Limited_Interface (Etype (Tag_Typ))) - then + else if not Is_Limited_Type (Tag_Typ) then Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust)); end if; - Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize)); + Append_To (Res, + Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize)); end if; Predef_List := Res; @@ -8647,42 +8520,41 @@ package body Exp_Ch3 is Name : TSS_Name_Type; For_Body : Boolean := False) return Node_Id is - Prof : List_Id; - Type_B : Entity_Id; + Formals : List_Id; begin - if Name = TSS_Deep_Finalize then - Prof := New_List; - Type_B := Standard_Boolean; + -- V : in out Tag_Typ - else - Prof := New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, Name_L), - In_Present => True, - Out_Present => True, - Parameter_Type => - New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); - Type_B := Standard_Short_Short_Integer; - end if; + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_V), + In_Present => True, + Out_Present => True, + Parameter_Type => + New_Reference_To (Tag_Typ, Loc))); - Append_To (Prof, - Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), - In_Present => True, - Out_Present => True, - Parameter_Type => New_Reference_To (Tag_Typ, Loc))); + -- F : Boolean := True - Append_To (Prof, + if Name = TSS_Deep_Adjust + or else Name = TSS_Deep_Finalize + then + Append_To (Formals, Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, Name_B), - Parameter_Type => New_Reference_To (Type_B, Loc))); + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_F), + Parameter_Type => + New_Reference_To (Standard_Boolean, Loc), + Expression => + New_Reference_To (Standard_True, Loc))); + end if; - return Predef_Spec_Or_Body (Loc, - Name => Make_TSS_Name (Tag_Typ, Name), - Tag_Typ => Tag_Typ, - Profile => Prof, - For_Body => For_Body); + return + Predef_Spec_Or_Body (Loc, + Name => Make_TSS_Name (Tag_Typ, Name), + Tag_Typ => Tag_Typ, + Profile => Formals, + For_Body => For_Body); exception when RE_Not_Available => @@ -9018,48 +8890,30 @@ package body Exp_Ch3 is Append_To (Res, Decl); end if; - -- Generate dummy bodies for finalization actions of types that have - -- no controlled components. + -- Generate empty bodies of routines Deep_Adjust and Deep_Finalize for + -- tagged types which do not contain controlled components. - -- Skip this processing if we are in the finalization routine in the - -- runtime itself, otherwise we get hopelessly circularly confused! + -- Do not generate the routines if finalization is disabled - if In_Finalization_Root (Tag_Typ) then + if Restriction_Active (No_Finalization) then null; - -- Skip this if finalization is not available - - elsif Restriction_Active (No_Finalization) then - null; - - elsif (Etype (Tag_Typ) = Tag_Typ - or else Is_Controlled (Tag_Typ) - - -- Ada 2005 (AI-251): We must also generate these subprograms - -- if the immediate ancestor of Tag_Typ is an interface to - -- ensure the correct initialization of its dispatch table. - - or else (not Is_Interface (Tag_Typ) - and then - Is_Interface (Etype (Tag_Typ)))) - and then not Has_Controlled_Component (Tag_Typ) - then + elsif not Has_Controlled_Component (Tag_Typ) then if not Is_Limited_Type (Tag_Typ) then Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True); if Is_Controlled (Tag_Typ) then Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, - Make_Adjust_Call ( - Ref => Make_Identifier (Loc, Name_V), - Typ => Tag_Typ, - Flist_Ref => Make_Identifier (Loc, Name_L), - With_Attach => Make_Identifier (Loc, Name_B)))); - + Statements => New_List ( + Make_Adjust_Call ( + Obj_Ref => Make_Identifier (Loc, Name_V), + Typ => Tag_Typ)))); else Set_Handled_Statement_Sequence (Decl, - Make_Handled_Sequence_Of_Statements (Loc, New_List ( - Make_Null_Statement (Loc)))); + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Null_Statement (Loc)))); end if; Append_To (Res, Decl); @@ -9070,15 +8924,15 @@ package body Exp_Ch3 is if Is_Controlled (Tag_Typ) then Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, - Make_Final_Call ( - Ref => Make_Identifier (Loc, Name_V), - Typ => Tag_Typ, - With_Detach => Make_Identifier (Loc, Name_B)))); - + Statements => New_List ( + Make_Final_Call ( + Obj_Ref => Make_Identifier (Loc, Name_V), + Typ => Tag_Typ)))); else Set_Handled_Statement_Sequence (Decl, - Make_Handled_Sequence_Of_Statements (Loc, New_List ( - Make_Null_Statement (Loc)))); + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Null_Statement (Loc)))); end if; Append_To (Res, Decl); @@ -9195,22 +9049,31 @@ package body Exp_Ch3 is -- to be (implicitly) inherited in that case because it can lead to a VM -- exception. - return (not Is_Limited_Type (Typ) - or else Is_Interface (Typ) - or else Has_Predefined_Or_Specified_Stream_Attribute) - and then (Operation /= TSS_Stream_Input - or else not Is_Abstract_Type (Typ) - or else not Is_Derived_Type (Typ)) + -- Do not generate stream routines for type Finalization_Collection + -- because collection may never appear in types and therefore cannot be + -- read or written. + + return + (not Is_Limited_Type (Typ) + or else Is_Interface (Typ) + or else Has_Predefined_Or_Specified_Stream_Attribute) + and then + (Operation /= TSS_Stream_Input + or else not Is_Abstract_Type (Typ) + or else not Is_Derived_Type (Typ)) and then not Has_Unknown_Discriminants (Typ) - and then not (Is_Interface (Typ) - and then (Is_Task_Interface (Typ) - or else Is_Protected_Interface (Typ) - or else Is_Synchronized_Interface (Typ))) + and then not + (Is_Interface (Typ) + and then + (Is_Task_Interface (Typ) + or else Is_Protected_Interface (Typ) + or else Is_Synchronized_Interface (Typ))) and then not Restriction_Active (No_Streams) and then not Restriction_Active (No_Dispatch) and then not No_Run_Time_Mode and then RTE_Available (RE_Tag) - and then RTE_Available (RE_Root_Stream_Type); + and then RTE_Available (RE_Root_Stream_Type) + and then not Is_RTE (Typ, RE_Finalization_Collection); end Stream_Operation_OK; end Exp_Ch3; diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 91431efc680..54aba222f9c 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -113,6 +113,22 @@ package Exp_Ch3 is -- want Gigi to see the node. This function can't delete the node itself -- since it would confuse any remaining processing of the freeze node. + function Get_Simple_Init_Val + (T : Entity_Id; + N : Node_Id; + Size : Uint := No_Uint) return Node_Id; + -- For a type which Needs_Simple_Initialization (see above), prepares the + -- tree for an expression representing the required initial value. N is a + -- node whose source location used in constructing this tree which is + -- returned as the result of the call. The Size parameter indicates the + -- target size of the object if it is known (indicated by a value that is + -- not No_Uint and is greater than zero). If Size is not given (Size set to + -- No_Uint, or non-positive), then the Esize of T is used as an estimate of + -- the Size. The object size is needed to prepare a known invalid value for + -- use by Normalize_Scalars. A call to this routine where T is a scalar + -- type is only valid if we are in Normalize_Scalars or Initialize_Scalars + -- mode, or if N is the node for a 'Invalid_Value attribute node. + procedure Init_Secondary_Tags (Typ : Entity_Id; Target : Node_Id; @@ -139,20 +155,4 @@ package Exp_Ch3 is -- set to False, but if Consider_IS is set to True, then the cases above -- mentioning Normalize_Scalars also apply for Initialize_Scalars mode. - function Get_Simple_Init_Val - (T : Entity_Id; - N : Node_Id; - Size : Uint := No_Uint) return Node_Id; - -- For a type which Needs_Simple_Initialization (see above), prepares the - -- tree for an expression representing the required initial value. N is a - -- node whose source location used in constructing this tree which is - -- returned as the result of the call. The Size parameter indicates the - -- target size of the object if it is known (indicated by a value that is - -- not No_Uint and is greater than zero). If Size is not given (Size set to - -- No_Uint, or non-positive), then the Esize of T is used as an estimate of - -- the Size. The object size is needed to prepare a known invalid value for - -- use by Normalize_Scalars. A call to this routine where T is a scalar - -- type is only valid if we are in Normalize_Scalars or Initialize_Scalars - -- mode, or if N is the node for a 'Invalid_Value attribute node. - end Exp_Ch3; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 1487f770abd..95b23d8379a 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 -- --------------------------------- diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 51ae183bc35..4f175f177f7 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -56,8 +56,6 @@ with Stand; use Stand; with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; -with Ttypes; use Ttypes; -with Uintp; use Uintp; with Validsw; use Validsw; package body Exp_Ch5 is @@ -1980,17 +1978,17 @@ package body Exp_Ch5 is Append_To (L, Make_Raise_Constraint_Error (Loc, Condition => - Make_Op_Ne (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => Duplicate_Subexpr (Lhs), - Selector_Name => - Make_Identifier (Loc, Name_uTag)), - Right_Opnd => - Make_Selected_Component (Loc, - Prefix => Duplicate_Subexpr (Rhs), - Selector_Name => - Make_Identifier (Loc, Name_uTag))), + Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Lhs), + Selector_Name => + Make_Identifier (Loc, Name_uTag)), + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Rhs), + Selector_Name => + Make_Identifier (Loc, Name_uTag))), Reason => CE_Tag_Check_Failed)); end if; @@ -3482,33 +3480,25 @@ package body Exp_Ch5 is ------------------------------ function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (N); + Asn : constant Node_Id := Relocate_Node (N); L : constant Node_Id := Name (N); + Loc : constant Source_Ptr := Sloc (N); + Res : constant List_Id := New_List; T : constant Entity_Id := Underlying_Type (Etype (L)); + Comp_Asn : constant Boolean := Is_Fully_Repped_Tagged_Type (T); Ctrl_Act : constant Boolean := Needs_Finalization (T) and then not No_Ctrl_Actions (N); - - Component_Assign : constant Boolean := - Is_Fully_Repped_Tagged_Type (T); - Save_Tag : constant Boolean := Is_Tagged_Type (T) - and then not Component_Assign + and then not Comp_Asn and then not No_Ctrl_Actions (N) and then Tagged_Type_Expansion; -- Tags are not saved and restored when VM_Target because VM tags are -- represented implicitly in objects. - Res : List_Id; - Tag_Tmp : Entity_Id; - - Prev_Tmp : Entity_Id; - Next_Tmp : Entity_Id; - Ctrl_Ref : Node_Id; + Tag_Tmp : Entity_Id; begin - Res := New_List; - -- Finalize the target of the assignment when controlled -- We have two exceptions here: @@ -3539,11 +3529,10 @@ package body Exp_Ch5 is null; else - Append_List_To (Res, - Make_Final_Call - (Ref => Duplicate_Subexpr_No_Checks (L), - Typ => Etype (L), - With_Detach => New_Reference_To (Standard_False, Loc))); + Append_To (Res, + Make_Final_Call ( + Obj_Ref => Duplicate_Subexpr_No_Checks (L), + Typ => Etype (L))); end if; -- Save the Tag in a local variable Tag_Tmp @@ -3554,12 +3543,14 @@ package body Exp_Ch5 is Append_To (Res, Make_Object_Declaration (Loc, Defining_Identifier => Tag_Tmp, - Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), + Object_Definition => + New_Reference_To (RTE (RE_Tag), Loc), Expression => Make_Selected_Component (Loc, - Prefix => Duplicate_Subexpr_No_Checks (L), - Selector_Name => New_Reference_To (First_Tag_Component (T), - Loc)))); + Prefix => + Duplicate_Subexpr_No_Checks (L), + Selector_Name => + New_Reference_To (First_Tag_Component (T), Loc)))); -- Otherwise Tag_Tmp not used @@ -3567,391 +3558,18 @@ package body Exp_Ch5 is Tag_Tmp := Empty; end if; - if Ctrl_Act then - if VM_Target /= No_VM then - - -- Cannot assign part of the object in a VM context, so instead - -- fallback to the previous mechanism, even though it is not - -- completely correct ??? + -- If the tagged type has a full rep clause, expand the assignment into + -- component-wise assignments. Mark the node as unanalyzed in order to + -- generate the proper code and propagate this scenario by setting a + -- flag to avoid infinite recursion. - -- Save the Finalization Pointers in local variables Prev_Tmp and - -- Next_Tmp. For objects with Has_Controlled_Component set, these - -- pointers are in the Record_Controller - - Ctrl_Ref := Duplicate_Subexpr (L); - - if Has_Controlled_Component (T) then - Ctrl_Ref := - Make_Selected_Component (Loc, - Prefix => Ctrl_Ref, - Selector_Name => - New_Reference_To (Controller_Component (T), Loc)); - end if; - - Prev_Tmp := Make_Temporary (Loc, 'B'); - - Append_To (Res, - Make_Object_Declaration (Loc, - Defining_Identifier => Prev_Tmp, - - Object_Definition => - New_Reference_To (RTE (RE_Finalizable_Ptr), Loc), - - Expression => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_Finalizable), Ctrl_Ref), - Selector_Name => Make_Identifier (Loc, Name_Prev)))); - - Next_Tmp := Make_Temporary (Loc, 'C'); - - Append_To (Res, - Make_Object_Declaration (Loc, - Defining_Identifier => Next_Tmp, - - Object_Definition => - New_Reference_To (RTE (RE_Finalizable_Ptr), Loc), - - Expression => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_Finalizable), - New_Copy_Tree (Ctrl_Ref)), - Selector_Name => Make_Identifier (Loc, Name_Next)))); - - -- Do the Assignment - - Append_To (Res, Relocate_Node (N)); - - else - -- Regular (non VM) processing for controlled types and types with - -- controlled components - - -- Variables of such types contain pointers used to chain them in - -- finalization lists, in addition to user data. These pointers - -- are specific to each object of the type, not to the value being - -- assigned. - - -- Thus they need to be left intact during the assignment. We - -- achieve this by constructing a Storage_Array subtype, and by - -- overlaying objects of this type on the source and target of the - -- assignment. The assignment is then rewritten to assignments of - -- slices of these arrays, copying the user data, and leaving the - -- pointers untouched. - - Controlled_Actions : declare - Prev_Ref : Node_Id; - -- A reference to the Prev component of the record controller - - First_After_Root : Node_Id := Empty; - -- Index of first byte to be copied (used to skip - -- Root_Controlled in controlled objects). - - Last_Before_Hole : Node_Id := Empty; - -- Index of last byte to be copied before outermost record - -- controller data. - - Hole_Length : Node_Id := Empty; - -- Length of record controller data (Prev and Next pointers) - - First_After_Hole : Node_Id := Empty; - -- Index of first byte to be copied after outermost record - -- controller data. - - Expr, Source_Size : Node_Id; - Source_Actual_Subtype : Entity_Id; - -- Used for computation of the size of the data to be copied - - Range_Type : Entity_Id; - Opaque_Type : Entity_Id; - - function Build_Slice - (Rec : Entity_Id; - Lo : Node_Id; - Hi : Node_Id) return Node_Id; - -- Build and return a slice of an array of type S overlaid on - -- object Rec, with bounds specified by Lo and Hi. If either - -- bound is empty, a default of S'First (respectively S'Last) - -- is used. - - ----------------- - -- Build_Slice -- - ----------------- - - function Build_Slice - (Rec : Node_Id; - Lo : Node_Id; - Hi : Node_Id) return Node_Id - is - Lo_Bound : Node_Id; - Hi_Bound : Node_Id; - - Opaque : constant Node_Id := - Unchecked_Convert_To (Opaque_Type, - Make_Attribute_Reference (Loc, - Prefix => Rec, - Attribute_Name => Name_Address)); - -- Access value designating an opaque storage array of type - -- S overlaid on record Rec. - - begin - -- Compute slice bounds using S'First (1) and S'Last as - -- default values when not specified by the caller. - - if No (Lo) then - Lo_Bound := Make_Integer_Literal (Loc, 1); - else - Lo_Bound := Lo; - end if; - - if No (Hi) then - Hi_Bound := Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Range_Type, Loc), - Attribute_Name => Name_Last); - else - Hi_Bound := Hi; - end if; - - return Make_Slice (Loc, - Prefix => - Opaque, - Discrete_Range => Make_Range (Loc, - Lo_Bound, Hi_Bound)); - end Build_Slice; - - -- Start of processing for Controlled_Actions - - begin - -- Create a constrained subtype of Storage_Array whose size - -- corresponds to the value being assigned. - - -- subtype G is Storage_Offset range - -- 1 .. (Expr'Size + Storage_Unit - 1) / Storage_Unit - - Expr := Duplicate_Subexpr_No_Checks (Expression (N)); - - if Nkind (Expr) = N_Qualified_Expression then - Expr := Expression (Expr); - end if; - - Source_Actual_Subtype := Etype (Expr); - - if Has_Discriminants (Source_Actual_Subtype) - and then not Is_Constrained (Source_Actual_Subtype) - then - Append_To (Res, - Build_Actual_Subtype (Source_Actual_Subtype, Expr)); - Source_Actual_Subtype := Defining_Identifier (Last (Res)); - end if; - - Source_Size := - Make_Op_Add (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Source_Actual_Subtype, Loc), - Attribute_Name => Name_Size), - Right_Opnd => - Make_Integer_Literal (Loc, - Intval => System_Storage_Unit - 1)); - - Source_Size := - Make_Op_Divide (Loc, - Left_Opnd => Source_Size, - Right_Opnd => - Make_Integer_Literal (Loc, - Intval => System_Storage_Unit)); - - Range_Type := Make_Temporary (Loc, 'G'); - - Append_To (Res, - Make_Subtype_Declaration (Loc, - Defining_Identifier => Range_Type, - Subtype_Indication => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Reference_To (RTE (RE_Storage_Offset), Loc), - Constraint => Make_Range_Constraint (Loc, - Range_Expression => - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), - High_Bound => Source_Size))))); - - -- subtype S is Storage_Array (G) - - Append_To (Res, - Make_Subtype_Declaration (Loc, - Defining_Identifier => Make_Temporary (Loc, 'S'), - Subtype_Indication => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Reference_To (RTE (RE_Storage_Array), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => - New_List (New_Reference_To (Range_Type, Loc)))))); - - -- type A is access S - - Opaque_Type := Make_Temporary (Loc, 'A'); - - Append_To (Res, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Opaque_Type, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of ( - Defining_Identifier (Last (Res)), Loc)))); - - -- Generate appropriate slice assignments - - First_After_Root := Make_Integer_Literal (Loc, 1); - - -- For controlled object, skip Root_Controlled part - - if Is_Controlled (T) then - First_After_Root := - Make_Op_Add (Loc, - First_After_Root, - Make_Op_Divide (Loc, - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Root_Controlled), Loc), - Attribute_Name => Name_Size), - Make_Integer_Literal (Loc, System_Storage_Unit))); - end if; - - -- For the case of a record with controlled components, skip - -- record controller Prev/Next components. These components - -- constitute a 'hole' in the middle of the data to be copied. - - if Has_Controlled_Component (T) then - Prev_Ref := - Make_Selected_Component (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => Duplicate_Subexpr_No_Checks (L), - Selector_Name => - New_Reference_To (Controller_Component (T), Loc)), - Selector_Name => Make_Identifier (Loc, Name_Prev)); - - -- Last index before hole: determined by position of the - -- _Controller.Prev component. - - Last_Before_Hole := Make_Temporary (Loc, 'L'); - - Append_To (Res, - Make_Object_Declaration (Loc, - Defining_Identifier => Last_Before_Hole, - Object_Definition => New_Occurrence_Of ( - RTE (RE_Storage_Offset), Loc), - Constant_Present => True, - Expression => - Make_Op_Add (Loc, - Make_Attribute_Reference (Loc, - Prefix => Prev_Ref, - Attribute_Name => Name_Position), - Make_Attribute_Reference (Loc, - Prefix => New_Copy_Tree (Prefix (Prev_Ref)), - Attribute_Name => Name_Position)))); - - -- Hole length: size of the Prev and Next components - - Hole_Length := - Make_Op_Multiply (Loc, - Left_Opnd => Make_Integer_Literal (Loc, Uint_2), - Right_Opnd => - Make_Op_Divide (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Copy_Tree (Prev_Ref), - Attribute_Name => Name_Size), - Right_Opnd => - Make_Integer_Literal (Loc, - Intval => System_Storage_Unit))); - - -- First index after hole - - First_After_Hole := Make_Temporary (Loc, 'F'); - - Append_To (Res, - Make_Object_Declaration (Loc, - Defining_Identifier => First_After_Hole, - Object_Definition => New_Occurrence_Of ( - RTE (RE_Storage_Offset), Loc), - Constant_Present => True, - Expression => - Make_Op_Add (Loc, - Left_Opnd => - Make_Op_Add (Loc, - Left_Opnd => - New_Occurrence_Of (Last_Before_Hole, Loc), - Right_Opnd => Hole_Length), - Right_Opnd => Make_Integer_Literal (Loc, 1)))); - - Last_Before_Hole := - New_Occurrence_Of (Last_Before_Hole, Loc); - First_After_Hole := - New_Occurrence_Of (First_After_Hole, Loc); - end if; - - -- Assign the first slice (possibly skipping Root_Controlled, - -- up to the beginning of the record controller if present, - -- up to the end of the object if not). - - Append_To (Res, Make_Assignment_Statement (Loc, - Name => Build_Slice ( - Rec => Duplicate_Subexpr_No_Checks (L), - Lo => First_After_Root, - Hi => Last_Before_Hole), - - Expression => Build_Slice ( - Rec => Expression (N), - Lo => First_After_Root, - Hi => New_Copy_Tree (Last_Before_Hole)))); - - if Present (First_After_Hole) then - - -- If a record controller is present, copy the second slice, - -- from right after the _Controller.Next component up to the - -- end of the object. - - Append_To (Res, Make_Assignment_Statement (Loc, - Name => Build_Slice ( - Rec => Duplicate_Subexpr_No_Checks (L), - Lo => First_After_Hole, - Hi => Empty), - Expression => Build_Slice ( - Rec => Duplicate_Subexpr_No_Checks (Expression (N)), - Lo => New_Copy_Tree (First_After_Hole), - Hi => Empty))); - end if; - end Controlled_Actions; - end if; - - -- Not controlled case - - else - declare - Asn : constant Node_Id := Relocate_Node (N); - - begin - -- If this is the case of a tagged type with a full rep clause, - -- we must expand it into component assignments, so we mark the - -- node as unanalyzed, to get it reanalyzed, but flag it has - -- requiring component-wise assignment so we don't get infinite - -- recursion. - - if Component_Assign then - Set_Analyzed (Asn, False); - Set_Componentwise_Assignment (Asn, True); - end if; - - Append_To (Res, Asn); - end; + if Comp_Asn then + Set_Analyzed (Asn, False); + Set_Componentwise_Assignment (Asn, True); end if; + Append_To (Res, Asn); + -- Restore the tag if Save_Tag then @@ -3965,40 +3583,14 @@ package body Exp_Ch5 is Expression => New_Reference_To (Tag_Tmp, Loc))); end if; - if Ctrl_Act then - if VM_Target /= No_VM then - -- Restore the finalization pointers + -- Adjust the target after the assignment when controlled (not in the + -- init proc since it is an initialization more than an assignment). - Append_To (Res, - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_Finalizable), - New_Copy_Tree (Ctrl_Ref)), - Selector_Name => Make_Identifier (Loc, Name_Prev)), - Expression => New_Reference_To (Prev_Tmp, Loc))); - - Append_To (Res, - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_Finalizable), - New_Copy_Tree (Ctrl_Ref)), - Selector_Name => Make_Identifier (Loc, Name_Next)), - Expression => New_Reference_To (Next_Tmp, Loc))); - end if; - - -- Adjust the target after the assignment when controlled (not in the - -- init proc since it is an initialization more than an assignment). - - Append_List_To (Res, + if Ctrl_Act then + Append_To (Res, Make_Adjust_Call ( - Ref => Duplicate_Subexpr_Move_Checks (L), - Typ => Etype (L), - Flist_Ref => New_Reference_To (RTE (RE_Global_Final_List), Loc), - With_Attach => Make_Integer_Literal (Loc, 0))); + Obj_Ref => Duplicate_Subexpr_Move_Checks (L), + Typ => Etype (L))); end if; return Res; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index d09261eae85..87403a5feeb 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -110,19 +110,14 @@ package body Exp_Ch6 is -- Adds Extra_Actual as a named parameter association for the formal -- Extra_Formal in Subprogram_Call. - procedure Add_Final_List_Actual_To_Build_In_Place_Call - (Function_Call : Node_Id; - Function_Id : Entity_Id; - Acc_Type : Entity_Id; - Sel_Comp : Node_Id := Empty); - -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has - -- controlled parts, add an actual parameter that is a pointer to - -- appropriate finalization list. The finalization list is that of the - -- current scope, except for "new Acc'(F(...))" in which case it's the - -- finalization list of the access type returned by the allocator. Acc_Type - -- is that type in the allocator case; Empty otherwise. If Sel_Comp is - -- not Empty, then it denotes a selected component and the finalization - -- list is obtained from the _controller list of the prefix object. + procedure Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call : Node_Id; + Func_Id : Entity_Id; + Ptr_Typ : Entity_Id := Empty); + -- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs + -- finalization actions, add an actual parameter which is a pointer to the + -- finalization collection of the caller. If Ptr_Typ is left Empty, this + -- will result in an automatic "null" value for the actual. procedure Add_Task_Actuals_To_Build_In_Place_Call (Function_Call : Node_Id; @@ -191,6 +186,11 @@ package body Exp_Ch6 is -- For non-scalar objects that are possibly unaligned, add call by copy -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT). + procedure Expand_Ctrl_Function_Call (N : Node_Id); + -- N is a function call which returns a controlled object. Transform the + -- call into a temporary which retrieves the returned object from the + -- secondary stack using 'reference. + procedure Expand_Inlined_Call (N : Node_Id; Subp : Entity_Id; @@ -340,6 +340,91 @@ package body Exp_Ch6 is (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual); end Add_Alloc_Form_Actual_To_Build_In_Place_Call; + -------------------------------------------------- + -- Add_Collection_Actual_To_Build_In_Place_Call -- + -------------------------------------------------- + + procedure Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call : Node_Id; + Func_Id : Entity_Id; + Ptr_Typ : Entity_Id := Empty) + is + begin + if not Needs_BIP_Collection (Func_Id) then + return; + end if; + + declare + Formal : constant Entity_Id := + Build_In_Place_Formal (Func_Id, BIP_Collection); + Loc : constant Source_Ptr := Sloc (Func_Call); + + Actual : Node_Id; + Desig_Typ : Entity_Id; + + begin + -- Case where the context does not require an actual collection + + if No (Ptr_Typ) then + Actual := Make_Null (Loc); + + else + Desig_Typ := Directly_Designated_Type (Ptr_Typ); + + -- Check for a library-level access type whose designated type has + -- supressed finalization. Such an access types lack a collection. + -- Pass a null actual to the callee in order to signal a missing + -- collection. + + if Is_Library_Level_Entity (Ptr_Typ) + and then Finalize_Storage_Only (Desig_Typ) + then + Actual := Make_Null (Loc); + + -- Types in need of finalization actions + + elsif Needs_Finalization (Desig_Typ) then + + -- The general mechanism of creating finalization collections + -- for anonymous access types is disabled by default, otherwise + -- collections will pop all over the place. Such types use + -- context-specific collections. + + if Ekind (Ptr_Typ) = E_Anonymous_Access_Type + and then No (Associated_Collection (Ptr_Typ)) + then + Build_Finalization_Collection + (Typ => Ptr_Typ, + Ins_Node => Associated_Node_For_Itype (Ptr_Typ), + Encl_Scope => Scope (Ptr_Typ)); + end if; + + -- Access-to-controlled types should always have a collection + + pragma Assert (Present (Associated_Collection (Ptr_Typ))); + + Actual := + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Associated_Collection (Ptr_Typ), Loc), + Attribute_Name => Name_Unrestricted_Access); + + -- Tagged types + + else + Actual := Make_Null (Loc); + end if; + end if; + + Analyze_And_Resolve (Actual, Etype (Formal)); + + -- Build the parameter association for the new actual and add it to + -- the end of the function's actuals. + + Add_Extra_Actual_To_Call (Func_Call, Formal, Actual); + end; + end Add_Collection_Actual_To_Build_In_Place_Call; + ------------------------------ -- Add_Extra_Actual_To_Call -- ------------------------------ @@ -393,79 +478,6 @@ package body Exp_Ch6 is end if; end Add_Extra_Actual_To_Call; - -------------------------------------------------- - -- Add_Final_List_Actual_To_Build_In_Place_Call -- - -------------------------------------------------- - - procedure Add_Final_List_Actual_To_Build_In_Place_Call - (Function_Call : Node_Id; - Function_Id : Entity_Id; - Acc_Type : Entity_Id; - Sel_Comp : Node_Id := Empty) - is - Loc : constant Source_Ptr := Sloc (Function_Call); - Final_List : Node_Id; - Final_List_Actual : Node_Id; - Final_List_Formal : Node_Id; - Is_Ctrl_Result : constant Boolean := - Needs_Finalization - (Underlying_Type (Etype (Function_Id))); - - begin - -- No such extra parameter is needed if there are no controlled parts. - -- The test for Needs_Finalization accounts for class-wide results - -- (which potentially have controlled parts, even if the root type - -- doesn't), and the test for a tagged result type is needed because - -- calls to such a function can in general occur in dispatching - -- contexts, which must be treated the same as a call to class-wide - -- functions. Both of these situations require that a finalization list - -- be passed. - - if not Needs_BIP_Final_List (Function_Id) then - return; - end if; - - -- Locate implicit finalization list parameter in the called function - - Final_List_Formal := Build_In_Place_Formal (Function_Id, BIP_Final_List); - - -- Create the actual which is a pointer to the appropriate finalization - -- list. Acc_Type is present if and only if this call is the - -- initialization of an allocator. Use the Current_Scope or the - -- Acc_Type as appropriate. - - if Present (Acc_Type) - and then (Ekind (Acc_Type) = E_Anonymous_Access_Type - or else - Present (Associated_Final_Chain (Base_Type (Acc_Type)))) - then - Final_List := Find_Final_List (Acc_Type); - - -- If Sel_Comp is present and the function result is controlled, then - -- the finalization list will be obtained from the _controller list of - -- the selected component's prefix object. - - elsif Present (Sel_Comp) and then Is_Ctrl_Result then - Final_List := Find_Final_List (Current_Scope, Sel_Comp); - - else - Final_List := Find_Final_List (Current_Scope); - end if; - - Final_List_Actual := - Make_Attribute_Reference (Loc, - Prefix => Final_List, - Attribute_Name => Name_Unrestricted_Access); - - Analyze_And_Resolve (Final_List_Actual, Etype (Final_List_Formal)); - - -- Build the parameter association for the new actual and add it to the - -- end of the function's actuals. - - Add_Extra_Actual_To_Call - (Function_Call, Final_List_Formal, Final_List_Actual); - end Add_Final_List_Actual_To_Build_In_Place_Call; - --------------------------------------------- -- Add_Task_Actuals_To_Build_In_Place_Call -- --------------------------------------------- @@ -549,8 +561,8 @@ package body Exp_Ch6 is case Kind is when BIP_Alloc_Form => return "BIPalloc"; - when BIP_Final_List => - return "BIPfinallist"; + when BIP_Collection => + return "BIPcollection"; when BIP_Master => return "BIPmaster"; when BIP_Activation_Chain => @@ -1777,6 +1789,10 @@ package body Exp_Ch6 is -- convoluted tree traversal before setting the proper subprogram to be -- called. + function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean; + -- Determine whether Subp denotes a non-dispatching call to a Deep + -- routine. + function New_Value (From : Node_Id) return Node_Id; -- From is the original Expression. New_Value is equivalent to a call -- to Duplicate_Subexpr with an explicit dereference when From is an @@ -1945,6 +1961,42 @@ package body Exp_Ch6 is raise Program_Error; end Inherited_From_Formal; + ------------------------- + -- Is_Direct_Deep_Call -- + ------------------------- + + function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean is + begin + if Is_TSS (Subp, TSS_Deep_Adjust) + or else Is_TSS (Subp, TSS_Deep_Finalize) + or else Is_TSS (Subp, TSS_Deep_Initialize) + then + declare + Actual : Node_Id; + Formal : Node_Id; + + begin + Actual := First (Parameter_Associations (N)); + Formal := First_Formal (Subp); + while Present (Actual) + and then Present (Formal) + loop + if Nkind (Actual) = N_Identifier + and then Is_Controlling_Actual (Actual) + and then Etype (Actual) = Etype (Formal) + then + return True; + end if; + + Next (Actual); + Next_Formal (Formal); + end loop; + end; + end if; + + return False; + end Is_Direct_Deep_Call; + --------------- -- New_Value -- --------------- @@ -2795,6 +2847,7 @@ package body Exp_Ch6 is if Nkind (Call_Node) /= N_Entry_Call_Statement and then No (Controlling_Argument (Call_Node)) and then Present (Parent_Subp) + and then not Is_Direct_Deep_Call (Subp) then if Present (Inherited_From_Formal (Subp)) then Parent_Subp := Inherited_From_Formal (Subp); @@ -3229,12 +3282,12 @@ package body Exp_Ch6 is Expand_Protected_Subprogram_Call (Call_Node, Subp, Scop); end if; - -- Functions returning controlled objects need special attention: - -- if the return type is limited, the context is an initialization - -- and different processing applies. If the call is to a protected - -- function, the expansion above will call Expand_Call recursively. - -- To prevent a double attachment, check that the current call is - -- not a rewriting of a protected function call. + -- Functions returning controlled objects need special attention. If + -- the return type is limited, then the context is initialization and + -- different processing applies. If the call is to a protected function, + -- the expansion above will call Expand_Call recursively. Otherwise the + -- function call is transformed into a temporary which obtains the + -- result from the secondary stack. if Needs_Finalization (Etype (Subp)) then if not Is_Immutably_Limited_Type (Etype (Subp)) @@ -3407,6 +3460,33 @@ package body Exp_Ch6 is end if; end Expand_Call; + ------------------------------- + -- Expand_Ctrl_Function_Call -- + ------------------------------- + + procedure Expand_Ctrl_Function_Call (N : Node_Id) is + begin + -- Optimization, if the returned value (which is on the sec-stack) is + -- returned again, no need to copy/readjust/finalize, we can just pass + -- the value thru (see Expand_N_Simple_Return_Statement), and thus no + -- attachment is needed + + if Nkind (Parent (N)) = N_Simple_Return_Statement then + return; + end if; + + -- Resolution is now finished, make sure we don't start analysis again + -- because of the duplication. + + Set_Analyzed (N); + + -- A function which returns a controlled object uses the secondary + -- stack. Rewrite the call into a temporary which obtains the result of + -- the function using 'reference. + + Remove_Side_Effects (N); + end Expand_Ctrl_Function_Call; + -------------------------- -- Expand_Inlined_Call -- -------------------------- @@ -4245,20 +4325,53 @@ package body Exp_Ch6 is procedure Expand_N_Extended_Return_Statement (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Return_Object_Entity : constant Entity_Id := - First_Entity (Return_Statement_Entity (N)); - Return_Object_Decl : constant Node_Id := - Parent (Return_Object_Entity); - Parent_Function : constant Entity_Id := - Return_Applies_To (Return_Statement_Entity (N)); - Is_Build_In_Place : constant Boolean := - Is_Build_In_Place_Function (Parent_Function); - - Return_Stm : Node_Id; - Statements : List_Id; - Handled_Stm_Seq : Node_Id; - Result : Node_Id; - Exp : Node_Id; + Par_Func : constant Entity_Id := + Return_Applies_To (Return_Statement_Entity (N)); + Ret_Obj_Id : constant Entity_Id := + First_Entity (Return_Statement_Entity (N)); + Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id); + + Is_Build_In_Place : constant Boolean := + Is_Build_In_Place_Function (Par_Func); + + Exp : Node_Id; + HSS : Node_Id; + Result : Node_Id; + Return_Stmt : Node_Id; + Stmts : List_Id; + + function Build_Heap_Allocator + (Temp_Id : Entity_Id; + Temp_Typ : Entity_Id; + Func_Id : Entity_Id; + Ret_Typ : Entity_Id; + Alloc_Expr : Node_Id) return Node_Id; + -- Create the statements necessary to allocate a return object on the + -- caller's collection. The collection is available through implicit + -- parameter BIPcollection. + -- + -- if BIPcollection /= null then + -- declare + -- type Ptr_Typ is access Ret_Typ; + -- for Ptr_Typ'Storage_Pool use + -- Base_Pool (BIPcollection.all).all; + -- Local : Ptr_Typ; + -- + -- begin + -- procedure Allocate (...) is + -- begin + -- Ada.Finalization.Heap_Management.Allocate (...); + -- end Allocate; + -- + -- Local := <Alloc_Expr>; + -- Temp_Id := Temp_Typ (Local); + -- end; + -- end if; + -- + -- Temp_Id is the temporary which is used to reference the internally + -- created object in all allocation forms. Temp_Typ is the type of the + -- temporary. Func_Id is the enclosing function. Ret_Typ is the return + -- type of Func_Id. Alloc_Expr is the actual allocator. function Move_Activation_Chain return Node_Id; -- Construct a call to System.Tasking.Stages.Move_Activation_Chain @@ -4267,99 +4380,254 @@ package body Exp_Ch6 is -- To activation chain passed in by the caller -- New_Master master passed in by the caller - function Move_Final_List return Node_Id; - -- Construct call to System.Finalization_Implementation.Move_Final_List - -- with parameters: - -- - -- From finalization list of the return statement - -- To finalization list passed in by the caller + -------------------------- + -- Build_Heap_Allocator -- + -------------------------- + + function Build_Heap_Allocator + (Temp_Id : Entity_Id; + Temp_Typ : Entity_Id; + Func_Id : Entity_Id; + Ret_Typ : Entity_Id; + Alloc_Expr : Node_Id) return Node_Id + is + begin + -- Processing for build-in-place object allocation. This is disabled + -- on .NET/JVM because pools are not supported. + + if VM_Target = No_VM + and then Is_Build_In_Place_Function (Func_Id) + and then Needs_Finalization (Ret_Typ) + then + declare + Collect : constant Entity_Id := + Build_In_Place_Formal (Func_Id, BIP_Collection); + Decls : constant List_Id := New_List; + Stmts : constant List_Id := New_List; + + Local_Id : Entity_Id; + Pool_Id : Entity_Id; + Ptr_Typ : Entity_Id; + + begin + -- Generate: + -- Pool_Id renames Base_Pool (BIPcollection.all).all; + + Pool_Id := Make_Temporary (Loc, 'P'); + + Append_To (Decls, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Pool_Id, + Subtype_Mark => + New_Reference_To (RTE (RE_Root_Storage_Pool), Loc), + Name => + Make_Explicit_Dereference (Loc, + Prefix => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Base_Pool), Loc), + + Parameter_Associations => New_List ( + Make_Explicit_Dereference (Loc, + Prefix => + New_Reference_To (Collect, Loc))))))); + + -- Create an access type which uses the storage pool of the + -- caller's collection. This additional type is necessary + -- because the collection cannot be associated with the type + -- of the temporary. Otherwise the secondary stack allocation + -- will fail. + + -- Generate: + -- type Ptr_Typ is access Ret_Typ; + + Ptr_Typ := Make_Temporary (Loc, 'P'); + + Append_To (Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Reference_To (Ret_Typ, Loc)))); + + -- Perform minor decoration in order to set the collection and + -- the storage pool attributes. + + Set_Ekind (Ptr_Typ, E_Access_Type); + Set_Associated_Collection (Ptr_Typ, Collect); + Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); + + -- Create the temporary, generate: + -- + -- Local_Id : Ptr_Typ; + + Local_Id := Make_Temporary (Loc, 'T'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Id, + Object_Definition => + New_Reference_To (Ptr_Typ, Loc))); + + -- Allocate the object, generate: + -- + -- Local_Id := <Alloc_Expr>; + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Local_Id, Loc), + Expression => Alloc_Expr)); + + -- Generate: + -- Temp_Id := Temp_Typ (Local_Id); + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Temp_Id, Loc), + Expression => + Unchecked_Convert_To (Temp_Typ, + New_Reference_To (Local_Id, Loc)))); + + -- Wrap the allocation in a block. This is further conditioned + -- by checking the caller collection at runtime. A null value + -- indicates a non-existent collection, most likely due to a + -- Finalize_Storage_Only allocation. + + -- Generate: + -- if BIPcollection /= null then + -- declare + -- <Decls> + -- begin + -- <Stmts> + -- end; + -- end if; + + return + Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + New_Reference_To (Collect, Loc), + Right_Opnd => + Make_Null (Loc)), + + Then_Statements => New_List ( + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)))); + end; + + -- For all other cases, generate: + -- + -- Temp_Id := <Alloc_Expr>; + + else + return + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Temp_Id, Loc), + Expression => Alloc_Expr); + end if; + end Build_Heap_Allocator; --------------------------- -- Move_Activation_Chain -- --------------------------- function Move_Activation_Chain return Node_Id is - Activation_Chain_Formal : constant Entity_Id := - Build_In_Place_Formal - (Parent_Function, BIP_Activation_Chain); - To : constant Node_Id := - New_Reference_To - (Activation_Chain_Formal, Loc); - Master_Formal : constant Entity_Id := - Build_In_Place_Formal - (Parent_Function, BIP_Master); - New_Master : constant Node_Id := - New_Reference_To (Master_Formal, Loc); - - Chain_Entity : Entity_Id; - From : Node_Id; + Chain_Formal : constant Entity_Id := + Build_In_Place_Formal + (Par_Func, BIP_Activation_Chain); + To : constant Node_Id := + New_Reference_To (Chain_Formal, Loc); + Master_Formal : constant Entity_Id := + Build_In_Place_Formal (Par_Func, BIP_Master); + New_Master : constant Node_Id := + New_Reference_To (Master_Formal, Loc); + + Chain_Id : Entity_Id; + From : Node_Id; begin - Chain_Entity := First_Entity (Return_Statement_Entity (N)); - while Chars (Chain_Entity) /= Name_uChain loop - Chain_Entity := Next_Entity (Chain_Entity); + Chain_Id := First_Entity (Return_Statement_Entity (N)); + while Chars (Chain_Id) /= Name_uChain loop + Chain_Id := Next_Entity (Chain_Id); end loop; From := Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Chain_Entity, Loc), + Prefix => + New_Reference_To (Chain_Id, Loc), Attribute_Name => Name_Unrestricted_Access); -- ??? Not clear why "Make_Identifier (Loc, Name_uChain)" doesn't - -- work, instead of "New_Reference_To (Chain_Entity, Loc)" above. + -- work, instead of "New_Reference_To (Chain_Id, Loc)" above. return Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Move_Activation_Chain), Loc), + Name => + New_Reference_To (RTE (RE_Move_Activation_Chain), Loc), Parameter_Associations => New_List (From, To, New_Master)); end Move_Activation_Chain; - --------------------- - -- Move_Final_List -- - --------------------- + -- Start of processing for Expand_N_Extended_Return_Statement - function Move_Final_List return Node_Id is - Flist : constant Entity_Id := - Finalization_Chain_Entity (Return_Statement_Entity (N)); + begin + if Nkind (Ret_Obj_Decl) = N_Object_Declaration then + Exp := Expression (Ret_Obj_Decl); + else + Exp := Empty; + end if; - From : constant Node_Id := New_Reference_To (Flist, Loc); + HSS := Handled_Statement_Sequence (N); - Caller_Final_List : constant Entity_Id := - Build_In_Place_Formal - (Parent_Function, BIP_Final_List); + -- If the returned object needs finalization actions, the function must + -- perform the appropriate cleanup should it fail to return. The state + -- of the function itself is tracked through a flag which is coupled + -- with the scope finalizer. There is one flag per each return object + -- in case of multiple returns. - To : constant Node_Id := New_Reference_To (Caller_Final_List, Loc); + if Is_Build_In_Place + and then Needs_Finalization (Etype (Ret_Obj_Id)) + then + declare + Flag_Decl : Node_Id; + Flag_Id : Entity_Id; + Func_Bod : Node_Id; - begin - -- Catch cases where a finalization chain entity has not been - -- associated with the return statement entity. + begin + -- Recover the function body - pragma Assert (Present (Flist)); + Func_Bod := Unit_Declaration_Node (Par_Func); + if Nkind (Func_Bod) = N_Subprogram_Declaration then + Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod))); + end if; - -- Build required call + -- Create a flag to track the function state - return - Make_If_Statement (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => New_Copy (From), - Right_Opnd => New_Node (N_Null, Loc)), - Then_Statements => - New_List ( - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Move_Final_List), Loc), - Parameter_Associations => New_List (From, To)))); - end Move_Final_List; + Flag_Id := Make_Temporary (Loc, 'F'); + Set_Return_Flag (Ret_Obj_Id, Flag_Id); - -- Start of processing for Expand_N_Extended_Return_Statement + -- Insert the flag at the beginning of the function declarations, + -- generate: + -- Fnn : Boolean := False; - begin - if Nkind (Return_Object_Decl) = N_Object_Declaration then - Exp := Expression (Return_Object_Decl); - else - Exp := Empty; - end if; + Flag_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Flag_Id, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => + New_Reference_To (Standard_False, Loc)); - Handled_Stm_Seq := Handled_Statement_Sequence (N); + Prepend_To (Declarations (Func_Bod), Flag_Decl); + Analyze (Flag_Decl); + end; + end if; -- Build a simple_return_statement that returns the return object when -- there is a statement sequence, or no expression, or the result will @@ -4367,89 +4635,79 @@ package body Exp_Ch6 is -- composite cases, even though nonlimited composite results are not yet -- built in place (though we plan to do so eventually). - if Present (Handled_Stm_Seq) - or else Is_Composite_Type (Etype (Parent_Function)) + if Present (HSS) + or else Is_Composite_Type (Etype (Par_Func)) or else No (Exp) then - if No (Handled_Stm_Seq) then - Statements := New_List; + if No (HSS) then + Stmts := New_List; -- If the extended return has a handled statement sequence, then wrap -- it in a block and use the block as the first statement. else - Statements := - New_List (Make_Block_Statement (Loc, - Declarations => New_List, - Handled_Statement_Sequence => Handled_Stm_Seq)); + Stmts := New_List ( + Make_Block_Statement (Loc, + Declarations => New_List, + Handled_Statement_Sequence => HSS)); end if; - -- If control gets past the above Statements, we have successfully - -- completed the return statement. If the result type has controlled - -- parts and the return is for a build-in-place function, then we - -- call Move_Final_List to transfer responsibility for finalization - -- of the return object to the caller. An alternative would be to - -- declare a Success flag in the function, initialize it to False, - -- and set it to True here. Then move the Move_Final_List call into - -- the cleanup code, and check Success. If Success then make a call - -- to Move_Final_List else do finalization. Then we can remove the - -- abort-deferral and the nulling-out of the From parameter from - -- Move_Final_List. Note that the current method is not quite correct - -- in the rather obscure case of a select-then-abort statement whose - -- abortable part contains the return statement. - - -- Check the type of the function to determine whether to move the - -- finalization list. A special case arises when processing a simple - -- return statement which has been rewritten as an extended return. - -- In that case check the type of the returned object or the original - -- expression. Note that Needs_Finalization accounts for the case - -- of class-wide types, which which must be assumed to require - -- finalization. + -- If the result type contains tasks, we call Move_Activation_Chain. + -- Later, the cleanup code will call Complete_Master, which will + -- terminate any unactivated tasks belonging to the return statement + -- master. But Move_Activation_Chain updates their master to be that + -- of the caller, so they will not be terminated unless the return + -- statement completes unsuccessfully due to exception, abort, goto, + -- or exit. As a formality, we test whether the function requires the + -- result to be built in place, though that's necessarily true for + -- the case of result types with task parts. if Is_Build_In_Place - and then Needs_BIP_Final_List (Parent_Function) - and then - ((Present (Exp) and then Needs_Finalization (Etype (Exp))) - or else - (not Present (Exp) - and then Needs_Finalization (Etype (Return_Object_Entity)))) + and Has_Task (Etype (Par_Func)) then - Append_To (Statements, Move_Final_List); + Append_To (Stmts, Move_Activation_Chain); end if; - -- Similarly to the above Move_Final_List, if the result type - -- contains tasks, we call Move_Activation_Chain. Later, the cleanup - -- code will call Complete_Master, which will terminate any - -- unactivated tasks belonging to the return statement master. But - -- Move_Activation_Chain updates their master to be that of the - -- caller, so they will not be terminated unless the return statement - -- completes unsuccessfully due to exception, abort, goto, or exit. - -- As a formality, we test whether the function requires the result - -- to be built in place, though that's necessarily true for the case - -- of result types with task parts. - - if Is_Build_In_Place and Has_Task (Etype (Parent_Function)) then - Append_To (Statements, Move_Activation_Chain); + -- Update the state of the function right before the object is + -- returned. + + if Is_Build_In_Place + and then Needs_Finalization (Etype (Ret_Obj_Id)) + then + declare + Flag_Id : constant Entity_Id := Return_Flag (Ret_Obj_Id); + + begin + -- Generate: + -- Fnn := True; + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Flag_Id, Loc), + Expression => + New_Reference_To (Standard_True, Loc))); + end; end if; -- Build a simple_return_statement that returns the return object - Return_Stm := + Return_Stmt := Make_Simple_Return_Statement (Loc, - Expression => New_Occurrence_Of (Return_Object_Entity, Loc)); - Append_To (Statements, Return_Stm); + Expression => + New_Occurrence_Of (Ret_Obj_Id, Loc)); + Append_To (Stmts, Return_Stmt); - Handled_Stm_Seq := - Make_Handled_Sequence_Of_Statements (Loc, Statements); + HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts); end if; - -- Case where we build a block + -- Case where we build a return statement block - if Present (Handled_Stm_Seq) then + if Present (HSS) then Result := Make_Block_Statement (Loc, Declarations => Return_Object_Declarations (N), - Handled_Statement_Sequence => Handled_Stm_Seq); + Handled_Statement_Sequence => HSS); -- We set the entity of the new block statement to be that of the -- return statement. This is necessary so that various fields, such @@ -4468,15 +4726,16 @@ package body Exp_Ch6 is -- allocation of the return object. if Is_Build_In_Place - and then - Nkind (Return_Object_Decl) = N_Object_Renaming_Declaration + and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration then - pragma Assert (Nkind (Original_Node (Return_Object_Decl)) = - N_Object_Declaration - and then Is_Build_In_Place_Function_Call - (Expression (Original_Node (Return_Object_Decl)))); + pragma Assert + (Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration + and then Is_Build_In_Place_Function_Call + (Expression (Original_Node (Ret_Obj_Decl)))); + + -- Return the build-in-place result by reference - Set_By_Ref (Return_Stm); -- Return build-in-place results by ref + Set_By_Ref (Return_Stmt); elsif Is_Build_In_Place then @@ -4488,27 +4747,26 @@ package body Exp_Ch6 is -- expanded as separate assignments, then add an assignment -- statement to ensure the return object gets initialized. - -- declare - -- Result : T [:= <expression>]; - -- begin - -- ... + -- declare + -- Result : T [:= <expression>]; + -- begin + -- ... -- is converted to - -- declare - -- Result : T renames FuncRA.all; - -- [Result := <expression;] - -- begin - -- ... + -- declare + -- Result : T renames FuncRA.all; + -- [Result := <expression;] + -- begin + -- ... declare Return_Obj_Id : constant Entity_Id := - Defining_Identifier (Return_Object_Decl); + Defining_Identifier (Ret_Obj_Decl); Return_Obj_Typ : constant Entity_Id := Etype (Return_Obj_Id); Return_Obj_Expr : constant Node_Id := - Expression (Return_Object_Decl); - Result_Subt : constant Entity_Id := - Etype (Parent_Function); + Expression (Ret_Obj_Decl); + Result_Subt : constant Entity_Id := Etype (Par_Func); Constr_Result : constant Boolean := Is_Constrained (Result_Subt); Obj_Alloc_Formal : Entity_Id; @@ -4519,12 +4777,12 @@ package body Exp_Ch6 is begin -- Build-in-place results must be returned by reference - Set_By_Ref (Return_Stm); + Set_By_Ref (Return_Stmt); -- Retrieve the implicit access parameter passed by the caller Object_Access := - Build_In_Place_Formal (Parent_Function, BIP_Object_Access); + Build_In_Place_Formal (Par_Func, BIP_Object_Access); -- If the return object's declaration includes an expression -- and the declaration isn't marked as No_Initialization, then @@ -4543,13 +4801,16 @@ package body Exp_Ch6 is -- interface has no assignment operation). if Present (Return_Obj_Expr) - and then not No_Initialization (Return_Object_Decl) + and then not No_Initialization (Ret_Obj_Decl) and then not Is_Interface (Return_Obj_Typ) then Init_Assignment := Make_Assignment_Statement (Loc, - Name => New_Reference_To (Return_Obj_Id, Loc), - Expression => Relocate_Node (Return_Obj_Expr)); + Name => + New_Reference_To (Return_Obj_Id, Loc), + Expression => + Relocate_Node (Return_Obj_Expr)); + Set_Etype (Name (Init_Assignment), Etype (Return_Obj_Id)); Set_Assignment_OK (Name (Init_Assignment)); Set_No_Ctrl_Actions (Init_Assignment); @@ -4557,7 +4818,7 @@ package body Exp_Ch6 is Set_Parent (Name (Init_Assignment), Init_Assignment); Set_Parent (Expression (Init_Assignment), Init_Assignment); - Set_Expression (Return_Object_Decl, Empty); + Set_Expression (Ret_Obj_Decl, Empty); if Is_Class_Wide_Type (Etype (Return_Obj_Id)) and then not Is_Class_Wide_Type @@ -4566,8 +4827,7 @@ package body Exp_Ch6 is Rewrite (Expression (Init_Assignment), Make_Type_Conversion (Loc, Subtype_Mark => - New_Occurrence_Of - (Etype (Return_Obj_Id), Loc), + New_Occurrence_Of (Etype (Return_Obj_Id), Loc), Expression => Relocate_Node (Expression (Init_Assignment)))); end if; @@ -4581,7 +4841,7 @@ package body Exp_Ch6 is if Constr_Result and then not Is_Tagged_Type (Underlying_Type (Result_Subt)) then - Insert_After (Return_Object_Decl, Init_Assignment); + Insert_After (Ret_Obj_Decl, Init_Assignment); end if; end if; @@ -4608,7 +4868,7 @@ package body Exp_Ch6 is or else Is_Tagged_Type (Underlying_Type (Result_Subt)) then Obj_Alloc_Formal := - Build_In_Place_Formal (Parent_Function, BIP_Alloc_Form); + Build_In_Place_Formal (Par_Func, BIP_Alloc_Form); declare Ref_Type : Entity_Id; @@ -4616,8 +4876,8 @@ package body Exp_Ch6 is Alloc_Obj_Id : Entity_Id; Alloc_Obj_Decl : Node_Id; Alloc_If_Stmt : Node_Id; - SS_Allocator : Node_Id; Heap_Allocator : Node_Id; + SS_Allocator : Node_Id; begin -- Reuse the itype created for the function's implicit @@ -4625,7 +4885,7 @@ package body Exp_Ch6 is -- access type here, plus it allows assigning the access -- formal directly without applying a conversion. - -- Ref_Type := Etype (Object_Access); + -- Ref_Type := Etype (Object_Access); -- Create an access type designating the function's -- result subtype. @@ -4641,7 +4901,7 @@ package body Exp_Ch6 is Subtype_Indication => New_Reference_To (Return_Obj_Typ, Loc))); - Insert_Before (Return_Object_Decl, Ptr_Type_Decl); + Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl); -- Create an access object that will be initialized to an -- access value denoting the return object, either coming @@ -4654,17 +4914,17 @@ package body Exp_Ch6 is Alloc_Obj_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Alloc_Obj_Id, - Object_Definition => New_Reference_To - (Ref_Type, Loc)); + Object_Definition => + New_Reference_To (Ref_Type, Loc)); - Insert_Before (Return_Object_Decl, Alloc_Obj_Decl); + Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl); -- Create allocators for both the secondary stack and -- global heap. If there's an initialization expression, -- then create these as initialized allocators. if Present (Return_Obj_Expr) - and then not No_Initialization (Return_Object_Decl) + and then not No_Initialization (Ret_Obj_Decl) then -- Always use the type of the expression for the -- qualified expression, rather than the result type. @@ -4755,10 +5015,10 @@ package body Exp_Ch6 is -- statement, past the point where these flags are -- normally set. - Set_Sec_Stack_Needed_For_Return (Parent_Function); + Set_Sec_Stack_Needed_For_Return (Par_Func); Set_Sec_Stack_Needed_For_Return (Return_Statement_Entity (N)); - Set_Uses_Sec_Stack (Parent_Function); + Set_Uses_Sec_Stack (Par_Func); Set_Uses_Sec_Stack (Return_Statement_Entity (N)); end if; @@ -4780,7 +5040,7 @@ package body Exp_Ch6 is Alloc_If_Stmt := Make_If_Statement (Loc, - Condition => + Condition => Make_Op_Eq (Loc, Left_Opnd => New_Reference_To (Obj_Alloc_Formal, Loc), @@ -4788,45 +5048,42 @@ package body Exp_Ch6 is Make_Integer_Literal (Loc, UI_From_Int (BIP_Allocation_Form'Pos (Caller_Allocation)))), - Then_Statements => - New_List (Make_Assignment_Statement (Loc, - Name => - New_Reference_To - (Alloc_Obj_Id, Loc), - Expression => - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => - New_Reference_To (Ref_Type, Loc), - Expression => - New_Reference_To - (Object_Access, Loc)))), - Elsif_Parts => - New_List (Make_Elsif_Part (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To - (Obj_Alloc_Formal, Loc), - Right_Opnd => - Make_Integer_Literal (Loc, - UI_From_Int ( - BIP_Allocation_Form'Pos + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Alloc_Obj_Id, Loc), + Expression => + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To (Ref_Type, Loc), + Expression => + New_Reference_To (Object_Access, Loc)))), + + Elsif_Parts => New_List ( + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (Obj_Alloc_Formal, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, + UI_From_Int (BIP_Allocation_Form'Pos (Secondary_Stack)))), - Then_Statements => - New_List - (Make_Assignment_Statement (Loc, - Name => - New_Reference_To - (Alloc_Obj_Id, Loc), - Expression => - SS_Allocator)))), - Else_Statements => - New_List (Make_Assignment_Statement (Loc, - Name => - New_Reference_To - (Alloc_Obj_Id, Loc), - Expression => - Heap_Allocator))); + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Alloc_Obj_Id, Loc), + Expression => SS_Allocator)))), + + Else_Statements => New_List ( + Build_Heap_Allocator + (Temp_Id => Alloc_Obj_Id, + Temp_Typ => Ref_Type, + Func_Id => Par_Func, + Ret_Typ => Return_Obj_Typ, + Alloc_Expr => Heap_Allocator))); -- If a separate initialization assignment was created -- earlier, append that following the assignment of the @@ -4839,7 +5096,9 @@ package body Exp_Ch6 is if Present (Init_Assignment) then Rewrite (Name (Init_Assignment), Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Alloc_Obj_Id, Loc))); + Prefix => + New_Reference_To (Alloc_Obj_Id, Loc))); + Set_Etype (Name (Init_Assignment), Etype (Return_Obj_Id)); @@ -4848,7 +5107,7 @@ package body Exp_Ch6 is Init_Assignment); end if; - Insert_Before (Return_Object_Decl, Alloc_If_Stmt); + Insert_Before (Ret_Obj_Decl, Alloc_If_Stmt); -- Remember the local access object for use in the -- dereference of the renaming created below. @@ -4863,15 +5122,16 @@ package body Exp_Ch6 is Obj_Acc_Deref := Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Object_Access, Loc)); + Prefix => + New_Reference_To (Object_Access, Loc)); - Rewrite (Return_Object_Decl, + Rewrite (Ret_Obj_Decl, Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Return_Obj_Id, - Access_Definition => Empty, - Subtype_Mark => New_Occurrence_Of - (Return_Obj_Typ, Loc), - Name => Obj_Acc_Deref)); + Access_Definition => Empty, + Subtype_Mark => + New_Occurrence_Of (Return_Obj_Typ, Loc), + Name => Obj_Acc_Deref)); Set_Renamed_Object (Return_Obj_Id, Obj_Acc_Deref); end; @@ -4880,49 +5140,23 @@ package body Exp_Ch6 is -- Case where we do not build a block else + -- We're about to drop Return_Object_Declarations on the floor, so + -- we need to insert it, in case it got expanded into useful code. -- Remove side effects from expression, which may be duplicated in -- subsequent checks (see Expand_Simple_Function_Return). + Insert_List_Before (N, Return_Object_Declarations (N)); Remove_Side_Effects (Exp); -- Build simple_return_statement that returns the expression directly - Return_Stm := Make_Simple_Return_Statement (Loc, Expression => Exp); - - -- The expansion of the return expression may create a finalization - -- chain to service transient temporaries. The entity of the chain - -- appears as a semantic attribute of the return statement scope. - -- For the chain to be handled properly by Expand_Cleanup_Actions, - -- the return statement is wrapped in a block and reanalyzed. - - if Present - (Finalization_Chain_Entity (Return_Statement_Entity (N))) - then - Result := - Make_Block_Statement (Loc, - Declarations => Return_Object_Declarations (N), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Return_Stm))); - - -- Propagate the return statement scope to the block in order to - -- preserve the various semantic fields. - - Set_Identifier - (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc)); - else - -- We're about to drop Return_Object_Declarations on the floor, so - -- we need to insert it, in case it got expanded into useful code. - - Insert_List_Before (N, Return_Object_Declarations (N)); - - Result := Return_Stm; - end if; + Return_Stmt := Make_Simple_Return_Statement (Loc, Expression => Exp); + Result := Return_Stmt; end if; -- Set the flag to prevent infinite recursion - Set_Comes_From_Extended_Return_Statement (Return_Stm); + Set_Comes_From_Extended_Return_Statement (Return_Stmt); Rewrite (N, Result); Analyze (N); @@ -6557,7 +6791,7 @@ package body Exp_Ch6 is Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)))); while Present (Iface_DT_Ptr) - and then Ekind (Node (Iface_DT_Ptr)) = E_Constant + and then Ekind (Node (Iface_DT_Ptr)) = E_Constant loop pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); @@ -6600,7 +6834,7 @@ package body Exp_Ch6 is pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); -- Skip the tag of the predefined primitives no-thunks dispatch - -- table + -- table. Next_Elmt (Iface_DT_Ptr); pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); @@ -6611,7 +6845,7 @@ package body Exp_Ch6 is -- Local variables - Subp : constant Entity_Id := Entity (N); + Subp : constant Entity_Id := Entity (N); -- Start of processing for Freeze_Subprogram @@ -6862,7 +7096,7 @@ package body Exp_Ch6 is Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); - Add_Final_List_Actual_To_Build_In_Place_Call + Add_Collection_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Acc_Type); Add_Task_Actuals_To_Build_In_Place_Call @@ -6890,14 +7124,13 @@ package body Exp_Ch6 is -- operations. ??? else - -- Pass an allocation parameter indicating that the function should -- allocate its result on the heap. Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Alloc_Form => Global_Heap); - Add_Final_List_Actual_To_Build_In_Place_Call + Add_Collection_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Acc_Type); Add_Task_Actuals_To_Build_In_Place_Call @@ -6910,6 +7143,30 @@ package body Exp_Ch6 is (Func_Call, Function_Id, Return_Object => Empty); end if; + -- If the build-in-place function call returns a controlled object, the + -- finalization collection will require a reference to routine Finalize_ + -- Address of the designated type. Setting this attribute is done in the + -- same manner to expansion of allocators. + + if Needs_Finalization (Result_Subt) then + + -- Controlled types with supressed finalization do not need to + -- associate the address of their Finalize_Address primitives with a + -- collection since they do not need a collection to begin with. + + if Is_Library_Level_Entity (Acc_Type) + and then Finalize_Storage_Only (Result_Subt) + then + null; + + else + Insert_Action (Allocator, + Make_Set_Finalize_Address_Ptr_Call (Loc, + Typ => Etype (Function_Id), + Ptr_Typ => Acc_Type)); + end if; + end if; + -- Finally, replace the allocator node with a reference to the result -- of the function call itself (which will effectively be an access -- to the object created by the allocator). @@ -6970,10 +7227,47 @@ package body Exp_Ch6 is Result_Subt := Etype (Function_Id); + -- If the build-in-place function returns a controlled object, then the + -- object needs to be finalized immediately after the context. Since + -- this case produces a transient scope, the servicing finalizer needs + -- to name the returned object. Create a temporary which is initialized + -- with the function call: + -- + -- Temp_Id : Func_Type := BIP_Func_Call; + -- + -- The initialization expression of the temporary will be rewritten by + -- the expander using the appropriate mechanism in Make_Build_In_Place_ + -- Call_In_Object_Declaration. + + if Needs_Finalization (Result_Subt) then + declare + Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R'); + Temp_Decl : Node_Id; + + begin + -- Reset the guard on the function call since the following does + -- not perform actual call expansion. + + Set_Is_Expanded_Build_In_Place_Call (Func_Call, False); + + Temp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Object_Definition => + New_Reference_To (Result_Subt, Loc), + Expression => + New_Copy_Tree (Function_Call)); + + Insert_Action (Function_Call, Temp_Decl); + + Rewrite (Function_Call, New_Reference_To (Temp_Id, Loc)); + Analyze (Function_Call); + end; + -- When the result subtype is constrained, an object of the subtype is -- declared and an access value designating it is passed as an actual. - if Is_Constrained (Underlying_Type (Result_Subt)) then + elsif Is_Constrained (Underlying_Type (Result_Subt)) then -- Create a temporary object to hold the function result @@ -6999,8 +7293,8 @@ package body Exp_Ch6 is Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); - Add_Final_List_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, Acc_Type => Empty); + Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id); Add_Task_Actuals_To_Build_In_Place_Call (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); @@ -7023,8 +7317,8 @@ package body Exp_Ch6 is Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); - Add_Final_List_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, Acc_Type => Empty); + Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id); Add_Task_Actuals_To_Build_In_Place_Call (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); @@ -7101,16 +7395,8 @@ package body Exp_Ch6 is Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Func_Id, Alloc_Form => Caller_Allocation); - -- If Lhs is a selected component, then pass it along so that its prefix - -- object will be used as the source of the finalization list. - - if Nkind (Lhs) = N_Selected_Component then - Add_Final_List_Actual_To_Build_In_Place_Call - (Func_Call, Func_Id, Acc_Type => Empty, Sel_Comp => Lhs); - else - Add_Final_List_Actual_To_Build_In_Place_Call - (Func_Call, Func_Id, Acc_Type => Empty); - end if; + Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call, Func_Id); Add_Task_Actuals_To_Build_In_Place_Call (Func_Call, Func_Id, Make_Identifier (Loc, Name_uMaster)); @@ -7176,58 +7462,6 @@ package body Exp_Ch6 is else return; end if; - - -- When the target of the assignment is a return object of an enclosing - -- build-in-place function and also requires finalization, the list - -- generated for the assignment must be moved to that of the enclosing - -- function. - - -- function Enclosing_BIP_Function return Ctrl_Typ is - -- begin - -- return (Ctrl_Parent_Part => BIP_Function with ...); - -- end Enclosing_BIP_Function; - - if Is_Return_Object (Target) - and then Needs_Finalization (Etype (Target)) - and then Needs_Finalization (Result_Subt) - then - declare - Obj_List : constant Node_Id := Find_Final_List (Obj_Id); - Encl_List : Node_Id; - Encl_Scop : Entity_Id; - - begin - Encl_Scop := Scope (Target); - - -- Locate the scope of the extended return statement - - while Present (Encl_Scop) - and then Ekind (Encl_Scop) /= E_Return_Statement - loop - Encl_Scop := Scope (Encl_Scop); - end loop; - - -- A return object should always be enclosed by a return statement - -- scope at some level. - - pragma Assert (Present (Encl_Scop)); - - Encl_List := - Make_Attribute_Reference (Loc, - Prefix => - New_Reference_To ( - Finalization_Chain_Entity (Encl_Scop), Loc), - Attribute_Name => Name_Unrestricted_Access); - - -- Generate a call to move final list - - Insert_After_And_Analyze (Obj_Decl, - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Move_Final_List), Loc), - Parameter_Associations => New_List (Obj_List, Encl_List))); - end; - end if; end Make_Build_In_Place_Call_In_Assignment; ---------------------------------------------------- @@ -7377,8 +7611,8 @@ package body Exp_Ch6 is Establish_Transient_Scope (Object_Decl, Sec_Stack => True); end if; - Add_Final_List_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, Acc_Type => Empty); + Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id); if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement and then Has_Task (Result_Subt) @@ -7525,23 +7759,17 @@ package body Exp_Ch6 is end Make_Build_In_Place_Call_In_Object_Declaration; -------------------------- - -- Needs_BIP_Final_List -- + -- Needs_BIP_Collection -- -------------------------- - function Needs_BIP_Final_List (E : Entity_Id) return Boolean is - pragma Assert (Is_Build_In_Place_Function (E)); - Result_Subt : constant Entity_Id := Underlying_Type (Etype (E)); + function Needs_BIP_Collection (Func_Id : Entity_Id) return Boolean is + pragma Assert (Is_Build_In_Place_Function (Func_Id)); + Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); begin - -- We need the BIP_Final_List if the result type needs finalization. We - -- also need it for tagged types, even if not class-wide, because some - -- type extension might need finalization, and all overriding functions - -- must have the same calling conventions. However, if there is a - -- pragma Restrictions (No_Finalization), we never need this parameter. - - return (Needs_Finalization (Result_Subt) - or else Is_Tagged_Type (Underlying_Type (Result_Subt))) - and then not Restriction_Active (No_Finalization); - end Needs_BIP_Final_List; + return + not Restriction_Active (No_Finalization) + and then Needs_Finalization (Func_Typ); + end Needs_BIP_Collection; end Exp_Ch6; diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index e04e217e80e..433b96a62b7 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -61,23 +61,28 @@ package Exp_Ch6 is -- formals created for build-in-place functions. The order of the above -- enumeration literals matches the order in which the formals are -- declared. See Sem_Ch6.Create_Extra_Formals. + (BIP_Alloc_Form, -- Present if result subtype is unconstrained, or if the result type -- is tagged. Indicates whether the return object is allocated by the -- caller or callee, and if the callee, whether to use the secondary -- stack or the heap. See Create_Extra_Formals. - BIP_Final_List, + + BIP_Collection, -- Present if result type needs finalization. Pointer to caller's - -- finalization list. + -- finalization collection. + BIP_Master, -- Present if result type contains tasks. Master associated with -- calling context. + BIP_Activation_Chain, -- Present if result type contains tasks. Caller's activation chain + BIP_Object_Access); -- Present for all build-in-place functions. Address at which to place - -- the return object, or null if BIP_Alloc_Form indicates - -- allocated by callee. + -- the return object, or null if BIP_Alloc_Form indicates allocated by + -- callee. -- ??? We also need to be able to pass in some way to access a -- user-defined storage pool at some point. And perhaps a constrained -- flag. @@ -158,9 +163,8 @@ package Exp_Ch6 is -- for which Is_Build_In_Place_Call is True, or an N_Qualified_Expression -- node applied to such a function call. - function Needs_BIP_Final_List (E : Entity_Id) return Boolean; - -- ???pragma Precondition (Is_Build_In_Place_Function (E)); - -- Ada 2005 (AI-318-02): Returns True if the function needs the - -- BIP_Final_List implicit parameter. + function Needs_BIP_Collection (Func_Id : Entity_Id) return Boolean; + -- Ada 2005 (AI-318-02): Return True if the function needs a finalization + -- collection implicit parameter. end Exp_Ch6; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 8063601256b..4fd7d2a7ac1 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -30,7 +30,9 @@ with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; +with Elists; use Elists; with Errout; use Errout; +with Exp_Ch6; use Exp_Ch6; with Exp_Ch9; use Exp_Ch9; with Exp_Ch11; use Exp_Ch11; with Exp_Dbug; use Exp_Dbug; @@ -54,12 +56,13 @@ with Sem_Ch3; use Sem_Ch3; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Res; use Sem_Res; -with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Snames; use Snames; with Stand; use Stand; +with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; +with Ttypes; use Ttypes; with Uintp; use Uintp; package body Exp_Ch7 is @@ -128,118 +131,24 @@ package body Exp_Ch7 is -- pointers of N until it find the appropriate node to wrap. If it returns -- Empty, it means that no transient scope is needed in this context. - function Make_Clean - (N : Node_Id; - Clean : Entity_Id; - Mark : Entity_Id; - Flist : Entity_Id; - Is_Task : Boolean; - Is_Master : Boolean; - Is_Protected_Subprogram : Boolean; - Is_Task_Allocation_Block : Boolean; - Is_Asynchronous_Call_Block : Boolean; - Chained_Cleanup_Action : Node_Id) return Node_Id; - -- Expand the clean-up procedure for a controlled and/or transient block, - -- and/or task master or task body, or a block used to implement task - -- allocation or asynchronous entry calls, or a procedure used to implement - -- protected procedures. Clean is the entity for such a procedure. Mark - -- is the entity for the secondary stack mark, if empty only controlled - -- block clean-up will be performed. Flist is the entity for the local - -- final list, if empty only transient scope clean-up will be performed. - -- The flags Is_Task and Is_Master control the calls to the corresponding - -- finalization actions for a task body or for an entity that is a task - -- master. Finally if Chained_Cleanup_Action is present, it is a reference - -- to a previous cleanup procedure, a call to which is appended at the - -- end of the generated one. - - procedure Set_Node_To_Be_Wrapped (N : Node_Id); - -- Set the field Node_To_Be_Wrapped of the current scope - procedure Insert_Actions_In_Scope_Around (N : Node_Id); -- Insert the before-actions kept in the scope stack before N, and the -- after-actions after N, which must be a member of a list. function Make_Transient_Block (Loc : Source_Ptr; - Action : Node_Id) return Node_Id; - -- Create a transient block whose name is Scope, which is also a controlled - -- block if Flist is not empty and whose only code is Action (either a - -- single statement or single declaration). - - type Final_Primitives is (Initialize_Case, Adjust_Case, Finalize_Case); - -- This enumeration type is defined in order to ease sharing code for - -- building finalization procedures for composite types. - - Name_Of : constant array (Final_Primitives) of Name_Id := - (Initialize_Case => Name_Initialize, - Adjust_Case => Name_Adjust, - Finalize_Case => Name_Finalize); - - Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type := - (Initialize_Case => TSS_Deep_Initialize, - Adjust_Case => TSS_Deep_Adjust, - Finalize_Case => TSS_Deep_Finalize); - - procedure Build_Record_Deep_Procs (Typ : Entity_Id); - -- Build the deep Initialize/Adjust/Finalize for a record Typ with - -- Has_Component_Component set and store them using the TSS mechanism. - - procedure Build_Array_Deep_Procs (Typ : Entity_Id); - -- Build the deep Initialize/Adjust/Finalize for a record Typ with - -- Has_Controlled_Component set and store them using the TSS mechanism. - - function Make_Deep_Proc - (Prim : Final_Primitives; - Typ : Entity_Id; - Stmts : List_Id) return Node_Id; - -- This function generates the tree for Deep_Initialize, Deep_Adjust or - -- Deep_Finalize procedures according to the first parameter, these - -- procedures operate on the type Typ. The Stmts parameter gives the body - -- of the procedure. - - function Make_Deep_Array_Body - (Prim : Final_Primitives; - Typ : Entity_Id) return List_Id; - -- This function generates the list of statements for implementing - -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to - -- the first parameter, these procedures operate on the array type Typ. + Action : Node_Id; + Par : Node_Id) return Node_Id; + -- Action is a single statement or object declaration. Par is the proper + -- parent of the generated block. Create a transient block whose name is + -- the current scope and the only handled statement is Action. If Action + -- involves controlled objects or secondary stack usage, the corresponding + -- cleanup actions are performed at the end of the block. - function Make_Deep_Record_Body - (Prim : Final_Primitives; - Typ : Entity_Id) return List_Id; - -- This function generates the list of statements for implementing - -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to - -- the first parameter, these procedures operate on the record type Typ. - - procedure Check_Visibly_Controlled - (Prim : Final_Primitives; - Typ : Entity_Id; - E : in out Entity_Id; - Cref : in out Node_Id); - -- The controlled operation declared for a derived type may not be - -- overriding, if the controlled operations of the parent type are - -- hidden, for example when the parent is a private type whose full - -- view is controlled. For other primitive operations we modify the - -- name of the operation to indicate that it is not overriding, but - -- this is not possible for Initialize, etc. because they have to be - -- retrievable by name. Before generating the proper call to one of - -- these operations we check whether Typ is known to be controlled at - -- the point of definition. If it is not then we must retrieve the - -- hidden operation of the parent and use it instead. This is one - -- case that might be solved more cleanly once Overriding pragmas or - -- declarations are in place. + procedure Set_Node_To_Be_Wrapped (N : Node_Id); + -- Set the field Node_To_Be_Wrapped of the current scope - function Convert_View - (Proc : Entity_Id; - Arg : Node_Id; - Ind : Pos := 1) return Node_Id; - -- Proc is one of the Initialize/Adjust/Finalize operations, and - -- Arg is the argument being passed to it. Ind indicates which - -- formal of procedure Proc we are trying to match. This function - -- will, if necessary, generate an conversion between the partial - -- and full view of Arg to match the type of the formal of Proc, - -- or force a conversion to the class-wide type in the case where - -- the operation is abstract. + -- ??? The entire comment needs to be rewritten ----------------------------- -- Finalization Management -- @@ -346,7 +255,6 @@ package body Exp_Ch7 is -- Attach_To_Final_List (_L, Finalizable (Y), 1); -- -- type R is record - -- _C : Record_Controller; -- C : Controlled; -- end record; -- W : R; @@ -368,17 +276,182 @@ package body Exp_Ch7 is -- _Clean; -- end; - function Global_Flist_Ref (Flist_Ref : Node_Id) return Boolean; - -- Return True if Flist_Ref refers to a global final list, either the - -- object Global_Final_List which is used to attach standalone objects, - -- or any of the list controllers associated with library-level access - -- to controlled objects. + type Final_Primitives is + (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case); + -- This enumeration type is defined in order to ease sharing code for + -- building finalization procedures for composite types. + + Name_Of : constant array (Final_Primitives) of Name_Id := + (Initialize_Case => Name_Initialize, + Adjust_Case => Name_Adjust, + Finalize_Case => Name_Finalize, + Address_Case => Name_Finalize_Address); + + Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type := + (Initialize_Case => TSS_Deep_Initialize, + Adjust_Case => TSS_Deep_Adjust, + Finalize_Case => TSS_Deep_Finalize, + Address_Case => TSS_Finalize_Address); + + procedure Build_Array_Deep_Procs (Typ : Entity_Id); + -- Build the deep Initialize/Adjust/Finalize for a record Typ with + -- Has_Controlled_Component set and store them using the TSS mechanism. + + function Build_Cleanup_Statements (N : Node_Id) return List_Id; + -- Create the clean up calls for an asynchronous call block, task master, + -- protected subprogram body, task allocation block or task body. If N is + -- neither of these constructs, the routine returns a new list. + + function Build_Exception_Handler + (Loc : Source_Ptr; + E_Id : Entity_Id; + Raised_Id : Entity_Id; + For_Library : Boolean := False) return Node_Id; + -- Subsidiary to Build_Finalizer, Make_Deep_Array_Body and Make_Deep_Record + -- _Body. Create an exception handler of the following form: + -- + -- when others => + -- if not Raised_Id then + -- Raised_Id := True; + -- Save_Occurrence (E_Id, Get_Current_Excep.all.all); + -- end if; + -- + -- If flag For_Library is set: + -- + -- when others => + -- if not Raised_Id then + -- Raised_Id := True; + -- Save_Library_Occurrence (Get_Current_Excep.all.all); + -- end if; + -- + -- E_Id denotes the defining identifier of a local exception occurrence. + -- Raised_Id is the entity of a local boolean flag. Flag For_Library is + -- used when operating at the library level, when enabled the current + -- exception will be saved to a global location. + + procedure Build_Finalizer + (N : Node_Id; + Clean_Stmts : List_Id; + Mark_Id : Entity_Id; + Top_Decls : List_Id; + Defer_Abort : Boolean; + Fin_Id : out Entity_Id); + -- N may denote an accept statement, block, entry body, package body, + -- package spec, protected body, subprogram body, and a task body. Create + -- a procedure which contains finalization calls for all controlled objects + -- declared in the declarative or statement region of N. The calls are + -- built in reverse order relative to the original declarations. In the + -- case of a tack body, the routine delays the creation of the finalizer + -- until all statements have been moved to the task body procedure. + -- Clean_Stmts may contain additional context-dependent code used to abort + -- asynchronous calls or complete tasks (see Build_Cleanup_Statements). + -- Mark_Id is the secondary stack used in the current context or Empty if + -- missing. Top_Decls is the list on which the declaration of the finalizer + -- is attached in the non-package case. Defer_Abort indicates that the + -- statements passed in perform actions that require abort to be deferred, + -- such as for task termination. Fin_Id is the finalizer declaration + -- entity. + + procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id); + -- N is a construct which contains a handled sequence of statements, Fin_Id + -- is the entity of a finalizer. Create an At_End handler which covers the + -- statements of N and calls Fin_Id. If the handled statement sequence has + -- an exception handler, the statements will be wrapped in a block to avoid + -- unwanted interaction with the new At_End handler. + + function Build_Object_Declarations + (Loc : Source_Ptr; + E_Id : Entity_Id; + Raised_Id : Entity_Id) return List_Id; + -- Subsidiary to Make_Deep_Array_Body and Make_Deep_Record_Body. Return a + -- list containing the object declarations of the exception occurrence E_Id + -- and boolean flag Raised_Id. + -- + -- E_Id : Exception_Occurrence; + -- Raised_Id : Boolean := False; + + procedure Build_Record_Deep_Procs (Typ : Entity_Id); + -- Build the deep Initialize/Adjust/Finalize for a record Typ with + -- Has_Component_Component set and store them using the TSS mechanism. + + procedure Check_Visibly_Controlled + (Prim : Final_Primitives; + Typ : Entity_Id; + E : in out Entity_Id; + Cref : in out Node_Id); + -- The controlled operation declared for a derived type may not be + -- overriding, if the controlled operations of the parent type are hidden, + -- for example when the parent is a private type whose full view is + -- controlled. For other primitive operations we modify the name of the + -- operation to indicate that it is not overriding, but this is not + -- possible for Initialize, etc. because they have to be retrievable by + -- name. Before generating the proper call to one of these operations we + -- check whether Typ is known to be controlled at the point of definition. + -- If it is not then we must retrieve the hidden operation of the parent + -- and use it instead. This is one case that might be solved more cleanly + -- once Overriding pragmas or declarations are in place. + + function Convert_View + (Proc : Entity_Id; + Arg : Node_Id; + Ind : Pos := 1) return Node_Id; + -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the + -- argument being passed to it. Ind indicates which formal of procedure + -- Proc we are trying to match. This function will, if necessary, generate + -- a conversion between the partial and full view of Arg to match the type + -- of the formal of Proc, or force a conversion to the class-wide type in + -- the case where the operation is abstract. + + function Enclosing_Function (E : Entity_Id) return Entity_Id; + -- Given an arbitrary entity, traverse the scope chain looking for the + -- first enclosing function. Return Empty if no function was found. + + function Make_Call + (Loc : Source_Ptr; + Proc_Id : Entity_Id; + Param : Node_Id; + For_Parent : Boolean := False) return Node_Id; + -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of + -- routine [Deep_]Adjust / Finalize and an object parameter, create an + -- adjust / finalization call. Flag For_Parent should be set when field + -- _parent is being processed. + + function Make_Deep_Proc + (Prim : Final_Primitives; + Typ : Entity_Id; + Stmts : List_Id) return Node_Id; + -- This function generates the tree for Deep_Initialize, Deep_Adjust or + -- Deep_Finalize procedures according to the first parameter, these + -- procedures operate on the type Typ. The Stmts parameter gives the body + -- of the procedure. - procedure Clean_Simple_Protected_Objects (N : Node_Id); - -- Protected objects without entries are not controlled types, and the - -- locks have to be released explicitly when such an object goes out - -- of scope. Traverse declarations in scope to determine whether such - -- objects are present. + function Make_Deep_Array_Body + (Prim : Final_Primitives; + Typ : Entity_Id) return List_Id; + -- This function generates the list of statements for implementing + -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to + -- the first parameter, these procedures operate on the array type Typ. + + function Make_Deep_Record_Body + (Prim : Final_Primitives; + Typ : Entity_Id; + Is_Local : Boolean := False) return List_Id; + -- This function generates the list of statements for implementing + -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to + -- the first parameter, these procedures operate on the record type Typ. + -- Flag Is_Local is used in conjunction with Deep_Finalize to designate + -- whether the inner logic should be dictated by state counters. + + function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id; + -- Subsidiary to Make_Finalize_Address_Body and Make_Deep_Array_Body. + -- Generate the following statements: + -- + -- declare + -- type Acc_Typ is access all Typ; + -- for Acc_Typ'Storage_Size use 0; + -- begin + -- [Deep_]Finalize (Acc_Typ (V).all); + -- end; ---------------------------- -- Build_Array_Deep_Procs -- @@ -405,8 +478,254 @@ package body Exp_Ch7 is Prim => Finalize_Case, Typ => Typ, Stmts => Make_Deep_Array_Body (Finalize_Case, Typ))); + + -- Create TSS primitive Finalize_Address for non-VM targets. JVM and + -- .NET do not support address arithmetic and unchecked conversions. + + if VM_Target = No_VM then + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Address_Case, + Typ => Typ, + Stmts => Make_Deep_Array_Body (Address_Case, Typ))); + end if; end Build_Array_Deep_Procs; + ------------------------------ + -- Build_Cleanup_Statements -- + ------------------------------ + + function Build_Cleanup_Statements (N : Node_Id) return List_Id is + Is_Asynchronous_Call : constant Boolean := + Nkind (N) = N_Block_Statement + and then Is_Asynchronous_Call_Block (N); + Is_Master : constant Boolean := + Nkind (N) /= N_Entry_Body + and then Is_Task_Master (N); + Is_Protected_Body : constant Boolean := + Nkind (N) = N_Subprogram_Body + and then Is_Protected_Subprogram_Body (N); + Is_Task_Allocation : constant Boolean := + Nkind (N) = N_Block_Statement + and then Is_Task_Allocation_Block (N); + Is_Task_Body : constant Boolean := + Nkind (Original_Node (N)) = N_Task_Body; + Loc : constant Source_Ptr := Sloc (N); + Stmts : constant List_Id := New_List; + + begin + if Is_Task_Body then + if Restricted_Profile then + Append_To (Stmts, + Build_Runtime_Call (Loc, RE_Complete_Restricted_Task)); + else + Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task)); + end if; + + elsif Is_Master then + if Restriction_Active (No_Task_Hierarchy) = False then + Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master)); + end if; + + -- Add statements to unlock the protected object parameter and to + -- undefer abort. If the context is a protected procedure and the object + -- has entries, call the entry service routine. + + -- NOTE: The generated code references _object, a parameter to the + -- procedure. + + elsif Is_Protected_Body then + declare + Spec : constant Node_Id := Parent (Corresponding_Spec (N)); + Conc_Typ : Entity_Id; + Nam : Node_Id; + Param : Node_Id; + Param_Typ : Entity_Id; + + begin + -- Find the _object parameter representing the protected object + + Param := First (Parameter_Specifications (Spec)); + loop + Param_Typ := Etype (Parameter_Type (Param)); + + if Ekind (Param_Typ) = E_Record_Type then + Conc_Typ := Corresponding_Concurrent_Type (Param_Typ); + end if; + + exit when No (Param) or else Present (Conc_Typ); + Next (Param); + end loop; + + pragma Assert (Present (Param)); + + -- If the associated protected object has entries, a protected + -- procedure has to service entry queues. In this case generate: + + -- Service_Entries (_object._object'Access); + + if Nkind (Specification (N)) = N_Procedure_Specification + and then Has_Entries (Conc_Typ) + then + case Corresponding_Runtime_Package (Conc_Typ) is + when System_Tasking_Protected_Objects_Entries => + Nam := New_Reference_To (RTE (RE_Service_Entries), Loc); + + when System_Tasking_Protected_Objects_Single_Entry => + Nam := New_Reference_To (RTE (RE_Service_Entry), Loc); + + when others => + raise Program_Error; + end case; + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => Nam, + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To ( + Defining_Identifier (Param), Loc), + Selector_Name => + Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)))); + + else + -- Generate: + -- Unlock (_object._object'Access); + + case Corresponding_Runtime_Package (Conc_Typ) is + when System_Tasking_Protected_Objects_Entries => + Nam := New_Reference_To (RTE (RE_Unlock_Entries), Loc); + + when System_Tasking_Protected_Objects_Single_Entry => + Nam := New_Reference_To (RTE (RE_Unlock_Entry), Loc); + + when System_Tasking_Protected_Objects => + Nam := New_Reference_To (RTE (RE_Unlock), Loc); + + when others => + raise Program_Error; + end case; + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => Nam, + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + New_Reference_To + (Defining_Identifier (Param), Loc), + Selector_Name => + Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)))); + end if; + + -- Generate: + -- Abort_Undefer; + + if Abort_Allowed then + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Abort_Undefer), Loc), + Parameter_Associations => Empty_List)); + end if; + end; + + -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated + -- tasks. Other unactivated tasks are completed by Complete_Task or + -- Complete_Master. + + -- NOTE: The generated code references _chain, a local object + + elsif Is_Task_Allocation then + + -- Generate: + -- Expunge_Unactivated_Tasks (_chain); + + -- where _chain is the list of tasks created by the allocator but not + -- yet activated. This list will be empty unless the block completes + -- abnormally. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + RTE (RE_Expunge_Unactivated_Tasks), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Activation_Chain_Entity (N), Loc)))); + + -- Attempt to cancel an asynchronous entry call whenever the block which + -- contains the abortable part is exited. + + -- NOTE: The generated code references Cnn, a local object + + elsif Is_Asynchronous_Call then + declare + Cancel_Param : constant Entity_Id := + Entry_Cancel_Parameter (Entity (Identifier (N))); + + begin + -- If it is of type Communication_Block, this must be a protected + -- entry call. Generate: + + -- if Enqueued (Cancel_Param) then + -- Cancel_Protected_Entry_Call (Cancel_Param); + -- end if; + + if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then + Append_To (Stmts, + Make_If_Statement (Loc, + Condition => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Enqueued), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Cancel_Param, Loc))), + + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + RTE (RE_Cancel_Protected_Entry_Call), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Cancel_Param, Loc)))))); + + -- Asynchronous delay, generate: + -- Cancel_Async_Delay (Cancel_Param); + + elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Cancel_Param, Loc), + Attribute_Name => Name_Unchecked_Access)))); + + -- Task entry call, generate: + -- Cancel_Task_Entry_Call (Cancel_Param); + + else + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Cancel_Task_Entry_Call), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Cancel_Param, Loc)))); + end if; + end; + end if; + + return Stmts; + end Build_Cleanup_Statements; + ----------------------------- -- Build_Controlling_Procs -- ----------------------------- @@ -421,57 +740,2110 @@ package body Exp_Ch7 is end if; end Build_Controlling_Procs; - ---------------------- - -- Build_Final_List -- - ---------------------- + ----------------------------- + -- Build_Exception_Handler -- + ----------------------------- - procedure Build_Final_List (N : Node_Id; Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); - Decl : Node_Id; + function Build_Exception_Handler + (Loc : Source_Ptr; + E_Id : Entity_Id; + Raised_Id : Entity_Id; + For_Library : Boolean := False) return Node_Id + is + Actuals : List_Id; + Proc_To_Call : Entity_Id; begin - Set_Associated_Final_Chain (Typ, - Make_Defining_Identifier (Loc, - New_External_Name (Chars (Typ), 'L'))); + pragma Assert (Present (E_Id)); + pragma Assert (Present (Raised_Id)); - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => - Associated_Final_Chain (Typ), - Object_Definition => - New_Reference_To - (RTE (RE_List_Controller), Loc)); - - -- If the type is declared in a package declaration and designates a - -- Taft amendment type that requires finalization, place declaration - -- of finalization list in the body, because no client of the package - -- can create objects of the type and thus make use of this list. This - -- ensures the tree for the spec is identical whenever it is compiled. - - if Has_Completion_In_Body (Directly_Designated_Type (Typ)) - and then In_Package_Body (Current_Scope) - and then Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body - and then - Nkind (Parent (Declaration_Node (Typ))) = N_Package_Specification + -- Generate: + -- Get_Current_Excep.all.all + + Actuals := New_List ( + Make_Explicit_Dereference (Loc, + Prefix => + Make_Function_Call (Loc, + Name => + Make_Explicit_Dereference (Loc, + Prefix => + New_Reference_To (RTE (RE_Get_Current_Excep), Loc))))); + + if For_Library then + Proc_To_Call := RTE (RE_Save_Library_Occurrence); + + else + Proc_To_Call := RTE (RE_Save_Occurrence); + Prepend_To (Actuals, New_Reference_To (E_Id, Loc)); + end if; + + -- Generate: + -- when others => + -- if not Raised_Id then + -- Raised_Id := True; + + -- Save_Occurrence (E_Id, Get_Current_Excep.all.all); + -- or + -- Save_Library_Occurrence (Get_Current_Excep.all.all); + -- end if; + + return + Make_Exception_Handler (Loc, + Exception_Choices => New_List ( + Make_Others_Choice (Loc)), + + Statements => New_List ( + Make_If_Statement (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + New_Reference_To (Raised_Id, Loc)), + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Raised_Id, Loc), + Expression => + New_Reference_To (Standard_True, Loc)), + + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Proc_To_Call, Loc), + Parameter_Associations => Actuals))))); + end Build_Exception_Handler; + + ----------------------------------- + -- Build_Finalization_Collection -- + ----------------------------------- + + procedure Build_Finalization_Collection + (Typ : Entity_Id; + Ins_Node : Node_Id := Empty; + Encl_Scope : Entity_Id := Empty) + is + Desig_Typ : constant Entity_Id := Directly_Designated_Type (Typ); + + function In_Deallocation_Instance (E : Entity_Id) return Boolean; + -- Determine whether entity E is inside a wrapper package created for + -- an instance of Ada.Unchecked_Deallocation. + + ------------------------------ + -- In_Deallocation_Instance -- + ------------------------------ + + function In_Deallocation_Instance (E : Entity_Id) return Boolean is + Pkg : constant Entity_Id := Scope (E); + Par : Node_Id := Empty; + + begin + if Ekind (Pkg) = E_Package + and then Present (Related_Instance (Pkg)) + and then Ekind (Related_Instance (Pkg)) = E_Procedure + then + Par := Generic_Parent (Parent (Related_Instance (Pkg))); + + return + Present (Par) + and then Chars (Par) = Name_Unchecked_Deallocation + and then Chars (Scope (Par)) = Name_Ada + and then Scope (Scope (Par)) = Standard_Standard; + end if; + + return False; + end In_Deallocation_Instance; + + -- Start of processing for Build_Finalization_Collection + + begin + if Present (Associated_Collection (Typ)) then + return; + + -- Do not process types that return on the secondary stack + + -- ??? The need for a secondary stack should be revisited and perhaps + -- changed. + + elsif Present (Associated_Storage_Pool (Typ)) + and then Is_RTE (Associated_Storage_Pool (Typ), RE_SS_Pool) + then + return; + + -- Do not process types which may never allocate an object + + elsif No_Pool_Assigned (Typ) then + return; + + -- Do not process access types coming from Ada.Unchecked_Deallocation + -- instances. Even though the designated type may be controlled, the + -- access type will never participate in allocation. + + elsif In_Deallocation_Instance (Typ) then + return; + + -- Ignore the general use of anonymous access types unless the context + -- requires a collection. + + elsif Ekind (Typ) = E_Anonymous_Access_Type + and then No (Ins_Node) then - Insert_Action (Parent (Designated_Type (Typ)), Decl); + return; - -- The type may have been frozen already, and this is a late freezing - -- action, in which case the declaration must be elaborated at once. - -- If the call is for an allocator, the chain must also be created now, - -- because the freezing of the type does not build one. Otherwise, the - -- declaration is one of the freezing actions for a user-defined type. + -- Do not process non-library access types when restriction No_Nested_ + -- Finalization is in effect since collections are controlled objects. - elsif Is_Frozen (Typ) - or else (Nkind (N) = N_Allocator - and then Ekind (Etype (N)) = E_Anonymous_Access_Type) + elsif Restriction_Active (No_Nested_Finalization) + and then not Is_Library_Level_Entity (Typ) then - Insert_Action (N, Decl); + return; + + -- Do not process access-to-controlled types on .NET/JVM targets + + elsif VM_Target /= No_VM then + return; + end if; + + declare + Loc : constant Source_Ptr := Sloc (Typ); + Actions : constant List_Id := New_List; + Coll_Id : Entity_Id; + Pool_Id : Entity_Id; + + begin + -- Generate: + -- Fnn : Finalization_Collection; + + -- Source access types use fixed names for their collections since + -- the collection is inserted only once in the same source unit and + -- there is no possible name overlap. Internally-generated access + -- types on the other hand use temporaries as collection names due + -- to possible name collisions. + + if Comes_From_Source (Typ) then + Coll_Id := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Chars (Typ), "FC")); + else + Coll_Id := Make_Temporary (Loc, 'F'); + end if; + + Append_To (Actions, + Make_Object_Declaration (Loc, + Defining_Identifier => Coll_Id, + Object_Definition => + New_Reference_To (RTE (RE_Finalization_Collection), Loc))); + + -- If the access type has a user-defined pool, use it as the base + -- storage medium for the finalization pool. + + if Present (Associated_Storage_Pool (Typ)) then + Pool_Id := Associated_Storage_Pool (Typ); + + -- Access subtypes must use the storage pool of their base type + + elsif Ekind (Typ) = E_Access_Subtype then + declare + Base_Typ : constant Entity_Id := Base_Type (Typ); + + begin + if No (Associated_Storage_Pool (Base_Typ)) then + Pool_Id := RTE (RE_Global_Pool_Object); + Set_Associated_Storage_Pool (Base_Typ, Pool_Id); + else + Pool_Id := Associated_Storage_Pool (Base_Typ); + end if; + end; + + -- The default choice is the global pool + + else + Pool_Id := RTE (RE_Global_Pool_Object); + Set_Associated_Storage_Pool (Typ, Pool_Id); + end if; + + -- Generate: + -- Set_Storage_Pool_Ptr (Fnn, Pool_Id'Unchecked_Access); + + Append_To (Actions, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Set_Storage_Pool_Ptr), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Coll_Id, Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Pool_Id, Loc), + Attribute_Name => Name_Unrestricted_Access)))); + + Set_Associated_Collection (Typ, Coll_Id); + + -- A finalization collection created for an anonymous access type + -- must be inserted before a context-dependent node. + + if Present (Ins_Node) then + Push_Scope (Encl_Scope); + + -- Treat use clauses as declarations and insert directly in front + -- of them. + + if Nkind_In (Ins_Node, N_Use_Package_Clause, + N_Use_Type_Clause) + then + Insert_List_Before_And_Analyze (Ins_Node, Actions); + else + Insert_Actions (Ins_Node, Actions); + end if; + + Pop_Scope; + + elsif Ekind (Typ) = E_Access_Subtype + or else (Ekind (Desig_Typ) = E_Incomplete_Type + and then Has_Completion_In_Body (Desig_Typ)) + then + Insert_Actions (Parent (Typ), Actions); + + -- If the designated type is not yet frozen, then append the actions + -- to that type's freeze actions. The actions need to be appended to + -- whichever type is frozen later, similarly to what Freeze_Type does + -- for appending the storage pool declaration for an access type. + -- Otherwise, the call to Set_Storage_Pool_Ptr might reference the + -- pool object before it's declared. However, it's not clear that + -- this is exactly the right test to accomplish that here. ??? + + elsif Present (Freeze_Node (Desig_Typ)) + and then not Analyzed (Freeze_Node (Desig_Typ)) + then + Append_Freeze_Actions (Desig_Typ, Actions); + + elsif Present (Freeze_Node (Typ)) + and then not Analyzed (Freeze_Node (Typ)) + then + Append_Freeze_Actions (Typ, Actions); + + -- If there's a pool created locally for the access type, then we + -- need to ensure that the collection gets created after the pool + -- object, because otherwise we can have a forward reference, so + -- we force the collection actions to be inserted and analyzed after + -- the pool entity. Note that both the access type and its designated + -- type may have already been frozen and had their freezing actions + -- analyzed at this point. (This seems a little unclean.???) + + elsif VM_Target = No_VM + and then Scope (Pool_Id) = Scope (Typ) + then + Insert_List_After_And_Analyze (Parent (Pool_Id), Actions); + + else + Insert_Actions (Parent (Typ), Actions); + end if; + end; + end Build_Finalization_Collection; + + --------------------- + -- Build_Finalizer -- + --------------------- + + procedure Build_Finalizer + (N : Node_Id; + Clean_Stmts : List_Id; + Mark_Id : Entity_Id; + Top_Decls : List_Id; + Defer_Abort : Boolean; + Fin_Id : out Entity_Id) + is + Acts_As_Clean : constant Boolean := + Present (Mark_Id) + or else + (Present (Clean_Stmts) + and then Is_Non_Empty_List (Clean_Stmts)); + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body; + For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration; + For_Package : constant Boolean := + For_Package_Body or else For_Package_Spec; + Loc : constant Source_Ptr := Sloc (N); + + -- NOTE: Local variable declarations are conservative and do not create + -- structures right from the start. Entities and lists are created once + -- it has been established that N has at least one controlled object. + + Components_Built : Boolean := False; + -- A flag used to avoid double initialization of entities and lists. If + -- the flag is set then the following variables have been initialized: + -- + -- Counter_Id + -- E_Id + -- Finalizer_Decls + -- Finalizer_Stmts + -- Jump_Alts + -- Raised_Id + + Counter_Id : Entity_Id := Empty; + Counter_Val : Int := 0; + -- Name and value of the state counter + + Decls : List_Id := No_List; + -- Declarative region of N (if available). If N is a package declaration + -- Decls denotes the visible declarations. + + E_Id : Entity_Id := Empty; + -- Entity of the local exception occurence. The first exception which + -- occurred during finalization is stored in E_Id and later reraised. + + Finalizer_Decls : List_Id := No_List; + -- Local variable declarations. This list holds the label declarations + -- of all jump block alternatives as well as the declaration of the + -- local exception occurence and the raised flag. + -- + -- E : Exception_Occurrence; + -- Raised : Boolean := False; + -- L<counter value> : label; + + Finalizer_Insert_Nod : Node_Id := Empty; + -- Insertion point for the finalizer body. Depending on the context + -- (Nkind of N) and the individual grouping of controlled objects, this + -- node may denote a package declaration or body, package instantiation, + -- block statement or a counter update statement. + + Finalizer_Stmts : List_Id := No_List; + -- The statement list of the finalizer body. It contains the following: + -- + -- Abort_Defer; -- Added if abort is allowed + -- <call to Prev_At_End> -- Added if exists + -- <cleanup statements> -- Added if Acts_As_Clean + -- <jump block> -- Added if Has_Ctrl_Objs + -- <finalization statements> -- Added if Has_Ctrl_Objs + -- <stack release> -- Added if Mark_Id exists + -- Abort_Undefer; -- Added if abort is allowed + + Has_Ctrl_Objs : Boolean := False; + -- A general flag which denotes whether N has at least one controlled + -- object. + + HSS : Node_Id := Empty; + -- The sequence of statements of N (if available) + + Jump_Alts : List_Id := No_List; + -- Jump block alternatives. Depending on the value of the state counter, + -- the control flow jumps to a sequence of finalization statments. This + -- list contains the following: + -- + -- when <counter value> => + -- goto L<counter value>; + + Jump_Block_Insert_Nod : Node_Id := Empty; + -- Specific point in the finalizer statements where the jump block is + -- inserted. + + Last_Top_Level_Ctrl_Construct : Node_Id := Empty; + -- The last controlled construct encountered when processing the top + -- level lists of N. This can be a nested package, an instantiation or + -- an object declaration. + + Prev_At_End : Entity_Id := Empty; + -- The previous at end procedure of the handled statements block of N + + Priv_Decls : List_Id := No_List; + -- The private declarations of N if N is a package declaration + + Raised_Id : Entity_Id := Empty; + -- Entity for the raised flag. Along with E_Id, the flag is used in the + -- propagation of exceptions which occur during finalization. + + Spec_Id : Entity_Id := Empty; + Spec_Decls : List_Id := Top_Decls; + Stmts : List_Id := No_List; + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Build_Components; + -- Create all entites and initialize all lists used in the creation of + -- the finalizer. + + procedure Create_Finalizer; + -- Create the spec and body of the finalizer and insert them in the + -- proper place in the tree depending on the context. + + procedure Process_Declarations + (Decls : List_Id; + Preprocess : Boolean := False; + Top_Level : Boolean := False); + -- Inspect a list of declarations or statements which may contain + -- objects that need finalization. When flag Preprocess is set, the + -- routine will simply count the total number of controlled objects in + -- Decls. Flag Top_Level denotes whether the processing is done for + -- objects in nested package decparations or instances. + + procedure Process_Object_Declaration + (Decl : Node_Id; + Has_No_Init : Boolean := False; + Is_Protected : Boolean := False); + -- Generate all the machinery associated with the finalization of a + -- single object. Flag Has_No_Init is used to denote certain contexts + -- where Decl does not have initialization call(s). Flag Is_Protected + -- is set when Decl denotes a simple protected object. + + ---------------------- + -- Build_Components -- + ---------------------- + + procedure Build_Components is + Counter_Decl : Node_Id; + Counter_Typ : Entity_Id; + Counter_Typ_Decl : Node_Id; + + begin + pragma Assert (Present (Decls)); + + -- This routine might be invoked several times when dealing with + -- constructs that have two lists (either two declarative regions + -- or declarations and statements). Avoid double initialization. + + if Components_Built then + return; + end if; + + Components_Built := True; + + if Has_Ctrl_Objs then + + -- Create entities for the counter, its type, the local exception + -- and the raised flag. + + Counter_Id := Make_Temporary (Loc, 'C'); + Counter_Typ := Make_Temporary (Loc, 'T'); + + if Exceptions_OK then + E_Id := Make_Temporary (Loc, 'E'); + Raised_Id := Make_Temporary (Loc, 'R'); + end if; + + -- Since the total number of controlled objects is always known, + -- build a subtype of Natural with precise bounds. This allows + -- the backend to optimize the case statement. Generate: + -- + -- subtype Tnn is Natural range 0 .. Counter_Val; + + Counter_Typ_Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Counter_Typ, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To (Standard_Natural, Loc), + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + Low_Bound => + Make_Integer_Literal (Loc, Uint_0), + High_Bound => + Make_Integer_Literal (Loc, Counter_Val))))); + + -- Generate the declaration of the counter itself: + -- + -- Counter : Integer := 0; + + Counter_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Counter_Id, + Object_Definition => + New_Reference_To (Counter_Typ, Loc), + Expression => + Make_Integer_Literal (Loc, 0)); + + -- Set the type of the counter explicitly to prevent errors when + -- examining object declarations later on. + + Set_Etype (Counter_Id, Counter_Typ); + + -- The counter and its type are inserted before the source + -- declarations of N. + + Prepend_To (Decls, Counter_Decl); + Prepend_To (Decls, Counter_Typ_Decl); + + -- The counter and its associated type must be manually analized + -- since N has already been analyzed. Use the scope of the spec + -- when inserting in a package. + + if For_Package then + Push_Scope (Spec_Id); + Analyze (Counter_Typ_Decl); + Analyze (Counter_Decl); + Pop_Scope; + + else + Analyze (Counter_Typ_Decl); + Analyze (Counter_Decl); + end if; + + Finalizer_Decls := New_List; + Jump_Alts := New_List; + end if; + + -- If the context requires additional clean up, the finalization + -- machinery is added after the clean up code. + + if Acts_As_Clean then + Finalizer_Stmts := Clean_Stmts; + Jump_Block_Insert_Nod := Last (Finalizer_Stmts); + else + Finalizer_Stmts := New_List; + end if; + end Build_Components; + + ---------------------- + -- Create_Finalizer -- + ---------------------- + + procedure Create_Finalizer is + Conv_Name : Name_Id; + E_Decl : Node_Id; + Fin_Body : Node_Id; + Fin_Spec : Node_Id; + Jump_Block : Node_Id; + Label : Node_Id; + Label_Id : Entity_Id; + Prag_Decl : Node_Id; + Spec_Decl : Node_Id; + + function Create_Finalizer_String return String_Id; + -- Generate a string of the form <Name>_finalize where <Name> denotes + -- the fully qualified name of the spec. The string is in lower case. + + ----------------------------- + -- Create_Finalizer_String -- + ----------------------------- + + function Create_Finalizer_String return String_Id is + procedure Create_Finalizer_String (Id : Entity_Id); + -- Generate a string of the form "Id__". If the identifier has a + -- non-standard scope, process the scope first. The generated + -- string is in lower case. + + ----------------------------- + -- Create_Finalizer_String -- + ----------------------------- + + procedure Create_Finalizer_String (Id : Entity_Id) is + S : constant Entity_Id := Scope (Id); + + begin + -- Climb the scope stack in order to start from the topmost + -- name. + + if Present (S) + and then S /= Standard_Standard + then + Create_Finalizer_String (S); + end if; + + Get_Name_String (Chars (Id)); + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + Store_String_Char ('_'); + Store_String_Char ('_'); + end Create_Finalizer_String; + + -- Start of processing for Create_Finalizer_String + + begin + Start_String; + + -- Build a fully qualified name. Compilations for .NET/JVM use the + -- finalizer name directly. + + if VM_Target = No_VM then + Create_Finalizer_String (Spec_Id); + end if; + + -- Add the name of the finalizer + + Get_Name_String (Chars (Fin_Id)); + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + + return End_String; + end Create_Finalizer_String; + + -- Start of processing for Create_Finalizer + + begin + -- Step 1: Creation of the finalizer name + + -- Packages must use a distinct name for their finalizers since the + -- binder will have to generate calls to them by name. + + if For_Package then + + -- finalizeS for specs + + if For_Package_Spec then + Fin_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Name_Finalize, 'S')); + + -- finalizeB for bodies + + else + Fin_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Name_Finalize, 'B')); + end if; + + -- The default name is _finalizer + + else + Fin_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Name_uFinalizer)); + end if; + + -- Step 2: Creation of the finalizer specification and export for + -- packages. + + -- Generate: + -- procedure Fin_Id; + + -- pragma Export (CIL, Fin_Id, "Finalize[S/B]"); + -- -- for .NET targets + + -- pragma Export (Java, Fin_Id, "Finalize[S/B]"); + -- -- for JVM targets + + -- pragma Export (Ada, Fin_Id, "Spec_Id_Finalize[S/B]"); + -- -- for default targets + + if For_Package then + Spec_Decl := + Make_Subprogram_Declaration (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Fin_Id)); + + -- Determine the proper convention depending on the target + + if VM_Target = CLI_Target then + Conv_Name := Name_CIL; + + elsif VM_Target = JVM_Target then + Conv_Name := Name_Java; + + else + Conv_Name := Name_Ada; + end if; + + Prag_Decl := + Make_Pragma (Loc, + Chars => Name_Export, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Identifier (Loc, Conv_Name)), + + Make_Pragma_Argument_Association (Loc, + Expression => + New_Reference_To (Fin_Id, Loc)), + + Make_Pragma_Argument_Association (Loc, + Expression => + Make_String_Literal (Loc, Create_Finalizer_String)))); + end if; + + -- Step 3: Creation of the finalizer body + + if Has_Ctrl_Objs then + + -- Add L0, the default destination to the jump block + + Label_Id := + Make_Identifier (Loc, New_External_Name ('L', 0)); + Set_Entity (Label_Id, + Make_Defining_Identifier (Loc, Chars (Label_Id))); + Label := Make_Label (Loc, Label_Id); + + -- Generate: + -- L0 : label; + + Prepend_To (Finalizer_Decls, + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Entity (Label_Id), + Label_Construct => Label)); + + -- Generate: + -- when others => + -- goto L0; + + Append_To (Jump_Alts, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Goto_Statement (Loc, + Name => + New_Reference_To (Entity (Label_Id), Loc))))); + + -- Generate: + -- <<L0>> + + Append_To (Finalizer_Stmts, Label); + + -- The local exception does not need to be reraised for library- + -- level finalizers. Generate: + -- + -- if Raised then + -- Raise_From_Controlled_Operation (E); + -- end if; + + if not For_Package + and then Exceptions_OK + then + Append_To (Finalizer_Stmts, + Build_Raise_Statement (Loc, E_Id, Raised_Id)); + end if; + + -- Create the jump block which controls the finalization flow + -- depending on the value of the state counter. + + Jump_Block := + Make_Case_Statement (Loc, + Expression => + Make_Identifier (Loc, Chars (Counter_Id)), + Alternatives => Jump_Alts); + + if Acts_As_Clean + and then Present (Jump_Block_Insert_Nod) + then + Insert_After (Jump_Block_Insert_Nod, Jump_Block); + else + Prepend_To (Finalizer_Stmts, Jump_Block); + end if; + end if; + + -- Add a call to the previous At_End handler if it exists. The call + -- must always precede the jump block. + + if Present (Prev_At_End) then + Prepend_To (Finalizer_Stmts, + Make_Procedure_Call_Statement (Loc, Prev_At_End)); + + -- Clear the At_End handler since we have already generated the + -- proper replacement call for it. + + Set_At_End_Proc (HSS, Empty); + end if; + + -- Release the secondary stack mark + + if Present (Mark_Id) then + Append_To (Finalizer_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_SS_Release), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Mark_Id, Loc)))); + end if; + + -- Protect the statements with abort defer/undefer. This is only when + -- aborts are allowed and the clean up statements require deferral or + -- there are controlled objects to be finalized. + + if Abort_Allowed + and then + (Defer_Abort or else Has_Ctrl_Objs) + then + Prepend_To (Finalizer_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Abort_Defer), Loc))); + + Append_To (Finalizer_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Abort_Undefer), Loc))); + end if; + + -- Generate: + -- procedure Fin_Id is + -- E : Exception_Occurrence; -- All added if flag + -- Raised : Boolean := False; -- Has_Ctrl_Objs is set + -- L0 : label; + -- ... + -- Lnn : label; + -- begin + -- Abort_Defer; -- Added if abort is allowed + -- <call to Prev_At_End> -- Added if exists + -- <cleanup statements> -- Added if Acts_As_Clean + -- <jump block> -- Added if Has_Ctrl_Objs + -- <finalization statements> -- Added if Has_Ctrl_Objs + -- <stack release> -- Added if Mark_Id exists + -- Abort_Undefer; -- Added if abort is allowed + -- end Fin_Id; + + if Has_Ctrl_Objs + and then Exceptions_OK + then + -- Generate: + -- Raised : Boolean := False; + + Prepend_To (Finalizer_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Raised_Id, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => + New_Reference_To (Standard_False, Loc))); + + -- Generate: + -- E : Exception_Occurrence; + + E_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => E_Id, + Object_Definition => + New_Reference_To (RTE (RE_Exception_Occurrence), Loc)); + Set_No_Initialization (E_Decl); + + Prepend_To (Finalizer_Decls, E_Decl); + end if; + + -- Create the body of the finalizer + + Fin_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Chars (Fin_Id))), + + Declarations => Finalizer_Decls, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Finalizer_Stmts)); + + -- Step 4: Spec and body insertion, analysis + + if For_Package then + + -- If the package spec has private declarations, the finalizer + -- body must be added to the end of the list in order to have + -- visibility of all private controlled objects. The spec is + -- inserted at the top of the visible declarations. + + if For_Package_Spec then + Prepend_To (Decls, Prag_Decl); + Prepend_To (Decls, Spec_Decl); + + if Present (Priv_Decls) then + Append_To (Priv_Decls, Fin_Body); + else + Append_To (Decls, Fin_Body); + end if; + + -- For package bodies, the finalizer body is added to the + -- declarative region of the body and finalizer spec goes + -- on the visible declarations of the package spec. + + else + declare + Spec_Nod : Node_Id := Spec_Id; + Vis_Decls : List_Id; + + begin + while Nkind (Spec_Nod) /= N_Package_Specification loop + Spec_Nod := Parent (Spec_Nod); + end loop; + + Vis_Decls := Visible_Declarations (Spec_Nod); + + Prepend_To (Vis_Decls, Prag_Decl); + Prepend_To (Vis_Decls, Spec_Decl); + Append_To (Decls, Fin_Body); + end; + end if; + + -- Push the name of the package + + Push_Scope (Spec_Id); + Analyze (Spec_Decl); + Analyze (Prag_Decl); + Analyze (Fin_Body); + Pop_Scope; + + -- Non-package case + + else + -- Create the spec for the finalizer. The At_End handler must be + -- able to call the body which resides in a nested structure. + + -- Generate: + -- declare + -- procedure Fin_Id; -- Spec + -- begin + -- <objects and possibly statements> + -- procedure Fin_Id is ... -- Body + -- <statements> + -- at end + -- Fin_Id; -- At_End handler + -- end; + + Fin_Spec := + Make_Subprogram_Declaration (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Fin_Id)); + + pragma Assert (Present (Spec_Decls)); + + Append_To (Spec_Decls, Fin_Spec); + Analyze (Fin_Spec); + + -- When the finalizer acts solely as a clean up routine, the body + -- is inserted right after the spec. + + if Acts_As_Clean + and then not Has_Ctrl_Objs + then + Insert_After (Fin_Spec, Fin_Body); + + -- In all other cases the body is inserted after either: + -- + -- 1) The counter update statement of the last controlled object + -- 2) The last top level nested controlled package + -- 3) The last top level controlled instantiation + + else + -- Manually freeze the spec. This is somewhat of a hack because + -- a subprogram is frozen when its body is seen and the freeze + -- node appears right before the body. However, in this case, + -- the spec must be frozen earlier since the At_End handler + -- must be able to call it. + -- + -- declare + -- procedure Fin_Id; -- Spec + -- [Fin_Id] -- Freeze node + -- begin + -- ... + -- at end + -- Fin_Id; -- At_End handler + -- end; + + Ensure_Freeze_Node (Fin_Id); + Insert_After (Fin_Spec, Freeze_Node (Fin_Id)); + Set_Is_Frozen (Fin_Id); + + -- In the case where the last construct to contain a controlled + -- object is either a nested package or instantiation, the body + -- must be inserted directly after the construct. + + if Nkind_In (Last_Top_Level_Ctrl_Construct, + N_Package_Declaration, + N_Package_Body) + then + Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct; + end if; + + Insert_After (Finalizer_Insert_Nod, Fin_Body); + end if; + + Analyze (Fin_Body); + end if; + end Create_Finalizer; + + -------------------------- + -- Process_Declarations -- + -------------------------- + + procedure Process_Declarations + (Decls : List_Id; + Preprocess : Boolean := False; + Top_Level : Boolean := False) + is + Decl : Node_Id; + Expr : Node_Id; + Obj_Id : Entity_Id; + Obj_Typ : Entity_Id; + Pack_Id : Entity_Id; + Spec : Node_Id; + Typ : Entity_Id; + + Old_Counter_Val : Int; + -- This variable is used to determine whether a nested package or + -- instance contains at least one controlled object. + + procedure Processing_Actions + (Has_No_Init : Boolean := False; + Is_Protected : Boolean := False); + -- Depending on the mode of operation of Process_Declarations, either + -- increment the controlled object counter, set the controlled object + -- flag and store the last top level construct or process the current + -- declaration. Flag Has_No_Init is used to propagate scenarios where + -- the current declaration may not have initialization proc(s). Flag + -- Is_Protected should be set when the current declaration denotes a + -- simple protected object. + + ------------------------ + -- Processing_Actions -- + ------------------------ + + procedure Processing_Actions + (Has_No_Init : Boolean := False; + Is_Protected : Boolean := False) + is + begin + if Preprocess then + Counter_Val := Counter_Val + 1; + Has_Ctrl_Objs := True; + + if Top_Level + and then No (Last_Top_Level_Ctrl_Construct) + then + Last_Top_Level_Ctrl_Construct := Decl; + end if; + else + Process_Object_Declaration (Decl, Has_No_Init, Is_Protected); + end if; + end Processing_Actions; + + -- Start of processing for Process_Declarations + + begin + if No (Decls) or else Is_Empty_List (Decls) then + return; + end if; + + -- Process all declarations in reverse order + + Decl := Last_Non_Pragma (Decls); + 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 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 + Processing_Actions; + + -- 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_Null_Access_BIP_Func_Call (Expr) + or else + (Is_Non_BIP_Func_Call (Expr) + and then not Is_Related_To_Func_Return (Obj_Id))) + then + Processing_Actions (Has_No_Init => 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. + -- The only exception is illustrated in the following example: + + -- package Pkg is + -- type Ctrl is new Controlled ... + -- procedure Finalize (Obj : in out Ctrl); + -- Lib_Obj : Ctrl; + -- end Pkg; + + -- package body Pkg is + -- protected Prot is + -- procedure Do_Something (Obj : in out Ctrl); + -- end Prot; + -- + -- protected body Prot is + -- procedure Do_Something (Obj : in out Ctrl) is ... + -- end Prot; + -- + -- procedure Finalize (Obj : in out Ctrl) is + -- begin + -- Prot.Do_Something (Obj); + -- end Finalize; + -- end Pkg; + + -- Since for the most part entities in package bodies depend on + -- those in package specs, Prot's lock should be cleaned up + -- first. The subsequent cleanup of the spec finalizes Lib_Obj. + -- This act however attempts to invoke Do_Something and fails + -- because the lock has disappeared. + + elsif Ekind (Obj_Id) = E_Variable + and then not In_Library_Level_Package_Body (Obj_Id) + and then + (Is_Simple_Protected_Type (Obj_Typ) + or else Has_Simple_Protected_Object (Obj_Typ)) + then + Processing_Actions (Is_Protected => True); + 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 + Processing_Actions (Has_No_Init => 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 + Process_Declarations (Actions (Decl), Preprocess); + end if; + + -- Nested package declarations, avoid generics + + elsif Nkind (Decl) = N_Package_Declaration then + Spec := Specification (Decl); + Pack_Id := Defining_Unit_Name (Spec); + + 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 then + Old_Counter_Val := Counter_Val; + Process_Declarations + (Private_Declarations (Spec), Preprocess); + Process_Declarations + (Visible_Declarations (Spec), Preprocess); + + -- Either the visible or the private declarations contain a + -- controlled object. The nested package declaration is the + -- last such construct. + + if Preprocess + and then Top_Level + and then No (Last_Top_Level_Ctrl_Construct) + and then Counter_Val > Old_Counter_Val + then + Last_Top_Level_Ctrl_Construct := Decl; + end if; + end if; + + -- Nested package bodies, avoid generics + + elsif Nkind (Decl) = N_Package_Body then + Spec := Corresponding_Spec (Decl); + + if Ekind (Spec) /= E_Generic_Package then + Old_Counter_Val := Counter_Val; + Process_Declarations (Declarations (Decl), Preprocess); + + -- The nested package body is the last construct to contain + -- a controlled object. + + if Preprocess + and then Top_Level + and then No (Last_Top_Level_Ctrl_Construct) + and then Counter_Val > Old_Counter_Val + then + Last_Top_Level_Ctrl_Construct := Decl; + end if; + end if; + + -- Handle a rare case caused by a controlled transient variable + -- created as part of a record init proc. The variable is wrapped + -- in a block, but the block is not associated with a transient + -- scope. + + elsif Nkind (Decl) = N_Block_Statement + and then Inside_Init_Proc + then + Old_Counter_Val := Counter_Val; + + if Present (Handled_Statement_Sequence (Decl)) then + Process_Declarations + (Statements (Handled_Statement_Sequence (Decl)), + Preprocess); + end if; + + Process_Declarations (Declarations (Decl), Preprocess); + + -- Either the declaration or statement list of the block has a + -- controlled object. + + if Preprocess + and then Top_Level + and then No (Last_Top_Level_Ctrl_Construct) + and then Counter_Val > Old_Counter_Val + then + Last_Top_Level_Ctrl_Construct := Decl; + end if; + end if; + + Prev_Non_Pragma (Decl); + end loop; + end Process_Declarations; + + -------------------------------- + -- Process_Object_Declaration -- + -------------------------------- + + procedure Process_Object_Declaration + (Decl : Node_Id; + Has_No_Init : Boolean := False; + Is_Protected : Boolean := False) + is + Obj_Id : constant Entity_Id := Defining_Identifier (Decl); + Body_Ins : Node_Id; + Count_Ins : Node_Id; + Fin_Call : Node_Id; + Fin_Stmts : List_Id; + Inc_Decl : Node_Id; + Label : Node_Id; + Label_Id : Entity_Id; + Obj_Ref : Node_Id; + Obj_Typ : Entity_Id; + + function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id; + -- Once it has been established that the current object is in fact a + -- return object of build-in-place function Func_Id, generate the + -- following cleanup code: + -- + -- if BIPallocfrom > Secondary_Stack'Pos + -- and then BIPcollection /= null + -- then + -- declare + -- type Ptr_Typ is access Obj_Typ; + -- for Ptr_Typ'Storage_Pool use Base_Pool (BIPcollection); + -- + -- begin + -- Free (Ptr_Typ (Temp)); + -- end; + -- end if; + -- + -- Obj_Typ is the type of the current object, Temp is the original + -- allocation which Obj_Id renames. + + procedure Find_Last_Init + (Decl : Node_Id; + Typ : Entity_Id; + Last_Init : out Node_Id; + Body_Insert : out Node_Id); + -- An object declaration has at least one and at most two init calls: + -- that of the type and the user-defined initialize. Given an object + -- declaration, Last_Init denotes the last initialization call which + -- follows the declaration. Body_Insert denotes the place where the + -- finalizer body could be potentially inserted. + + ----------------------------- + -- Build_BIP_Cleanup_Stmts -- + ----------------------------- + + function Build_BIP_Cleanup_Stmts + (Func_Id : Entity_Id) return Node_Id + is + Collect : constant Entity_Id := + Build_In_Place_Formal (Func_Id, BIP_Collection); + Decls : constant List_Id := New_List; + Obj_Typ : constant Entity_Id := Etype (Func_Id); + Temp_Id : constant Entity_Id := + Entity (Prefix (Name (Parent (Obj_Id)))); + + Cond : Node_Id; + Free_Blk : Node_Id; + Free_Stmt : Node_Id; + Pool_Id : Entity_Id; + Ptr_Typ : Entity_Id; + + begin + -- Generate: + -- Pool_Id renames Base_Pool (BIPcollection.all).all; + + Pool_Id := Make_Temporary (Loc, 'P'); + + Append_To (Decls, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Pool_Id, + Subtype_Mark => + New_Reference_To (RTE (RE_Root_Storage_Pool), Loc), + Name => + Make_Explicit_Dereference (Loc, + Prefix => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Base_Pool), Loc), + + Parameter_Associations => New_List ( + Make_Explicit_Dereference (Loc, + Prefix => + New_Reference_To (Collect, Loc))))))); + + -- Create an access type which uses the storage pool of the + -- caller's collection. + + -- Generate: + -- type Ptr_Typ is access Obj_Typ; + + Ptr_Typ := Make_Temporary (Loc, 'P'); + + Append_To (Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Reference_To (Obj_Typ, Loc)))); + + -- Perform minor decoration in order to set the collection and the + -- storage pool attributes. + + Set_Ekind (Ptr_Typ, E_Access_Type); + Set_Associated_Collection (Ptr_Typ, Collect); + Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); + + -- Create an explicit free statement. Note that the free uses the + -- caller's pool expressed as a renaming. + + Free_Stmt := + Make_Free_Statement (Loc, + Expression => + Unchecked_Convert_To (Ptr_Typ, + New_Reference_To (Temp_Id, Loc))); + + Set_Storage_Pool (Free_Stmt, Pool_Id); + + -- Create a block to house the dummy type and the instantiation as + -- well as to perform the cleanup the temporary. + + -- Generate: + -- declare + -- <Decls> + -- begin + -- Free (Ptr_Typ (Temp_Id)); + -- end; + + Free_Blk := + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Free_Stmt))); + + -- Generate: + -- if BIPcollection /= null then + + Cond := + Make_Op_Ne (Loc, + Left_Opnd => + New_Reference_To (Collect, Loc), + Right_Opnd => + Make_Null (Loc)); + + -- For constrained or tagged results escalate the condition to + -- include the allocation format. Generate: + -- + -- if BIPallocform > Secondary_Stack'Pos + -- and then BIPcollection /= null + -- then + + if not Is_Constrained (Obj_Typ) + or else Is_Tagged_Type (Obj_Typ) + then + declare + Alloc : constant Entity_Id := + Build_In_Place_Formal (Func_Id, BIP_Alloc_Form); + begin + Cond := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => + New_Reference_To (Alloc, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, + UI_From_Int + (BIP_Allocation_Form'Pos (Secondary_Stack)))), + + Right_Opnd => Cond); + end; + end if; + + -- Generate: + -- if <Cond> then + -- <Free_Blk> + -- end if; + + return + Make_If_Statement (Loc, + Condition => Cond, + Then_Statements => New_List (Free_Blk)); + end Build_BIP_Cleanup_Stmts; + + -------------------- + -- Find_Last_Init -- + -------------------- + + procedure Find_Last_Init + (Decl : Node_Id; + Typ : Entity_Id; + Last_Init : out Node_Id; + Body_Insert : out Node_Id) + is + Nod_1 : Node_Id := Empty; + Nod_2 : Node_Id := Empty; + Utyp : Entity_Id; + + function Is_Init_Call + (N : Node_Id; + Typ : Entity_Id) return Boolean; + -- Given an arbitrary node, determine whether N is a procedure + -- call and if it is, try to match the name of the call with the + -- [Deep_]Initialize proc of Typ. + + ------------------ + -- Is_Init_Call -- + ------------------ + + function Is_Init_Call + (N : Node_Id; + Typ : Entity_Id) return Boolean + is + begin + -- A call to [Deep_]Initialize is always direct + + if Nkind (N) = N_Procedure_Call_Statement + and then Nkind (Name (N)) = N_Identifier + then + declare + Call_Nam : constant Name_Id := Chars (Entity (Name (N))); + Deep_Init : constant Entity_Id := + TSS (Typ, TSS_Deep_Initialize); + Init : Entity_Id := Empty; + + begin + -- A type may have controlled components but not be + -- controlled. + + if Is_Controlled (Typ) then + Init := Find_Prim_Op (Typ, Name_Initialize); + end if; + + return + (Present (Deep_Init) + and then Chars (Deep_Init) = Call_Nam) + or else + (Present (Init) + and then Chars (Init) = Call_Nam); + end; + end if; + + return False; + end Is_Init_Call; + + -- Start of processing for Find_Last_Init + + begin + Last_Init := Decl; + Body_Insert := Empty; + + -- Object renamings and objects associated with controlled + -- function results do not have initialization calls. + + if Has_No_Init then + return; + end if; + + if Is_Concurrent_Type (Typ) then + Utyp := Corresponding_Record_Type (Typ); + else + Utyp := Typ; + end if; + + -- The init procedures are arranged as follows: + + -- Object : Controlled_Type; + -- Controlled_TypeIP (Object); + -- [[Deep_]Initialize (Object);] + + -- where the user-defined initialize may be optional or may appear + -- inside a block when abort deferral is needed. + + Nod_1 := Next (Decl); + if Present (Nod_1) then + Nod_2 := Next (Nod_1); + + -- The statement following an object declaration is always a + -- call to the type init proc. + + Last_Init := Nod_1; + end if; + + -- Optional user-defined init or deep init processing + + if Present (Nod_2) then + + -- The statement following the type init proc may be a block + -- statement in cases where abort deferral is required. + + if Nkind (Nod_2) = N_Block_Statement then + declare + HSS : constant Node_Id := + Handled_Statement_Sequence (Nod_2); + Stmt : Node_Id; + + begin + if Present (HSS) + and then Present (Statements (HSS)) + then + Stmt := First (Statements (HSS)); + + -- Examine individual block statements and locate the + -- call to [Deep_]Initialze. + + while Present (Stmt) loop + if Is_Init_Call (Stmt, Utyp) then + Last_Init := Stmt; + Body_Insert := Nod_2; + + exit; + end if; + + Next (Stmt); + end loop; + end if; + end; + + elsif Is_Init_Call (Nod_2, Utyp) then + Last_Init := Nod_2; + end if; + end if; + end Find_Last_Init; + + -- Start of processing for Process_Object_Declaration + + begin + Obj_Ref := New_Reference_To (Obj_Id, Loc); + Obj_Typ := Base_Type (Etype (Obj_Id)); + + -- Handle access types + + if Is_Access_Type (Obj_Typ) then + Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); + Obj_Typ := Directly_Designated_Type (Obj_Typ); + end if; + + Set_Etype (Obj_Ref, Obj_Typ); + + -- Set a new value for the state counter and insert the statement + -- after the object declaration. Generate: + -- + -- Counter := <value>; + + Inc_Decl := + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Counter_Id, Loc), + Expression => + Make_Integer_Literal (Loc, Counter_Val)); + + -- Insert the counter after all initialization has been done. The + -- place of insertion depends on the context. When dealing with a + -- controlled function, the counter is inserted directly after the + -- declaration because such objects lack init calls. + + Find_Last_Init (Decl, Obj_Typ, Count_Ins, Body_Ins); + + Insert_After (Count_Ins, Inc_Decl); + Analyze (Inc_Decl); + + -- If the current declaration is the last in the list, the finalizer + -- body needs to be inserted after the set counter statement for the + -- current object declaration. This is complicated by the fact that + -- the set counter statement may appear in abort deferred block. In + -- that case, the proper insertion place is after the block. + + if No (Finalizer_Insert_Nod) then + + -- Insertion after an abort deffered block + + if Present (Body_Ins) then + Finalizer_Insert_Nod := Body_Ins; + else + Finalizer_Insert_Nod := Inc_Decl; + end if; + end if; + + -- Create the associated label with this object, generate: + -- + -- L<counter> : label; + + Label_Id := + Make_Identifier (Loc, + Chars => New_External_Name ('L', Counter_Val)); + Set_Entity (Label_Id, + Make_Defining_Identifier (Loc, Chars (Label_Id))); + Label := Make_Label (Loc, Label_Id); + + Prepend_To (Finalizer_Decls, + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Entity (Label_Id), + Label_Construct => Label)); + + -- Create the associated jump with this object, generate: + -- + -- when <counter> => + -- goto L<counter>; + + Prepend_To (Jump_Alts, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Integer_Literal (Loc, Counter_Val)), + Statements => New_List ( + Make_Goto_Statement (Loc, + Name => + New_Reference_To (Entity (Label_Id), Loc))))); + + -- Insert the jump destination, generate: + -- + -- <<L<counter>>> + + Append_To (Finalizer_Stmts, Label); + + -- Processing for simple protected objects. Such objects require + -- manual finalization of their lock managers. + + if Is_Protected then + Fin_Stmts := No_List; + + if Is_Simple_Protected_Type (Obj_Typ) then + Fin_Stmts := + New_List (Cleanup_Protected_Object (Decl, Obj_Ref)); + + elsif Has_Simple_Protected_Object (Obj_Typ) then + if Is_Record_Type (Obj_Typ) then + Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ); + + elsif Is_Array_Type (Obj_Typ) then + Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ); + end if; + end if; + + -- Generate: + -- begin + -- System.Tasking.Protected_Objects.Finalize_Protection + -- (Obj._object); + -- + -- exception + -- when others => + -- null; + -- end; + + if Present (Fin_Stmts) then + Append_To (Finalizer_Stmts, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Fin_Stmts, + + Exception_Handlers => New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List ( + Make_Others_Choice (Loc)), + + Statements => New_List ( + Make_Null_Statement (Loc))))))); + end if; + + -- Processing for regular controlled objects + + else + -- Generate: + -- [Deep_]Finalize (Obj); -- No_Exception_Propagation + + -- begin -- Exception handlers allowed + -- [Deep_]Finalize (Obj); + -- + -- exception + -- when Id : others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, Id); + -- end if; + -- end; + + Fin_Call := + Make_Final_Call ( + Obj_Ref => Obj_Ref, + Typ => Obj_Typ); + + if Exceptions_OK then + Fin_Stmts := New_List ( + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Fin_Call), + + Exception_Handlers => New_List ( + Build_Exception_Handler + (Loc, E_Id, Raised_Id, For_Package))))); + + -- When exception handlers are prohibited, the finalization call + -- appears unprotected. Any exception raised during finalization + -- will bypass the circuitry which ensures the cleanup of all + -- remaining objects. + + else + Fin_Stmts := New_List (Fin_Call); + end if; + + -- If we are dealing with a return object of a build-in-place + -- function, generate the following cleanup statements: + -- + -- if BIPallocfrom > Secondary_Stack'Pos then + -- declare + -- type Ptr_Typ is access Obj_Typ; + -- for Ptr_Typ'Storage_Pool use + -- Base_Pool (BIPcollection.all).all; + -- + -- begin + -- Free (Ptr_Typ (Temp)); + -- end; + -- end if; + -- + -- The generated code effectively detaches the temporary from the + -- caller finalization chain and deallocates the object. This is + -- disabled on .NET/JVM because pools are not supported. + + if VM_Target = No_VM + and then Is_Return_Object (Obj_Id) + then + declare + Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id); + + begin + if Is_Build_In_Place_Function (Func_Id) + and then Needs_BIP_Collection (Func_Id) + then + Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id)); + end if; + end; + end if; + + -- Return objects use a flag to aid their potential finalization + -- then the enclosing function fails to return properly. Generate: + -- + -- if not Flag then + -- <object finalization statements> + -- end if; + + if Ekind_In (Obj_Id, E_Constant, E_Variable) + and then Is_Return_Object (Obj_Id) + and then Present (Return_Flag (Obj_Id)) + then + Fin_Stmts := New_List ( + Make_If_Statement (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + New_Reference_To (Return_Flag (Obj_Id), Loc)), + + Then_Statements => Fin_Stmts)); + end if; + end if; + + Append_List_To (Finalizer_Stmts, Fin_Stmts); + + -- Since the declarations are examined in reverse, the state counter + -- must be dectemented in order to keep with the true position of + -- objects. + + Counter_Val := Counter_Val - 1; + end Process_Object_Declaration; + + -- Start of processing for Build_Finalizer + + begin + Fin_Id := Empty; + + -- Step 1: Extract all lists which may contain controlled objects + + if For_Package_Spec then + Decls := Visible_Declarations (Specification (N)); + Priv_Decls := Private_Declarations (Specification (N)); + + -- Retrieve the package spec id + + Spec_Id := Defining_Unit_Name (Specification (N)); + + if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then + Spec_Id := Defining_Identifier (Spec_Id); + end if; + + -- Accept statement, block, entry body, package body, protected body, + -- subprogram body or task body. else - Append_Freeze_Action (Typ, Decl); + Decls := Declarations (N); + HSS := Handled_Statement_Sequence (N); + + if Present (HSS) then + if Present (Statements (HSS)) then + Stmts := Statements (HSS); + end if; + + if Present (At_End_Proc (HSS)) then + Prev_At_End := At_End_Proc (HSS); + end if; + end if; + + -- Retrieve the package spec id for package bodies + + if For_Package_Body then + Spec_Id := Corresponding_Spec (N); + end if; end if; - end Build_Final_List; + + -- Do not process nested packages since those are handled by the + -- enclosing scope's finalizer. Do not process non-expanded package + -- instantiations since those will be re-analyzed and re-expanded. + + if For_Package + and then + (not Is_Library_Level_Entity (Spec_Id) + + -- Nested packages are considered to be library level entities, + -- but do not need to be processed separately. True library level + -- packages have a scope value of 1. + + or else Scope_Depth_Value (Spec_Id) /= Uint_1 + or else (Is_Generic_Instance (Spec_Id) + and then Package_Instantiation (Spec_Id) /= N)) + then + return; + end if; + + -- Step 2: Object [pre]processing + + if For_Package then + + -- Preprocess the visible declarations now in order to obtain the + -- correct number of controlled object by the time the private + -- declarations are processed. + + Process_Declarations (Decls, Preprocess => True, Top_Level => True); + + -- From all the possible contexts, only package specifications may + -- have private declarations. + + if For_Package_Spec then + Process_Declarations + (Priv_Decls, Preprocess => True, Top_Level => True); + + -- The preprocessing has determined that the context has objects + -- that need finalization actions. Private declarations are + -- processed first in order to preserve possible dependencies + -- between public and private objects. + + if Has_Ctrl_Objs then + Build_Components; + Process_Declarations (Priv_Decls); + end if; + end if; + + -- Process the public declarations + + if Has_Ctrl_Objs then + Build_Components; + Process_Declarations (Decls); + end if; + + -- Non-package case + + else + -- Preprocess both declarations and statements + + Process_Declarations (Decls, Preprocess => True, Top_Level => True); + Process_Declarations (Stmts, Preprocess => True, Top_Level => True); + + -- At this point it is known that N has controlled objects. Ensure + -- that N has a declarative list since the finalizer spec will be + -- attached to it. + + if Has_Ctrl_Objs + and then No (Decls) + then + Set_Declarations (N, New_List); + Decls := Declarations (N); + Spec_Decls := Decls; + end if; + + -- The current context may lack controlled objects, but require some + -- other form of completion (task termination for instance). In such + -- cases, the finalizer must be created and carry the additional + -- statements. + + if Acts_As_Clean + or else Has_Ctrl_Objs + then + Build_Components; + end if; + + if Has_Ctrl_Objs then + Process_Declarations (Stmts); + Process_Declarations (Decls); + end if; + end if; + + -- Step 3: Finalizer creation + + if Acts_As_Clean + or else Has_Ctrl_Objs + then + Create_Finalizer; + end if; + end Build_Finalizer; + + -------------------------- + -- Build_Finalizer_Call -- + -------------------------- + + procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + HSS : Node_Id := Handled_Statement_Sequence (N); + + Is_Prot_Body : constant Boolean := + Nkind (N) = N_Subprogram_Body + and then Is_Protected_Subprogram_Body (N); + -- Determine whether N denotes the protected version of a subprogram + -- which belongs to a protected type. + + begin + -- The At_End handler should have been assimilated by the finalizer + + pragma Assert (No (At_End_Proc (HSS))); + + -- If the construct to be cleaned up is a protected subprogram body, the + -- finalizer call needs to be associated with the block which wraps the + -- unprotected version of the subprogram. The following illustrates this + -- scenario: + -- + -- procedure Prot_SubpP is + -- procedure finalizer is + -- begin + -- Service_Entries (Prot_Obj); + -- Abort_Undefer; + -- end finalizer; + -- + -- begin + -- . . . + -- begin + -- Prot_SubpN (Prot_Obj); + -- at end + -- finalizer; + -- end; + -- end Prot_SubpP; + + if Is_Prot_Body then + HSS := Handled_Statement_Sequence (Last (Statements (HSS))); + + -- An At_End handler and regular exception handlers cannot coexist in + -- the same statement sequence. Wrap the original statements in a block. + + elsif Present (Exception_Handlers (HSS)) then + declare + End_Lab : constant Node_Id := End_Label (HSS); + Block : Node_Id; + + begin + Block := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => HSS); + + Set_Handled_Statement_Sequence (N, + Make_Handled_Sequence_Of_Statements (Loc, New_List (Block))); + + HSS := Handled_Statement_Sequence (N); + Set_End_Label (HSS, End_Lab); + end; + end if; + + Set_At_End_Proc (HSS, New_Reference_To (Fin_Id, Loc)); + + Analyze (At_End_Proc (HSS)); + Expand_At_End_Handler (HSS, Empty); + end Build_Finalizer_Call; --------------------- -- Build_Late_Proc -- @@ -490,6 +2862,77 @@ package body Exp_Ch7 is end loop; end Build_Late_Proc; + ------------------------------- + -- Build_Object_Declarations -- + ------------------------------- + + function Build_Object_Declarations + (Loc : Source_Ptr; + E_Id : Entity_Id; + Raised_Id : Entity_Id) return List_Id + is + E_Decl : Node_Id; + + begin + if Restriction_Active (No_Exception_Propagation) then + return Empty_List; + end if; + + pragma Assert (Present (E_Id)); + pragma Assert (Present (Raised_Id)); + + E_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => E_Id, + Object_Definition => + New_Reference_To (RTE (RE_Exception_Occurrence), Loc)); + Set_No_Initialization (E_Decl); + + return New_List (E_Decl, + Make_Object_Declaration (Loc, + Defining_Identifier => Raised_Id, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => + New_Reference_To (Standard_False, Loc))); + end Build_Object_Declarations; + + --------------------------- + -- Build_Raise_Statement -- + --------------------------- + + function Build_Raise_Statement + (Loc : Source_Ptr; + E_Id : Entity_Id; + R_Id : Entity_Id) return Node_Id + is + Raise_Id : Entity_Id; + + begin + if VM_Target = No_VM then + Raise_Id := RTE (RE_Raise_From_Controlled_Operation); + else + Raise_Id := RTE (RE_Reraise_Occurrence); + end if; + + -- Generate: + -- if R_Id then + -- <Raise_Id> (E_Id); + -- end if; + + return + Make_If_Statement (Loc, + Condition => + New_Reference_To (R_Id, Loc), + + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Raise_Id, Loc), + Parameter_Associations => New_List ( + New_Reference_To (E_Id, Loc))))); + end Build_Raise_Statement; + ----------------------------- -- Build_Record_Deep_Procs -- ----------------------------- @@ -515,6 +2958,17 @@ package body Exp_Ch7 is Prim => Finalize_Case, Typ => Typ, Stmts => Make_Deep_Record_Body (Finalize_Case, Typ))); + + -- Create TSS primitive Finalize_Address for non-VM targets. JVM and + -- .NET do not support address arithmetic and unchecked conversions. + + if VM_Target = No_VM then + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Address_Case, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Address_Case, Typ))); + end if; end Build_Record_Deep_Procs; ------------------- @@ -576,7 +3030,7 @@ package body Exp_Ch7 is ------------------------ function Free_One_Dimension (Dim : Int) return List_Id is - Index : Entity_Id; + Index : Entity_Id; begin if Dim > Number_Dimensions (Typ) then @@ -701,73 +3155,12 @@ package body Exp_Ch7 is begin return Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Finalize_Protection), Loc), - Parameter_Associations => New_List ( - Concurrent_Ref (Ref))); + Name => + New_Reference_To (RTE (RE_Finalize_Protection), Loc), + Parameter_Associations => + New_List (Concurrent_Ref (Ref))); end Cleanup_Protected_Object; - ------------------------------------ - -- Clean_Simple_Protected_Objects -- - ------------------------------------ - - procedure Clean_Simple_Protected_Objects (N : Node_Id) is - Stmts : constant List_Id := Statements (Handled_Statement_Sequence (N)); - Stmt : Node_Id := Last (Stmts); - E : Entity_Id; - - begin - E := First_Entity (Current_Scope); - while Present (E) loop - if (Ekind (E) = E_Variable - or else Ekind (E) = E_Constant) - and then Has_Simple_Protected_Object (Etype (E)) - and then not Has_Task (Etype (E)) - and then Nkind (Parent (E)) /= N_Object_Renaming_Declaration - then - declare - Typ : constant Entity_Id := Etype (E); - Ref : constant Node_Id := New_Occurrence_Of (E, Sloc (Stmt)); - - begin - -- If the current context is a function, the end of the - -- statement sequence is likely to be a return statement. - -- The cleanup code must be executed before the return. - - if Ekind (Current_Scope) = E_Function - and then Nkind (Stmt) = Sinfo.N_Return_Statement - then - Stmt := Prev (Stmt); - end if; - - if Is_Simple_Protected_Type (Typ) then - Insert_After (Stmt, Cleanup_Protected_Object (N, Ref)); - - elsif Has_Simple_Protected_Object (Typ) then - if Is_Record_Type (Typ) then - Insert_List_After (Stmt, Cleanup_Record (N, Ref, Typ)); - - elsif Is_Array_Type (Typ) then - Insert_List_After (Stmt, Cleanup_Array (N, Ref, Typ)); - end if; - end if; - end; - end if; - - Next_Entity (E); - end loop; - - -- Analyze inserted cleanup statements - - if Present (Stmt) then - Stmt := Next (Stmt); - - while Present (Stmt) loop - Analyze (Stmt); - Next (Stmt); - end loop; - end if; - end Clean_Simple_Protected_Objects; - ------------------ -- Cleanup_Task -- ------------------ @@ -780,52 +3173,12 @@ package body Exp_Ch7 is begin return Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Free_Task), Loc), + Name => + New_Reference_To (RTE (RE_Free_Task), Loc), Parameter_Associations => New_List (Concurrent_Ref (Ref))); end Cleanup_Task; - --------------------------------- - -- Has_Simple_Protected_Object -- - --------------------------------- - - function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is - Comp : Entity_Id; - - begin - if Is_Simple_Protected_Type (T) then - return True; - - elsif Is_Array_Type (T) then - return Has_Simple_Protected_Object (Component_Type (T)); - - elsif Is_Record_Type (T) then - Comp := First_Component (T); - - while Present (Comp) loop - if Has_Simple_Protected_Object (Etype (Comp)) then - return True; - end if; - - Next_Component (Comp); - end loop; - - return False; - - else - return False; - end if; - end Has_Simple_Protected_Object; - - ------------------------------ - -- Is_Simple_Protected_Type -- - ------------------------------ - - function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is - begin - return Is_Protected_Type (T) and then not Has_Entries (T); - end Is_Simple_Protected_Type; - ------------------------------ -- Check_Visibly_Controlled -- ------------------------------ @@ -876,57 +3229,6 @@ package body Exp_Ch7 is return Is_Class_Wide_Type (T) or else Needs_Finalization (T); end CW_Or_Has_Controlled_Part; - -------------------------- - -- Controller_Component -- - -------------------------- - - function Controller_Component (Typ : Entity_Id) return Entity_Id is - T : Entity_Id := Base_Type (Typ); - Comp : Entity_Id; - Comp_Scop : Entity_Id; - Res : Entity_Id := Empty; - Res_Scop : Entity_Id := Empty; - - begin - if Is_Class_Wide_Type (T) then - T := Root_Type (T); - end if; - - if Is_Private_Type (T) then - T := Underlying_Type (T); - end if; - - -- Fetch the outermost controller - - Comp := First_Entity (T); - while Present (Comp) loop - if Chars (Comp) = Name_uController then - Comp_Scop := Scope (Original_Record_Component (Comp)); - - -- If this controller is at the outermost level, no need to - -- look for another one - - if Comp_Scop = T then - return Comp; - - -- Otherwise record the outermost one and continue looking - - elsif Res = Empty - or else Is_Ancestor (Res_Scop, Comp_Scop, Use_Full_View => True) - then - Res := Comp; - Res_Scop := Comp_Scop; - end if; - end if; - - Next_Entity (Comp); - end loop; - - -- If we fall through the loop, there is no controller component - - return Res; - end Controller_Component; - ------------------ -- Convert_View -- ------------------ @@ -982,6 +3284,27 @@ package body Exp_Ch7 is end if; end Convert_View; + ------------------------ + -- Enclosing_Function -- + ------------------------ + + function Enclosing_Function (E : Entity_Id) return Entity_Id is + Func_Id : Entity_Id := E; + + begin + while Present (Func_Id) + and then Func_Id /= Standard_Standard + loop + if Ekind (Func_Id) = E_Function then + return Func_Id; + end if; + + Func_Id := Scope (Func_Id); + end loop; + + return Empty; + end Enclosing_Function; + ------------------------------- -- Establish_Transient_Scope -- ------------------------------- @@ -1060,475 +3383,247 @@ package body Exp_Ch7 is ---------------------------- procedure Expand_Cleanup_Actions (N : Node_Id) is - S : constant Entity_Id := Current_Scope; - Flist : constant Entity_Id := Finalization_Chain_Entity (S); - Is_Task : constant Boolean := Nkind (Original_Node (N)) = N_Task_Body; + Scop : constant Entity_Id := Current_Scope; + Is_Asynchronous_Call : constant Boolean := + Nkind (N) = N_Block_Statement + and then Is_Asynchronous_Call_Block (N); Is_Master : constant Boolean := Nkind (N) /= N_Entry_Body and then Is_Task_Master (N); - Is_Protected : constant Boolean := + Is_Protected_Body : constant Boolean := Nkind (N) = N_Subprogram_Body and then Is_Protected_Subprogram_Body (N); Is_Task_Allocation : constant Boolean := Nkind (N) = N_Block_Statement and then Is_Task_Allocation_Block (N); - Is_Asynchronous_Call : constant Boolean := - Nkind (N) = N_Block_Statement - and then Is_Asynchronous_Call_Block (N); - - Previous_At_End_Proc : constant Node_Id := - At_End_Proc (Handled_Statement_Sequence (N)); - - Clean : Entity_Id; - Loc : Source_Ptr; - Mark : Entity_Id := Empty; - New_Decls : constant List_Id := New_List; - Blok : Node_Id; - End_Lab : Node_Id; - Wrapped : Boolean; - Chain : Entity_Id := Empty; - Decl : Node_Id; - Old_Poll : Boolean; - - begin - -- If we are generating expanded code for debugging purposes, use - -- the Sloc of the point of insertion for the cleanup code. The Sloc - -- will be updated subsequently to reference the proper line in the - -- .dg file. If we are not debugging generated code, use instead - -- No_Location, so that no debug information is generated for the - -- cleanup code. This makes the behavior of the NEXT command in GDB - -- monotonic, and makes the placement of breakpoints more accurate. - - if Debug_Generated_Code then - Loc := Sloc (S); - else - Loc := No_Location; - end if; - - -- There are cleanup actions only if the secondary stack needs - -- releasing or some finalizations are needed or in the context - -- of tasking - - if Uses_Sec_Stack (Current_Scope) - and then not Sec_Stack_Needed_For_Return (Current_Scope) - then - null; - elsif No (Flist) - and then not Is_Master - and then not Is_Task - and then not Is_Protected - and then not Is_Task_Allocation - and then not Is_Asynchronous_Call - then - Clean_Simple_Protected_Objects (N); - return; - end if; - - -- If the current scope is the subprogram body that is the rewriting - -- of a task body, and the descriptors have not been delayed (due to - -- some nested instantiations) do not generate redundant cleanup - -- actions: the cleanup procedure already exists for this body. - - if Nkind (N) = N_Subprogram_Body - and then Nkind (Original_Node (N)) = N_Task_Body - and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N)) - then - return; - end if; - - -- Set polling off, since we don't need to poll during cleanup - -- actions, and indeed for the cleanup routine, which is executed - -- with aborts deferred, we don't want polling. - - Old_Poll := Polling_Required; - Polling_Required := False; - - -- Make sure we have a declaration list, since we will add to it - - if No (Declarations (N)) then - Set_Declarations (N, New_List); - end if; - - -- The task activation call has already been built for task - -- allocation blocks. - - if not Is_Task_Allocation then - Build_Task_Activation_Call (N); - end if; - - if Is_Master then - Establish_Task_Master (N); - end if; - - -- If secondary stack is in use, expand: - -- _Mxx : constant Mark_Id := SS_Mark; - - -- Suppress calls to SS_Mark and SS_Release if VM_Target, - -- since we never use the secondary stack on the VM. - - if Uses_Sec_Stack (Current_Scope) - and then not Sec_Stack_Needed_For_Return (Current_Scope) - and then VM_Target = No_VM - then - Mark := Make_Temporary (Loc, 'M'); - Append_To (New_Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Mark, - Object_Definition => New_Reference_To (RTE (RE_Mark_Id), Loc), - Expression => - Make_Function_Call (Loc, - Name => New_Reference_To (RTE (RE_SS_Mark), Loc)))); - - Set_Uses_Sec_Stack (Current_Scope, False); - end if; - - -- If finalization list is present then expand: - -- Local_Final_List : System.FI.Finalizable_Ptr; - - if Present (Flist) then - Append_To (New_Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Flist, - Object_Definition => - New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); - end if; - - -- Clean-up procedure definition - - Clean := Make_Defining_Identifier (Loc, Name_uClean); - Set_Suppress_Elaboration_Warnings (Clean); - Append_To (New_Decls, - Make_Clean (N, Clean, Mark, Flist, - Is_Task, - Is_Master, - Is_Protected, - Is_Task_Allocation, - Is_Asynchronous_Call, - Previous_At_End_Proc)); - - -- The previous AT END procedure, if any, has been captured in Clean: - -- reset it to Empty now because we check further on that we never - -- overwrite an existing AT END call. - - Set_At_End_Proc (Handled_Statement_Sequence (N), Empty); - - -- If exception handlers are present, wrap the Sequence of statements in - -- a block because it is not possible to get exception handlers and an - -- AT END call in the same scope. - - if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then + Is_Task_Body : constant Boolean := + Nkind (Original_Node (N)) = N_Task_Body; + Needs_Sec_Stack_Mark : constant Boolean := + Uses_Sec_Stack (Scop) + and then + not Sec_Stack_Needed_For_Return (Scop) + and then VM_Target = No_VM; + + Actions_Required : constant Boolean := + Has_Controlled_Objects (N) + or else Is_Asynchronous_Call + or else Is_Master + or else Is_Protected_Body + or else Is_Task_Allocation + or else Is_Task_Body + or else Needs_Sec_Stack_Mark; + + HSS : Node_Id := Handled_Statement_Sequence (N); + Loc : Source_Ptr; + + procedure Wrap_HSS_In_Block; + -- Move HSS inside a new block along with the original exception + -- handlers. Make the newly generated block the sole statement of HSS. + + ----------------------- + -- Wrap_HSS_In_Block -- + ----------------------- + + procedure Wrap_HSS_In_Block is + Block : Node_Id; + End_Lab : Node_Id; + begin -- Preserve end label to provide proper cross-reference information - End_Lab := End_Label (Handled_Statement_Sequence (N)); - Blok := + End_Lab := End_Label (HSS); + Block := Make_Block_Statement (Loc, - Handled_Statement_Sequence => Handled_Statement_Sequence (N)); + Handled_Statement_Sequence => HSS); + Set_Handled_Statement_Sequence (N, - Make_Handled_Sequence_Of_Statements (Loc, New_List (Blok))); - Set_End_Label (Handled_Statement_Sequence (N), End_Lab); - Wrapped := True; + Make_Handled_Sequence_Of_Statements (Loc, New_List (Block))); + HSS := Handled_Statement_Sequence (N); + + Set_First_Real_Statement (HSS, Block); + Set_End_Label (HSS, End_Lab); -- Comment needed here, see RH for 1.306 ??? if Nkind (N) = N_Subprogram_Body then - Set_Has_Nested_Block_With_Handler (Current_Scope); + Set_Has_Nested_Block_With_Handler (Scop); end if; + end Wrap_HSS_In_Block; - -- Otherwise we do not wrap - - else - Wrapped := False; - Blok := Empty; - end if; + -- Start of processing for Expand_Cleanup_Actions - -- Don't move the _chain Activation_Chain declaration in task - -- allocation blocks. Task allocation blocks use this object - -- in their cleanup handlers, and gigi complains if it is declared - -- in the sequence of statements of the scope that declares the - -- handler. - - if Is_Task_Allocation then - Chain := Activation_Chain_Entity (N); - - Decl := First (Declarations (N)); - while Nkind (Decl) /= N_Object_Declaration - or else Defining_Identifier (Decl) /= Chain - loop - Next (Decl); - pragma Assert (Present (Decl)); - end loop; + begin + -- The current construct does not need any form of servicing - Remove (Decl); - Prepend_To (New_Decls, Decl); - end if; + if not Actions_Required then + return; - -- Now we move the declarations into the Sequence of statements - -- in order to get them protected by the AT END call. It may seem - -- weird to put declarations in the sequence of statement but in - -- fact nothing forbids that at the tree level. We also set the - -- First_Real_Statement field so that we remember where the real - -- statements (i.e. original statements) begin. Note that if we - -- wrapped the statements, the first real statement is inside the - -- inner block. If the First_Real_Statement is already set (as is - -- the case for subprogram bodies that are expansions of task bodies) - -- then do not reset it, because its declarative part would migrate - -- to the statement part. + -- If the current node is a rewritten task body and the descriptors have + -- not been delayed (due to some nested instantiations), do not generate + -- redundant cleanup actions. - if not Wrapped then - if No (First_Real_Statement (Handled_Statement_Sequence (N))) then - Set_First_Real_Statement (Handled_Statement_Sequence (N), - First (Statements (Handled_Statement_Sequence (N)))); - end if; - - else - Set_First_Real_Statement (Handled_Statement_Sequence (N), Blok); + elsif Is_Task_Body + and then Nkind (N) = N_Subprogram_Body + and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N)) + then + return; end if; - Append_List_To (Declarations (N), - Statements (Handled_Statement_Sequence (N))); - Set_Statements (Handled_Statement_Sequence (N), Declarations (N)); - - -- We need to reset the Sloc of the handled statement sequence to - -- properly reflect the new initial "statement" in the sequence. - - Set_Sloc - (Handled_Statement_Sequence (N), Sloc (First (Declarations (N)))); - - -- The declarations of the _Clean procedure and finalization chain - -- replace the old declarations that have been moved inward. - - Set_Declarations (N, New_Decls); - Analyze_Declarations (New_Decls); - - -- The At_End call is attached to the sequence of statements - declare - HSS : Node_Id; + Decls : List_Id := Declarations (N); + Fin_Id : Entity_Id; + Mark : Entity_Id := Empty; + New_Decls : List_Id; + Old_Poll : Boolean; begin - -- If the construct is a protected subprogram, then the call to - -- the corresponding unprotected subprogram appears in a block which - -- is the last statement in the body, and it is this block that must - -- be covered by the At_End handler. - - if Is_Protected then - HSS := Handled_Statement_Sequence - (Last (Statements (Handled_Statement_Sequence (N)))); + -- If we are generating expanded code for debugging purposes, use the + -- Sloc of the point of insertion for the cleanup code. The Sloc will + -- be updated subsequently to reference the proper line in .dg files. + -- If we are not debugging generated code, use No_Location instead, + -- so that no debug information is generated for the cleanup code. + -- This makes the behavior of the NEXT command in GDB monotonic, and + -- makes the placement of breakpoints more accurate. + + if Debug_Generated_Code then + Loc := Sloc (Scop); else - HSS := Handled_Statement_Sequence (N); + Loc := No_Location; end if; - -- Never overwrite an existing AT END call - - pragma Assert (No (At_End_Proc (HSS))); - - Set_At_End_Proc (HSS, New_Occurrence_Of (Clean, Loc)); - Expand_At_End_Handler (HSS, Empty); - end; - - -- Restore saved polling mode - - Polling_Required := Old_Poll; - end Expand_Cleanup_Actions; - - ------------------------------- - -- Expand_Ctrl_Function_Call -- - ------------------------------- - - procedure Expand_Ctrl_Function_Call (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Rtype : constant Entity_Id := Etype (N); - Utype : constant Entity_Id := Underlying_Type (Rtype); - Ref : Node_Id; - Action : Node_Id; - Action2 : Node_Id := Empty; - - Attach_Level : Uint := Uint_1; - Len_Ref : Node_Id := Empty; + -- Set polling off. The finalization and cleanup code is executed + -- with aborts deferred. - function Last_Array_Component - (Ref : Node_Id; - Typ : Entity_Id) return Node_Id; - -- Creates a reference to the last component of the array object - -- designated by Ref whose type is Typ. + Old_Poll := Polling_Required; + Polling_Required := False; - -------------------------- - -- Last_Array_Component -- - -------------------------- - - function Last_Array_Component - (Ref : Node_Id; - Typ : Entity_Id) return Node_Id - is - Index_List : constant List_Id := New_List; - - begin - for N in 1 .. Number_Dimensions (Typ) loop - Append_To (Index_List, - Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr_No_Checks (Ref), - Attribute_Name => Name_Last, - Expressions => New_List ( - Make_Integer_Literal (Loc, N)))); - end loop; - - return - Make_Indexed_Component (Loc, - Prefix => Duplicate_Subexpr (Ref), - Expressions => Index_List); - end Last_Array_Component; + -- A task activation call has already been built for a task + -- allocation block. - -- Start of processing for Expand_Ctrl_Function_Call + if not Is_Task_Allocation then + Build_Task_Activation_Call (N); + end if; - begin - -- Optimization, if the returned value (which is on the sec-stack) is - -- returned again, no need to copy/readjust/finalize, we can just pass - -- the value thru (see Expand_N_Simple_Return_Statement), and thus no - -- attachment is needed + if Is_Master then + Establish_Task_Master (N); + end if; - if Nkind (Parent (N)) = N_Simple_Return_Statement then - return; - end if; + New_Decls := New_List; - -- Resolution is now finished, make sure we don't start analysis again - -- because of the duplication. + -- If secondary stack is in use, generate: + -- + -- Mnn : constant Mark_Id := SS_Mark; - Set_Analyzed (N); - Ref := Duplicate_Subexpr_No_Checks (N); + -- Suppress calls to SS_Mark and SS_Release if VM_Target, since the + -- secondary stack is never used on a VM. - -- Now we can generate the Attach Call. Note that this value is always - -- on the (secondary) stack and thus is attached to a singly linked - -- final list: + if Needs_Sec_Stack_Mark then + Mark := Make_Temporary (Loc, 'M'); - -- Resx := F (X)'reference; - -- Attach_To_Final_List (_Lx, Resx.all, 1); + Append_To (New_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Mark, + Object_Definition => + New_Reference_To (RTE (RE_Mark_Id), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_SS_Mark), Loc)))); - -- or when there are controlled components: + Set_Uses_Sec_Stack (Scop, False); + end if; - -- Attach_To_Final_List (_Lx, Resx._controller, 1); + -- If exception handlers are present, wrap the sequence of statements + -- in a block since it is not possible to have exception handlers and + -- an At_End handler in the same construct. - -- or when it is both Is_Controlled and Has_Controlled_Components: + if Present (Exception_Handlers (HSS)) then + Wrap_HSS_In_Block; - -- Attach_To_Final_List (_Lx, Resx._controller, 1); - -- Attach_To_Final_List (_Lx, Resx, 1); + -- Ensure that the First_Real_Statement field is set - -- or if it is an array with Is_Controlled (and Has_Controlled) + elsif No (First_Real_Statement (HSS)) then + Set_First_Real_Statement (HSS, First (Statements (HSS))); + end if; - -- Attach_To_Final_List (_Lx, Resx (Resx'last), 3); + -- Do not move the Activation_Chain declaration in the context of + -- task allocation blocks. Task allocation blocks use _chain in their + -- cleanup handlers and gigi complains if it is declared in the + -- sequence of statements of the scope that declares the handler. - -- An attach level of 3 means that a whole array is to be attached to - -- the finalization list (including the controlled components). + if Is_Task_Allocation then + declare + Chain : constant Entity_Id := Activation_Chain_Entity (N); + Decl : Node_Id; - -- or if it is an array with Has_Controlled_Components but not - -- Is_Controlled: + begin + Decl := First (Decls); + while Nkind (Decl) /= N_Object_Declaration + or else Defining_Identifier (Decl) /= Chain + loop + Next (Decl); - -- Attach_To_Final_List (_Lx, Resx (Resx'last)._controller, 3); + -- A task allocation block should always include a _chain + -- declaration. - -- Case where type has controlled components + pragma Assert (Present (Decl)); + end loop; - if Has_Controlled_Component (Rtype) then - declare - T1 : Entity_Id := Rtype; - T2 : Entity_Id := Utype; + Remove (Decl); + Prepend_To (New_Decls, Decl); + end; + end if; - begin - if Is_Array_Type (T2) then - Len_Ref := - Make_Attribute_Reference (Loc, - Prefix => - Duplicate_Subexpr_Move_Checks - (Unchecked_Convert_To (T2, Ref)), - Attribute_Name => Name_Length); - end if; + -- Ensure the presence of a declaration list in order to successfully + -- append all original statements to it. - while Is_Array_Type (T2) loop - if T1 /= T2 then - Ref := Unchecked_Convert_To (T2, Ref); - end if; + if No (Decls) then + Set_Declarations (N, New_List); + Decls := Declarations (N); + end if; - Ref := Last_Array_Component (Ref, T2); - Attach_Level := Uint_3; - T1 := Component_Type (T2); - T2 := Underlying_Type (T1); - end loop; + -- Move the declarations into the sequence of statements in order to + -- have them protected by the At_End handler. It may seem weird to + -- put declarations in the sequence of statement but in fact nothing + -- forbids that at the tree level. - -- If the type has controlled components, go to the controller - -- except in the case of arrays of controlled objects since in - -- this case objects and their components are already chained - -- and the head of the chain is the last array element. + Append_List_To (Decls, Statements (HSS)); + Set_Statements (HSS, Decls); - if Is_Array_Type (Rtype) and then Is_Controlled (T2) then - null; + -- Reset the Sloc of the handled statement sequence to properly + -- reflect the new initial "statement" in the sequence. - elsif Has_Controlled_Component (T2) then - if T1 /= T2 then - Ref := Unchecked_Convert_To (T2, Ref); - end if; + Set_Sloc (HSS, Sloc (First (Decls))); - Ref := - Make_Selected_Component (Loc, - Prefix => Ref, - Selector_Name => Make_Identifier (Loc, Name_uController)); - end if; - end; + -- The declarations of finalizer spec and auxiliary variables replace + -- the old declarations that have been moved inward. - -- Here we know that 'Ref' has a controller so we may as well attach - -- it directly. + Set_Declarations (N, New_Decls); + Analyze_Declarations (New_Decls); - Action := - Make_Attach_Call ( - Obj_Ref => Ref, - Flist_Ref => Find_Final_List (Current_Scope), - With_Attach => Make_Integer_Literal (Loc, Attach_Level)); + -- Generate finalization calls for all controlled objects appearing + -- in the statements of N. Add context specific cleanup for various + -- constructs. - -- If it is also Is_Controlled we need to attach the global object + Build_Finalizer + (N => N, + Clean_Stmts => Build_Cleanup_Statements (N), + Mark_Id => Mark, + Top_Decls => New_Decls, + Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body + or else Is_Master, + Fin_Id => Fin_Id); - if Is_Controlled (Rtype) then - Action2 := - Make_Attach_Call ( - Obj_Ref => Duplicate_Subexpr_No_Checks (N), - Flist_Ref => Find_Final_List (Current_Scope), - With_Attach => Make_Integer_Literal (Loc, Attach_Level)); + if Present (Fin_Id) then + Build_Finalizer_Call (N, Fin_Id); end if; - -- Here, we have a controlled type that does not seem to have controlled - -- components but it could be a class wide type whose further - -- derivations have controlled components. So we don't know if the - -- object itself needs to be attached or if it has a record controller. - -- We need to call a runtime function (Deep_Tag_Attach) which knows what - -- to do thanks to the RC_Offset in the dispatch table. - - else - Action := - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Deep_Tag_Attach), Loc), - Parameter_Associations => New_List ( - Find_Final_List (Current_Scope), - - Make_Attribute_Reference (Loc, - Prefix => Ref, - Attribute_Name => Name_Address), - - Make_Integer_Literal (Loc, Attach_Level))); - end if; - - if Present (Len_Ref) then - Action := - Make_Implicit_If_Statement (N, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => Len_Ref, - Right_Opnd => Make_Integer_Literal (Loc, 0)), - Then_Statements => New_List (Action)); - end if; + -- Restore saved polling mode - Insert_Action (N, Action); - if Present (Action2) then - Insert_Action (N, Action2); - end if; - end Expand_Ctrl_Function_Call; + Polling_Required := Old_Poll; + end; + end Expand_Cleanup_Actions; --------------------------- -- Expand_N_Package_Body -- @@ -1542,17 +3637,18 @@ package body Exp_Ch7 is -- Encode entity names in package body procedure Expand_N_Package_Body (N : Node_Id) is - Ent : constant Entity_Id := Corresponding_Spec (N); + Spec_Ent : constant Entity_Id := Corresponding_Spec (N); + Fin_Id : Entity_Id; begin -- This is done only for non-generic packages - if Ekind (Ent) = E_Package then + if Ekind (Spec_Ent) = E_Package then Push_Scope (Corresponding_Spec (N)); -- Build dispatch tables of library level tagged types - if Is_Library_Level_Entity (Ent) then + if Is_Library_Level_Entity (Spec_Ent) then if Tagged_Type_Expansion then Build_Static_Dispatch_Tables (N); @@ -1577,11 +3673,34 @@ package body Exp_Ch7 is end if; Set_Elaboration_Flag (N, Corresponding_Spec (N)); - Set_In_Package_Body (Ent, False); + Set_In_Package_Body (Spec_Ent, False); -- Set to encode entity names in package body before gigi is called Qualify_Entity_Names (N); + + if Ekind (Spec_Ent) /= E_Generic_Package then + Build_Finalizer + (N => N, + Clean_Stmts => No_List, + Mark_Id => Empty, + Top_Decls => No_List, + Defer_Abort => False, + Fin_Id => Fin_Id); + + if Present (Fin_Id) then + declare + Body_Ent : Node_Id := Defining_Unit_Name (N); + + begin + if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then + Body_Ent := Defining_Identifier (Body_Ent); + end if; + + Set_Finalizer (Body_Ent, Fin_Id); + end; + end if; + end if; end Expand_N_Package_Body; ---------------------------------- @@ -1594,9 +3713,10 @@ package body Exp_Ch7 is -- appear. procedure Expand_N_Package_Declaration (N : Node_Id) is - Spec : constant Node_Id := Specification (N); Id : constant Entity_Id := Defining_Entity (N); + Spec : constant Node_Id := Specification (N); Decls : List_Id; + Fin_Id : Entity_Id; No_Body : Boolean := False; -- True in the case of a package declaration that is a compilation unit -- and for which no associated body will be compiled in @@ -1712,150 +3832,19 @@ package body Exp_Ch7 is -- Set to encode entity names in package spec before gigi is called Qualify_Entity_Names (N); - end Expand_N_Package_Declaration; - - --------------------- - -- Find_Final_List -- - --------------------- - - function Find_Final_List - (E : Entity_Id; - Ref : Node_Id := Empty) return Node_Id - is - Loc : constant Source_Ptr := Sloc (Ref); - S : Entity_Id; - Id : Entity_Id; - R : Node_Id; - - begin - -- If the restriction No_Finalization applies, then there isn't a - -- finalization list available to return, so return Empty. - - if Restriction_Active (No_Finalization) then - return Empty; - - -- Case of an internal component. The Final list is the record - -- controller of the enclosing record. - - elsif Present (Ref) then - R := Ref; - loop - case Nkind (R) is - when N_Unchecked_Type_Conversion | N_Type_Conversion => - R := Expression (R); - - when N_Indexed_Component | N_Explicit_Dereference => - R := Prefix (R); - - when N_Selected_Component => - R := Prefix (R); - exit; - - when N_Identifier => - exit; - - when others => - raise Program_Error; - end case; - end loop; - - return - Make_Selected_Component (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => R, - Selector_Name => Make_Identifier (Loc, Name_uController)), - Selector_Name => Make_Identifier (Loc, Name_F)); - - -- Case of a dynamically allocated object whose access type has an - -- Associated_Final_Chain. The final list is the corresponding list - -- controller (the next entity in the scope of the access type with - -- the right type). If the type comes from a With_Type clause, no - -- controller was created, we use the global chain instead. (The code - -- related to with_type clauses should presumably be removed at some - -- point since that feature is obsolete???) - - -- An anonymous access type either has a list created for it when the - -- allocator is a for an access parameter or an access discriminant, - -- or else it uses the list of the enclosing dynamic scope, when the - -- context is a declaration or an assignment. - - elsif Is_Access_Type (E) - and then (Present (Associated_Final_Chain (E)) - or else From_With_Type (E)) - then - if From_With_Type (E) then - return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E)); - - -- Use the access type's associated finalization chain - - else - return - Make_Selected_Component (Loc, - Prefix => - New_Reference_To - (Associated_Final_Chain (Base_Type (E)), Loc), - Selector_Name => Make_Identifier (Loc, Name_F)); - end if; - - else - S := Nearest_Dynamic_Scope (E); - - -- When the finalization chain entity is 'Error', it means that there - -- should not be any chain at that level and that the enclosing one - -- should be used. - - -- This is a nasty kludge, see ??? note in exp_ch11 - - while Finalization_Chain_Entity (S) = Error loop - S := Enclosing_Dynamic_Scope (S); - end loop; - - if S = Standard_Standard then - return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E)); - else - if No (Finalization_Chain_Entity (S)) then - - -- In the case where the scope is a subprogram, retrieve the - -- Sloc of subprogram's body for association with the chain, - -- since using the Sloc of the spec would be confusing during - -- source-line stepping within the debugger. - - declare - Flist_Loc : Source_Ptr := Sloc (S); - Subp_Body : Node_Id; - - begin - if Ekind (S) in Subprogram_Kind then - Subp_Body := Unit_Declaration_Node (S); - - if Nkind (Subp_Body) /= N_Subprogram_Body then - Subp_Body := Corresponding_Body (Subp_Body); - end if; - - if Present (Subp_Body) then - Flist_Loc := Sloc (Subp_Body); - end if; - end if; - - Id := Make_Temporary (Flist_Loc, 'F'); - end; - - Set_Finalization_Chain_Entity (S, Id); - - -- Set momentarily some semantics attributes to allow normal - -- analysis of expansions containing references to this chain. - -- Will be fully decorated during the expansion of the scope - -- itself. - Set_Ekind (Id, E_Variable); - Set_Etype (Id, RTE (RE_Finalizable_Ptr)); - end if; + if Ekind (Id) /= E_Generic_Package then + Build_Finalizer + (N => N, + Clean_Stmts => No_List, + Mark_Id => Empty, + Top_Decls => No_List, + Defer_Abort => False, + Fin_Id => Fin_Id); - return New_Reference_To (Finalization_Chain_Entity (S), Sloc (E)); - end if; + Set_Finalizer (Id, Fin_Id); end if; - end Find_Final_List; + end Expand_N_Package_Declaration; ----------------------------- -- Find_Node_To_Be_Wrapped -- @@ -2002,34 +3991,6 @@ package body Exp_Ch7 is end loop; end Find_Node_To_Be_Wrapped; - ---------------------- - -- Global_Flist_Ref -- - ---------------------- - - function Global_Flist_Ref (Flist_Ref : Node_Id) return Boolean is - Flist : Entity_Id; - - begin - -- Look for the Global_Final_List - - if Is_Entity_Name (Flist_Ref) then - Flist := Entity (Flist_Ref); - - -- Look for the final list associated with an access to controlled - - elsif Nkind (Flist_Ref) = N_Selected_Component - and then Is_Entity_Name (Prefix (Flist_Ref)) - then - Flist := Entity (Prefix (Flist_Ref)); - else - return False; - end if; - - return Present (Flist) - and then Present (Scope (Flist)) - and then Enclosing_Dynamic_Scope (Flist) = Standard_Standard; - end Global_Flist_Ref; - ---------------------------------- -- Has_New_Controlled_Component -- ---------------------------------- @@ -2062,22 +4023,43 @@ package body Exp_Ch7 is return False; end Has_New_Controlled_Component; - -------------------------- - -- In_Finalization_Root -- - -------------------------- + --------------------------------- + -- Has_Simple_Protected_Object -- + --------------------------------- - -- It would seem simpler to test Scope (RTE (RE_Root_Controlled)) but - -- the purpose of this function is to avoid a circular call to Rtsfind - -- which would been caused by such a test. + function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is + begin + if Has_Task (T) then + return False; - function In_Finalization_Root (E : Entity_Id) return Boolean is - S : constant Entity_Id := Scope (E); + elsif Is_Simple_Protected_Type (T) then + return True; - begin - return Chars (Scope (S)) = Name_System - and then Chars (S) = Name_Finalization_Root - and then Scope (Scope (S)) = Standard_Standard; - end In_Finalization_Root; + elsif Is_Array_Type (T) then + return Has_Simple_Protected_Object (Component_Type (T)); + + elsif Is_Record_Type (T) then + declare + Comp : Entity_Id; + + begin + Comp := First_Component (T); + + while Present (Comp) loop + if Has_Simple_Protected_Object (Etype (Comp)) then + return True; + end if; + + Next_Component (Comp); + end loop; + + return False; + end; + + else + return False; + end if; + end Has_Simple_Protected_Object; ------------------------------------ -- Insert_Actions_In_Scope_Around -- @@ -2085,787 +4067,2497 @@ package body Exp_Ch7 is procedure Insert_Actions_In_Scope_Around (N : Node_Id) is SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); - Target : Node_Id; + After : List_Id renames SE.Actions_To_Be_Wrapped_After; + Before : List_Id renames SE.Actions_To_Be_Wrapped_Before; + + procedure Process_Transient_Objects + (First_Object : Node_Id; + Last_Object : Node_Id; + Related_Node : Node_Id); + -- First_Object and Last_Object define a list which contains potential + -- controlled transient objects. Finalization flags are inserted before + -- First_Object and finalization calls are inserted after Last_Object. + -- Related_Node is the node for which transient objects have been + -- created. + + ------------------------------- + -- Process_Transient_Objects -- + ------------------------------- + + procedure Process_Transient_Objects + (First_Object : Node_Id; + Last_Object : Node_Id; + Related_Node : Node_Id) + is + Built : Boolean := False; + Desig : Entity_Id; + E_Decl : Node_Id; + E_Id : Entity_Id; + Fin_Block : Node_Id; + Last_Fin : Node_Id := Empty; + Loc : Source_Ptr; + Obj_Id : Entity_Id; + Obj_Ref : Node_Id; + Obj_Typ : Entity_Id; + Raised_Id : Entity_Id; + Stmt : Node_Id; + + begin + -- Examine all objects in the list First_Object .. Last_Object + + Stmt := First_Object; + while Present (Stmt) loop + if Nkind (Stmt) = N_Object_Declaration + and then Analyzed (Stmt) + and then Is_Finalizable_Transient (Stmt, N) + + -- Do not process the node to be wrapped since it will be + -- handled by the enclosing finalizer. + + and then Stmt /= Related_Node + then + Loc := Sloc (Stmt); + Obj_Id := Defining_Identifier (Stmt); + Obj_Typ := Base_Type (Etype (Obj_Id)); + Desig := Obj_Typ; + + Set_Is_Processed_Transient (Obj_Id); + + -- Handle access types + + if Is_Access_Type (Desig) then + Desig := Available_View (Designated_Type (Desig)); + end if; + + -- Create the necessary entities and declarations the first + -- time around. + + if not Built then + + -- Generate: + -- Enn : Exception_Occurrence; + + E_Id := Make_Temporary (Loc, 'E'); + + E_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => E_Id, + Object_Definition => + New_Reference_To (RTE (RE_Exception_Occurrence), Loc)); + Set_No_Initialization (E_Decl); + Insert_Before_And_Analyze (First_Object, E_Decl); + + -- Generate: + -- Rnn : Boolean := False; + + Raised_Id := Make_Temporary (Loc, 'R'); + + Insert_Before_And_Analyze (First_Object, + Make_Object_Declaration (Loc, + Defining_Identifier => Raised_Id, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => + New_Reference_To (Standard_False, Loc))); + + Built := True; + end if; + + -- Generate: + -- begin + -- [Deep_]Finalize (Obj_Ref); + + -- exception + -- when others => + -- if not Rnn then + -- Rnn := True; + -- Save_Occurrence + -- (Enn, Get_Current_Excep.all.all); + -- end if; + -- end; + + Obj_Ref := New_Reference_To (Obj_Id, Loc); + + if Is_Access_Type (Obj_Typ) then + Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); + end if; + + Fin_Block := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Final_Call ( + Obj_Ref => Obj_Ref, + Typ => Desig)), + + Exception_Handlers => New_List ( + Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + Insert_After_And_Analyze (Last_Object, Fin_Block); + + -- The raise statement must be inserted after all the + -- finalization blocks. + + if No (Last_Fin) then + Last_Fin := Fin_Block; + end if; + + -- When the associated node is an array object, the expander may + -- sometimes generate a loop and create transient objects inside + -- the loop. + + elsif Nkind (Stmt) = N_Loop_Statement then + Process_Transient_Objects + (First_Object => First (Statements (Stmt)), + Last_Object => Last (Statements (Stmt)), + Related_Node => Related_Node); + + -- Terminate the scan after the last object has been processed + + elsif Stmt = Last_Object then + exit; + end if; + + Next (Stmt); + end loop; + + -- Generate: + -- if Rnn then + -- Raise_From_Controlled_Operation (Enn); + -- end if; + + if Built + and then Present (Last_Fin) + then + Insert_After_And_Analyze (Last_Fin, + Build_Raise_Statement (Loc, E_Id, Raised_Id)); + end if; + end Process_Transient_Objects; + + -- Start of processing for Insert_Actions_In_Scope_Around begin - -- If the node to be wrapped is the triggering statement of an - -- asynchronous select, it is not part of a statement list. The - -- actions must be inserted before the Select itself, which is - -- part of some list of statements. Note that the triggering - -- alternative includes the triggering statement and an optional - -- statement list. If the node to be wrapped is part of that list, - -- the normal insertion applies. - - if Nkind (Parent (Node_To_Be_Wrapped)) = N_Triggering_Alternative - and then not Is_List_Member (Node_To_Be_Wrapped) - then - Target := Parent (Parent (Node_To_Be_Wrapped)); - else - Target := N; + if No (Before) and then No (After) then + return; end if; - if Present (SE.Actions_To_Be_Wrapped_Before) then - Insert_List_Before (Target, SE.Actions_To_Be_Wrapped_Before); - SE.Actions_To_Be_Wrapped_Before := No_List; - end if; + declare + Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped; + First_Obj : Node_Id; + Last_Obj : Node_Id; + Target : Node_Id; - if Present (SE.Actions_To_Be_Wrapped_After) then - Insert_List_After (Target, SE.Actions_To_Be_Wrapped_After); - SE.Actions_To_Be_Wrapped_After := No_List; - end if; + begin + -- If the node to be wrapped is the trigger of an asynchronous + -- select, it is not part of a statement list. The actions must be + -- inserted before the select itself, which is part of some list of + -- statements. Note that the triggering alternative includes the + -- triggering statement and an optional statement list. If the node + -- to be wrapped is part of that list, the normal insertion applies. + + if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative + and then not Is_List_Member (Node_To_Wrap) + then + Target := Parent (Parent (Node_To_Wrap)); + else + Target := N; + end if; + + First_Obj := Target; + Last_Obj := Target; + + -- Add all actions associated with a transient scope into the main + -- tree. There are several scenarios here: + -- + -- +--- Before ----+ +----- After ---+ + -- 1) First_Obj ....... Target ........ Last_Obj + -- + -- 2) First_Obj ....... Target + -- + -- 3) Target ........ Last_Obj + + if Present (Before) then + + -- Flag declarations are inserted before the first object + + First_Obj := First (Before); + + Insert_List_Before (Target, Before); + end if; + + if Present (After) then + + -- Finalization calls are inserted after the last object + + Last_Obj := Last (After); + + Insert_List_After (Target, After); + end if; + + -- Check for transient controlled objects associated with Target and + -- generate the appropriate finalization actions for them. + + Process_Transient_Objects + (First_Object => First_Obj, + Last_Object => Last_Obj, + Related_Node => Target); + + -- Reset the action lists + + if Present (Before) then + Before := No_List; + end if; + + if Present (After) then + After := No_List; + end if; + end; end Insert_Actions_In_Scope_Around; + ------------------------------ + -- Is_Simple_Protected_Type -- + ------------------------------ + + function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is + begin + return + Is_Protected_Type (T) + and then not Has_Entries (T) + and then Is_RTE (Find_Protection_Type (T), RE_Protection); + end Is_Simple_Protected_Type; + ----------------------- -- Make_Adjust_Call -- ----------------------- function Make_Adjust_Call - (Ref : Node_Id; - Typ : Entity_Id; - Flist_Ref : Node_Id; - With_Attach : Node_Id; - Allocator : Boolean := False) return List_Id + (Obj_Ref : Node_Id; + Typ : Entity_Id; + For_Parent : Boolean := False) return Node_Id is - Loc : constant Source_Ptr := Sloc (Ref); - Res : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Obj_Ref); + Adj_Id : Entity_Id := Empty; + Ref : Node_Id := Obj_Ref; Utyp : Entity_Id; - Proc : Entity_Id; - Cref : Node_Id := Ref; - Cref2 : Node_Id; - Attach : Node_Id := With_Attach; begin + -- Recover the proper type which contains Deep_Adjust + if Is_Class_Wide_Type (Typ) then - Utyp := Underlying_Type (Base_Type (Root_Type (Typ))); + Utyp := Root_Type (Typ); else - Utyp := Underlying_Type (Base_Type (Typ)); + Utyp := Typ; end if; - Set_Assignment_OK (Cref); + Utyp := Underlying_Type (Base_Type (Utyp)); + Set_Assignment_OK (Ref); -- Deal with non-tagged derivation of private views if Is_Untagged_Derivation (Typ) then Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); - Cref := Unchecked_Convert_To (Utyp, Cref); - Set_Assignment_OK (Cref); - -- To prevent problems with UC see 1.156 RH ??? + Ref := Unchecked_Convert_To (Utyp, Ref); + Set_Assignment_OK (Ref); end if; - -- If the underlying_type is a subtype, we are dealing with - -- the completion of a private type. We need to access - -- the base type and generate a conversion to it. + -- When dealing with the completion of a private type, use the base + -- type instead. if Utyp /= Base_Type (Utyp) then pragma Assert (Is_Private_Type (Typ)); + Utyp := Base_Type (Utyp); - Cref := Unchecked_Convert_To (Utyp, Cref); + Ref := Unchecked_Convert_To (Utyp, Ref); end if; - -- If the object is unanalyzed, set its expected type for use - -- in Convert_View in case an additional conversion is needed. + -- Select the appropriate version of adjust - if No (Etype (Cref)) - and then Nkind (Cref) /= N_Unchecked_Type_Conversion - then - Set_Etype (Cref, Typ); - end if; + if For_Parent then + if Has_Controlled_Component (Utyp) then + Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust); + end if; - -- We do not need to attach to one of the Global Final Lists - -- the objects whose type is Finalize_Storage_Only + -- For types that are both controlled and have controlled components, + -- generate a call to Deep_Adjust. - if Finalize_Storage_Only (Typ) - and then (Global_Flist_Ref (Flist_Ref) - or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) - = Standard_True) + elsif Is_Controlled (Utyp) + and then Has_Controlled_Component (Utyp) then - Attach := Make_Integer_Literal (Loc, 0); - end if; - - -- Special case for allocators: need initialization of the chain - -- pointers. For the 0 case, reset them to null. + Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust); - if Allocator then - pragma Assert (Nkind (Attach) = N_Integer_Literal); - - if Intval (Attach) = 0 then - Set_Intval (Attach, Uint_4); - end if; - end if; + -- For types that are not controlled themselves, but contain controlled + -- components or can be extended by types with controlled components, + -- create a call to Deep_Adjust. - -- Generate: - -- Deep_Adjust (Flist_Ref, Ref, Attach); - - if Has_Controlled_Component (Utyp) - or else Is_Class_Wide_Type (Typ) + elsif Is_Class_Wide_Type (Typ) + or else Has_Controlled_Component (Utyp) then if Is_Tagged_Type (Utyp) then - Proc := Find_Prim_Op (Utyp, TSS_Deep_Adjust); - + Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust); else - Proc := TSS (Utyp, TSS_Deep_Adjust); + Adj_Id := TSS (Utyp, TSS_Deep_Adjust); end if; - Cref := Convert_View (Proc, Cref, 2); + -- For types that are derived from Controlled and do not have controlled + -- components, build a call to Adjust. - Append_To (Res, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (Proc, Loc), - Parameter_Associations => - New_List (Flist_Ref, Cref, Attach))); + else + Adj_Id := Find_Prim_Op (Utyp, Name_Of (Adjust_Case)); + end if; - -- Generate: - -- if With_Attach then - -- Attach_To_Final_List (Ref, Flist_Ref); - -- end if; - -- Adjust (Ref); + if Present (Adj_Id) then - else -- Is_Controlled (Utyp) + -- If the object is unanalyzed, set its expected type for use in + -- Convert_View in case an additional conversion is needed. - Proc := Find_Prim_Op (Utyp, Name_Of (Adjust_Case)); - Cref := Convert_View (Proc, Cref); - Cref2 := New_Copy_Tree (Cref); + if No (Etype (Ref)) + and then Nkind (Ref) /= N_Unchecked_Type_Conversion + then + Set_Etype (Ref, Typ); + end if; - Append_To (Res, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (Proc, Loc), - Parameter_Associations => New_List (Cref2))); + -- The object reference may need another conversion depending on the + -- type of the formal and that of the actual. - Append_To (Res, Make_Attach_Call (Cref, Flist_Ref, Attach)); - end if; + if not Is_Class_Wide_Type (Typ) then + Ref := Convert_View (Adj_Id, Ref); + end if; - return Res; + return Make_Call (Loc, Adj_Id, New_Copy_Tree (Ref), For_Parent); + else + return Empty; + end if; end Make_Adjust_Call; - ---------------------- - -- Make_Attach_Call -- - ---------------------- - - -- Generate: - -- System.FI.Attach_To_Final_List (Flist, Ref, Nb_Link) + --------------- + -- Make_Call -- + --------------- - function Make_Attach_Call - (Obj_Ref : Node_Id; - Flist_Ref : Node_Id; - With_Attach : Node_Id) return Node_Id + function Make_Call + (Loc : Source_Ptr; + Proc_Id : Entity_Id; + Param : Node_Id; + For_Parent : Boolean := False) return Node_Id is - Loc : constant Source_Ptr := Sloc (Obj_Ref); + Params : constant List_Id := New_List (Param); begin - -- Optimization: If the number of links is statically '0', don't - -- call the attach_proc. + -- When creating a call to Deep_Finalize for a _parent field of a + -- derived type, disable the invocation of the nested Finalize by giving + -- the corresponding flag a False value. - if Nkind (With_Attach) = N_Integer_Literal - and then Intval (With_Attach) = Uint_0 - then - return Make_Null_Statement (Loc); + if For_Parent then + Append_To (Params, New_Reference_To (Standard_False, Loc)); end if; return Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Attach_To_Final_List), Loc), - Parameter_Associations => New_List ( - Flist_Ref, - OK_Convert_To (RTE (RE_Finalizable), Obj_Ref), - With_Attach)); - end Make_Attach_Call; - - ---------------- - -- Make_Clean -- - ---------------- - - function Make_Clean - (N : Node_Id; - Clean : Entity_Id; - Mark : Entity_Id; - Flist : Entity_Id; - Is_Task : Boolean; - Is_Master : Boolean; - Is_Protected_Subprogram : Boolean; - Is_Task_Allocation_Block : Boolean; - Is_Asynchronous_Call_Block : Boolean; - Chained_Cleanup_Action : Node_Id) return Node_Id - is - Loc : constant Source_Ptr := Sloc (Clean); - Stmt : constant List_Id := New_List; + Name => + New_Reference_To (Proc_Id, Loc), + Parameter_Associations => Params); + end Make_Call; - Sbody : Node_Id; - Spec : Node_Id; - Name : Node_Id; - Param : Node_Id; - Param_Type : Entity_Id; - Pid : Entity_Id := Empty; - Cancel_Param : Entity_Id; + -------------------------- + -- Make_Deep_Array_Body -- + -------------------------- - begin - if Is_Task then - if Restricted_Profile then - Append_To - (Stmt, Build_Runtime_Call (Loc, RE_Complete_Restricted_Task)); - else - Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Task)); - end if; + function Make_Deep_Array_Body + (Prim : Final_Primitives; + Typ : Entity_Id) return List_Id + is + function Build_Adjust_Or_Finalize_Statements + (Typ : Entity_Id) return List_Id; + -- Create the statements necessary to adjust or finalize an array of + -- controlled elements. Generate: + + -- declare + -- E : Exception_Occurrence; + -- Raised : Boolean := False; + + -- begin + -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop + -- ^-- in the finalization case + -- ... + -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop + -- begin + -- [Deep_]Adjust / Finalize (V (J1, ..., Jn)); + + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, Get_Current_Excep.all.all); + -- end if; + -- end; + -- end loop; + -- ... + -- end loop; + + -- if Raised then + -- Raise_From_Controlled_Operation (E); + -- end if; + -- end; + + function Build_Initialize_Statements (Typ : Entity_Id) return List_Id; + -- Create the statements necessary to initialize an array of controlled + -- elements. Include a mechanism to carry out partial finalization if an + -- exception occurs. Generate: + + -- declare + -- Counter : Integer := 0; + + -- begin + -- for J1 in V'Range (1) loop + -- ... + -- for JN in V'Range (N) loop + -- begin + -- [Deep_]Initialize (V (J1, ..., JN)); + + -- Counter := Counter + 1; + + -- exception + -- when others => + -- declare + -- E : Exception_Occurence; + -- Raised : Boolean := False; + + -- begin + -- Counter := + -- V'Length (1) * + -- V'Length (2) * + -- ... + -- V'Length (N) - Counter; + + -- for F1 in reverse V'Range (1) loop + -- ... + -- for FN in reverse V'Range (N) loop + -- if Counter > 0 then + -- Counter := Counter - 1; + -- else + -- begin + -- [Deep_]Finalize (V (F1, ..., FN)); + + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, + -- Get_Current_Excep.all.all); + -- end if; + -- end; + -- end if; + -- end loop; + -- ... + -- end loop; + -- end; + + -- if Raised then + -- Raise_From_Controlled_Operation (E); + -- end if; + + -- raise; + -- end; + -- end loop; + -- end loop; + -- end; + + function New_References_To + (L : List_Id; + Loc : Source_Ptr) return List_Id; + -- Given a list of defining identifiers, return a list of references to + -- the original identifiers, in the same order as they appear. + + ----------------------------------------- + -- Build_Adjust_Or_Finalize_Statements -- + ----------------------------------------- + + function Build_Adjust_Or_Finalize_Statements + (Typ : Entity_Id) return List_Id + is + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Index_List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + Num_Dims : constant Int := Number_Dimensions (Typ); + Call : Node_Id; + Comp_Ref : Node_Id; + Core_Loop : Node_Id; + Dim : Int; + E_Id : Entity_Id := Empty; + J : Entity_Id; + Loop_Id : Entity_Id; + Raised_Id : Entity_Id := Empty; + Stmts : List_Id; + + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + + procedure Build_Indices; + -- Generate the indices used in the dimension loops + + ------------------- + -- Build_Indices -- + ------------------- + + procedure Build_Indices is + begin + -- Generate the following identifiers: + -- Jnn - for initialization - elsif Is_Master then - if Restriction_Active (No_Task_Hierarchy) = False then - Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Master)); - end if; + for Dim in 1 .. Num_Dims loop + Append_To (Index_List, + Make_Defining_Identifier (Loc, New_External_Name ('J', Dim))); + end loop; + end Build_Indices; - elsif Is_Protected_Subprogram then + -- Start of processing for Build_Adjust_Or_Finalize_Statements - -- Add statements to the cleanup handler of the (ordinary) - -- subprogram expanded to implement a protected subprogram, - -- unlocking the protected object parameter and undeferring abort. - -- If this is a protected procedure, and the object contains - -- entries, this also calls the entry service routine. + begin + Build_Indices; - -- NOTE: This cleanup handler references _object, a parameter - -- to the procedure. + if Exceptions_OK then + E_Id := Make_Temporary (Loc, 'E'); + Raised_Id := Make_Temporary (Loc, 'R'); + end if; - -- Find the _object parameter representing the protected object + Comp_Ref := + Make_Indexed_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_V), + Expressions => + New_References_To (Index_List, Loc)); + Set_Etype (Comp_Ref, Comp_Typ); - Spec := Parent (Corresponding_Spec (N)); + -- Generate: + -- [Deep_]Adjust (V (J1, ..., JN)) - Param := First (Parameter_Specifications (Spec)); - loop - Param_Type := Etype (Parameter_Type (Param)); + if Prim = Adjust_Case then + Call := + Make_Adjust_Call ( + Obj_Ref => Comp_Ref, + Typ => Comp_Typ); - if Ekind (Param_Type) = E_Record_Type then - Pid := Corresponding_Concurrent_Type (Param_Type); - end if; + -- Generate: + -- [Deep_]Finalize (V (J1, ..., JN)) - exit when No (Param) or else Present (Pid); - Next (Param); - end loop; + else pragma Assert (Prim = Finalize_Case); + Call := + Make_Final_Call ( + Obj_Ref => Comp_Ref, + Typ => Comp_Typ); + end if; - pragma Assert (Present (Param)); + -- Generate the block which houses the adjust or finalize call: - -- If the associated protected object declares entries, - -- a protected procedure has to service entry queues. - -- In this case, add + -- <adjust or finalize call>; -- No_Exception_Propagation - -- Service_Entries (_object._object'Access); + -- begin -- Exception handlers allowed + -- <adjust or finalize call> - -- _object is the record used to implement the protected object. - -- It is a parameter to the protected subprogram. + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, Get_Current_Excep.all.all); + -- end if; + -- end; - if Nkind (Specification (N)) = N_Procedure_Specification - and then Has_Entries (Pid) - then - case Corresponding_Runtime_Package (Pid) is - when System_Tasking_Protected_Objects_Entries => - Name := New_Reference_To (RTE (RE_Service_Entries), Loc); + if Exceptions_OK then + Core_Loop := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Call), - when System_Tasking_Protected_Objects_Single_Entry => - Name := New_Reference_To (RTE (RE_Service_Entry), Loc); + Exception_Handlers => New_List ( + Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + else + Core_Loop := Call; + end if; - when others => - raise Program_Error; - end case; + -- Generate the dimension loops starting from the innermost one - Append_To (Stmt, - Make_Procedure_Call_Statement (Loc, - Name => Name, - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => - New_Reference_To (Defining_Identifier (Param), Loc), - Selector_Name => - Make_Identifier (Loc, Name_uObject)), - Attribute_Name => Name_Unchecked_Access)))); + -- for Jnn in [reverse] V'Range (Dim) loop + -- <core loop> + -- end loop; - else - -- Unlock (_object._object'Access); + J := Last (Index_List); + Dim := Num_Dims; + while Present (J) + and then Dim > 0 + loop + Loop_Id := J; + Prev (J); + Remove (Loop_Id); - -- object is the record used to implement the protected object. - -- It is a parameter to the protected subprogram. + Core_Loop := + Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Loop_Id, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => + Make_Identifier (Loc, Name_V), + Attribute_Name => + Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, Dim))), - case Corresponding_Runtime_Package (Pid) is - when System_Tasking_Protected_Objects_Entries => - Name := New_Reference_To (RTE (RE_Unlock_Entries), Loc); + Reverse_Present => Prim = Finalize_Case)), - when System_Tasking_Protected_Objects_Single_Entry => - Name := New_Reference_To (RTE (RE_Unlock_Entry), Loc); + Statements => New_List (Core_Loop), + End_Label => Empty); - when System_Tasking_Protected_Objects => - Name := New_Reference_To (RTE (RE_Unlock), Loc); + Dim := Dim - 1; + end loop; - when others => - raise Program_Error; - end case; + -- Generate the block which contains the core loop, the declarations + -- of the flag and exception occurrence and the conditional raise: - Append_To (Stmt, - Make_Procedure_Call_Statement (Loc, - Name => Name, - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => - New_Reference_To (Defining_Identifier (Param), Loc), - Selector_Name => - Make_Identifier (Loc, Name_uObject)), - Attribute_Name => Name_Unchecked_Access)))); - end if; + -- declare + -- E : Exception_Occurrence; + -- Raised : Boolean := False; - if Abort_Allowed then + -- begin + -- <core loop> - -- Abort_Undefer; + -- if Raised then -- Expection handlers allowed + -- Raise_From_Controlled_Operation (E); + -- end if; + -- end; - Append_To (Stmt, - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To ( - RTE (RE_Abort_Undefer), Loc), - Parameter_Associations => Empty_List)); + Stmts := New_List (Core_Loop); + + if Exceptions_OK then + Append_To (Stmts, Build_Raise_Statement (Loc, E_Id, Raised_Id)); end if; - elsif Is_Task_Allocation_Block then + return + New_List ( + Make_Block_Statement (Loc, + Declarations => + Build_Object_Declarations (Loc, E_Id, Raised_Id), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts))); + end Build_Adjust_Or_Finalize_Statements; + + --------------------------------- + -- Build_Initialize_Statements -- + --------------------------------- + + function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Final_List : constant List_Id := New_List; + Index_List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + Num_Dims : constant Int := Number_Dimensions (Typ); + Counter_Id : Entity_Id; + Dim : Int; + E_Id : Entity_Id := Empty; + F : Node_Id; + Fin_Stmt : Node_Id; + Final_Block : Node_Id; + Final_Loop : Node_Id; + Init_Loop : Node_Id; + J : Node_Id; + Loop_Id : Node_Id; + Raised_Id : Entity_Id := Empty; + Stmts : List_Id; + + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + + function Build_Counter_Assignment return Node_Id; + -- Generate the following assignment: + -- Counter := V'Length (1) * + -- ... + -- V'Length (N) - Counter; + + function Build_Finalization_Call return Node_Id; + -- Generate a deep finalization call for an array element + + procedure Build_Indices; + -- Generate the initialization and finalization indices used in the + -- dimension loops. + + function Build_Initialization_Call return Node_Id; + -- Generate a deep initialization call for an array element + + ------------------------------ + -- Build_Counter_Assignment -- + ------------------------------ + + function Build_Counter_Assignment return Node_Id is + Dim : Int; + Expr : Node_Id; - -- Add a call to Expunge_Unactivated_Tasks to the cleanup - -- handler of a block created for the dynamic allocation of - -- tasks: + begin + -- Start from the first dimension and generate: + -- V'Length (1) - -- Expunge_Unactivated_Tasks (_chain); + Dim := 1; + Expr := + Make_Attribute_Reference (Loc, + Prefix => + Make_Identifier (Loc, Name_V), + Attribute_Name => + Name_Length, + Expressions => New_List ( + Make_Integer_Literal (Loc, Dim))); + + -- Process the rest of the dimensions, generate: + -- Expr * V'Length (N) + + Dim := Dim + 1; + while Dim <= Num_Dims loop + Expr := + Make_Op_Multiply (Loc, + Left_Opnd => + Expr, + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + Make_Identifier (Loc, Name_V), + Attribute_Name => + Name_Length, + Expressions => New_List ( + Make_Integer_Literal (Loc, Dim)))); + + Dim := Dim + 1; + end loop; - -- where _chain is the list of tasks created by the allocator - -- but not yet activated. This list will be empty unless - -- the block completes abnormally. + -- Generate: + -- Counter := Expr - Counter; - -- This only applies to dynamically allocated tasks; - -- other unactivated tasks are completed by Complete_Task or - -- Complete_Master. + return + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Counter_Id, Loc), + Expression => + Make_Op_Subtract (Loc, + Left_Opnd => + Expr, + Right_Opnd => + New_Reference_To (Counter_Id, Loc))); + end Build_Counter_Assignment; + + ----------------------------- + -- Build_Finalization_Call -- + ----------------------------- + + function Build_Finalization_Call return Node_Id is + Comp_Ref : constant Node_Id := + Make_Indexed_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_V), + Expressions => + New_References_To (Final_List, Loc)); - -- NOTE: This cleanup handler references _chain, a local - -- object. + begin + Set_Etype (Comp_Ref, Comp_Typ); - Append_To (Stmt, - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To ( - RTE (RE_Expunge_Unactivated_Tasks), Loc), - Parameter_Associations => New_List ( - New_Reference_To (Activation_Chain_Entity (N), Loc)))); + -- Generate: + -- [Deep_]Finalize (V); - elsif Is_Asynchronous_Call_Block then + return + Make_Final_Call ( + Obj_Ref => Comp_Ref, + Typ => Comp_Typ); + end Build_Finalization_Call; - -- Add a call to attempt to cancel the asynchronous entry call - -- whenever the block containing the abortable part is exited. + ------------------- + -- Build_Indices -- + ------------------- - -- NOTE: This cleanup handler references C, a local object + procedure Build_Indices is + begin + -- Generate the following identifiers: + -- Jnn - for initialization + -- Fnn - for finalization - -- Get the argument to the Cancel procedure - Cancel_Param := Entry_Cancel_Parameter (Entity (Identifier (N))); + for Dim in 1 .. Num_Dims loop + Append_To (Index_List, + Make_Defining_Identifier (Loc, New_External_Name ('J', Dim))); - -- If it is of type Communication_Block, this must be a - -- protected entry call. + Append_To (Final_List, + Make_Defining_Identifier (Loc, New_External_Name ('F', Dim))); + end loop; + end Build_Indices; - if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then + ------------------------------- + -- Build_Initialization_Call -- + ------------------------------- - Append_To (Stmt, + function Build_Initialization_Call return Node_Id is + Comp_Ref : constant Node_Id := + Make_Indexed_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_V), + Expressions => + New_References_To (Index_List, Loc)); - -- if Enqueued (Cancel_Parameter) then + begin + Set_Etype (Comp_Ref, Comp_Typ); - Make_Implicit_If_Statement (Clean, - Condition => Make_Function_Call (Loc, - Name => New_Reference_To ( - RTE (RE_Enqueued), Loc), - Parameter_Associations => New_List ( - New_Reference_To (Cancel_Param, Loc))), - Then_Statements => New_List ( + -- Generate: + -- [Deep_]Initialize (V (J1, ..., JN)); - -- Cancel_Protected_Entry_Call (Cancel_Param); + return + Make_Init_Call ( + Obj_Ref => Comp_Ref, + Typ => Comp_Typ); + end Build_Initialization_Call; - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To ( - RTE (RE_Cancel_Protected_Entry_Call), Loc), - Parameter_Associations => New_List ( - New_Reference_To (Cancel_Param, Loc)))))); + -- Start of processing for Build_Initialize_Statements - -- Asynchronous delay + begin + Build_Indices; - elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then - Append_To (Stmt, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Cancel_Param, Loc), - Attribute_Name => Name_Unchecked_Access)))); + Counter_Id := Make_Temporary (Loc, 'C'); - -- Task entry call + if Exceptions_OK then + E_Id := Make_Temporary (Loc, 'E'); + Raised_Id := Make_Temporary (Loc, 'R'); + end if; + -- Generate the block which houses the finalization call, the index + -- guard and the handler which triggers Program_Error later on. + + -- if Counter > 0 then + -- Counter := Counter - 1; + -- else + -- [Deep_]Finalize (V (F1, ..., FN)); -- No_Except_Propagation + + -- begin -- Exceptions allowed + -- [Deep_]Finalize (V (F1, ..., FN)); + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, Get_Current_Excep.all.all); + -- end if; + -- end; + -- end if; + + if Exceptions_OK then + Fin_Stmt := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Build_Finalization_Call), + + Exception_Handlers => New_List ( + Build_Exception_Handler (Loc, E_Id, Raised_Id)))); else - -- Append call to Cancel_Task_Entry_Call (C); - - Append_To (Stmt, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To ( - RTE (RE_Cancel_Task_Entry_Call), - Loc), - Parameter_Associations => New_List ( - New_Reference_To (Cancel_Param, Loc)))); - + Fin_Stmt := Build_Finalization_Call; end if; - end if; - if Present (Flist) then - Append_To (Stmt, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Finalize_List), Loc), - Parameter_Associations => New_List ( - New_Reference_To (Flist, Loc)))); - end if; + -- This is the core of the loop, the dimension iterators are added + -- one by one in reverse. - if Present (Mark) then - Append_To (Stmt, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_SS_Release), Loc), - Parameter_Associations => New_List ( - New_Reference_To (Mark, Loc)))); - end if; + Final_Loop := + Make_If_Statement (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => + New_Reference_To (Counter_Id, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, 0)), + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Counter_Id, Loc), + Expression => + Make_Op_Subtract (Loc, + Left_Opnd => + New_Reference_To (Counter_Id, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, 1)))), + + Else_Statements => New_List (Fin_Stmt)); + + -- Generate all finalization loops starting from the innermost + -- dimension. + + -- for Fnn in reverse V'Range (Dim) loop + -- <final loop> + -- end loop; + + F := Last (Final_List); + Dim := Num_Dims; + while Present (F) + and then Dim > 0 + loop + Loop_Id := F; + Prev (F); + Remove (Loop_Id); - if Present (Chained_Cleanup_Action) then - Append_To (Stmt, - Make_Procedure_Call_Statement (Loc, - Name => Chained_Cleanup_Action)); - end if; + Final_Loop := + Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Loop_Id, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => + Make_Identifier (Loc, Name_V), + Attribute_Name => + Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, Dim))), - Sbody := - Make_Subprogram_Body (Loc, - Specification => - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Clean), + Reverse_Present => True)), - Declarations => New_List, + Statements => New_List (Final_Loop), + End_Label => Empty); - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stmt)); + Dim := Dim - 1; + end loop; - if Present (Flist) or else Is_Task or else Is_Master then - Wrap_Cleanup_Procedure (Sbody); - end if; + -- Generate the block which houses the finalization failure flag, + -- all the finalization loops and the exception raise. - -- We do not want debug information for _Clean routines, - -- since it just confuses the debugging operation unless - -- we are debugging generated code. + -- declare + -- E : Exception_Occurrence; + -- Raised : Boolean := False; - if not Debug_Generated_Code then - Set_Debug_Info_Off (Clean, True); - end if; + -- begin + -- Counter := + -- V'Length (1) * + -- ... + -- V'Length (N) - Counter; - return Sbody; - end Make_Clean; + -- <final loop> - -------------------------- - -- Make_Deep_Array_Body -- - -------------------------- + -- if Raised then -- Exception handlers allowed + -- Raise_From_Controlled_Operation (E); + -- end if; - -- Array components are initialized and adjusted in the normal order - -- and finalized in the reverse order. Exceptions are handled and - -- Program_Error is re-raise in the Adjust and Finalize case - -- (RM 7.6.1(12)). Generate the following code : - -- - -- procedure Deep_<P> -- with <P> being Initialize or Adjust or Finalize - -- (L : in out Finalizable_Ptr; - -- V : in out Typ) - -- is - -- begin - -- for J1 in Typ'First (1) .. Typ'Last (1) loop - -- ^ reverse ^ -- in the finalization case - -- ... - -- for J2 in Typ'First (n) .. Typ'Last (n) loop - -- Make_<P>_Call (Typ, V (J1, .. , Jn), L, V); - -- end loop; - -- ... - -- end loop; - -- exception -- not in the - -- when others => raise Program_Error; -- Initialize case - -- end Deep_<P>; + -- raise; -- Exception handlers allowed + -- end; - function Make_Deep_Array_Body - (Prim : Final_Primitives; - Typ : Entity_Id) return List_Id - is - Loc : constant Source_Ptr := Sloc (Typ); + Stmts := New_List (Build_Counter_Assignment, Final_Loop); - Index_List : constant List_Id := New_List; - -- Stores the list of references to the indexes (one per dimension) + if Exceptions_OK then + Append_To (Stmts, Build_Raise_Statement (Loc, E_Id, Raised_Id)); + Append_To (Stmts, Make_Raise_Statement (Loc)); + end if; - function One_Component return List_Id; - -- Create one statement to initialize/adjust/finalize one array - -- component, designated by a full set of indexes. + Final_Block := + Make_Block_Statement (Loc, + Declarations => + Build_Object_Declarations (Loc, E_Id, Raised_Id), - function One_Dimension (N : Int) return List_Id; - -- Create loop to deal with one dimension of the array. The single - -- statement in the body of the loop initializes the inner dimensions if - -- any, or else a single component. + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); - ------------------- - -- One_Component -- - ------------------- + -- Generate the block which contains the initialization call and + -- the partial finalization code. - function One_Component return List_Id is - Comp_Typ : constant Entity_Id := Component_Type (Typ); - Comp_Ref : constant Node_Id := - Make_Indexed_Component (Loc, - Prefix => Make_Identifier (Loc, Name_V), - Expressions => Index_List); + -- begin + -- [Deep_]Initialize (V (J1, ..., JN)); - begin - -- Set the etype of the component Reference, which is used to - -- determine whether a conversion to a parent type is needed. + -- Counter := Counter + 1; - Set_Etype (Comp_Ref, Comp_Typ); + -- exception + -- when others => + -- <finalization code> + -- end; - case Prim is - when Initialize_Case => - return Make_Init_Call (Comp_Ref, Comp_Typ, - Make_Identifier (Loc, Name_L), - Make_Identifier (Loc, Name_B)); + Init_Loop := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Build_Initialization_Call), + + Exception_Handlers => New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List ( + Make_Others_Choice (Loc)), + Statements => New_List ( + Final_Block))))); + + Append_To (Statements (Handled_Statement_Sequence (Init_Loop)), + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Counter_Id, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => + New_Reference_To (Counter_Id, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, 1)))); + + -- Generate all initialization loops starting from the innermost + -- dimension. + + -- for Jnn in V'Range (Dim) loop + -- <init loop> + -- end loop; + + J := Last (Index_List); + Dim := Num_Dims; + while Present (J) + and then Dim > 0 + loop + Loop_Id := J; + Prev (J); + Remove (Loop_Id); - when Adjust_Case => - return Make_Adjust_Call (Comp_Ref, Comp_Typ, - Make_Identifier (Loc, Name_L), - Make_Identifier (Loc, Name_B)); + Init_Loop := + Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Loop_Id, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => + Make_Identifier (Loc, Name_V), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, Dim))))), - when Finalize_Case => - return Make_Final_Call (Comp_Ref, Comp_Typ, - Make_Identifier (Loc, Name_B)); - end case; - end One_Component; + Statements => New_List (Init_Loop), + End_Label => Empty); - ------------------- - -- One_Dimension -- - ------------------- + Dim := Dim - 1; + end loop; - function One_Dimension (N : Int) return List_Id is - Index : Entity_Id; + -- Generate the block which contains the counter variable and the + -- initialization loops. - begin - if N > Number_Dimensions (Typ) then - return One_Component; + -- declare + -- Counter : Integer := 0; + -- begin + -- <init loop> + -- end; - else - Index := - Make_Defining_Identifier (Loc, New_External_Name ('J', N)); + return + New_List ( + Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Counter_Id, + Object_Definition => + New_Reference_To (Standard_Integer, Loc), + Expression => + Make_Integer_Literal (Loc, 0))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Init_Loop)))); + end Build_Initialize_Statements; + + ----------------------- + -- New_References_To -- + ----------------------- + + function New_References_To + (L : List_Id; + Loc : Source_Ptr) return List_Id + is + Refs : constant List_Id := New_List; + Id : Node_Id; - Append_To (Index_List, New_Reference_To (Index, Loc)); + begin + Id := First (L); + while Present (Id) loop + Append_To (Refs, New_Reference_To (Id, Loc)); + Next (Id); + end loop; - return New_List ( - Make_Implicit_Loop_Statement (Typ, - Identifier => Empty, - Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Loop_Parameter_Specification => - Make_Loop_Parameter_Specification (Loc, - Defining_Identifier => Index, - Discrete_Subtype_Definition => - Make_Attribute_Reference (Loc, - Prefix => Make_Identifier (Loc, Name_V), - Attribute_Name => Name_Range, - Expressions => New_List ( - Make_Integer_Literal (Loc, N))), - Reverse_Present => Prim = Finalize_Case)), - Statements => One_Dimension (N + 1))); - end if; - end One_Dimension; + return Refs; + end New_References_To; -- Start of processing for Make_Deep_Array_Body begin - return One_Dimension (1); + case Prim is + when Address_Case => + return Make_Finalize_Address_Stmts (Typ); + + when Adjust_Case | + Finalize_Case => + return Build_Adjust_Or_Finalize_Statements (Typ); + + when Initialize_Case => + return Build_Initialize_Statements (Typ); + end case; end Make_Deep_Array_Body; -------------------- -- Make_Deep_Proc -- -------------------- - -- Generate: - -- procedure DEEP_<prim> - -- (L : IN OUT Finalizable_Ptr; -- not for Finalize - -- V : IN OUT <typ>; - -- B : IN Short_Short_Integer) is - -- begin - -- <stmts>; - -- exception -- Finalize and Adjust Cases only - -- raise Program_Error; -- idem - -- end DEEP_<prim>; - function Make_Deep_Proc (Prim : Final_Primitives; Typ : Entity_Id; Stmts : List_Id) return Entity_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Formals : List_Id; - Proc_Name : Entity_Id; - Handler : List_Id := No_List; - Type_B : Entity_Id; + Loc : constant Source_Ptr := Sloc (Typ); + Formals : List_Id; + Proc_Id : Entity_Id; begin - if Prim = Finalize_Case then - Formals := New_List; - Type_B := Standard_Boolean; + -- Create the object formal, generate: + -- V : System.Address - else + if Prim = Address_Case then Formals := New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, Name_L), - In_Present => True, - Out_Present => True, - Parameter_Type => - New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); - Type_B := Standard_Short_Short_Integer; - end if; + Make_Defining_Identifier (Loc, Name_V), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc))); - Append_To (Formals, - Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), - In_Present => True, - Out_Present => True, - Parameter_Type => New_Reference_To (Typ, Loc))); + -- Default case - Append_To (Formals, - Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, Name_B), - Parameter_Type => New_Reference_To (Type_B, Loc))); + else + -- V : in out Typ - if Prim = Finalize_Case or else Prim = Adjust_Case then - Handler := New_List (Make_Handler_For_Ctrl_Operation (Loc)); + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_V), + In_Present => True, + Out_Present => True, + Parameter_Type => + New_Reference_To (Typ, Loc))); + + -- F : Boolean := True + + if Prim = Adjust_Case + or else Prim = Finalize_Case + then + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_F), + Parameter_Type => + New_Reference_To (Standard_Boolean, Loc), + Expression => + New_Reference_To (Standard_True, Loc))); + end if; end if; - Proc_Name := + Proc_Id := Make_Defining_Identifier (Loc, Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim))); + -- Generate: + -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is + -- begin + -- <stmts> + -- exception -- Finalize and Adjust cases only + -- raise Program_Error; + -- end Deep_Initialize / Adjust / Finalize; + + -- or + + -- procedure Finalize_Address (V : System.Address) is + -- begin + -- <stmts> + -- end Finalize_Address; + Discard_Node ( Make_Subprogram_Body (Loc, Specification => Make_Procedure_Specification (Loc, - Defining_Unit_Name => Proc_Name, + Defining_Unit_Name => Proc_Id, Parameter_Specifications => Formals), - Declarations => Empty_List, + Declarations => Empty_List, + Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stmts, - Exception_Handlers => Handler))); + Statements => Stmts))); - return Proc_Name; + return Proc_Id; end Make_Deep_Proc; --------------------------- -- Make_Deep_Record_Body -- --------------------------- - -- The Deep procedures call the appropriate Controlling proc on the - -- controller component. In the init case, it also attach the - -- controller to the current finalization list. - function Make_Deep_Record_Body - (Prim : Final_Primitives; - Typ : Entity_Id) return List_Id + (Prim : Final_Primitives; + Typ : Entity_Id; + Is_Local : Boolean := False) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Controller_Typ : Entity_Id; - Obj_Ref : constant Node_Id := Make_Identifier (Loc, Name_V); - Controller_Ref : constant Node_Id := - Make_Selected_Component (Loc, - Prefix => Obj_Ref, - Selector_Name => - Make_Identifier (Loc, Name_uController)); - Res : constant List_Id := New_List; + function Build_Adjust_Statements (Typ : Entity_Id) return List_Id; + -- Build the statements necessary to adjust a record type. The type may + -- have discriminants and contain variant parts. Generate: + + -- begin + -- Root_Controlled (V).Finalized := False; + + -- begin + -- [Deep_]Adjust (V.Comp_1); + -- exception + -- when Id : others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, Get_Current_Excep.all.all); + -- end if; + -- end; + -- . . . + -- begin + -- [Deep_]Adjust (V.Comp_N); + -- exception + -- when Id : others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, Get_Current_Excep.all.all); + -- end if; + -- end; + + -- begin + -- Deep_Adjust (V._parent, False); -- If applicable + -- exception + -- when Id : others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, Get_Current_Excep.all.all); + -- end if; + -- end; + + -- if F then + -- begin + -- Adjust (V); -- If applicable + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurence (E, Get_Current_Excep.all.all); + -- end if; + -- end; + -- end if; + + -- if Raised then + -- Raise_From_Controlled_Object (E); + -- end if; + -- end; + + function Build_Finalize_Statements (Typ : Entity_Id) return List_Id; + -- Build the statements necessary to finalize a record type. The type + -- may have discriminants and contain variant parts. Generate: + + -- declare + -- E : Exception_Occurence; + -- Raised : Boolean := False; + + -- begin + -- if Root_Controlled (V).Finalized then + -- return; + -- end if; + + -- if F then + -- begin + -- Finalize (V); -- If applicable + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurence (E, Get_Current_Excep.all.all); + -- end if; + -- end; + -- end if; + + -- case Variant_1 is + -- when Value_1 => + -- case State_Counter_N => -- If Is_Local is enabled + -- when N => . + -- goto LN; . + -- ... . + -- when 1 => . + -- goto L1; . + -- when others => . + -- goto L0; . + -- end case; . + + -- <<LN>> -- If Is_Local is enabled + -- begin + -- [Deep_]Finalize (V.Comp_N); + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurence (E, Get_Current_Excep.all.all); + -- end if; + -- end; + -- . . . + -- <<L1>> + -- begin + -- [Deep_]Finalize (V.Comp_1); + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurence (E, Get_Current_Excep.all.all); + -- end if; + -- end; + -- <<L0>> + -- end case; + + -- case State_Counter_1 => -- If Is_Local is enabled + -- when M => . + -- goto LM; . + -- ... + + -- begin + -- Deep_Finalize (V._parent, False); -- If applicable + -- exception + -- when Id : others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, Get_Current_Excep.all.all); + -- end if; + -- end; + + -- Root_Controlled (V).Finalized := True; + + -- if Raised then + -- Raise_From_Controlled_Object (E); + -- end if; + -- end; + + function Parent_Field_Type (Typ : Entity_Id) return Entity_Id; + -- Given a derived tagged type Typ, traverse all components, find field + -- _parent and return its type. + + procedure Preprocess_Components + (Comps : Node_Id; + Num_Comps : out Int; + Has_POC : out Boolean); + -- Examine all components in component list Comps, count all controlled + -- components and determine whether at least one of them is per-object + -- constrained. Component _parent is always skipped. + + ----------------------------- + -- Build_Adjust_Statements -- + ----------------------------- + + function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Typ); + Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); + Bod_Stmts : List_Id; + E_Id : Entity_Id := Empty; + Raised_Id : Entity_Id := Empty; + Rec_Def : Node_Id; + Var_Case : Node_Id; + + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + + function Process_Component_List_For_Adjust + (Comps : Node_Id) return List_Id; + -- Build all necessary adjust statements for a single component list + + --------------------------------------- + -- Process_Component_List_For_Adjust -- + --------------------------------------- + + function Process_Component_List_For_Adjust + (Comps : Node_Id) return List_Id + is + Stmts : constant List_Id := New_List; + Decl : Node_Id; + Decl_Id : Entity_Id; + Decl_Typ : Entity_Id; + Has_POC : Boolean; + Num_Comps : Int; + + procedure Process_Component_For_Adjust (Decl : Node_Id); + -- Process the declaration of a single controlled component + + ---------------------------------- + -- Process_Component_For_Adjust -- + ---------------------------------- + + procedure Process_Component_For_Adjust (Decl : Node_Id) is + Id : constant Entity_Id := Defining_Identifier (Decl); + Typ : constant Entity_Id := Etype (Id); + Adj_Stmt : Node_Id; - begin - if Is_Immutably_Limited_Type (Typ) then - Controller_Typ := RTE (RE_Limited_Record_Controller); - else - Controller_Typ := RTE (RE_Record_Controller); - end if; + begin + -- Generate: + -- [Deep_]Adjust (V.Id); -- No_Exception_Propagation + + -- begin -- Exception handlers allowed + -- [Deep_]Adjust (V.Id); + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, Get_Current_Excep.all.all); + -- end if; + -- end; + + Adj_Stmt := + Make_Adjust_Call ( + Obj_Ref => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_V), + Selector_Name => + Make_Identifier (Loc, Chars (Id))), + Typ => Typ); + + if Exceptions_OK then + Adj_Stmt := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Adj_Stmt), + + Exception_Handlers => New_List ( + Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + end if; - case Prim is - when Initialize_Case => - Append_List_To (Res, - Make_Init_Call ( - Ref => Controller_Ref, - Typ => Controller_Typ, - Flist_Ref => Make_Identifier (Loc, Name_L), - With_Attach => Make_Identifier (Loc, Name_B))); + Append_To (Stmts, Adj_Stmt); + end Process_Component_For_Adjust; - -- When the type is also a controlled type by itself, - -- initialize it and attach it to the finalization chain. + -- Start of processing for Process_Component_List_For_Adjust - if Is_Controlled (Typ) then - Append_To (Res, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To ( - Find_Prim_Op (Typ, Name_Of (Prim)), Loc), - Parameter_Associations => - New_List (New_Copy_Tree (Obj_Ref)))); - - Append_To (Res, - Make_Attach_Call - (Obj_Ref => New_Copy_Tree (Obj_Ref), - Flist_Ref => Make_Identifier (Loc, Name_L), - With_Attach => Make_Identifier (Loc, Name_B))); + begin + -- Perform an initial check, determine the number of controlled + -- components in the current list and whether at least one of them + -- is per-object constrained. + + Preprocess_Components (Comps, Num_Comps, Has_POC); + + -- The processing in this routine is done in the following order: + -- 1) Regular components + -- 2) Per-object constrained components + -- 3) Variant parts + + if Num_Comps > 0 then + + -- Process all regular components in order of declarations + + Decl := First_Non_Pragma (Component_Items (Comps)); + while Present (Decl) loop + Decl_Id := Defining_Identifier (Decl); + Decl_Typ := Etype (Decl_Id); + + -- Skip _parent as well as per-object constrained components + + if Chars (Decl_Id) /= Name_uParent + and then Needs_Finalization (Decl_Typ) + then + if Has_Access_Constraint (Decl_Id) + and then No (Expression (Decl)) + then + null; + else + Process_Component_For_Adjust (Decl); + end if; + end if; + + Next_Non_Pragma (Decl); + end loop; + + -- Process all per-object constrained components in order of + -- declarations. + + if Has_POC then + Decl := First_Non_Pragma (Component_Items (Comps)); + while Present (Decl) loop + Decl_Id := Defining_Identifier (Decl); + Decl_Typ := Etype (Decl_Id); + + -- Skip _parent + + if Chars (Decl_Id) /= Name_uParent + and then Needs_Finalization (Decl_Typ) + and then Has_Access_Constraint (Decl_Id) + and then No (Expression (Decl)) + then + Process_Component_For_Adjust (Decl); + end if; + + Next_Non_Pragma (Decl); + end loop; + end if; end if; - when Adjust_Case => - Append_List_To (Res, - Make_Adjust_Call - (Controller_Ref, Controller_Typ, - Make_Identifier (Loc, Name_L), - Make_Identifier (Loc, Name_B))); + -- Process all variants, if any + + Var_Case := Empty; + if Present (Variant_Part (Comps)) then + declare + Var_Alts : constant List_Id := New_List; + Var : Node_Id; + + begin + Var := First_Non_Pragma (Variants (Variant_Part (Comps))); + while Present (Var) loop + + -- Generate: + -- when <discrete choices> => + -- <adjust statements> + + Append_To (Var_Alts, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_Copy_List (Discrete_Choices (Var)), + Statements => + Process_Component_List_For_Adjust ( + Component_List (Var)))); + + Next_Non_Pragma (Var); + end loop; + + -- Generate: + -- case V.<discriminant> is + -- when <discrete choices 1> => + -- <adjust statements 1> + -- ... + -- when <discrete choices N> => + -- <adjust statements N> + -- end case; + + Var_Case := + Make_Case_Statement (Loc, + Expression => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_V), + Selector_Name => + Make_Identifier (Loc, + Chars (Name (Variant_Part (Comps))))), + Alternatives => Var_Alts); + end; + end if; - -- When the type is also a controlled type by itself, - -- adjust it and attach it to the finalization chain. + -- Add the variant case statement to the list of statements - if Is_Controlled (Typ) then - Append_To (Res, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To ( - Find_Prim_Op (Typ, Name_Of (Prim)), Loc), - Parameter_Associations => - New_List (New_Copy_Tree (Obj_Ref)))); - - Append_To (Res, - Make_Attach_Call - (Obj_Ref => New_Copy_Tree (Obj_Ref), - Flist_Ref => Make_Identifier (Loc, Name_L), - With_Attach => Make_Identifier (Loc, Name_B))); + if Present (Var_Case) then + Append_To (Stmts, Var_Case); end if; - when Finalize_Case => - if Is_Controlled (Typ) then - Append_To (Res, - Make_Implicit_If_Statement (Obj_Ref, - Condition => Make_Identifier (Loc, Name_B), - Then_Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Finalize_One), Loc), - Parameter_Associations => New_List ( - OK_Convert_To (RTE (RE_Finalizable), - New_Copy_Tree (Obj_Ref))))), + -- If the component list did not have any controlled components + -- nor variants, return null. - Else_Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To ( - Find_Prim_Op (Typ, Name_Of (Prim)), Loc), - Parameter_Associations => - New_List (New_Copy_Tree (Obj_Ref)))))); + if Is_Empty_List (Stmts) then + Append_To (Stmts, Make_Null_Statement (Loc)); end if; - Append_List_To (Res, - Make_Final_Call - (Controller_Ref, Controller_Typ, - Make_Identifier (Loc, Name_B))); - end case; + return Stmts; + end Process_Component_List_For_Adjust; + + -- Start of processing for Build_Adjust_Statements + + begin + if Exceptions_OK then + E_Id := Make_Temporary (Loc, 'E'); + Raised_Id := Make_Temporary (Loc, 'R'); + end if; + + if Nkind (Typ_Def) = N_Derived_Type_Definition then + Rec_Def := Record_Extension_Part (Typ_Def); + else + Rec_Def := Typ_Def; + end if; + + -- Create an adjust sequence for all record components + + if Present (Component_List (Rec_Def)) then + Bod_Stmts := + Process_Component_List_For_Adjust (Component_List (Rec_Def)); + end if; + + -- A derived record type must adjust all inherited components. This + -- action poses the following problem: + -- + -- procedure Deep_Adjust (Obj : in out Parent_Typ) is + -- begin + -- Adjust (Obj); + -- ... + -- + -- procedure Deep_Adjust (Obj : in out Derived_Typ) is + -- begin + -- Deep_Adjust (Obj._parent); + -- ... + -- Adjust (Obj); + -- ... + -- + -- Adjusting the derived type will invoke Adjust of the parent and + -- then that of the derived type. This is undesirable because both + -- routines may modify shared components. Only the Adjust of the + -- derived type should be invoked. + -- + -- To prevent this double adjustment of shared components, + -- Deep_Adjust uses a flag to control the invocation of Adjust: + -- + -- procedure Deep_Adjust + -- (Obj : in out Some_Type; + -- Flag : Boolean := True) + -- is + -- begin + -- if Flag then + -- Adjust (Obj); + -- end if; + -- ... + -- + -- When Deep_Adjust is invokes for field _parent, a value of False is + -- provided for the flag: + -- + -- Deep_Adjust (Obj._parent, False); + + if Is_Tagged_Type (Typ) + and then Is_Derived_Type (Typ) + then + declare + Par_Typ : constant Entity_Id := Parent_Field_Type (Typ); + Adj_Stmt : Node_Id; + Call : Node_Id; + + begin + if Needs_Finalization (Par_Typ) then + Call := + Make_Adjust_Call ( + Obj_Ref => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_V), + Selector_Name => + Make_Identifier (Loc, Name_uParent)), + Typ => Par_Typ, + For_Parent => True); + + -- Generate: + -- Deep_Adjust (V._parent, False); -- No_Except_Propagat + + -- begin -- Exceptions OK + -- Deep_Adjust (V._parent, False); + -- exception + -- when Id : others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, + -- Get_Current_Excep.all.all); + -- end if; + -- end; + + if Present (Call) then + Adj_Stmt := Call; + + if Exceptions_OK then + Adj_Stmt := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Adj_Stmt), + + Exception_Handlers => New_List ( + Build_Exception_Handler + (Loc, E_Id, Raised_Id)))); + end if; + + Prepend_To (Bod_Stmts, Adj_Stmt); + end if; + end if; + end; + end if; + + -- Adjust the object. This action must be performed last after all + -- components have been adjusted. + + if Is_Controlled (Typ) then + declare + Adj_Stmt : Node_Id; + Proc : Entity_Id; + + begin + Proc := Find_Prim_Op (Typ, Name_Adjust); + + -- Generate: + -- if F then + -- Adjust (V); -- No_Exception_Propagation + + -- begin -- Exception handlers allowed + -- Adjust (V); + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, + -- Get_Current_Excep.all.all); + -- end if; + -- end; + -- end if; + + if Present (Proc) then + Adj_Stmt := + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Proc, Loc), + Parameter_Associations => New_List ( + Make_Identifier (Loc, Name_V))); + + if Exceptions_OK then + Adj_Stmt := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Adj_Stmt), + + Exception_Handlers => New_List ( + Build_Exception_Handler + (Loc, E_Id, Raised_Id)))); + end if; + + Append_To (Bod_Stmts, + Make_If_Statement (Loc, + Condition => + Make_Identifier (Loc, Name_F), + Then_Statements => New_List (Adj_Stmt))); + end if; + end; + end if; + + -- At this point either all adjustment statements have been generated + -- or the type is not controlled. + + if Is_Empty_List (Bod_Stmts) then + Append_To (Bod_Stmts, Make_Null_Statement (Loc)); + + return Bod_Stmts; + + -- Generate: + -- declare + -- E : Exception_Occurence; + -- Raised : Boolean := False; + + -- begin + -- Root_Controlled (V).Finalized := False; + + -- <adjust statements> + + -- if Raised then + -- Raise_From_Controlled_Operation (E); + -- end if; + -- end; + + else + if Exceptions_OK then + Append_To (Bod_Stmts, + Build_Raise_Statement (Loc, E_Id, Raised_Id)); + end if; + + return + New_List ( + Make_Block_Statement (Loc, + Declarations => + Build_Object_Declarations (Loc, E_Id, Raised_Id), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Bod_Stmts))); + end if; + end Build_Adjust_Statements; + + ------------------------------- + -- Build_Finalize_Statements -- + ------------------------------- + + function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Typ); + Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); + Bod_Stmts : List_Id; + Counter : Int := 0; + E_Id : Entity_Id := Empty; + Raised_Id : Entity_Id := Empty; + Rec_Def : Node_Id; + Var_Case : Node_Id; + + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + + function Process_Component_List_For_Finalize + (Comps : Node_Id) return List_Id; + -- Build all necessary finalization statements for a single component + -- list. The statements may include a jump circuitry if flag Is_Local + -- is enabled. + + ----------------------------------------- + -- Process_Component_List_For_Finalize -- + ----------------------------------------- + + function Process_Component_List_For_Finalize + (Comps : Node_Id) return List_Id + is + Alts : List_Id; + Counter_Id : Entity_Id; + Decl : Node_Id; + Decl_Id : Entity_Id; + Decl_Typ : Entity_Id; + Decls : List_Id; + Has_POC : Boolean; + Jump_Block : Node_Id; + Label : Node_Id; + Label_Id : Entity_Id; + Num_Comps : Int; + Stmts : List_Id; + + procedure Process_Component_For_Finalize + (Decl : Node_Id; + Alts : List_Id; + Decls : List_Id; + Stmts : List_Id); + -- Process the declaration of a single controlled component. If + -- flag Is_Local is enabled, create the corresponding label and + -- jump circuitry. Alts is the list of case alternatives, Decls + -- is the top level declaration list where labels are declared + -- and Stmts is the list of finalization actions. + + ------------------------------------ + -- Process_Component_For_Finalize -- + ------------------------------------ + + procedure Process_Component_For_Finalize + (Decl : Node_Id; + Alts : List_Id; + Decls : List_Id; + Stmts : List_Id) + is + Id : constant Entity_Id := Defining_Identifier (Decl); + Typ : constant Entity_Id := Etype (Id); + Fin_Stmt : Node_Id; + + begin + if Is_Local then + declare + Label : Node_Id; + Label_Id : Entity_Id; + + begin + -- Generate: + -- LN : label; + + Label_Id := + Make_Identifier (Loc, + Chars => New_External_Name ('L', Num_Comps)); + Set_Entity (Label_Id, + Make_Defining_Identifier (Loc, Chars (Label_Id))); + Label := Make_Label (Loc, Label_Id); + + Append_To (Decls, + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Entity (Label_Id), + Label_Construct => Label)); + + -- Generate: + -- when N => + -- goto LN; + + Append_To (Alts, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Integer_Literal (Loc, Num_Comps)), + + Statements => New_List ( + Make_Goto_Statement (Loc, + Name => + New_Reference_To (Entity (Label_Id), Loc))))); + + -- Generate: + -- <<LN>> + + Append_To (Stmts, Label); + + -- Decrease the number of components to be processed. + -- This action yields a new Label_Id in future calls. + + Num_Comps := Num_Comps - 1; + end; + end if; + + -- Generate: + -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation + + -- begin -- Exception handlers allowed + -- [Deep_]Finalize (V.Id); + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, + -- Get_Current_Excep.all.all); + -- end if; + -- end; + + Fin_Stmt := + Make_Final_Call ( + Obj_Ref => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_V), + Selector_Name => + Make_Identifier (Loc, Chars (Id))), + Typ => Typ); + + if not Restriction_Active (No_Exception_Propagation) then + Fin_Stmt := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Fin_Stmt), + + Exception_Handlers => New_List ( + Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + end if; + + Append_To (Stmts, Fin_Stmt); + end Process_Component_For_Finalize; + + -- Start of processing for Process_Component_List_For_Finalize + + begin + -- Perform an initial check, look for controlled and per-object + -- constrained components. + + Preprocess_Components (Comps, Num_Comps, Has_POC); + + -- Create a state counter to service the current component list. + -- This step is performed before the variants are inspected in + -- order to generate the same state counter names as those from + -- Build_Initialize_Statements. + + if Num_Comps > 0 + and then Is_Local + then + Counter := Counter + 1; + + Counter_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name ('C', Counter)); + end if; + + -- Process the component in the following order: + -- 1) Variants + -- 2) Per-object constrained components + -- 3) Regular components + + -- Start with the variant parts + + Var_Case := Empty; + if Present (Variant_Part (Comps)) then + declare + Var_Alts : constant List_Id := New_List; + Var : Node_Id; + + begin + Var := First_Non_Pragma (Variants (Variant_Part (Comps))); + while Present (Var) loop + + -- Generate: + -- when <discrete choices> => + -- <finalize statements> + + Append_To (Var_Alts, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_Copy_List (Discrete_Choices (Var)), + Statements => + Process_Component_List_For_Finalize ( + Component_List (Var)))); + + Next_Non_Pragma (Var); + end loop; + + -- Generate: + -- case V.<discriminant> is + -- when <discrete choices 1> => + -- <finalize statements 1> + -- ... + -- when <discrete choices N> => + -- <finalize statements N> + -- end case; + + Var_Case := + Make_Case_Statement (Loc, + Expression => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_V), + Selector_Name => + Make_Identifier (Loc, + Chars (Name (Variant_Part (Comps))))), + Alternatives => Var_Alts); + end; + end if; + + -- The current component list does not have a single controlled + -- component, however it may contain variants. Return the case + -- statement for the variants or nothing. + + if Num_Comps = 0 then + if Present (Var_Case) then + return New_List (Var_Case); + else + return New_List (Make_Null_Statement (Loc)); + end if; + end if; + + -- Prepare all lists + + Alts := New_List; + Decls := New_List; + Stmts := New_List; + + -- Process all per-object constrained components in reverse order + + if Has_POC then + Decl := Last_Non_Pragma (Component_Items (Comps)); + while Present (Decl) loop + Decl_Id := Defining_Identifier (Decl); + Decl_Typ := Etype (Decl_Id); + + -- Skip _parent + + if Chars (Decl_Id) /= Name_uParent + and then Needs_Finalization (Decl_Typ) + and then Has_Access_Constraint (Decl_Id) + and then No (Expression (Decl)) + then + Process_Component_For_Finalize (Decl, Alts, Decls, Stmts); + end if; + + Prev_Non_Pragma (Decl); + end loop; + end if; + + -- Process the rest of the components in reverse order + + Decl := Last_Non_Pragma (Component_Items (Comps)); + while Present (Decl) loop + Decl_Id := Defining_Identifier (Decl); + Decl_Typ := Etype (Decl_Id); + + -- Skip _parent + + if Chars (Decl_Id) /= Name_uParent + and then Needs_Finalization (Decl_Typ) + then + -- Skip per-object constrained components since they were + -- handled in the above step. + + if Has_Access_Constraint (Decl_Id) + and then No (Expression (Decl)) + then + null; + else + Process_Component_For_Finalize (Decl, Alts, Decls, Stmts); + end if; + end if; + + Prev_Non_Pragma (Decl); + end loop; + + -- Generate: + -- declare + -- LN : label; -- If Is_Local is enabled + -- ... . + -- L0 : label; . + + -- begin . + -- case CounterX is . + -- when N => . + -- goto LN; . + -- ... . + -- when 1 => . + -- goto L1; . + -- when others => . + -- goto L0; . + -- end case; . + + -- <<LN>> -- If Is_Local is enabled + -- begin + -- [Deep_]Finalize (V.CompY); + -- exception + -- when Id : others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, + -- Get_Current_Excep.all.all); + -- end if; + -- end; + -- ... + -- <<L0>> -- If Is_Local is enabled + -- end; + + if Is_Local then + + -- Add the declaration of default jump location L0, its + -- corresponding alternative and its place in the statements. + + Label_Id := + Make_Identifier (Loc, New_External_Name ('L', 0)); + Set_Entity (Label_Id, + Make_Defining_Identifier (Loc, Chars (Label_Id))); + Label := Make_Label (Loc, Label_Id); + + Append_To (Decls, -- declaration + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Entity (Label_Id), + Label_Construct => Label)); + + Append_To (Alts, -- alternative + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Others_Choice (Loc)), + + Statements => New_List ( + Make_Goto_Statement (Loc, + Name => + New_Reference_To (Entity (Label_Id), Loc))))); + + Append_To (Stmts, Label); -- statement + + -- Create the jump block + + Prepend_To (Stmts, + Make_Case_Statement (Loc, + Expression => + Make_Identifier (Loc, Chars (Counter_Id)), + Alternatives => Alts)); + end if; + + Jump_Block := + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + + if Present (Var_Case) then + return New_List (Var_Case, Jump_Block); + else + return New_List (Jump_Block); + end if; + end Process_Component_List_For_Finalize; + + -- Start of processing for Build_Finalize_Statements + + begin + if Exceptions_OK then + E_Id := Make_Temporary (Loc, 'E'); + Raised_Id := Make_Temporary (Loc, 'R'); + end if; + + if Nkind (Typ_Def) = N_Derived_Type_Definition then + Rec_Def := Record_Extension_Part (Typ_Def); + else + Rec_Def := Typ_Def; + end if; - return Res; + -- Create a finalization sequence for all record components + + if Present (Component_List (Rec_Def)) then + Bod_Stmts := + Process_Component_List_For_Finalize (Component_List (Rec_Def)); + end if; + + -- A derived record type must finalize all inherited components. This + -- action poses the following problem: + -- + -- procedure Deep_Finalize (Obj : in out Parent_Typ) is + -- begin + -- Finalize (Obj); + -- ... + -- + -- procedure Deep_Finalize (Obj : in out Derived_Typ) is + -- begin + -- Deep_Finalize (Obj._parent); + -- ... + -- Finalize (Obj); + -- ... + -- + -- Finalizing the derived type will invoke Finalize of the parent and + -- then that of the derived type. This is undesirable because both + -- routines may modify shared components. Only the Finalize of the + -- derived type should be invoked. + -- + -- To prevent this double adjustment of shared components, + -- Deep_Finalize uses a flag to control the invocation of Finalize: + -- + -- procedure Deep_Finalize + -- (Obj : in out Some_Type; + -- Flag : Boolean := True) + -- is + -- begin + -- if Flag then + -- Finalize (Obj); + -- end if; + -- ... + -- + -- When Deep_Finalize is invokes for field _parent, a value of False + -- is provided for the flag: + -- + -- Deep_Finalize (Obj._parent, False); + + if Is_Tagged_Type (Typ) + and then Is_Derived_Type (Typ) + then + declare + Par_Typ : constant Entity_Id := Parent_Field_Type (Typ); + Call : Node_Id; + Fin_Stmt : Node_Id; + + begin + if Needs_Finalization (Par_Typ) then + Call := + Make_Final_Call ( + Obj_Ref => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_V), + Selector_Name => + Make_Identifier (Loc, Name_uParent)), + Typ => Par_Typ, + For_Parent => True); + + -- Generate: + -- Deep_Finalize (V._parent, False); -- No_Except_Propag + + -- begin -- Exceptions OK + -- Deep_Finalize (V._parent, False); + -- exception + -- when Id : others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, + -- Get_Current_Excep.all.all); + -- end if; + -- end; + + if Present (Call) then + Fin_Stmt := Call; + + if Exceptions_OK then + Fin_Stmt := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Fin_Stmt), + + Exception_Handlers => New_List ( + Build_Exception_Handler + (Loc, E_Id, Raised_Id)))); + end if; + + Append_To (Bod_Stmts, Fin_Stmt); + end if; + end if; + end; + end if; + + -- Finalize the object. This action must be performed first before + -- all components have been finalized. + + if Is_Controlled (Typ) + and then not Is_Local + then + declare + Fin_Stmt : Node_Id; + Proc : Entity_Id; + + begin + Proc := Find_Prim_Op (Typ, Name_Finalize); + + -- Generate: + -- if F then + -- Finalize (V); -- No_Exception_Propagation + + -- begin + -- Finalize (V); + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, + -- Get_Current_Excep.all.all); + -- end if; + -- end; + -- end if; + + if Present (Proc) then + Fin_Stmt := + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Proc, Loc), + Parameter_Associations => New_List ( + Make_Identifier (Loc, Name_V))); + + if Exceptions_OK then + Fin_Stmt := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Fin_Stmt), + + Exception_Handlers => New_List ( + Build_Exception_Handler + (Loc, E_Id, Raised_Id)))); + end if; + + Prepend_To (Bod_Stmts, + Make_If_Statement (Loc, + Condition => + Make_Identifier (Loc, Name_F), + Then_Statements => New_List (Fin_Stmt))); + end if; + end; + end if; + + -- At this point either all finalization statements have been + -- generated or the type is not controlled. + + if No (Bod_Stmts) then + return New_List (Make_Null_Statement (Loc)); + + -- Generate: + -- declare + -- E : Exception_Occurence; + -- Raised : Boolean := False; + + -- begin + -- if V.Finalized then + -- return; + -- end if; + + -- <finalize statements> + -- V.Finalized := True; + + -- if Raised then + -- Raise_From_Controlled_Operation (E); + -- end if; + -- end; + + else + if Exceptions_OK then + Append_To (Bod_Stmts, + Build_Raise_Statement (Loc, E_Id, Raised_Id)); + end if; + + return + New_List ( + Make_Block_Statement (Loc, + Declarations => + Build_Object_Declarations (Loc, E_Id, Raised_Id), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Bod_Stmts))); + end if; + end Build_Finalize_Statements; + + ----------------------- + -- Parent_Field_Type -- + ----------------------- + + function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is + Field : Entity_Id; + + begin + Field := First_Entity (Typ); + while Present (Field) loop + if Chars (Field) = Name_uParent then + return Etype (Field); + end if; + + Next_Entity (Field); + end loop; + + -- A derived tagged type should always have a parent field + + raise Program_Error; + end Parent_Field_Type; + + --------------------------- + -- Preprocess_Components -- + --------------------------- + + procedure Preprocess_Components + (Comps : Node_Id; + Num_Comps : out Int; + Has_POC : out Boolean) + is + Decl : Node_Id; + Id : Entity_Id; + Typ : Entity_Id; + + begin + Num_Comps := 0; + Has_POC := False; + + Decl := First_Non_Pragma (Component_Items (Comps)); + while Present (Decl) loop + Id := Defining_Identifier (Decl); + Typ := Etype (Id); + + -- Skip field _parent + + if Chars (Id) /= Name_uParent + and then Needs_Finalization (Typ) + then + Num_Comps := Num_Comps + 1; + + if Has_Access_Constraint (Id) + and then No (Expression (Decl)) + then + Has_POC := True; + end if; + end if; + + Next_Non_Pragma (Decl); + end loop; + end Preprocess_Components; + + -- Start of processing for Make_Deep_Record_Body + + begin + case Prim is + when Address_Case => + return Make_Finalize_Address_Stmts (Typ); + + when Adjust_Case => + return Build_Adjust_Statements (Typ); + + when Finalize_Case => + return Build_Finalize_Statements (Typ); + + when Initialize_Case => + declare + Loc : constant Source_Ptr := Sloc (Typ); + + begin + if Is_Controlled (Typ) then + return New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + Find_Prim_Op (Typ, Name_Of (Prim)), Loc), + + Parameter_Associations => New_List ( + Make_Identifier (Loc, Name_V)))); + else + return Empty_List; + end if; + end; + end case; end Make_Deep_Record_Body; ---------------------- @@ -2873,138 +6565,438 @@ package body Exp_Ch7 is ---------------------- function Make_Final_Call - (Ref : Node_Id; - Typ : Entity_Id; - With_Detach : Node_Id) return List_Id + (Obj_Ref : Node_Id; + Typ : Entity_Id; + For_Parent : Boolean := False) return Node_Id is - Loc : constant Source_Ptr := Sloc (Ref); - Res : constant List_Id := New_List; - Cref : Node_Id; - Cref2 : Node_Id; - Proc : Entity_Id; - Utyp : Entity_Id; + Loc : constant Source_Ptr := Sloc (Obj_Ref); + Fin_Id : Entity_Id := Empty; + Ref : Node_Id; + Utyp : Entity_Id; begin + -- Recover the proper type which contains [Deep_]Finalize + if Is_Class_Wide_Type (Typ) then Utyp := Root_Type (Typ); - Cref := Ref; + Ref := Obj_Ref; elsif Is_Concurrent_Type (Typ) then Utyp := Corresponding_Record_Type (Typ); - Cref := Convert_Concurrent (Ref, Typ); + Ref := Convert_Concurrent (Obj_Ref, Typ); elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) and then Is_Concurrent_Type (Full_View (Typ)) then Utyp := Corresponding_Record_Type (Full_View (Typ)); - Cref := Convert_Concurrent (Ref, Full_View (Typ)); + Ref := Convert_Concurrent (Obj_Ref, Full_View (Typ)); + else Utyp := Typ; - Cref := Ref; + Ref := Obj_Ref; end if; Utyp := Underlying_Type (Base_Type (Utyp)); - Set_Assignment_OK (Cref); + Set_Assignment_OK (Ref); - -- Deal with non-tagged derivation of private views. If the parent is - -- now known to be protected, the finalization routine is the one - -- defined on the corresponding record of the ancestor (corresponding - -- records do not automatically inherit operations, but maybe they - -- should???) + -- Deal with non-tagged derivation of private views. If the parent type + -- is a protected type, Deep_Finalize is found on the corresponding + -- record of the ancestor. if Is_Untagged_Derivation (Typ) then if Is_Protected_Type (Typ) then Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); else Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); + + if Is_Protected_Type (Utyp) then + Utyp := Corresponding_Record_Type (Utyp); + end if; end if; - Cref := Unchecked_Convert_To (Utyp, Cref); + Ref := Unchecked_Convert_To (Utyp, Ref); + Set_Assignment_OK (Ref); + end if; - -- We need to set Assignment_OK to prevent problems with unchecked - -- conversions, where we do not want them to be converted back in the - -- case of untagged record derivation (see code in Make_*_Call - -- procedures for similar situations). + -- Deal with derived private types which do not inherit primitives from + -- their parents. In this case, [Deep_]Finalize can be found in the full + -- view of the parent type. - Set_Assignment_OK (Cref); + if Is_Tagged_Type (Utyp) + and then Is_Derived_Type (Utyp) + and then Is_Empty_Elmt_List (Primitive_Operations (Utyp)) + and then Is_Private_Type (Etype (Utyp)) + and then Present (Full_View (Etype (Utyp))) + then + Utyp := Full_View (Etype (Utyp)); + Ref := Unchecked_Convert_To (Utyp, Ref); + Set_Assignment_OK (Ref); end if; - -- If the underlying_type is a subtype, we are dealing with - -- the completion of a private type. We need to access - -- the base type and generate a conversion to it. + -- When dealing with the completion of a private type, use the base type + -- instead. if Utyp /= Base_Type (Utyp) then pragma Assert (Is_Private_Type (Typ)); + Utyp := Base_Type (Utyp); - Cref := Unchecked_Convert_To (Utyp, Cref); + Ref := Unchecked_Convert_To (Utyp, Ref); + Set_Assignment_OK (Ref); end if; - -- Generate: - -- Deep_Finalize (Ref, With_Detach); + -- Select the appropriate version of finalize + + if For_Parent then + if Has_Controlled_Component (Utyp) then + Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize); + end if; + + -- For types that are both controlled and have controlled components, + -- generate a call to Deep_Finalize. + + elsif Is_Controlled (Utyp) + and then Has_Controlled_Component (Utyp) + then + Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize); + + -- For types that are not controlled themselves, but contain controlled + -- components or can be extended by types with controlled components, + -- create a call to Deep_Finalize. - if Has_Controlled_Component (Utyp) - or else Is_Class_Wide_Type (Typ) + elsif Is_Class_Wide_Type (Typ) + or else Is_Interface (Typ) + or else Has_Controlled_Component (Utyp) then if Is_Tagged_Type (Utyp) then - Proc := Find_Prim_Op (Utyp, TSS_Deep_Finalize); + Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize); else - Proc := TSS (Utyp, TSS_Deep_Finalize); + Fin_Id := TSS (Utyp, TSS_Deep_Finalize); end if; - Cref := Convert_View (Proc, Cref); + -- For types that are derived from Controlled and do not have controlled + -- components, build a call to Finalize. - Append_To (Res, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (Proc, Loc), - Parameter_Associations => - New_List (Cref, With_Detach))); + else + Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case)); + end if; - -- Generate: - -- if With_Detach then - -- Finalize_One (Ref); - -- else - -- Finalize (Ref); - -- end if; + if Present (Fin_Id) then + + -- When finalizing a class-wide object, do not convert to the root + -- type in order to produce a dispatching call. + + if Is_Class_Wide_Type (Typ) then + null; + -- Ensure that a finalization routine is at least decorated in order + -- to inspect the object parameter. + + elsif Analyzed (Fin_Id) + or else Ekind (Fin_Id) = E_Procedure + then + -- In certain cases, such as the creation of Stream_Read, the + -- visible entity of the type is its full view. Since Stream_Read + -- will have to create an object of type Typ, the local object + -- will be finalzed by the scope finalizer generated later on. The + -- object parameter of Deep_Finalize will always use the private + -- view of the type. To avoid such a clash between a private and a + -- full view, perform an unchecked conversion of the object + -- reference to the private view. + + declare + Formal_Typ : constant Entity_Id := + Etype (First_Formal (Fin_Id)); + begin + if Is_Private_Type (Formal_Typ) + and then Present (Full_View (Formal_Typ)) + and then Full_View (Formal_Typ) = Utyp + then + Ref := Unchecked_Convert_To (Formal_Typ, Ref); + end if; + end; + + Ref := Convert_View (Fin_Id, Ref); + end if; + + return Make_Call (Loc, Fin_Id, New_Copy_Tree (Ref), For_Parent); else - Proc := Find_Prim_Op (Utyp, Name_Of (Finalize_Case)); + return Empty; + end if; + end Make_Final_Call; - if Chars (With_Detach) = Chars (Standard_True) then - Append_To (Res, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Finalize_One), Loc), - Parameter_Associations => New_List ( - OK_Convert_To (RTE (RE_Finalizable), Cref)))); + -------------------------------- + -- Make_Finalize_Address_Body -- + -------------------------------- - elsif Chars (With_Detach) = Chars (Standard_False) then - Append_To (Res, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (Proc, Loc), - Parameter_Associations => - New_List (Convert_View (Proc, Cref)))); + procedure Make_Finalize_Address_Body (Typ : Entity_Id) is + begin + -- Nothing to do if the type is not controlled or it already has a + -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not + -- come from source. These are usually generated for completeness and + -- do not need the Finalize_Address primitive. + + if not Needs_Finalization (Typ) + or else Present (TSS (Typ, TSS_Finalize_Address)) + or else + (Is_Class_Wide_Type (Typ) + and then Ekind (Root_Type (Typ)) = E_Record_Subtype + and then not Comes_From_Source (Root_Type (Typ))) + then + return; + end if; + + declare + Loc : constant Source_Ptr := Sloc (Typ); + Proc_Id : Entity_Id; + + begin + Proc_Id := + Make_Defining_Identifier (Loc, + Make_TSS_Name (Typ, TSS_Finalize_Address)); + + -- Generate: + -- procedure TypFD (V : System.Address) is + -- begin + -- declare + -- type Pnn is access all Typ; + -- for Pnn'Storage_Size use 0; + -- begin + -- [Deep_]Finalize (Pnn (V).all); + -- end; + -- end TypFD; + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Id, + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_V), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)))), + + Declarations => No_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => + Make_Finalize_Address_Stmts (Typ)))); + + Set_TSS (Typ, Proc_Id); + end; + end Make_Finalize_Address_Body; + --------------------------------- + -- Make_Finalize_Address_Stmts -- + --------------------------------- + + function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Typ); + Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'P'); + Decls : List_Id; + Desg_Typ : Entity_Id; + Obj_Expr : Node_Id; + + begin + if Is_Array_Type (Typ) then + if Is_Constrained (First_Subtype (Typ)) then + Desg_Typ := First_Subtype (Typ); else - Cref2 := New_Copy_Tree (Cref); - Append_To (Res, - Make_Implicit_If_Statement (Ref, - Condition => With_Detach, - Then_Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Finalize_One), Loc), - Parameter_Associations => New_List ( - OK_Convert_To (RTE (RE_Finalizable), Cref)))), - - Else_Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (Proc, Loc), - Parameter_Associations => - New_List (Convert_View (Proc, Cref2)))))); + Desg_Typ := Base_Type (Typ); end if; + + -- Class-wide types of constrained root types + + elsif Is_Class_Wide_Type (Typ) + and then Has_Discriminants (Root_Type (Typ)) + and then not Is_Empty_Elmt_List ( + Discriminant_Constraint (Root_Type (Typ))) + then + declare + Parent_Typ : Entity_Id := Root_Type (Typ); + + begin + -- Climb the parent type chain looking for a non-constrained type + + while Parent_Typ /= Etype (Parent_Typ) + and then Has_Discriminants (Parent_Typ) + and then not Is_Empty_Elmt_List ( + Discriminant_Constraint (Parent_Typ)) + loop + Parent_Typ := Etype (Parent_Typ); + end loop; + + -- Handle views created for tagged types with unknown + -- discriminants. + + if Is_Underlying_Record_View (Parent_Typ) then + Parent_Typ := Underlying_Record_View (Parent_Typ); + end if; + + Desg_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ)); + end; + + -- General case + + else + Desg_Typ := Typ; end if; - return Res; - end Make_Final_Call; + -- Generate: + -- type Ptr_Typ is access all Typ; + -- for Ptr_Typ'Storage_Size use 0; + + Decls := New_List ( + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Reference_To (Desg_Typ, Loc))), + + Make_Attribute_Definition_Clause (Loc, + Name => + New_Reference_To (Ptr_Typ, Loc), + Chars => Name_Storage_Size, + Expression => + Make_Integer_Literal (Loc, 0))); + + Obj_Expr := Make_Identifier (Loc, Name_V); + + -- Unconstrained arrays require special processing in order to retrieve + -- the elements. To achieve this, we have to skip the dope vector which + -- lays infront of the elements and then use a thin pointer to perform + -- the address-to-access conversion. + + if Is_Array_Type (Typ) + and then not Is_Constrained (First_Subtype (Typ)) + then + declare + Dope_Expr : Node_Id; + Dope_Id : Entity_Id; + For_First : Boolean := True; + Index : Node_Id; + + function Bounds_Size_Expression (Typ : Entity_Id) return Node_Id; + -- Given the type of an array index, create the following + -- expression: + -- + -- 2 * Esize (Typ) / Storage_Unit + + ---------------------------- + -- Bounds_Size_Expression -- + ---------------------------- + + function Bounds_Size_Expression (Typ : Entity_Id) return Node_Id is + begin + return + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Integer_Literal (Loc, 2), + Right_Opnd => + Make_Op_Divide (Loc, + Left_Opnd => + Make_Integer_Literal (Loc, Esize (Typ)), + Right_Opnd => + Make_Integer_Literal (Loc, System_Storage_Unit))); + end Bounds_Size_Expression; + + -- Start of processing for arrays + + begin + -- Ensure that Ptr_Typ a thin pointer, generate: + -- + -- for Ptr_Typ'Size use System.Address'Size; + + Append_To (Decls, + Make_Attribute_Definition_Clause (Loc, + Name => + New_Reference_To (Ptr_Typ, Loc), + Chars => Name_Size, + Expression => + Make_Integer_Literal (Loc, System_Address_Size))); + + -- For unconstrained arrays, create the expression which computes + -- the size of the dope vector. Note that in the end, all values + -- will be constant folded. + + Index := First_Index (Typ); + while Present (Index) loop + + -- Generate: + -- 2 * Esize (Index_Typ) / Storage_Unit + + if For_First then + For_First := False; + Dope_Expr := Bounds_Size_Expression (Etype (Index)); + + -- Generate: + -- Dope_Expr + 2 * Esize (Index_Typ) / Storage_Unit + + else + Dope_Expr := + Make_Op_Add (Loc, + Left_Opnd => + Dope_Expr, + Right_Opnd => + Bounds_Size_Expression (Etype (Index))); + end if; + + Next_Index (Index); + end loop; + + -- Generate: + -- Dnn : Storage_Offset := Dope_Expr; + + Dope_Id := Make_Temporary (Loc, 'D'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Dope_Id, + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Storage_Offset), Loc), + Expression => Dope_Expr)); + + -- Shift the address from the start of the dope vector to the + -- start of the elements: + -- + -- V + Dnn + -- + -- Note that this is done through a wrapper routine since RTSfind + -- cannot retrieve operations with string names of the form "+". + + Obj_Expr := + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Add_Offset_To_Address), Loc), + Parameter_Associations => New_List ( + Obj_Expr, + New_Reference_To (Dope_Id, Loc))); + end; + end if; + + -- Create the block and the finalization call + + return New_List ( + Make_Block_Statement (Loc, + Declarations => Decls, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Final_Call ( + Obj_Ref => + Make_Explicit_Dereference (Loc, + Prefix => + Unchecked_Convert_To (Ptr_Typ, Obj_Expr)), + Typ => Desg_Typ))))); + end Make_Finalize_Address_Stmts; ------------------------------------- -- Make_Handler_For_Ctrl_Operation -- @@ -3032,33 +7024,46 @@ package body Exp_Ch7 is -- Procedure call or raise statement begin - if RTE_Available (RE_Raise_From_Controlled_Operation) then + -- .NET/JVM runtime: add choice parameter E and pass it to Reraise_ + -- Occurrence. - -- Standard runtime: add choice parameter E, and pass it to - -- Raise_From_Controlled_Operation so that the original exception - -- name and message can be recorded in the exception message for - -- Program_Error. + if VM_Target /= No_VM then + E_Occ := Make_Defining_Identifier (Loc, Name_E); + Raise_Node := + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Reraise_Occurrence), Loc), + Parameter_Associations => New_List ( + New_Reference_To (E_Occ, Loc))); + + -- Standard runtime: add choice parameter E and pass it to Raise_From_ + -- Controlled_Operation so that the original exception name and message + -- can be recorded in the exception message for Program_Error. + elsif RTE_Available (RE_Raise_From_Controlled_Operation) then E_Occ := Make_Defining_Identifier (Loc, Name_E); - Raise_Node := Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of ( - RTE (RE_Raise_From_Controlled_Operation), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (E_Occ, Loc))); + Raise_Node := + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + RTE (RE_Raise_From_Controlled_Operation), Loc), + Parameter_Associations => New_List ( + New_Reference_To (E_Occ, Loc))); - else - -- Restricted runtime: exception messages are not supported + -- Restricted runtime: exception messages are not supported + else E_Occ := Empty; - Raise_Node := Make_Raise_Program_Error (Loc, - Reason => PE_Finalize_Raised_Exception); + Raise_Node := + Make_Raise_Program_Error (Loc, + Reason => PE_Finalize_Raised_Exception); end if; - return Make_Implicit_Exception_Handler (Loc, - Exception_Choices => New_List (Make_Others_Choice (Loc)), - Choice_Parameter => E_Occ, - Statements => New_List (Raise_Node)); + return + Make_Implicit_Exception_Handler (Loc, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Choice_Parameter => E_Occ, + Statements => New_List (Raise_Node)); end Make_Handler_For_Ctrl_Operation; -------------------- @@ -3066,25 +7071,23 @@ package body Exp_Ch7 is -------------------- function Make_Init_Call - (Ref : Node_Id; - Typ : Entity_Id; - Flist_Ref : Node_Id; - With_Attach : Node_Id) return List_Id + (Obj_Ref : Node_Id; + Typ : Entity_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (Ref); + Loc : constant Source_Ptr := Sloc (Obj_Ref); Is_Conc : Boolean; - Res : constant List_Id := New_List; Proc : Entity_Id; + Ref : Node_Id; Utyp : Entity_Id; - Cref : Node_Id; - Cref2 : Node_Id; - Attach : Node_Id := With_Attach; begin + -- Deal with the type and object reference. Depending on the context, an + -- object reference may need several conversions. + if Is_Concurrent_Type (Typ) then Is_Conc := True; Utyp := Corresponding_Record_Type (Typ); - Cref := Convert_Concurrent (Ref, Typ); + Ref := Convert_Concurrent (Obj_Ref, Typ); elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) @@ -3092,17 +7095,17 @@ package body Exp_Ch7 is then Is_Conc := True; Utyp := Corresponding_Record_Type (Underlying_Type (Typ)); - Cref := Convert_Concurrent (Ref, Underlying_Type (Typ)); + Ref := Convert_Concurrent (Obj_Ref, Underlying_Type (Typ)); else Is_Conc := False; Utyp := Typ; - Cref := Ref; + Ref := Obj_Ref; end if; - Utyp := Underlying_Type (Base_Type (Utyp)); + Set_Assignment_OK (Ref); - Set_Assignment_OK (Cref); + Utyp := Underlying_Type (Base_Type (Utyp)); -- Deal with non-tagged derivation of private views @@ -3110,109 +7113,208 @@ package body Exp_Ch7 is and then not Is_Conc then Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); - Cref := Unchecked_Convert_To (Utyp, Cref); - Set_Assignment_OK (Cref); + Ref := Unchecked_Convert_To (Utyp, Ref); + Set_Assignment_OK (Ref); -- To prevent problems with UC see 1.156 RH ??? end if; - -- If the underlying_type is a subtype, we are dealing with - -- the completion of a private type. We need to access - -- the base type and generate a conversion to it. + -- If the underlying_type is a subtype, then we are dealing with the + -- completion of a private type. We need to access the base type and + -- generate a conversion to it. if Utyp /= Base_Type (Utyp) then pragma Assert (Is_Private_Type (Typ)); Utyp := Base_Type (Utyp); - Cref := Unchecked_Convert_To (Utyp, Cref); + Ref := Unchecked_Convert_To (Utyp, Ref); end if; - -- We do not need to attach to one of the Global Final Lists - -- the objects whose type is Finalize_Storage_Only + -- Select the appropriate version of initialize - if Finalize_Storage_Only (Typ) - and then (Global_Flist_Ref (Flist_Ref) - or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) - = Standard_True) - then - Attach := Make_Integer_Literal (Loc, 0); + if Has_Controlled_Component (Utyp) then + Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case)); + + else + Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case)); + Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref); end if; + -- The object reference may need another conversion depending on the + -- type of the formal and that of the actual. + + Ref := Convert_View (Proc, Ref); + -- Generate: - -- Deep_Initialize (Ref, Flist_Ref); + -- [Deep_]Initialize (Ref); - if Has_Controlled_Component (Utyp) then - Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case)); + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Proc, Loc), + Parameter_Associations => New_List (Ref)); + end Make_Init_Call; - Cref := Convert_View (Proc, Cref, 2); + ------------------------------ + -- Make_Local_Deep_Finalize -- + ------------------------------ - Append_To (Res, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (Proc, Loc), - Parameter_Associations => New_List ( - Node1 => Flist_Ref, - Node2 => Cref, - Node3 => Attach))); + function Make_Local_Deep_Finalize + (Typ : Entity_Id; + Nam : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Formals : List_Id; - -- Generate: - -- Attach_To_Final_List (Ref, Flist_Ref); - -- Initialize (Ref); + begin + Formals := New_List ( - else -- Is_Controlled (Utyp) - Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case)); - Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Cref); + -- V : in out Typ - Cref := Convert_View (Proc, Cref); - Cref2 := New_Copy_Tree (Cref); + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_V), + In_Present => True, + Out_Present => True, + Parameter_Type => + New_Reference_To (Typ, Loc)), - Append_To (Res, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (Proc, Loc), - Parameter_Associations => New_List (Cref2))); + -- F : Boolean := True - Append_To (Res, - Make_Attach_Call (Cref, Flist_Ref, Attach)); + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_F), + Parameter_Type => + New_Reference_To (Standard_Boolean, Loc), + Expression => + New_Reference_To (Standard_True, Loc))); + + -- Add the necessary number of counters to represent the initialization + -- state of an object. + + return + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Nam, + Parameter_Specifications => Formals), + + Declarations => No_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => + Make_Deep_Record_Body (Finalize_Case, Typ, True))); + end Make_Local_Deep_Finalize; + + ---------------------------------------- + -- Make_Set_Finalize_Address_Ptr_Call -- + ---------------------------------------- + + function Make_Set_Finalize_Address_Ptr_Call + (Loc : Source_Ptr; + Typ : Entity_Id; + Ptr_Typ : Entity_Id) return Node_Id + is + Desig_Typ : constant Entity_Id := + Available_View (Designated_Type (Ptr_Typ)); + Utyp : Entity_Id; + + begin + -- If the context is a class-wide allocator, we use the class-wide type + -- to obtain the proper Finalize_Address routine. + + if Is_Class_Wide_Type (Desig_Typ) then + Utyp := Desig_Typ; + + else + Utyp := Typ; + + if Is_Private_Type (Utyp) + and then Present (Full_View (Utyp)) + then + Utyp := Full_View (Utyp); + end if; + + if Is_Concurrent_Type (Utyp) then + Utyp := Corresponding_Record_Type (Utyp); + end if; end if; - return Res; - end Make_Init_Call; + Utyp := Underlying_Type (Base_Type (Utyp)); + + -- Deal with non-tagged derivation of private views. If the parent is + -- now known to be protected, the finalization routine is the one + -- defined on the corresponding record of the ancestor (corresponding + -- records do not automatically inherit operations, but maybe they + -- should???) + + if Is_Untagged_Derivation (Typ) then + if Is_Protected_Type (Typ) then + Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); + else + Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); + + if Is_Protected_Type (Utyp) then + Utyp := Corresponding_Record_Type (Utyp); + end if; + end if; + end if; + + -- If the underlying_type is a subtype, we are dealing with the + -- completion of a private type. We need to access the base type and + -- generate a conversion to it. + + if Utyp /= Base_Type (Utyp) then + pragma Assert (Is_Private_Type (Typ)); + + Utyp := Base_Type (Utyp); + end if; + + -- Generate: + -- Set_Finalize_Address_Ptr + -- (<Ptr_Typ>FC, <Utyp>FD'Unrestricted_Access); + + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Set_Finalize_Address_Ptr), Loc), + + Parameter_Associations => New_List ( + New_Reference_To (Associated_Collection (Ptr_Typ), Loc), + + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (TSS (Utyp, TSS_Finalize_Address), Loc), + Attribute_Name => Name_Unrestricted_Access))); + end Make_Set_Finalize_Address_Ptr_Call; -------------------------- -- Make_Transient_Block -- -------------------------- - -- If finalization is involved, this function just wraps the instruction - -- into a block whose name is the transient block entity, and then - -- Expand_Cleanup_Actions (called on the expansion of the handled - -- sequence of statements will do the necessary expansions for - -- cleanups). - function Make_Transient_Block (Loc : Source_Ptr; - Action : Node_Id) return Node_Id + Action : Node_Id; + Par : Node_Id) return Node_Id is - Flist : constant Entity_Id := Finalization_Chain_Entity (Current_Scope); - Decls : constant List_Id := New_List; - Par : constant Node_Id := Parent (Action); - Instrs : constant List_Id := New_List (Action); - Blk : Node_Id; + Decls : constant List_Id := New_List; + Instrs : constant List_Id := New_List (Action); + Block : Node_Id; + Insert : Node_Id; begin -- Case where only secondary stack use is involved if VM_Target = No_VM and then Uses_Sec_Stack (Current_Scope) - and then No (Flist) and then Nkind (Action) /= N_Simple_Return_Statement and then Nkind (Par) /= N_Exception_Handler then declare - S : Entity_Id; - K : Entity_Kind; + S : Entity_Id; begin S := Scope (Current_Scope); loop - K := Ekind (S); - -- At the outer level, no need to release the sec stack if S = Standard_Standard then @@ -3224,7 +7326,7 @@ package body Exp_Ch7 is -- the result may be lost. The caller is responsible for -- releasing. - elsif K = E_Function then + elsif Ekind (S) = E_Function then Set_Uses_Sec_Stack (Current_Scope, False); if not Requires_Transient_Scope (Etype (S)) then @@ -3237,16 +7339,14 @@ package body Exp_Ch7 is -- In a loop or entry we should install a block encompassing -- all the construct. For now just release right away. - elsif K = E_Loop or else K = E_Entry then + elsif Ekind_In (S, E_Entry, E_Loop) then exit; -- In a procedure or a block, we release on exit of the -- procedure or block. ??? memory leak can be created by -- recursive calls. - elsif K = E_Procedure - or else K = E_Block - then + elsif Ekind_In (S, E_Block, E_Procedure) then Set_Uses_Sec_Stack (S, True); Check_Restriction (No_Secondary_Stack, Action); Set_Uses_Sec_Stack (Current_Scope, False); @@ -3259,26 +7359,29 @@ package body Exp_Ch7 is end; end if; - -- Insert actions stuck in the transient scopes as well as all - -- freezing nodes needed by those actions - - Insert_Actions_In_Scope_Around (Action); - - declare - Last_Inserted : Node_Id := Prev (Action); - begin - if Present (Last_Inserted) then - Freeze_All (First_Entity (Current_Scope), Last_Inserted); - end if; - end; + -- Create the transient block. Set the parent now since the block itself + -- is not part of the tree. - Blk := + Block := Make_Block_Statement (Loc, - Identifier => New_Reference_To (Current_Scope, Loc), + Identifier => + New_Reference_To (Current_Scope, Loc), Declarations => Decls, Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs), + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Instrs), Has_Created_Identifier => True); + Set_Parent (Block, Par); + + -- Insert actions stuck in the transient scopes as well as all freezing + -- nodes needed by those actions. + + Insert_Actions_In_Scope_Around (Action); + + Insert := Prev (Action); + if Present (Insert) then + Freeze_All (First_Entity (Current_Scope), Insert); + end if; -- When the transient scope was established, we pushed the entry for -- the transient scope onto the scope stack, so that the scope was @@ -3287,91 +7390,10 @@ package body Exp_Ch7 is Pop_Scope; - return Blk; + return Block; end Make_Transient_Block; ------------------------ - -- 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 - return - - -- Class-wide types must be treated as controlled and therefore - -- requiring finalization (because they may be extended with an - -- extension that has controlled components. - - (Is_Class_Wide_Type (T) - - -- However, avoid treating class-wide types as controlled if - -- finalization is not available and in particular CIL value - -- types never have finalization). - - and then not In_Finalization_Root (T) - and then not Restriction_Active (No_Finalization) - and then not Is_Value_Type (Etype (T))) - - -- Controlled types always need finalization - - or else Is_Controlled (T) - or else Has_Some_Controlled_Component (T) - - -- For concurrent types, test the corresponding record type - - or else (Is_Concurrent_Type (T) - and then Present (Corresponding_Record_Type (T)) - and then Needs_Finalization (Corresponding_Record_Type (T))); - end Needs_Finalization; - - ------------------------ -- Node_To_Be_Wrapped -- ------------------------ @@ -3459,119 +7481,33 @@ package body Exp_Ch7 is -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2) -- is expanded into : - -- _local_final_list_1 : Finalizable_Ptr; -- X : Typ := [ complex Expression-Action ]; - -- Finalize_One(_v1); - -- Finalize_One (_v2); + -- [Deep_]Finalize (_v1); + -- [Deep_]Finalize (_v2); procedure Wrap_Transient_Declaration (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Next_N : constant Node_Id := Next (N); - Enclosing_S : Entity_Id; - First_Decl_Loc : Source_Ptr; - LC : Entity_Id := Empty; - Nodes : List_Id; - S : Entity_Id; - Uses_SS : Boolean; + Encl_S : Entity_Id; + S : Entity_Id; + Uses_SS : Boolean; begin S := Current_Scope; - Enclosing_S := Scope (S); + Encl_S := Scope (S); -- Insert Actions kept in the Scope stack Insert_Actions_In_Scope_Around (N); -- If the declaration is consuming some secondary stack, mark the - -- Enclosing scope appropriately. + -- enclosing scope appropriately. Uses_SS := Uses_Sec_Stack (S); Pop_Scope; - -- Create a List controller and rename the final list to be its - -- internal final pointer: - -- Lxxx : Simple_List_Controller; - -- Fxxx : Finalizable_Ptr renames Lxxx.F; - - if Present (Finalization_Chain_Entity (S)) then - LC := Make_Temporary (Loc, 'L'); - - -- Use the Sloc of the first declaration of N's containing list, to - -- maintain monotonicity of source-line stepping during debugging. - - First_Decl_Loc := Sloc (First (List_Containing (N))); - - Nodes := New_List ( - Make_Object_Declaration (First_Decl_Loc, - Defining_Identifier => LC, - Object_Definition => - New_Reference_To - (RTE (RE_Simple_List_Controller), First_Decl_Loc)), - - Make_Object_Renaming_Declaration (First_Decl_Loc, - Defining_Identifier => Finalization_Chain_Entity (S), - Subtype_Mark => - New_Reference_To (RTE (RE_Finalizable_Ptr), First_Decl_Loc), - Name => - Make_Selected_Component (Loc, - Prefix => New_Reference_To (LC, First_Decl_Loc), - Selector_Name => Make_Identifier (First_Decl_Loc, Name_F)))); - - -- Put the declaration at the beginning of the declaration part - -- to make sure it will be before all other actions that have been - -- inserted before N. - - Insert_List_Before_And_Analyze (First (List_Containing (N)), Nodes); - - -- Generate the Finalization calls by finalizing the list controller - -- right away. It will be re-finalized on scope exit but it doesn't - -- matter. It cannot be done when the call initializes a renaming - -- object though because in this case, the object becomes a pointer - -- to the temporary and thus increases its life span. Ditto if this - -- is a renaming of a component of an expression (such as a function - -- call). - - -- Note that there is a problem if an actual in the call needs - -- finalization, because in that case the call itself is the master, - -- and the actual should be finalized on return from the call ??? - - if Nkind (N) = N_Object_Renaming_Declaration - and then Needs_Finalization (Etype (Defining_Identifier (N))) - then - null; - - elsif Nkind (N) = N_Object_Renaming_Declaration - and then - Nkind_In (Renamed_Object (Defining_Identifier (N)), - N_Selected_Component, - N_Indexed_Component) - and then - Needs_Finalization - (Etype (Prefix (Renamed_Object (Defining_Identifier (N))))) - then - null; - - -- Finalize the list controller - - else - Nodes := - Make_Final_Call - (Ref => New_Reference_To (LC, Loc), - Typ => Etype (LC), - With_Detach => New_Reference_To (Standard_False, Loc)); - - if Present (Next_N) then - Insert_List_Before_And_Analyze (Next_N, Nodes); - else - Append_List_To (List_Containing (N), Nodes); - end if; - end if; - end if; - -- Put the local entities back in the enclosing scope, and set the -- Is_Public flag appropriately. - Transfer_Entities (S, Enclosing_S); + Transfer_Entities (S, Encl_S); -- Mark the enclosing dynamic scope so that the sec stack will be -- released upon its exit unless this is a function that returns on @@ -3595,87 +7531,68 @@ package body Exp_Ch7 is -- Wrap_Transient_Expression -- ------------------------------- - -- Insert actions before <Expression>: - - -- (lines marked with <CTRL> are expanded only in presence of Controlled - -- objects needing finalization) - - -- _E : Etyp; - -- declare - -- _M : constant Mark_Id := SS_Mark; - -- Local_Final_List : System.FI.Finalizable_Ptr; <CTRL> - - -- procedure _Clean is - -- begin - -- Abort_Defer; - -- System.FI.Finalize_List (Local_Final_List); <CTRL> - -- SS_Release (M); - -- Abort_Undefer; - -- end _Clean; - - -- begin - -- _E := <Expression>; - -- at end - -- _Clean; - -- end; - - -- then expression is replaced by _E - procedure Wrap_Transient_Expression (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - E : constant Entity_Id := Make_Temporary (Loc, 'E', N); - Etyp : constant Entity_Id := Etype (N); Expr : constant Node_Id := Relocate_Node (N); + Loc : constant Source_Ptr := Sloc (N); + Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N); + Typ : constant Entity_Id := Etype (N); begin + -- Generate: + -- Temp : Typ; + -- declare + -- M : constant Mark_Id := SS_Mark; + -- procedure Finalizer is ... (See Build_Finalizer) + -- + -- begin + -- Temp := <Expr>; + -- + -- at end + -- Finalizer; + -- end; + Insert_Actions (N, New_List ( Make_Object_Declaration (Loc, - Defining_Identifier => E, - Object_Definition => New_Reference_To (Etyp, Loc)), + Defining_Identifier => Temp, + Object_Definition => + New_Reference_To (Typ, Loc)), Make_Transient_Block (Loc, Action => Make_Assignment_Statement (Loc, - Name => New_Reference_To (E, Loc), - Expression => Expr)))); + Name => New_Reference_To (Temp, Loc), + Expression => Expr), + Par => Parent (N)))); - Rewrite (N, New_Reference_To (E, Loc)); - Analyze_And_Resolve (N, Etyp); + Rewrite (N, New_Reference_To (Temp, Loc)); + Analyze_And_Resolve (N, Typ); end Wrap_Transient_Expression; ------------------------------ -- Wrap_Transient_Statement -- ------------------------------ - -- Transform <Instruction> into - - -- (lines marked with <CTRL> are expanded only in presence of Controlled - -- objects needing finalization) - - -- declare - -- _M : Mark_Id := SS_Mark; - -- Local_Final_List : System.FI.Finalizable_Ptr ; <CTRL> - - -- procedure _Clean is - -- begin - -- Abort_Defer; - -- System.FI.Finalize_List (Local_Final_List); <CTRL> - -- SS_Release (_M); - -- Abort_Undefer; - -- end _Clean; - - -- begin - -- <Instruction>; - -- at end - -- _Clean; - -- end; - procedure Wrap_Transient_Statement (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - New_Statement : constant Node_Id := Relocate_Node (N); + Loc : constant Source_Ptr := Sloc (N); + New_Stmt : constant Node_Id := Relocate_Node (N); begin - Rewrite (N, Make_Transient_Block (Loc, New_Statement)); + -- Generate: + -- declare + -- M : constant Mark_Id := SS_Mark; + -- procedure Finalizer is ... (See Build_Finalizer) + -- + -- begin + -- <New_Stmt>; + -- + -- at end + -- Finalizer; + -- end; + + Rewrite (N, + Make_Transient_Block (Loc, + Action => New_Stmt, + Par => Parent (N))); -- With the scope stack back to normal, we can call analyze on the -- resulting block. At this point, the transient scope is being diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index 669f998c402..9aa7b0a1192 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,27 +35,41 @@ package Exp_Ch7 is -- Finalization Management -- ----------------------------- - function In_Finalization_Root (E : Entity_Id) return Boolean; - -- True if current scope is in package System.Finalization_Root. Used - -- to avoid certain expansions that would involve circularity in the - -- Rtsfind mechanism. - - procedure Build_Final_List (N : Node_Id; Typ : Entity_Id); - -- Build finalization list for anonymous access types, and for access - -- types that are frozen before their designated types are known to - -- be controlled. - procedure Build_Controlling_Procs (Typ : Entity_Id); -- Typ is a record, and array type having controlled components. -- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize -- that take care of finalization management at run-time. + procedure Build_Finalization_Collection + (Typ : Entity_Id; + Ins_Node : Node_Id := Empty; + Encl_Scope : Entity_Id := Empty); + -- Build a finalization collection for an access type. The designated type + -- may not necessarely be controlled or need finalization actions. The + -- routine creates a wrapper around a user-defined storage pool or the + -- general storage pool for access types. Ins_Nod and Encl_Scope are used + -- in conjunction with anonymous access types. Ins_Node designates the + -- insertion point before which the collection should be added. Encl_Scope + -- is the scope of the context, either the enclosing record or the scope + -- of the related function. + procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id); -- Build one controlling procedure when a late body overrides one of -- the controlling operations. - function Controller_Component (Typ : Entity_Id) return Entity_Id; - -- Returns the entity of the component whose name is 'Name_uController' + function Build_Raise_Statement + (Loc : Source_Ptr; + E_Id : Entity_Id; + R_Id : Entity_Id) return Node_Id; + -- Subsidiary to routines Build_Finalizer, Make_Deep_Array_Body and Make_ + -- Deep_Record_Body. Generate the following conditional raise statement: + -- + -- if R_Id then + -- Raise_From_Controlled_Operation (E_Id); + -- end if; + -- + -- E_Id denotes the defining identifier of a local exception occurrence, + -- R_Id is the entity of a local boolean flag. function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean; -- True if T is a class-wide type, or if it has controlled parts ("part" @@ -64,113 +78,68 @@ package Exp_Ch7 is -- applies, in which case we know that class-wide objects do not contain -- controlled parts. - procedure Expand_Ctrl_Function_Call (N : Node_Id); - -- Expand a call to a function returning a controlled value. That is to - -- say attach the result of the call to the current finalization list, - -- which is the one of the transient scope created for such constructs. - - function Find_Final_List - (E : Entity_Id; - Ref : Node_Id := Empty) return Node_Id; - -- E is an entity representing a controlled object, a controlled type or a - -- scope. If Ref is not empty, it is a reference to a controlled record, - -- the closest Final list is in the controller component of the record - -- containing Ref, otherwise this function returns a reference to the final - -- list attached to the closest dynamic scope (which can be E itself), - -- creating this final list if necessary. - function Has_New_Controlled_Component (E : Entity_Id) return Boolean; -- E is a type entity. Give the same result as Has_Controlled_Component -- except for tagged extensions where the result is True only if the -- latest extension contains a controlled component. - function Make_Attach_Call - (Obj_Ref : Node_Id; - Flist_Ref : Node_Id; - With_Attach : Node_Id) return Node_Id; - -- Attach the referenced object to the referenced Final Chain 'Flist_Ref' - -- With_Attach is an expression of type Short_Short_Integer which can be - -- either '0' to signify no attachment, '1' for attachment to a simply - -- linked list or '2' for attachment to a doubly linked list. - - function Make_Init_Call - (Ref : Node_Id; - Typ : Entity_Id; - Flist_Ref : Node_Id; - With_Attach : Node_Id) return List_Id; - -- Ref is an expression (with no-side effect and is not required to have - -- been previously analyzed) that references the object to be initialized. - -- Typ is the expected type of Ref, which is either a controlled type - -- (Is_Controlled) or a type with controlled components (Has_Controlled). - -- With_Attach is an integer expression which is the attachment level, - -- see System.Finalization_Implementation.Attach_To_Final_List for the - -- documentation of Nb_Link. - -- - -- This function will generate the appropriate calls to make sure that the - -- objects referenced by Ref are initialized. The generated code is quite - -- different for an IS_Controlled type or a HAS_Controlled type, but this - -- is not the problem for the caller, the details are in the body. - function Make_Adjust_Call - (Ref : Node_Id; - Typ : Entity_Id; - Flist_Ref : Node_Id; - With_Attach : Node_Id; - Allocator : Boolean := False) return List_Id; - -- Ref is an expression (with no-side effect and is not required to have - -- been previously analyzed) that references the object to be adjusted. Typ - -- is the expected type of Ref, which is a controlled type (Is_Controlled) - -- or a type with controlled components (Has_Controlled). With_Attach is an - -- integer expression giving the attachment level (see documentation of - -- Attach_To_Final_List.Nb_Link param documentation in s-finimp.ads. - -- Note: if Typ is Finalize_Storage_Only and the object is at library - -- level, then With_Attach will be ignored, and a zero link level will be - -- passed to Attach_To_Final_List. - -- - -- This function will generate the appropriate calls to make sure that the - -- objects referenced by Ref are adjusted. The generated code is quite - -- different depending on the fact the type IS_Controlled or HAS_Controlled - -- but this is not the problem of the caller, the details are in the body. - -- The objects must be attached when the adjust takes place after an - -- initialization expression but not when it takes place after a regular - -- assignment. - -- - -- If Allocator is True, we are adjusting a newly-created object. The - -- existing chaining pointers should not be left unchanged, because they - -- may come from a bit-for-bit copy of those from an initializing object. - -- So, when this flag is True, if the chaining pointers should otherwise - -- be left unset, instead they are reset to null. + (Obj_Ref : Node_Id; + Typ : Entity_Id; + For_Parent : Boolean := False) return Node_Id; + -- Create a call to either Adjust or Deep_Adjust depending on the structure + -- of type Typ. Obj_Ref is an expression with no-side effect (not required + -- to have been previously analyzed) that references the object to be + -- adjusted. Typ is the expected type of Obj_Ref. Flag For_Parent must be + -- set when an adjustment call is being created for field _parent. function Make_Final_Call - (Ref : Node_Id; - Typ : Entity_Id; - With_Detach : Node_Id) return List_Id; - -- Ref is an expression (with no-side effect and is not required to have - -- been previously analyzed) that references the object to be Finalized. - -- Typ is the expected type of Ref, which is a controlled type - -- (Is_Controlled) or a type with controlled components (Has_Controlled). - -- With_Detach is a boolean expression indicating whether to detach the - -- controlled object from whatever finalization list it is currently - -- attached to. - -- - -- This function will generate the appropriate calls to make sure that the - -- objects referenced by Ref are finalized. The generated code is quite - -- different depending on the fact the type IS_Controlled or HAS_Controlled - -- but this is not the problem of the caller, the details are in the body. - -- The objects must be detached when finalizing an unchecked deallocated - -- object but not when finalizing the target of an assignment, it is not - -- necessary either on scope exit. + (Obj_Ref : Node_Id; + Typ : Entity_Id; + For_Parent : Boolean := False) return Node_Id; + -- Create a call to either Finalize or Deep_Finalize depending on the + -- structure of type Typ. Obj_Ref is an expression (with no-side effect and + -- is not required to have been previously analyzed) that references the + -- object to be finalized. Typ is the expected type of Obj_Ref. Flag For_ + -- Parent must be set when a finalization call is being created for field + -- _parent. + + procedure Make_Finalize_Address_Body (Typ : Entity_Id); + -- Create the body of TSS routine Finalize_Address if Typ is controlled and + -- does not have a TSS entry for Finalize_Address. The procedure converts + -- an address into a pointer and subsequently calls Deep_Finalize on the + -- dereference. + + function Make_Init_Call + (Obj_Ref : Node_Id; + Typ : Entity_Id) return Node_Id; + -- Obj_Ref is an expression with no-side effect (not required to have been + -- previously analyzed) that references the object to be initialized. Typ + -- is the expected type of Obj_Ref, which is either a controlled type + -- (Is_Controlled) or a type with controlled components (Has_Controlled_ + -- Components). function Make_Handler_For_Ctrl_Operation (Loc : Source_Ptr) return Node_Id; -- Generate an implicit exception handler with an 'others' choice, -- converting any occurrence to a raise of Program_Error. - function Needs_Finalization (T : Entity_Id) return Boolean; - -- True if T potentially needs finalization actions. True if T is - -- controlled, or has subcomponents. Also True if T is a class-wide type, - -- because some type extension might add controlled subcomponents, except - -- that if pragma Restrictions (No_Finalization) applies, this is False for - -- class-wide types. + function Make_Local_Deep_Finalize + (Typ : Entity_Id; + Nam : Entity_Id) return Node_Id; + -- Create a special version of Deep_Finalize with identifier Nam. The + -- routine has state information and can parform partial finalization. + + function Make_Set_Finalize_Address_Ptr_Call + (Loc : Source_Ptr; + Typ : Entity_Id; + Ptr_Typ : Entity_Id) return Node_Id; + -- Generate the following call: + -- + -- Set_Finalize_Address_Ptr (<Ptr_Typ>FC, <Typ>FD'Unrestricted_Access); + -- + -- where Finalize_Address is the corresponding TSS primitive of type Typ + -- and Ptr_Typ is the access type of the related allocation. Loc is the + -- source location of the related allocator. -------------------------------------------- -- Task and Protected Object finalization -- @@ -204,10 +173,8 @@ package Exp_Ch7 is -- Check whether composite type contains a simple protected component function Is_Simple_Protected_Type (T : Entity_Id) return Boolean; - -- Check whether argument is a protected type without entries. Protected - -- types with entries are controlled, and their cleanup is handled by the - -- standard finalization machinery. For simple protected types we generate - -- inline code to release their locks. + -- Determine whether T denotes a protected type without entires whose + -- _object field is of type System.Tasking.Protected_Objects.Protection. -------------------------------- -- Transient Scope Management -- @@ -225,7 +192,7 @@ package Exp_Ch7 is -- secondary stack is brought in, otherwise it isn't. function Node_To_Be_Wrapped return Node_Id; - -- return the node to be wrapped if the current scope is transient + -- Return the node to be wrapped if the current scope is transient procedure Store_Before_Actions_In_Scope (L : List_Id); -- Append the list L of actions to the end of the before-actions store in diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 6500ea65c6a..d12c92c80d5 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -745,8 +745,8 @@ package body Exp_Ch9 is Obj_Ptr, Type_Definition => Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - New_Reference_To (Rec_Typ, Loc))); + Subtype_Indication => + New_Reference_To (Rec_Typ, Loc))); Set_Debug_Info_Needed (Defining_Identifier (Decl)); Prepend_To (Decls, Decl); end Add_Object_Pointer; @@ -1039,7 +1039,7 @@ package body Exp_Ch9 is -- for the task body. -- In fact the discriminals b) are used in the renaming declarations - -- for e). See details in einfo (Handling of Discriminants). + -- for e). See details in einfo (Handling of Discriminants). if Present (Discriminant_Specifications (N)) then Dlist := New_List; @@ -1185,10 +1185,6 @@ package body Exp_Ch9 is -- Generate the call to the runtime routine Set_Entry_Name with actuals -- _init._task_id or _init._object, Inn and Arg3. - function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id; - -- Given a protected type or its corresponding record, find the type of - -- field _object. - procedure Increment_Index (Stmts : List_Id); -- Generate the following and add it to Stmts -- Inn := Inn + 1; @@ -1367,34 +1363,6 @@ package body Exp_Ch9 is Arg3)); -- Val end Build_Set_Entry_Name_Call; - -------------------------- - -- 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; - --------------------- -- Increment_Index -- --------------------- @@ -7446,9 +7414,6 @@ package body Exp_Ch9 is Op_Body : Node_Id; Op_Id : Entity_Id; - Chain : Entity_Id := Empty; - -- Finalization chain that may be attached to new body - function Build_Dispatching_Subprogram_Body (N : Node_Id; Pid : Node_Id; @@ -7573,25 +7538,6 @@ package body Exp_Ch9 is New_Op_Body := Build_Unprotected_Subprogram_Body (Op_Body, Pid); - -- Propagate the finalization chain to the new body. In the - -- unlikely event that the subprogram contains a declaration - -- or allocator for an object that requires finalization, - -- the corresponding chain is created when analyzing the - -- body, and attached to its entity. This entity is not - -- further elaborated, and so the chain properly belongs to - -- the newly created subprogram body. - - Chain := - Finalization_Chain_Entity (Defining_Entity (Op_Body)); - - if Present (Chain) then - Set_Finalization_Chain_Entity - (Protected_Body_Subprogram - (Corresponding_Spec (Op_Body)), Chain); - Set_Analyzed - (Handled_Statement_Sequence (New_Op_Body), False); - end if; - Insert_After (Current_Node, New_Op_Body); Current_Node := New_Op_Body; Analyze (New_Op_Body); @@ -8223,7 +8169,7 @@ package body Exp_Ch9 is Set_Protected_Body_Subprogram (Defining_Unit_Name (Specification (Comp)), Defining_Unit_Name (Specification (Sub))); - Check_Inlining (Defining_Unit_Name (Specification (Comp))); + Check_Inlining (Defining_Unit_Name (Specification (Comp))); -- Make the protected version of the subprogram available for -- expansion of external calls. diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 47161e93e05..60711df9c48 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -31,7 +31,6 @@ with Elists; use Elists; with Errout; use Errout; with Exp_Atag; use Exp_Atag; with Exp_Ch6; use Exp_Ch6; -with Exp_Ch7; use Exp_Ch7; with Exp_CG; use Exp_CG; with Exp_Dbug; use Exp_Dbug; with Exp_Tss; use Exp_Tss; @@ -4901,7 +4900,7 @@ package body Exp_Disp is -- HT_Link => HT_Link'Address, -- Transportable => <<boolean-value>>, -- Type_Is_Abstract => <<boolean-value>>, - -- RC_Offset => <<integer-value>>, + -- Needs_Finalization => <<boolean-value>>, -- [ Size_Func => Size_Prim'Access ] -- [ Interfaces_Table => <<access-value>> ] -- [ SSD => SSD_Table'Address ] @@ -5183,62 +5182,15 @@ package body Exp_Disp is end; end if; - -- RC_Offset: These are the valid values and their meaning: - - -- >0: For simple types with controlled components is - -- type._record_controller'position - - -- 0: For types with no controlled components - - -- -1: For complex types with controlled components where the position - -- of the record controller is not statically computable but there - -- are controlled components at this level. The _Controller field - -- is available right after the _parent. - - -- -2: There are no controlled components at this level. We need to - -- get the position from the parent. + -- Needs_Finalization: Set if the type is controlled or has controlled + -- components. declare - RC_Offset_Node : Node_Id; + Needs_Fin : Entity_Id; begin - if not Has_Controlled_Component (Typ) then - RC_Offset_Node := Make_Integer_Literal (Loc, 0); - - elsif Etype (Typ) /= Typ - and then Has_Discriminants (Parent_Typ) - then - if Has_New_Controlled_Component (Typ) then - RC_Offset_Node := Make_Integer_Literal (Loc, -1); - else - RC_Offset_Node := Make_Integer_Literal (Loc, -2); - end if; - else - RC_Offset_Node := - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => New_Reference_To (Typ, Loc), - Selector_Name => - New_Reference_To (Controller_Component (Typ), Loc)), - Attribute_Name => Name_Position); - - -- This is not proper Ada code to use the attribute 'Position - -- on something else than an object but this is supported by - -- the back end (see comment on the Bit_Component attribute in - -- sem_attr). So we avoid semantic checking here. - - -- Is this documented in sinfo.ads??? it should be! - - Set_Analyzed (RC_Offset_Node); - Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller)); - Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ); - Set_Etype (Selector_Name (Prefix (RC_Offset_Node)), - RTE (RE_Record_Controller)); - Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset)); - end if; - - Append_To (TSD_Aggr_List, RC_Offset_Node); + Needs_Fin := Boolean_Literals (Needs_Finalization (Typ)); + Append_To (TSD_Aggr_List, New_Occurrence_Of (Needs_Fin, Loc)); end; -- Size_Func diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index dff0044f935..b858c97fc6e 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -875,20 +875,24 @@ package body Exp_Intr is -- structures to find and terminate those components. procedure Expand_Unc_Deallocation (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Arg : constant Node_Id := First_Actual (N); - Typ : constant Entity_Id := Etype (Arg); - Stmts : constant List_Id := New_List; - Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ)); - Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp); - - Desig_T : constant Entity_Id := Designated_Type (Typ); - Gen_Code : Node_Id; - Free_Node : Node_Id; - Deref : Node_Id; - Free_Arg : Node_Id; - Free_Cod : List_Id; - Blk : Node_Id; + Arg : constant Node_Id := First_Actual (N); + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (Arg); + Desig_T : constant Entity_Id := Designated_Type (Typ); + Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ)); + Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp); + Stmts : constant List_Id := New_List; + + Blk : Node_Id; + Deref : Node_Id; + Exc_Occ_Decl : Node_Id; + Exc_Occ_Id : Entity_Id := Empty; + Final_Code : List_Id; + Free_Arg : Node_Id; + Free_Node : Node_Id; + Gen_Code : Node_Id; + Raised_Decl : Node_Id; + Raised_Id : Entity_Id := Empty; Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N); -- This captures whether we know the argument to be non-null so that @@ -929,20 +933,93 @@ package body Exp_Intr is Set_Etype (Deref, Desig_T); end if; - Free_Cod := - Make_Final_Call - (Ref => Deref, - Typ => Desig_T, - With_Detach => New_Reference_To (Standard_True, Loc)); + -- The finalization call is expanded wrapped in a block to catch any + -- possible exception. If an exception does occur, then Program_Error + -- must be raised following the freeing of the object and its removal + -- from the finalization collection's list. We set a flag to record + -- that an exception was raised, and save its occurrence for use in + -- the later raise. + -- + -- Generate: + -- Raised : Boolean := False; + -- Exc_Occ : Exception_Occurrence; + -- + -- begin + -- [Deep_]Finalize (Obj); + -- exception + -- when others => + -- Raised := True; + -- Save_Occurrence (Exc_Occ, Get_Current_Excep.all.all); + -- end; + + Exc_Occ_Id := Make_Temporary (Loc, 'E'); + Raised_Id := Make_Temporary (Loc, 'R'); + + Raised_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Raised_Id, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => + New_Reference_To (Standard_False, Loc)); + + Append_To (Stmts, Raised_Decl); + Analyze (Raised_Decl); + + Exc_Occ_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Exc_Occ_Id, + Object_Definition => + New_Reference_To (RTE (RE_Exception_Occurrence), Loc)); + Set_No_Initialization (Exc_Occ_Decl); + + Append_To (Stmts, Exc_Occ_Decl); + Analyze (Exc_Occ_Decl); + + Final_Code := New_List ( + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Final_Call ( + Obj_Ref => Deref, + Typ => Desig_T)), + Exception_Handlers => New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List ( + Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Raised_Id, Loc), + Expression => + New_Reference_To (Standard_True, Loc)), + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Save_Occurrence), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Exc_Occ_Id, Loc), + Make_Explicit_Dereference (Loc, + Prefix => + Make_Function_Call (Loc, + Name => + Make_Explicit_Dereference (Loc, + Prefix => + New_Reference_To + (RTE (RE_Get_Current_Excep), + Loc)))))))))))); + + -- If aborts are allowed, then the finalization code must be + -- protected by an abort defer/undefer pair. if Abort_Allowed then - Prepend_To (Free_Cod, + Prepend_To (Final_Code, Build_Runtime_Call (Loc, RE_Abort_Defer)); Blk := Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => Free_Cod, + Statements => Final_Code, At_End_Proc => New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc))); @@ -962,7 +1039,7 @@ package body Exp_Intr is Kill_Current_Values; else - Append_List_To (Stmts, Free_Cod); + Append_List_To (Stmts, Final_Code); end if; end if; @@ -1167,6 +1244,21 @@ package body Exp_Intr is end; end if; + -- Generate a test of whether any earlier finalization raised an + -- exception, and in that case raise Program_Error with the previous + -- exception occurrence. + -- + -- Generate: + -- if Raised then + -- Reraise_Occurrence (Exc_Occ); -- for .NET + -- <or> + -- Raise_From_Controlled_Operation (Exc_Occ); -- all other cases + -- end if; + + if Present (Raised_Id) then + Append_To (Stmts, Build_Raise_Statement (Loc, Exc_Occ_Id, Raised_Id)); + end if; + -- If we know the argument is non-null, then make a block statement -- that contains the required statements, no need for a test. diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index b89e088b2f6..0f365e29fe9 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -1198,13 +1198,14 @@ package body Exp_Strm is Return_Object_Declarations => New_List (Obj_Decl), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - New_List (Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), - Attribute_Name => Name_Read, - Expressions => New_List ( - Make_Identifier (Loc, Name_S), - Make_Identifier (Loc, Name_V))))))); - + Statements => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V))))))); else Append_To (Decls, Obj_Decl); diff --git a/gcc/ada/exp_tss.ads b/gcc/ada/exp_tss.ads index d6a18fb1bfe..0fd967edd14 100644 --- a/gcc/ada/exp_tss.ads +++ b/gcc/ada/exp_tss.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -82,6 +82,7 @@ package Exp_Tss is TSS_Deep_Finalize : constant TNT := "DF"; -- Deep Finalize TSS_Deep_Initialize : constant TNT := "DI"; -- Deep Initialize TSS_Composite_Equality : constant TNT := "EQ"; -- Composite Equality + TSS_Finalize_Address : constant TNT := "FD"; -- Finalize Address TSS_From_Any : constant TNT := "FA"; -- PolyORB/DSA From_Any TSS_Init_Proc : constant TNT := "IP"; -- Initialization Procedure TSS_CPP_Init_Proc : constant TNT := "IC"; -- Init C++ dispatch tables @@ -103,6 +104,7 @@ package Exp_Tss is TSS_Deep_Finalize, TSS_Deep_Initialize, TSS_Composite_Equality, + TSS_Finalize_Address, TSS_From_Any, TSS_Init_Proc, TSS_CPP_Init_Proc, diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 7557a125a2a..9388e664a0c 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 -- ---------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index ae938a03504..e9b373d0e3f 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -118,6 +118,13 @@ package Exp_Util is -- Assoc_Node is the node with which the actions are associated. -- Ins_Actions may be No_List, in which case the call has no effect. + procedure Insert_Action_After + (Assoc_Node : Node_Id; + Ins_Action : Node_Id); + -- Assoc_Node must be a node in a list. Same as Insert_Action but the + -- action will be inserted after N in a manner that is compatible with + -- the transient scope mechanism. + procedure Insert_Actions_After (Assoc_Node : Node_Id; Ins_Actions : List_Id); @@ -187,6 +194,30 @@ package Exp_Util is -- Note that the added nodes are not analyzed. The analyze call is found in -- Exp_Ch13.Expand_N_Freeze_Entity. + procedure Build_Allocate_Deallocate_Proc + (N : Node_Id; + Is_Allocate : Boolean); + -- Create a custom Allocate/Deallocate to be associated with an allocation + -- or deallocation of a controlled or class-wide object. In the case of + -- allocation, N is the declaration of the temporary variable which + -- represents the expression of the original allocator node, otherwise N + -- must be a free statement. If flag Is_Allocate is set, the generated + -- routine is allocate, deallocate otherwise. The generated routine is: + -- + -- F : constant Boolean := -- CW case + -- Ada.Tags.Needs_Finalization (<Expr>'Tag); -- CW case + -- + -- procedure Allocate / Deallocate + -- (P : Storage_Pool; + -- A : [out] Address; -- out is present for Allocate + -- S : Storage_Count; + -- L : Storage_Count) + -- is + -- begin + -- Allocate / Deallocate + -- (<Ptr_Typ collection>, A, S, L, [Needs_Header => F]); + -- end Allocate; + function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id; -- Build an N_Procedure_Call_Statement calling the given runtime entity. -- The call has no parameters. The first argument provides the location @@ -393,6 +424,10 @@ package Exp_Util is -- in which this routine is invoked should always have a protection -- object. + function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id; + -- Given a protected type or its corresponding record, find the type of + -- field _object. + procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False); @@ -448,9 +483,21 @@ package Exp_Util is function Get_Stream_Size (E : Entity_Id) return Uint; -- Return the stream size value of the subtype E - function Has_Controlled_Coextensions (Typ : Entity_Id) return Boolean; - -- Determine whether a record type has anonymous access discriminants with - -- a controlled designated type. + function Has_Access_Constraint (E : Entity_Id) return Boolean; + -- Given object or type E, determine whether a discriminant is of an access + -- type. + + function Has_Controlled_Objects (N : Node_Id) return Boolean; + -- Given an arbitrary node N, determine whether it has a declarative or a + -- statement part and whether those lists contain at least one controlled + -- object. + + function Has_Controlled_Objects + (L : List_Id; + For_Package : Boolean) return Boolean; + -- Given a list, determine whether L contains at least one controlled + -- object. Flag For_Package should be set when the list comes from a + -- package spec or body. function Has_Following_Address_Clause (D : Node_Id) return Boolean; -- D is the node for an object declaration. This function searches the @@ -468,6 +515,10 @@ package Exp_Util is function Inside_Init_Proc return Boolean; -- Returns True if current scope is within an init proc + function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean; + -- Given an arbitrary entity, determine whether it appears at the library + -- level of a package body. + function In_Unconditional_Context (Node : Node_Id) return Boolean; -- Node is the node for a statement or a component of a statement. This -- function determines if the statement appears in a context that is @@ -479,6 +530,14 @@ package Exp_Util is -- False otherwise. True for an empty list. It is an error to call this -- routine with No_List as the argument. + function Is_Finalizable_Transient + (Decl : Node_Id; + Rel_Node : Node_Id) return Boolean; + -- Determine whether declaration Decl denotes a controlled transient which + -- should be finalized. Rel_Node is the related context. Even though some + -- transient are controlled, they may act as renamings of other objects or + -- function calls. + function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean; -- Tests given type T, and returns True if T is a non-discriminated tagged -- type which has a record representation clause that specifies the layout @@ -492,6 +551,13 @@ package Exp_Util is -- Return True if Typ is a library level tagged type. Currently we use -- this information to build statically allocated dispatch tables. + function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean; + -- Determine whether node Expr denotes a build-in-place function call with + -- a value of "null" for extra formal BIPaccess. + + function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean; + -- Determine whether node Expr denotes a non build-in-place function call + function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean; -- Determine whether the node P is a reference to a bit packed array, i.e. -- whether the designated object is a component of a bit packed array, or a @@ -504,6 +570,10 @@ package Exp_Util is -- whether the designated object is bit packed slice or a component of a -- bit packed slice. Return True if so. + function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean; + -- Determine whether object Id is related to an expanded return statement. + -- The case concerned is "return Id.all;". + function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean; -- Determine whether the node P is a slice of an array where the slice -- result may cause alignment problems because it has an alignment that @@ -614,6 +684,12 @@ package Exp_Util is -- consist of constants, when the object has a non-trivial initialization -- or is controlled. + function Needs_Finalization (T : Entity_Id) return Boolean; + -- True if type T is controlled, or has controlled subcomponents. Also + -- True if T is a class-wide type, because some type extension might add + -- controlled subcomponents, except that if pragma Restrictions + -- (No_Finalization) applies, this is False for class-wide types. + function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id; -- An anonymous access type may designate a limited view. Check whether -- non-limited view is available during expansion, to examine components diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index 308b5d76934..ffb8dad1162 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -211,6 +211,9 @@ package body Expander is when N_Extension_Aggregate => Expand_N_Extension_Aggregate (N); + when N_Free_Statement => + Expand_N_Free_Statement (N); + when N_Freeze_Entity => Expand_N_Freeze_Entity (N); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index c9d47bd8a06..cec09edc30f 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1190,7 +1190,6 @@ package body Freeze is Set_Expression (Par, New_Occurrence_Of (Temp, Loc)); return True; - else return False; end if; @@ -1303,7 +1302,7 @@ package body Freeze is Subp : Entity_Id; begin - Prim := First_Elmt (Prim_List); + Prim := First_Elmt (Prim_List); while Present (Prim) loop Subp := Node (Prim); @@ -1448,13 +1447,27 @@ package body Freeze is end loop; end; + -- We add finalization collections to access types whose designated + -- types require finalization. This is normally done when freezing + -- the type, but this misses recursive type definitions where the + -- later members of the recursion introduce controlled components + -- (such as can happen when incomplete types are involved), as well + -- cases where a component type is private and the controlled full + -- type occurs after the access type is frozen. Cases that don't + -- need a finalization collection are generic formal types (the + -- actual type will have it) and types with Java and CIL conventions, + -- since those are used for API bindings. (Are there any other cases + -- that should be excluded here???) + elsif Is_Access_Type (E) and then Comes_From_Source (E) - and then Ekind (Directly_Designated_Type (E)) = E_Incomplete_Type + and then not Is_Generic_Type (E) and then Needs_Finalization (Designated_Type (E)) - and then No (Associated_Final_Chain (E)) + and then No (Associated_Collection (E)) + and then Convention (Designated_Type (E)) /= Convention_Java + and then Convention (Designated_Type (E)) /= Convention_CIL then - Build_Final_List (Parent (E), E); + Build_Finalization_Collection (E); end if; Next_Entity (E); @@ -1800,40 +1813,6 @@ package body Freeze is -- Start of processing for Freeze_Record_Type begin - -- If this is a subtype of a controlled type, declared without a - -- constraint, the _controller may not appear in the component list - -- if the parent was not frozen at the point of subtype declaration. - -- Inherit the _controller component now. - - if Rec /= Base_Type (Rec) - and then Has_Controlled_Component (Rec) - then - if Nkind (Parent (Rec)) = N_Subtype_Declaration - and then Is_Entity_Name (Subtype_Indication (Parent (Rec))) - then - Set_First_Entity (Rec, First_Entity (Base_Type (Rec))); - - -- If this is an internal type without a declaration, as for - -- record component, the base type may not yet be frozen, and its - -- controller has not been created. Add an explicit freeze node - -- for the itype, so it will be frozen after the base type. This - -- freeze node is used to communicate with the expander, in order - -- to create the controller for the enclosing record, and it is - -- deleted afterwards (see exp_ch3). It must not be created when - -- expansion is off, because it might appear in the wrong context - -- for the back end. - - elsif Is_Itype (Rec) - and then Has_Delayed_Freeze (Base_Type (Rec)) - and then - Nkind (Associated_Node_For_Itype (Rec)) = - N_Component_Declaration - and then Expander_Active - then - Ensure_Freeze_Node (Rec); - end if; - end if; - -- Freeze components and embedded subtypes Comp := First_Entity (Rec); @@ -2747,23 +2726,24 @@ package body Freeze is if Has_Foreign_Convention (E) - -- We are looking for a return of unconstrained array + -- We are looking for a return of unconstrained array and then Is_Array_Type (R_Type) and then not Is_Constrained (R_Type) - -- Exclude imported routines, the warning does not - -- belong on the import, but on the routine definition. + -- Exclude imported routines, the warning does not + -- belong on the import, but rather on the routine + -- definition. and then not Is_Imported (E) - -- Exclude VM case, since both .NET and JVM can handle - -- return of unconstrained arrays without a problem. + -- Exclude VM case, since both .NET and JVM can handle + -- return of unconstrained arrays without a problem. and then VM_Target = No_VM - -- Check that general warning is enabled, and that it - -- is not suppressed for this particular case. + -- Check that general warning is enabled, and that it + -- is not suppressed for this particular case. and then Warn_On_Export_Import and then not Has_Warnings_Off (E) @@ -3940,7 +3920,7 @@ package body Freeze is if Is_Pure_Unit_Access_Type (E) and then (Ada_Version < Ada_2005 - or else not No_Pool_Assigned (E)) + or else not No_Pool_Assigned (E)) then Error_Msg_N ("named access type not allowed in pure unit", E); @@ -5469,13 +5449,13 @@ package body Freeze is elsif Is_Array_Type (Retype) and then not Is_Constrained (Retype) - -- Exclude cases where descriptor mechanism is set, since the - -- VMS descriptor mechanisms allow such unconstrained returns. + -- Exclude cases where descriptor mechanism is set, since the + -- VMS descriptor mechanisms allow such unconstrained returns. and then Mechanism (E) not in Descriptor_Codes - -- Check appropriate warning is enabled (should we check for - -- Warnings (Off) on specific entities here, probably so???) + -- Check appropriate warning is enabled (should we check for + -- Warnings (Off) on specific entities here, probably so???) and then Warn_On_Export_Import @@ -5745,11 +5725,10 @@ package body Freeze is Declarations => New_List ( Make_Object_Declaration (Loc, Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('T')), - Object_Definition => - New_Occurrence_Of (Etype (Formal), Loc), - Expression => New_Copy_Tree (Dcopy))), + Make_Temporary (Loc, 'T'), + Object_Definition => + New_Occurrence_Of (Etype (Formal), Loc), + Expression => New_Copy_Tree (Dcopy))), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 5f5a4a01b05..ec534e1f3f2 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -960,9 +960,7 @@ package body Inline is Set_Uses_Sec_Stack (Protected_Body_Subprogram (Scop), Uses_Sec_Stack (Scop)); - Set_Finalization_Chain_Entity - (Protected_Body_Subprogram (Scop), - Finalization_Chain_Entity (Scop)); + Scop := Protected_Body_Subprogram (Scop); end if; diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 78a55ed8a59..eab4a10db28 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -461,6 +461,13 @@ package body Lib.Writ is Write_Info_Str (" O"); Write_Info_Char (OA_Setting (Unit_Num)); + if (Ekind (Uent) = E_Package + or else Ekind (Uent) = E_Package_Body) + and then Present (Finalizer (Uent)) + then + Write_Info_Str (" PF"); + end if; + if Is_Preelaborated (Uent) then Write_Info_Str (" PR"); end if; diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index fa75a4dd547..98786f48dc5 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -497,6 +497,8 @@ package Lib.Writ is -- units in this file. All files in the partition that specify -- a default must specify the same default. -- + -- PF The unit has a library-level (package) finalizer + -- -- PK Unit is package, rather than a subprogram -- -- PU Unit has pragma Pure diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 8d45b2c3cb9..f2fc7654108 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -35,13 +35,13 @@ package body Ch4 is -- Attributes that cannot have arguments Is_Parameterless_Attribute : constant Attribute_Class_Array := - (Attribute_Body_Version => True, + (Attribute_Base => True, + Attribute_Body_Version => True, + Attribute_Class => True, Attribute_External_Tag => True, Attribute_Img => True, - Attribute_Version => True, - Attribute_Base => True, - Attribute_Class => True, Attribute_Stub_Type => True, + Attribute_Version => True, Attribute_Type_Key => True, others => False); -- This map contains True for parameterless attributes that return a diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 29257dc4c25..652ec29c61f 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -112,7 +112,7 @@ package Rtsfind is -- package see declarations in the runtime entity table below. RTU_Null, - -- Used as a null entry. Will cause an error if referenced + -- Used as a null entry. Will cause an error if referenced. -- Children of Ada @@ -138,7 +138,7 @@ package Rtsfind is -- Children of Ada.Finalization - Ada_Finalization_List_Controller, + Ada_Finalization_Heap_Management, -- Children of Ada.Interrupts @@ -245,7 +245,6 @@ package Rtsfind is System_Fat_VAX_D_Float, System_Fat_VAX_F_Float, System_Fat_VAX_G_Float, - System_Finalization_Implementation, System_Finalization_Root, System_Fore, System_Img_Bool, @@ -400,7 +399,7 @@ package Rtsfind is -- Range of values for children of Ada.Dispatching subtype Ada_Finalization_Child is Ada_Child range - Ada_Finalization_List_Controller .. Ada_Finalization_List_Controller; + Ada_Finalization_Heap_Management .. Ada_Finalization_Heap_Management; -- Range of values for children of Ada.Finalization subtype Ada_Interrupts_Child is Ada_Child range @@ -500,6 +499,7 @@ package Rtsfind is RE_Code_Loc, -- Ada.Exceptions RE_Current_Target_Exception, -- Ada.Exceptions (JGNAT use only) RE_Exception_Id, -- Ada.Exceptions + RE_Exception_Identity, -- Ada.Exceptions RE_Exception_Information, -- Ada.Exceptions RE_Exception_Message, -- Ada.Exceptions RE_Exception_Name_Simple, -- Ada.Exceptions @@ -515,8 +515,14 @@ package Rtsfind is RE_Reraise_Occurrence_No_Defer, -- Ada.Exceptions RE_Save_Occurrence, -- Ada.Exceptions - RE_Simple_List_Controller, -- Ada.Finalization.List_Controller - RE_List_Controller, -- Ada.Finalization.List_Controller + RE_Add_Offset_To_Address, -- Ada.Finalization.Heap_Management + RE_Allocate, -- Ada.Finalization.Heap_Management + RE_Base_Pool, -- Ada.Finalization.Heap_Management + RE_Deallocate, -- Ada.Finalization.Heap_Management + RE_Finalization_Collection, -- Ada.Finalization.Heap_Management + RE_Finalization_Collection_Ptr, -- Ada.Finalization.Heap_Management + RE_Set_Finalize_Address_Ptr, -- Ada.Finalization.Heap_Management + RE_Set_Storage_Pool_Ptr, -- Ada.Finalization.Heap_Management RE_Interrupt_ID, -- Ada.Interrupts RE_Is_Reserved, -- Ada.Interrupts @@ -576,6 +582,7 @@ package Rtsfind is RE_Interface_Tag, -- Ada.Tags RE_IW_Membership, -- Ada.Tags RE_Max_Predef_Prims, -- Ada.Tags + RE_Needs_Finalization, -- Ada.Tags RE_No_Dispatch_Table_Wrapper, -- Ada.Tags RE_NDT_Prims_Ptr, -- Ada.Tags RE_NDT_TSD, -- Ada.Tags @@ -788,16 +795,6 @@ package Rtsfind is RE_Attr_VAX_G_Float, -- System.Fat_VAX_G_Float RE_Fat_VAX_G, -- System.Fat_VAX_G_Float - RE_Attach_To_Final_List, -- System.Finalization_Implementation - RE_Finalizable_Ptr_Ptr, -- System.Finalization_Implementation - RE_Move_Final_List, -- System.Finalization_Implementation - RE_Finalize_List, -- System.Finalization_Implementation - RE_Finalize_One, -- System.Finalization_Implementation - RE_Global_Final_List, -- System.Finalization_Implementation - RE_Record_Controller, -- System.Finalization_Implementation - RE_Limited_Record_Controller, -- System.Finalization_Implementation - RE_Deep_Tag_Attach, -- System.Finalization_Implementation - RE_Root_Controlled, -- System.Finalization_Root RE_Finalizable, -- System.Finalization_Root RE_Finalizable_Ptr, -- System.Finalization_Root @@ -1314,8 +1311,9 @@ package Rtsfind is RE_Exception_Data_Ptr, -- System.Standard_Library RE_Integer_Address, -- System.Storage_Elements - RE_Storage_Offset, -- System.Storage_Elements RE_Storage_Array, -- System.Storage_Elements + RE_Storage_Count, -- System.Storage_Elements + RE_Storage_Offset, -- System.Storage_Elements RE_To_Address, -- System.Storage_Elements RE_Root_Storage_Pool, -- System.Storage_Pools @@ -1439,6 +1437,7 @@ package Rtsfind is RE_Enter_Master, -- System.Soft_Links RE_Get_Current_Excep, -- System.Soft_Links RE_Get_GNAT_Exception, -- System.Soft_Links + RE_Save_Library_Occurrence, -- System.Soft_Links RE_Update_Exception, -- System.Soft_Links RE_Bits_1, -- System.Unsigned_Types @@ -1677,6 +1676,7 @@ package Rtsfind is RE_Code_Loc => Ada_Exceptions, RE_Current_Target_Exception => Ada_Exceptions, -- of JGNAT RE_Exception_Id => Ada_Exceptions, + RE_Exception_Identity => Ada_Exceptions, RE_Exception_Information => Ada_Exceptions, RE_Exception_Message => Ada_Exceptions, RE_Exception_Name_Simple => Ada_Exceptions, @@ -1692,8 +1692,14 @@ package Rtsfind is RE_Reraise_Occurrence_No_Defer => Ada_Exceptions, RE_Save_Occurrence => Ada_Exceptions, - RE_Simple_List_Controller => Ada_Finalization_List_Controller, - RE_List_Controller => Ada_Finalization_List_Controller, + RE_Add_Offset_To_Address => Ada_Finalization_Heap_Management, + RE_Allocate => Ada_Finalization_Heap_Management, + RE_Base_Pool => Ada_Finalization_Heap_Management, + RE_Deallocate => Ada_Finalization_Heap_Management, + RE_Finalization_Collection => Ada_Finalization_Heap_Management, + RE_Finalization_Collection_Ptr => Ada_Finalization_Heap_Management, + RE_Set_Finalize_Address_Ptr => Ada_Finalization_Heap_Management, + RE_Set_Storage_Pool_Ptr => Ada_Finalization_Heap_Management, RE_Interrupt_ID => Ada_Interrupts, RE_Is_Reserved => Ada_Interrupts, @@ -1753,6 +1759,7 @@ package Rtsfind is RE_Interface_Tag => Ada_Tags, RE_IW_Membership => Ada_Tags, RE_Max_Predef_Prims => Ada_Tags, + RE_Needs_Finalization => Ada_Tags, RE_No_Dispatch_Table_Wrapper => Ada_Tags, RE_NDT_Prims_Ptr => Ada_Tags, RE_NDT_TSD => Ada_Tags, @@ -1965,16 +1972,6 @@ package Rtsfind is RE_Attr_VAX_G_Float => System_Fat_VAX_G_Float, RE_Fat_VAX_G => System_Fat_VAX_G_Float, - RE_Attach_To_Final_List => System_Finalization_Implementation, - RE_Finalizable_Ptr_Ptr => System_Finalization_Implementation, - RE_Move_Final_List => System_Finalization_Implementation, - RE_Finalize_List => System_Finalization_Implementation, - RE_Finalize_One => System_Finalization_Implementation, - RE_Global_Final_List => System_Finalization_Implementation, - RE_Record_Controller => System_Finalization_Implementation, - RE_Limited_Record_Controller => System_Finalization_Implementation, - RE_Deep_Tag_Attach => System_Finalization_Implementation, - RE_Root_Controlled => System_Finalization_Root, RE_Finalizable => System_Finalization_Root, RE_Finalizable_Ptr => System_Finalization_Root, @@ -2491,8 +2488,9 @@ package Rtsfind is RE_Exception_Data_Ptr => System_Standard_Library, RE_Integer_Address => System_Storage_Elements, - RE_Storage_Offset => System_Storage_Elements, RE_Storage_Array => System_Storage_Elements, + RE_Storage_Count => System_Storage_Elements, + RE_Storage_Offset => System_Storage_Elements, RE_To_Address => System_Storage_Elements, RE_Root_Storage_Pool => System_Storage_Pools, @@ -2616,6 +2614,7 @@ package Rtsfind is RE_Enter_Master => System_Soft_Links, RE_Get_Current_Excep => System_Soft_Links, RE_Get_GNAT_Exception => System_Soft_Links, + RE_Save_Library_Occurrence => System_Soft_Links, RE_Update_Exception => System_Soft_Links, RE_Bits_1 => System_Unsigned_Types, diff --git a/gcc/ada/s-finimp.adb b/gcc/ada/s-finimp.adb deleted file mode 100644 index 050f79995ec..00000000000 --- a/gcc/ada/s-finimp.adb +++ /dev/null @@ -1,540 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . F I N A L I Z A T I O N _ I M P L E M E N T A T I O N -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Exceptions; -with Ada.Tags; - -with System.Soft_Links; - -with System.Restrictions; - -package body System.Finalization_Implementation is - - use Ada.Exceptions; - use System.Finalization_Root; - - package SSL renames System.Soft_Links; - - use type SSE.Storage_Offset; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - type RC_Ptr is access all Record_Controller; - - function To_RC_Ptr is - new Ada.Unchecked_Conversion (Address, RC_Ptr); - - procedure Raise_From_Controlled_Operation (X : Exception_Occurrence); - pragma Import - (Ada, Raise_From_Controlled_Operation, - "ada__exceptions__raise_from_controlled_operation"); - pragma No_Return (Raise_From_Controlled_Operation); - -- Raise Program_Error from an exception that occurred during an Adjust or - -- Finalize operation. We use this rather kludgy Ada Import interface - -- because this procedure is not available in the visible part of the - -- Ada.Exceptions spec. - - procedure Raise_From_Finalize - (L : Finalizable_Ptr; - From_Abort : Boolean; - E_Occ : Exception_Occurrence); - -- Deal with an exception raised during finalization of a list. L is a - -- pointer to the list of element not yet finalized. From_Abort is true - -- if the finalization actions come from an abort rather than a normal - -- exit. E_Occ represents the exception being raised. - - function RC_Offset (T : Ada.Tags.Tag) return SSE.Storage_Offset; - pragma Import (Ada, RC_Offset, "ada__tags__get_rc_offset"); - - function Parent_Size (Obj : Address; T : Ada.Tags.Tag) - return SSE.Storage_Count; - pragma Import (Ada, Parent_Size, "ada__tags__parent_size"); - - function Get_Deep_Controller (Obj : System.Address) return RC_Ptr; - -- Given the address (obj) of a tagged object, return a - -- pointer to the record controller of this object. - - ------------ - -- Adjust -- - ------------ - - overriding procedure Adjust (Object : in out Record_Controller) is - - First_Comp : Finalizable_Ptr; - My_Offset : constant SSE.Storage_Offset := - Object.My_Address - Object'Address; - - procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr); - -- Subtract the offset to the pointer - - procedure Reverse_Adjust (P : Finalizable_Ptr); - -- Adjust the components in the reverse order in which they are stored - -- on the finalization list. (Adjust and Finalization are not done in - -- the same order) - - ---------------- - -- Ptr_Adjust -- - ---------------- - - procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr) is - begin - if Ptr /= null then - Ptr := To_Finalizable_Ptr (To_Addr (Ptr) - My_Offset); - end if; - end Ptr_Adjust; - - -------------------- - -- Reverse_Adjust -- - -------------------- - - procedure Reverse_Adjust (P : Finalizable_Ptr) is - begin - if P /= null then - Ptr_Adjust (P.Next); - Reverse_Adjust (P.Next); - Adjust (P.all); - Object.F := P; -- Successfully adjusted, so place in list - end if; - end Reverse_Adjust; - - -- Start of processing for Adjust - - begin - -- Adjust the components and their finalization pointers next. We must - -- protect against an exception in some call to Adjust, so we keep - -- pointing to the list of successfully adjusted components, which can - -- be finalized if an exception is raised. - - First_Comp := Object.F; - Object.F := null; -- nothing adjusted yet. - Ptr_Adjust (First_Comp); -- set address of first component. - Reverse_Adjust (First_Comp); - - -- Then Adjust the controller itself - - Object.My_Address := Object'Address; - - exception - when others => - -- Finalize those components that were successfully adjusted, and - -- propagate exception. The object itself is not yet attached to - -- global finalization list, so we cannot rely on the outer call to - -- Clean to take care of these components. - - Finalize (Object); - raise; - end Adjust; - - -------------------------- - -- Attach_To_Final_List -- - -------------------------- - - procedure Attach_To_Final_List - (L : in out Finalizable_Ptr; - Obj : in out Finalizable; - Nb_Link : Short_Short_Integer) - is - begin - -- Simple case: attachment to a one way list - - if Nb_Link = 1 then - Obj.Next := L; - L := Obj'Unchecked_Access; - - -- Dynamically allocated objects: they are attached to a doubly linked - -- list, so that an element can be finalized at any moment by means of - -- an unchecked deallocation. Attachment is protected against - -- multi-threaded access. - - elsif Nb_Link = 2 then - - -- Raise Program_Error if we're trying to allocate an object in a - -- collection whose finalization has already started. - - if L = Collection_Finalization_Started then - raise Program_Error with - "allocation after collection finalization started"; - end if; - - Locked_Processing : begin - SSL.Lock_Task.all; - Obj.Next := L.Next; - Obj.Prev := L.Next.Prev; - L.Next.Prev := Obj'Unchecked_Access; - L.Next := Obj'Unchecked_Access; - SSL.Unlock_Task.all; - - exception - when others => - SSL.Unlock_Task.all; - raise; - end Locked_Processing; - - -- Attachment of arrays to the final list (used only for objects - -- returned by function). Obj, in this case is the last element, - -- but all other elements are already threaded after it. We just - -- attach the rest of the final list at the end of the array list. - - elsif Nb_Link = 3 then - declare - P : Finalizable_Ptr := Obj'Unchecked_Access; - - begin - while P.Next /= null loop - P := P.Next; - end loop; - - P.Next := L; - L := Obj'Unchecked_Access; - end; - - -- Make the object completely unattached (case of a library-level, - -- Finalize_Storage_Only object). - - elsif Nb_Link = 4 then - Obj.Prev := null; - Obj.Next := null; - end if; - end Attach_To_Final_List; - - --------------------- - -- Deep_Tag_Attach -- - ---------------------- - - procedure Deep_Tag_Attach - (L : in out SFR.Finalizable_Ptr; - A : System.Address; - B : Short_Short_Integer) - is - V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A); - Controller : constant RC_Ptr := Get_Deep_Controller (A); - - begin - if Controller /= null then - Attach_To_Final_List (L, Controller.all, B); - end if; - - -- Is controlled - - if V.all in Finalizable then - Attach_To_Final_List (L, V.all, B); - end if; - end Deep_Tag_Attach; - - ----------------------------- - -- Detach_From_Final_List -- - ----------------------------- - - -- We know that the detach object is neither at the beginning nor at the - -- end of the list, thanks to the dummy First and Last Elements, but the - -- object may not be attached at all if it is Finalize_Storage_Only - - procedure Detach_From_Final_List (Obj : in out Finalizable) is - begin - -- When objects are not properly attached to a doubly linked list do - -- not try to detach them. The only case where it can happen is when - -- dealing with Finalize_Storage_Only objects which are not always - -- attached to the finalization list. - - if Obj.Next /= null and then Obj.Prev /= null then - SSL.Lock_Task.all; - Obj.Next.Prev := Obj.Prev; - Obj.Prev.Next := Obj.Next; - - -- Reset the pointers so that a new finalization of the same object - -- has no effect on the finalization list. - - Obj.Next := null; - Obj.Prev := null; - - SSL.Unlock_Task.all; - end if; - - exception - when others => - SSL.Unlock_Task.all; - raise; - end Detach_From_Final_List; - - -------------- - -- Finalize -- - -------------- - - overriding procedure Finalize (Object : in out Limited_Record_Controller) is - begin - Finalize_List (Object.F); - end Finalize; - - -------------------------- - -- Finalize_Global_List -- - -------------------------- - - procedure Finalize_Global_List is - begin - -- There are three case here: - - -- a. the application uses tasks, in which case Finalize_Global_Tasks - -- will defer abort. - - -- b. the application doesn't use tasks but uses other tasking - -- constructs, such as ATCs and protected objects. In this case, - -- the binder will call Finalize_Global_List instead of - -- Finalize_Global_Tasks, letting abort undeferred, and leading - -- to assertion failures in the GNULL - - -- c. the application doesn't use any tasking construct in which case - -- deferring abort isn't necessary. - - -- Until another solution is found to deal with case b, we need to - -- call abort_defer here to pass the checks, but we do not need to - -- undefer abort, since Finalize_Global_List is the last procedure - -- called before exiting the partition. - - SSL.Abort_Defer.all; - Finalize_List (Global_Final_List); - end Finalize_Global_List; - - ------------------- - -- Finalize_List -- - ------------------- - - procedure Finalize_List (L : Finalizable_Ptr) is - P : Finalizable_Ptr := L; - Q : Finalizable_Ptr; - - type Fake_Exception_Occurrence is record - Id : Exception_Id; - end record; - type Ptr is access all Fake_Exception_Occurrence; - - function To_Ptr is new - Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr); - - X : Exception_Id := Null_Id; - - begin - -- If abort is allowed, we get the current exception before starting - -- to finalize in order to check if we are in the abort case if an - -- exception is raised. When abort is not allowed, avoid accessing the - -- current exception since this can be a pretty costly operation in - -- programs using controlled types heavily. - - if System.Restrictions.Abort_Allowed then - X := To_Ptr (SSL.Get_Current_Excep.all).Id; - end if; - - while P /= null loop - Q := P.Next; - Finalize (P.all); - P := Q; - end loop; - - exception - when E_Occ : others => - Raise_From_Finalize ( - Q, - X = Standard'Abort_Signal'Identity, - E_Occ); - end Finalize_List; - - ------------------ - -- Finalize_One -- - ------------------ - - procedure Finalize_One (Obj : in out Finalizable) is - begin - Detach_From_Final_List (Obj); - Finalize (Obj); - exception - when E_Occ : others => Raise_From_Finalize (null, False, E_Occ); - end Finalize_One; - - ------------------------- - -- Get_Deep_Controller -- - ------------------------- - - function Get_Deep_Controller (Obj : System.Address) return RC_Ptr is - The_Tag : Ada.Tags.Tag := To_Finalizable_Ptr (Obj)'Tag; - Offset : SSE.Storage_Offset := RC_Offset (The_Tag); - - begin - -- Fetch the controller from the Parent or above if necessary - -- when there are no controller at this level. - - while Offset = -2 loop - The_Tag := Ada.Tags.Parent_Tag (The_Tag); - Offset := RC_Offset (The_Tag); - end loop; - - -- No Controlled component case - - if Offset = 0 then - return null; - - -- The _controller Offset is known statically - - elsif Offset > 0 then - return To_RC_Ptr (Obj + Offset); - - -- At this stage, we know that the controller is part of the - -- ancestor corresponding to the tag "The_Tag" and that its parent - -- is variable sized. We assume that the _controller is the first - -- component right after the parent. - - -- ??? note that it may not be true if there are new discriminants - - else -- Offset = -1 - - declare - -- define a faked record controller to avoid generating - -- unnecessary expanded code for controlled types - - type Faked_Record_Controller is record - Tag, Prec, Next : Address; - end record; - - -- Reconstruction of a type with characteristics - -- comparable to the original type - - D : constant := SSE.Storage_Offset (Storage_Unit - 1); - - type Parent_Type is new SSE.Storage_Array - (1 .. (Parent_Size (Obj, The_Tag) + D) / - SSE.Storage_Offset (Storage_Unit)); - for Parent_Type'Alignment use Address'Alignment; - - type Faked_Type_Of_Obj is record - Parent : Parent_Type; - Controller : Faked_Record_Controller; - end record; - - type Obj_Ptr is access all Faked_Type_Of_Obj; - function To_Obj_Ptr is - new Ada.Unchecked_Conversion (Address, Obj_Ptr); - - begin - return To_RC_Ptr (To_Obj_Ptr (Obj).Controller'Address); - end; - end if; - end Get_Deep_Controller; - - ---------------- - -- Initialize -- - ---------------- - - overriding procedure Initialize - (Object : in out Limited_Record_Controller) - is - pragma Warnings (Off, Object); - begin - null; - end Initialize; - - overriding procedure Initialize (Object : in out Record_Controller) is - begin - Object.My_Address := Object'Address; - end Initialize; - - --------------------- - -- Move_Final_List -- - --------------------- - - procedure Move_Final_List - (From : in out SFR.Finalizable_Ptr; - To : Finalizable_Ptr_Ptr) - is - begin - -- This is currently called at the end of the return statement, and the - -- caller does NOT defer aborts. We need to defer aborts to prevent - -- mangling the finalization lists. - - SSL.Abort_Defer.all; - - -- Put the return statement's finalization list onto the caller's one, - -- thus transferring responsibility for finalization of the return - -- object to the caller. - - Attach_To_Final_List (To.all, From.all, Nb_Link => 3); - - -- Empty the return statement's finalization list, so that when the - -- cleanup code executes, there will be nothing to finalize. - From := null; - - SSL.Abort_Undefer.all; - end Move_Final_List; - - ------------------------- - -- Raise_From_Finalize -- - ------------------------- - - procedure Raise_From_Finalize - (L : Finalizable_Ptr; - From_Abort : Boolean; - E_Occ : Exception_Occurrence) - is - P : Finalizable_Ptr := L; - Q : Finalizable_Ptr; - - begin - -- We already got an exception. We now finalize the remainder of - -- the list, ignoring all further exceptions. - - while P /= null loop - Q := P.Next; - - begin - Finalize (P.all); - exception - when others => null; - end; - - P := Q; - end loop; - - if From_Abort then - -- If finalization from an Abort, then nothing to do - - null; - - else - -- Else raise Program_Error with an appropriate message - - Raise_From_Controlled_Operation (E_Occ); - end if; - end Raise_From_Finalize; - --- Initialization of package, set Adafinal soft link - -begin - SSL.Finalize_Global_List := Finalize_Global_List'Access; -end System.Finalization_Implementation; diff --git a/gcc/ada/s-finimp.ads b/gcc/ada/s-finimp.ads deleted file mode 100644 index 944fe6f114c..00000000000 --- a/gcc/ada/s-finimp.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F I N A L I Z A T I O N _ I M P L E M E N T A T I O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -with System.Storage_Elements; -with System.Finalization_Root; - -package System.Finalization_Implementation is - pragma Elaborate_Body; - - package SSE renames System.Storage_Elements; - package SFR renames System.Finalization_Root; - - ------------------------------------------------ - -- Finalization Management Abstract Interface -- - ------------------------------------------------ - - function To_Finalizable_Ptr is new Ada.Unchecked_Conversion - (Source => System.Address, Target => SFR.Finalizable_Ptr); - - Collection_Finalization_Started : constant SFR.Finalizable_Ptr := - To_Finalizable_Ptr (SSE.To_Address (1)); - -- This is used to implement the rule in RM 4.8(10.2/2) that requires an - -- allocator to raise Program_Error if the collection finalization has - -- already started. See also Ada.Finalization.List_Controller. Finalize on - -- List_Controller first sets the list to Collection_Finalization_Started, - -- to indicate that finalization has started. An allocator will call - -- Attach_To_Final_List, which checks for the special value and raises - -- Program_Error if appropriate. The Collection_Finalization_Started value - -- must be different from 'Access of any finalizable object, and different - -- from null. See AI-280. - - Global_Final_List : SFR.Finalizable_Ptr; - -- This list stores the controlled objects defined in library-level - -- packages. They will be finalized after the main program completion. - - procedure Finalize_Global_List; - -- The procedure to be called in order to finalize the global list - - procedure Attach_To_Final_List - (L : in out SFR.Finalizable_Ptr; - Obj : in out SFR.Finalizable; - Nb_Link : Short_Short_Integer); - -- Attach finalizable object Obj to the linked list L. Nb_Link controls the - -- number of link of the linked_list, and is one of: 0 for no attachment, 1 - -- for simple linked lists or 2 for doubly linked lists or even 3 for a - -- simple attachment of a whole array of elements. Attachment to a simply - -- linked list is not protected against concurrent access and should only - -- be used in contexts where it doesn't matter, such as for objects - -- allocated on the stack. In the case of an attachment on a doubly linked - -- list, L must not be null and Obj will be inserted AFTER the first - -- element and the attachment is protected against concurrent call. - -- Typically used to attach to a dynamically allocated object to a - -- List_Controller (whose first element is always a dummy element) - - type Finalizable_Ptr_Ptr is access all SFR.Finalizable_Ptr; - -- A pointer to a finalization list. This is used as the type of the extra - -- implicit formal which are passed to build-in-place functions that return - -- controlled types (see Sem_Ch6). That extra formal is then passed on to - -- Move_Final_List (below). - - procedure Move_Final_List - (From : in out SFR.Finalizable_Ptr; - To : Finalizable_Ptr_Ptr); - -- Move all objects on From list to To list. This is used to implement - -- build-in-place function returns. The return object is initially placed - -- on a finalization list local to the return statement, in case the - -- return statement is left prematurely (due to raising an exception, - -- being aborted, or a goto or exit statement). Once the return statement - -- has completed successfully, Move_Final_List is called to move the - -- return object to the caller's finalization list. - - procedure Finalize_List (L : SFR.Finalizable_Ptr); - -- Call Finalize on each element of the list L - - procedure Finalize_One (Obj : in out SFR.Finalizable); - -- Call Finalize on Obj and remove its final list - - --------------------- - -- Deep Procedures -- - --------------------- - - procedure Deep_Tag_Attach - (L : in out SFR.Finalizable_Ptr; - A : System.Address; - B : Short_Short_Integer); - -- Generic attachment for tagged objects with controlled components. - -- A is the address of the object, L the finalization list when it needs - -- to be attached and B the attachment level (see Attach_To_Final_List). - - ----------------------------- - -- Record Controller Types -- - ----------------------------- - - -- Definition of the types of the controller component that is included - -- in records containing controlled components. This controller is - -- attached to the finalization chain of the upper-level and carries - -- the pointer of the finalization chain for the lower level. - - type Limited_Record_Controller is new SFR.Root_Controlled with record - F : SFR.Finalizable_Ptr; - end record; - - overriding procedure Initialize (Object : in out Limited_Record_Controller); - -- Does nothing currently - - overriding procedure Finalize (Object : in out Limited_Record_Controller); - -- Finalize the controlled components of the enclosing record by following - -- the list starting at Object.F. - - type Record_Controller is - new Limited_Record_Controller with record - My_Address : System.Address; - end record; - - overriding procedure Initialize (Object : in out Record_Controller); - -- Initialize the field My_Address to the Object'Address - - overriding procedure Adjust (Object : in out Record_Controller); - -- Adjust the components and their finalization pointers by subtracting by - -- the offset of the target and the source addresses of the assignment. - - -- Inherit Finalize from Limited_Record_Controller - - procedure Detach_From_Final_List (Obj : in out SFR.Finalizable); - -- Remove the specified object from its Final list, which must be a doubly - -- linked list. - -end System.Finalization_Implementation; diff --git a/gcc/ada/s-finroo.ads b/gcc/ada/s-finroo.ads index da373f7c34c..4de2b7c0375 100644 --- a/gcc/ada/s-finroo.ads +++ b/gcc/ada/s-finroo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,54 +32,29 @@ -- This unit provides the basic support for controlled (finalizable) types with Ada.Streams; -with Ada.Unchecked_Conversion; package System.Finalization_Root is pragma Preelaborate; - type Root_Controlled is tagged; + -- The base for types Controlled and Limited_Controlled declared in Ada. + -- Finalization. - type Finalizable_Ptr is access all Root_Controlled'Class; + type Root_Controlled is tagged null record; - function To_Finalizable_Ptr is - new Ada.Unchecked_Conversion (Address, Finalizable_Ptr); - - function To_Addr is - new Ada.Unchecked_Conversion (Finalizable_Ptr, Address); - - type Empty_Root_Controlled is abstract tagged null record; - -- Just for the sake of Controlled equality (see Ada.Finalization) - - type Root_Controlled is new Empty_Root_Controlled with record - Prev, Next : Finalizable_Ptr; - end record; - subtype Finalizable is Root_Controlled'Class; - - procedure Initialize (Object : in out Root_Controlled); - procedure Finalize (Object : in out Root_Controlled); procedure Adjust (Object : in out Root_Controlled); - - -- Stream-oriented attributes for Root_Controlled. These must be empty so - -- as to not copy the finalization chain pointers. They are declared in - -- a nested package so that they do not create primitive operations of - -- Root_Controlled. Otherwise this would add unwanted primitives to (the - -- full view of) Ada.Finalization.Limited_Controlled, which would cause - -- trouble in cases where a limited controlled type is used as the - -- designated type of a remote access-to-classwide type. + procedure Finalize (Object : in out Root_Controlled); + procedure Initialize (Object : in out Root_Controlled); package Stream_Attributes is - - procedure Write - (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - Item : Root_Controlled) is null; - procedure Read (Stream : not null access Ada.Streams.Root_Stream_Type'Class; Item : out Root_Controlled) is null; + procedure Write + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Item : Root_Controlled) is null; end Stream_Attributes; - for Root_Controlled'Read use Stream_Attributes.Read; + for Root_Controlled'Read use Stream_Attributes.Read; for Root_Controlled'Write use Stream_Attributes.Write; - end System.Finalization_Root; diff --git a/gcc/ada/s-pooglo.adb b/gcc/ada/s-pooglo.adb index 35bdf64101b..dc5596272c6 100644 --- a/gcc/ada/s-pooglo.adb +++ b/gcc/ada/s-pooglo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,7 +29,7 @@ -- -- ------------------------------------------------------------------------------ -with System.Storage_Pools; use System.Storage_Pools; +with System.Storage_Pools; use System.Storage_Pools; with System.Memory; package body System.Pool_Global is @@ -40,7 +40,7 @@ package body System.Pool_Global is -- Allocate -- -------------- - procedure Allocate + overriding procedure Allocate (Pool : in out Unbounded_No_Reclaim_Pool; Address : out System.Address; Storage_Size : SSE.Storage_Count; @@ -69,7 +69,7 @@ package body System.Pool_Global is -- Deallocate -- ---------------- - procedure Deallocate + overriding procedure Deallocate (Pool : in out Unbounded_No_Reclaim_Pool; Address : System.Address; Storage_Size : SSE.Storage_Count; @@ -87,7 +87,7 @@ package body System.Pool_Global is -- Storage_Size -- ------------------ - function Storage_Size + overriding function Storage_Size (Pool : Unbounded_No_Reclaim_Pool) return SSE.Storage_Count is diff --git a/gcc/ada/s-soflin.adb b/gcc/ada/s-soflin.adb index 4ae51f39f7f..1c0584451d6 100644 --- a/gcc/ada/s-soflin.adb +++ b/gcc/ada/s-soflin.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -95,9 +95,11 @@ package body System.Soft_Links is Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence); - -- Finalize the global list for controlled objects if needed + -- Finalize all library-level controlled objects if needed - Finalize_Global_List.all; + if Finalize_Library_Objects /= null then + Finalize_Library_Objects.all; + end if; end Adafinal_NT; --------------------------- @@ -243,14 +245,19 @@ package body System.Soft_Links is return NT_TSD.Pri_Stack_Info'Access; end Get_Stack_Info_NT; - ------------------------------- - -- Null_Finalize_Global_List -- - ------------------------------- + ----------------------------- + -- Save_Library_Occurrence -- + ----------------------------- - procedure Null_Finalize_Global_List is + procedure Save_Library_Occurrence + (E : Ada.Exceptions.Exception_Occurrence) + is begin - null; - end Null_Finalize_Global_List; + if not Library_Exception_Set then + Library_Exception_Set := True; + Ada.Exceptions.Save_Occurrence (Library_Exception, E); + end if; + end Save_Library_Occurrence; --------------------------- -- Set_Jmpbuf_Address_NT -- diff --git a/gcc/ada/s-soflin.ads b/gcc/ada/s-soflin.ads index 5a2c556f5a8..7f8de10dce0 100644 --- a/gcc/ada/s-soflin.ads +++ b/gcc/ada/s-soflin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -59,6 +59,11 @@ package System.Soft_Links is type No_Param_Proc is access procedure; pragma Favor_Top_Level (No_Param_Proc); + pragma Suppress_Initialization (No_Param_Proc); + -- Some uninitialized objects of that type are initialized by the Binder + -- so it is important that such objects are not reset to null during + -- elaboration + type Addr_Param_Proc is access procedure (Addr : Address); pragma Favor_Top_Level (Addr_Param_Proc); type EO_Param_Proc is access procedure (Excep : EO); @@ -158,9 +163,6 @@ package System.Soft_Links is -- Handle task termination routines for the environment task (non-tasking -- case, does nothing). - procedure Null_Finalize_Global_List; - -- Finalize global list for controlled objects (does nothing) - procedure Adafinal_NT; -- Shuts down the runtime system (non-tasking case) @@ -221,8 +223,10 @@ package System.Soft_Links is Task_Termination_Handler : EO_Param_Proc := Task_Termination_NT'Access; -- Handle task termination routines (task/non-task case as appropriate) - Finalize_Global_List : No_Param_Proc := Null_Finalize_Global_List'Access; - -- Performs finalization of global list for controlled objects + Finalize_Library_Objects : No_Param_Proc; + pragma Export (C, Finalize_Library_Objects, + "__gnat_finalize_library_objects"); + -- will be initialized by the binder Adafinal : No_Param_Proc := Adafinal_NT'Access; -- Performs the finalization of the Ada Runtime @@ -287,6 +291,16 @@ package System.Soft_Links is -- Exception Tracebacks Soft-Links -- ------------------------------------- + Library_Exception : EO; + pragma Export (Ada, Library_Exception, "__gnat_library_exception"); + -- Library-level finalization routines use this common reference to store + -- the first library-level exception which occurs during finalization. + + Library_Exception_Set : Boolean := False; + pragma Export (Ada, Library_Exception_Set, "__gnat_library_exception_set"); + -- Used in conjunction with Library_Exception, set when an exception has + -- been stored. + Traceback_Decorator_Wrapper : Traceback_Decorator_Wrapper_Call; -- Wrapper to the possible user specified traceback decorator to be -- called during automatic output of exception data. @@ -301,6 +315,10 @@ package System.Soft_Links is -- See the body of Tailored_Exception_Traceback in Ada.Exceptions for -- a more detailed description of the potential problems. + procedure Save_Library_Occurrence (E : Ada.Exceptions.Exception_Occurrence); + -- When invoked, this routine saves an exception occurrence into a hidden + -- reference. Subsequent calls will have no effect. + ------------------------ -- Task Specific Data -- ------------------------ diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 1663b89c62c..34e32915bd4 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -56,8 +56,8 @@ with System.Soft_Links; -- These are procedure pointers to non-tasking routines that use task -- specific data. In the absence of tasking, these routines refer to global -- data. In the presence of tasking, they must be replaced with pointers to --- task-specific versions. Also used for Create_TSD, Destroy_TSD, --- Get_Current_Excep, Finalize_Global_List, Task_Termination, Handler. +-- task-specific versions. Also used for Create_TSD, Destroy_TSD, Get_Current +-- _Excep, Finalize_Library_Objects, Task_Termination, Handler. with System.Tasking.Initialization; pragma Elaborate_All (System.Tasking.Initialization); @@ -854,9 +854,11 @@ package body System.Tasking.Stages is SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence); - -- Finalize the global list for controlled objects if needed + -- Finalize all library-level controlled objects - SSL.Finalize_Global_List.all; + if not SSL."=" (SSL.Finalize_Library_Objects, null) then + SSL.Finalize_Library_Objects.all; + end if; -- Reset the soft links to non-tasking diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 71fe0fbbbb3..050930bfa03 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -4197,7 +4197,6 @@ package body Sem_Aggr is elsif Chars (Selectr) /= Name_uTag and then Chars (Selectr) /= Name_uParent - and then Chars (Selectr) /= Name_uController then if not Has_Discriminants (Typ) then Error_Msg_Node_2 := Typ; diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 0e5c3db3cf0..8c54517c236 100755 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -216,16 +216,12 @@ package body Sem_Aux is -- The discriminants are not necessarily contiguous, because access -- discriminants will generate itypes. They are not the first entities - -- either, because tag and controller record must be ahead of them. + -- either because the tag must be ahead of them. if Chars (Ent) = Name_uTag then Ent := Next_Entity (Ent); end if; - if Chars (Ent) = Name_uController then - Ent := Next_Entity (Ent); - end if; - -- Skip all hidden stored discriminants if any while Present (Ent) loop @@ -289,17 +285,11 @@ package body Sem_Aux is Ent := Next_Entity (Ent); end if; - if Chars (Ent) = Name_uController then - Ent := Next_Entity (Ent); - end if; - if Has_Completely_Hidden_Discriminant (Ent) then - while Present (Ent) loop exit when Is_Completely_Hidden (Ent); Ent := Next_Entity (Ent); end loop; - end if; pragma Assert (Ekind (Ent) = E_Discriminant); diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index cf9af2e7178..03ff2fef534 100755 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -106,7 +106,7 @@ package Sem_Aux is function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id; -- For any entity, Ent, returns the closest dynamic scope in which the - -- entity is declared or Standard_Standard for library-level entities + -- entity is declared or Standard_Standard for library-level entities. function First_Discriminant (Typ : Entity_Id) return Entity_Id; -- Typ is a type with discriminants. The discriminants are the first diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 6c4e2442d86..e2e566dda68 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -5267,9 +5267,11 @@ package body Sem_Ch10 is procedure Decorate_Tagged_Type (Loc : Source_Ptr; T : Entity_Id; - Scop : Entity_Id); - -- Set basic attributes of tagged type T, including its class_wide type. - -- The parameters Loc, Scope are used to decorate the class_wide type. + Scop : Entity_Id; + Mark : Boolean := False); + -- Set basic attributes of tagged type T, including its class-wide type. + -- The parameters Loc, Scope are used to decorate the class-wide type. + -- Use flag Mark to label the class-wide type as Materialize_Entity. procedure Build_Chain (Scope : Entity_Id; First_Decl : Node_Id); -- Construct list of shadow entities and attach it to entity of @@ -5327,7 +5329,7 @@ package body Sem_Ch10 is if not Analyzed_Unit then if Is_Tagged then - Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); + Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope, True); else Decorate_Incomplete_Type (Comp_Typ, Scope); end if; @@ -5367,7 +5369,7 @@ package body Sem_Ch10 is if not Analyzed_Unit then if Is_Tagged then - Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); + Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope, True); else Decorate_Incomplete_Type (Comp_Typ, Scope); end if; @@ -5395,7 +5397,7 @@ package body Sem_Ch10 is Comp_Typ := Defining_Identifier (Decl); if not Analyzed_Unit then - Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); + Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope, True); end if; -- Create shadow entity for type @@ -5476,7 +5478,8 @@ package body Sem_Ch10 is procedure Decorate_Tagged_Type (Loc : Source_Ptr; T : Entity_Id; - Scop : Entity_Id) + Scop : Entity_Id; + Mark : Boolean := False) is CW : Entity_Id; @@ -5490,7 +5493,7 @@ package body Sem_Ch10 is -- and the full-view. if No (Class_Wide_Type (T)) then - CW := Make_Temporary (Loc, 'S'); + CW := New_External_Entity (E_Void, Scope (T), Loc, T, 'C', 0, 'T'); -- Set parent to be the same as the parent of the tagged type. -- We need a parent field set, and it is supposed to point to @@ -5514,6 +5517,7 @@ package body Sem_Ch10 is Set_Class_Wide_Type (CW, CW); Set_Equivalent_Type (CW, Empty); Set_From_With_Type (CW, From_With_Type (T)); + Set_Materialize_Entity (CW, Mark); -- Link type to its class-wide type diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index 48ffe4a5468..53f79cb3ac1 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -210,15 +210,6 @@ package body Sem_Ch11 is Push_Scope (H_Scope); Set_Etype (H_Scope, Standard_Void_Type); - -- Set the Finalization Chain entity to Error means that it - -- should not be used at that level but the parent one should - -- be used instead. - - -- ??? this usage needs documenting in Einfo/Exp_Ch7 ??? - -- ??? using Error for this non-error condition is nasty ??? - - Set_Finalization_Chain_Entity (H_Scope, Error); - Enter_Name (Choice); Set_Ekind (Choice, E_Variable); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 8f2376d7bb4..42303e7d02a 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -781,7 +781,7 @@ package body Sem_Ch3 is Anon_Type := Create_Itype - (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope); + (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope); if All_Present (N) and then Ada_Version >= Ada_2005 @@ -1279,8 +1279,11 @@ package body Sem_Ch3 is ---------------------------- procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is - S : constant Node_Id := Subtype_Indication (Def); P : constant Node_Id := Parent (Def); + S : constant Node_Id := Subtype_Indication (Def); + + Full_Desig : Entity_Id; + begin Check_SPARK_Restriction ("access type is not allowed", Def); @@ -1307,15 +1310,17 @@ package body Sem_Ch3 is Set_Ekind (T, E_Access_Type); end if; - if Base_Type (Designated_Type (T)) = T then + Full_Desig := Designated_Type (T); + + if Base_Type (Full_Desig) = T then Error_Msg_N ("access type cannot designate itself", S); -- In Ada 2005, the type may have a limited view through some unit -- in its own context, allowing the following circularity that cannot -- be detected earlier - elsif Is_Class_Wide_Type (Designated_Type (T)) - and then Etype (Designated_Type (T)) = T + elsif Is_Class_Wide_Type (Full_Desig) + and then Etype (Full_Desig) = T then Error_Msg_N ("access type cannot designate its own classwide type", S); @@ -1341,12 +1346,19 @@ package body Sem_Ch3 is Set_Has_Task (T, False); Set_Has_Controlled_Component (T, False); - -- Initialize Associated_Final_Chain explicitly to Empty, to avoid + -- Initialize Associated_Collection explicitly to Empty, to avoid -- problems where an incomplete view of this entity has been previously -- established by a limited with and an overlaid version of this field -- (Stored_Constraint) was initialized for the incomplete view. - Set_Associated_Final_Chain (T, Empty); + -- This reset is performed in most cases except where the access type + -- has been created for the purposes of allocating or deallocating a + -- build-in-place object. Such access types have explicitly set pools + -- and collections. + + if No (Associated_Storage_Pool (T)) then + Set_Associated_Collection (T, Empty); + end if; -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant -- attributes @@ -2537,7 +2549,7 @@ package body Sem_Ch3 is -- subtypes will be built after the full view of the type. Set_Private_Dependents (T, New_Elmt_List); - Set_Is_Pure (T, F); + Set_Is_Pure (T, F); end Analyze_Incomplete_Type_Decl; ----------------------------------- @@ -6980,35 +6992,32 @@ package body Sem_Ch3 is Derived_Type : Entity_Id; Derive_Subps : Boolean := True) is - Loc : constant Source_Ptr := Sloc (N); - Parent_Base : Entity_Id; - Type_Def : Node_Id; - Indic : Node_Id; - Discrim : Entity_Id; - Last_Discrim : Entity_Id; - Constrs : Elist_Id; - - Discs : Elist_Id := New_Elmt_List; - -- An empty Discs list means that there were no constraints in the - -- subtype indication or that there was an error processing it. - - Assoc_List : Elist_Id; - New_Discrs : Elist_Id; - New_Base : Entity_Id; - New_Decl : Node_Id; - New_Indic : Node_Id; - - Is_Tagged : constant Boolean := Is_Tagged_Type (Parent_Type); Discriminant_Specs : constant Boolean := Present (Discriminant_Specifications (N)); + Is_Tagged : constant Boolean := Is_Tagged_Type (Parent_Type); + Loc : constant Source_Ptr := Sloc (N); Private_Extension : constant Boolean := Nkind (N) = N_Private_Extension_Declaration; - + Assoc_List : Elist_Id; Constraint_Present : Boolean; + Constrs : Elist_Id; + Discrim : Entity_Id; + Indic : Node_Id; Inherit_Discrims : Boolean := False; + Last_Discrim : Entity_Id; + New_Base : Entity_Id; + New_Decl : Node_Id; + New_Discrs : Elist_Id; + New_Indic : Node_Id; + Parent_Base : Entity_Id; Save_Etype : Entity_Id; Save_Discr_Constr : Elist_Id; Save_Next_Entity : Entity_Id; + Type_Def : Node_Id; + + Discs : Elist_Id := New_Elmt_List; + -- An empty Discs list means that there were no constraints in the + -- subtype indication or that there was an error processing it. begin if Ekind (Parent_Type) = E_Record_Type_With_Private @@ -8586,7 +8595,7 @@ package body Sem_Ch3 is end if; if Is_Tagged_Type (T) then - Set_Is_Tagged_Type (Def_Id); + Set_Is_Tagged_Type (Def_Id); Make_Class_Wide_Type (Def_Id); end if; @@ -12194,8 +12203,8 @@ package body Sem_Ch3 is Next_Discriminant (Old_C); end loop; - -- The tag, and the possible parent and controller components - -- are unconditionally in the subtype. + -- The tag and the possible parent component are unconditionally in + -- the subtype. if Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) @@ -12204,7 +12213,6 @@ package body Sem_Ch3 is while Present (Old_C) loop if Chars ((Old_C)) = Name_uTag or else Chars ((Old_C)) = Name_uParent - or else Chars ((Old_C)) = Name_uController then Append_Elmt (Old_C, Comp_List); end if; @@ -12470,7 +12478,6 @@ package body Sem_Ch3 is if Original_Record_Component (Old_C) = Old_C and then Chars (Old_C) /= Name_uTag and then Chars (Old_C) /= Name_uParent - and then Chars (Old_C) /= Name_uController then Append_Elmt (Old_C, Comp_List); end if; @@ -16187,15 +16194,31 @@ package body Sem_Ch3 is Next_E : Entity_Id; begin - -- The class wide type can have been defined by the partial view, in - -- which case everything is already done. - if Present (Class_Wide_Type (T)) then - return; - end if; - CW_Type := - New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T'); + -- The class-wide type is a partially decorated entity created for a + -- unanalyzed tagged type referenced through a limited with clause. + -- When the tagged type is analyzed, its class-wide type needs to be + -- redecorated. Note that we reuse the entity created by Decorate_ + -- Tagged_Type in order to preserve all links. + + if Materialize_Entity (Class_Wide_Type (T)) then + CW_Type := Class_Wide_Type (T); + Set_Materialize_Entity (CW_Type, False); + + -- The class wide type can have been defined by the partial view, in + -- which case everything is already done. + + else + return; + end if; + + -- Default case, we need to create a new class-wide type + + else + CW_Type := + New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T'); + end if; -- Inherit root type characteristics @@ -17367,10 +17390,10 @@ package body Sem_Ch3 is Set_Is_Limited_Record (Full_T); -- GNAT allow its own definition of Limited_Controlled to disobey - -- this rule in order in ease the implementation. The next test is - -- safe because Root_Controlled is defined in a private system child + -- this rule in order in ease the implementation. This test is safe + -- because Root_Controlled is defined in a private system child. - elsif Etype (Full_T) = Full_View (RTE (RE_Root_Controlled)) then + elsif Is_RTE (Etype (Full_T), RE_Root_Controlled) then Set_Is_Limited_Composite (Full_T); else Error_Msg_N diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 6dacae55ca7..dd527b24070 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -2897,9 +2897,9 @@ package body Sem_Ch4 is Actual := First_Actual (N); Formal := First_Formal (Nam); - -- If we are analyzing a call rewritten from object notation, - -- skip first actual, which may be rewritten later as an - -- explicit dereference. + -- If we are analyzing a call rewritten from object notation, skip + -- first actual, which may be rewritten later as an explicit + -- dereference. if Must_Skip then Next_Actual (Actual); @@ -3914,7 +3914,7 @@ package body Sem_Ch4 is -- which can appear in expanded code in a tag check. if Ekind (Type_To_Use) = E_Record_Type_With_Private - and then Chars (Selector_Name (N)) /= Name_uTag + and then Chars (Selector_Name (N)) /= Name_uTag then exit when Comp = Last_Entity (Type_To_Use); end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 6c69643cbdd..31691113043 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1970,6 +1970,10 @@ package body Sem_Ch6 is while Present (Formal) loop Formal_Typ := Etype (Formal); + if Is_Class_Wide_Type (Formal_Typ) then + Formal_Typ := Root_Type (Formal_Typ); + end if; + -- From concurrent type to corresponding record if To_Corresponding then @@ -2061,6 +2065,10 @@ package body Sem_Ch6 is Formal_Typ := Etype (First_Formal (Subp_Id)); if Is_Concurrent_Record_Type (Formal_Typ) then + if Is_Class_Wide_Type (Formal_Typ) then + Formal_Typ := Root_Type (Formal_Typ); + end if; + Formal_Typ := Corresponding_Concurrent_Type (Formal_Typ); end if; @@ -6057,24 +6065,15 @@ package body Sem_Ch6 is E, BIP_Formal_Suffix (BIP_Alloc_Form)); end if; - -- For functions whose result type has controlled parts, we have - -- an extra formal of type System.Finalization_Implementation. - -- Finalizable_Ptr_Ptr. That is, we are passing a pointer to a - -- finalization list (which is itself a pointer). This extra - -- formal is then passed along to Move_Final_List in case of - -- successful completion of a return statement. We cannot pass an - -- 'in out' parameter, because we need to update the finalization - -- list during an abort-deferred region, rather than using - -- copy-back after the function returns. This is true even if we - -- are able to get away with having 'in out' parameters, which are - -- normally illegal for functions. This formal is also needed when - -- the function has a tagged result. - - if Needs_BIP_Final_List (E) then + -- In the case of functions whose result type needs finalization, + -- add an extra formal of type Ada.Finalization.Heap_Management. + -- Finalization_Collection_Ptr. + + if Needs_BIP_Collection (E) then Discard := Add_Extra_Formal - (E, RTE (RE_Finalizable_Ptr_Ptr), - E, BIP_Formal_Suffix (BIP_Final_List)); + (E, RTE (RE_Finalization_Collection_Ptr), + E, BIP_Formal_Suffix (BIP_Collection)); end if; -- If the result type contains tasks, we have two extra formals: diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 19581b99ba1..3256ae89b3c 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -914,7 +914,8 @@ package body Sem_Ch8 is (Designated_Type (T), Designated_Type (Etype (Nam))); elsif not Subtypes_Statically_Match - (Designated_Type (T), Designated_Type (Etype (Nam))) + (Designated_Type (T), + Available_View (Designated_Type (Etype (Nam)))) then Error_Msg_N ("subtype of renamed object does not statically match", N); @@ -5629,18 +5630,21 @@ package body Sem_Ch8 is then -- Do not build the subtype when referencing components of -- dispatch table wrappers. Required to avoid generating - -- elaboration code with HI runtimes. + -- elaboration code with HI runtimes. JVM and .NET use a + -- modified version of Ada.Tags which does not contain RE_ + -- Dispatch_Table_Wrapper and RE_No_Dispatch_Table_Wrapper. + -- Avoid raising RE_Not_Available exception in those cases. - if RTU_Loaded (Ada_Tags) - and then RTE_Available (RE_Dispatch_Table_Wrapper) - and then Scope (Selector) = RTE (RE_Dispatch_Table_Wrapper) - then - C_Etype := Empty; - - elsif RTU_Loaded (Ada_Tags) - and then RTE_Available (RE_No_Dispatch_Table_Wrapper) - and then Scope (Selector) - = RTE (RE_No_Dispatch_Table_Wrapper) + if VM_Target = No_VM + and then RTU_Loaded (Ada_Tags) + and then + ((RTE_Available (RE_Dispatch_Table_Wrapper) + and then Scope (Selector) = + RTE (RE_Dispatch_Table_Wrapper)) + or else + (RTE_Available (RE_No_Dispatch_Table_Wrapper) + and then Scope (Selector) = + RTE (RE_No_Dispatch_Table_Wrapper))) then C_Etype := Empty; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index b1e99dc79c5..96f2ff830c2 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -893,17 +893,17 @@ package body Sem_Disp is and then Is_Dispatching_Operation (Old_Subp) then pragma Assert - ((Ekind (Subp) = E_Function - and then Is_Dispatching_Operation (Old_Subp) - and then Is_Null_Extension (Base_Type (Etype (Subp)))) - or else - (Ekind (Subp) = E_Procedure + ((Ekind (Subp) = E_Function + and then Is_Dispatching_Operation (Old_Subp) + and then Is_Null_Extension (Base_Type (Etype (Subp)))) + or else + (Ekind (Subp) = E_Procedure and then Is_Dispatching_Operation (Old_Subp) and then Present (Alias (Old_Subp)) and then Is_Null_Interface_Primitive (Ultimate_Alias (Old_Subp))) - or else Get_TSS_Name (Subp) = TSS_Stream_Read - or else Get_TSS_Name (Subp) = TSS_Stream_Write); + or else Get_TSS_Name (Subp) = TSS_Stream_Read + or else Get_TSS_Name (Subp) = TSS_Stream_Write); Check_Controlling_Formals (Tagged_Type, Subp); Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp); @@ -1283,7 +1283,9 @@ package body Sem_Disp is or else Chars (Subp) = Name_Adjust or else - Chars (Subp) = Name_Finalize) + Chars (Subp) = Name_Finalize + or else + Chars (Subp) = Name_Finalize_Address) then declare F_Node : constant Node_Id := Freeze_Node (Tagged_Type); @@ -1292,15 +1294,17 @@ package body Sem_Disp is Old_Bod : Node_Id; Old_Spec : Entity_Id; - C_Names : constant array (1 .. 3) of Name_Id := + C_Names : constant array (1 .. 4) of Name_Id := (Name_Initialize, Name_Adjust, - Name_Finalize); + Name_Finalize, + Name_Finalize_Address); - D_Names : constant array (1 .. 3) of TSS_Name_Type := + D_Names : constant array (1 .. 4) of TSS_Name_Type := (TSS_Deep_Initialize, TSS_Deep_Adjust, - TSS_Deep_Finalize); + TSS_Deep_Finalize, + TSS_Finalize_Address); begin -- Remove previous controlled function which was constructed and diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 73f5b10b512..0a676effcfc 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -658,11 +658,9 @@ package body Sem_Elab is if Body_Acts_As_Spec then if Is_TSS (Ent, TSS_Deep_Initialize) then declare - Typ : Entity_Id; + Typ : constant Entity_Id := Etype (First_Formal (Ent)); Init : Entity_Id; begin - Typ := Etype (Next_Formal (First_Formal (Ent))); - if not Is_Controlled (Typ) then return; else diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 840592f289b..d2b8d3efb3b 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -37,8 +37,8 @@ with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; -with Exp_Ch7; use Exp_Ch7; with Exp_Dist; use Exp_Dist; +with Exp_Util; use Exp_Util; with Lib; use Lib; with Lib.Writ; use Lib.Writ; with Lib.Xref; use Lib.Xref; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index e88e551cb2e..95080c3f947 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -28,7 +28,6 @@ with Checks; use Checks; with Debug; use Debug; with Debug_A; use Debug_A; with Einfo; use Einfo; -with Elists; use Elists; with Errout; use Errout; with Expander; use Expander; with Exp_Disp; use Exp_Disp; @@ -4020,40 +4019,6 @@ package body Sem_Res is -- If the allocator is an actual in a call, it is allowed to be class- -- wide when the context is not because it is a controlling actual. - procedure Propagate_Coextensions (Root : Node_Id); - -- Propagate all nested coextensions which are located one nesting - -- level down the tree to the node Root. Example: - -- - -- Top_Record - -- Level_1_Coextension - -- Level_2_Coextension - -- - -- The algorithm is paired with delay actions done by the Expander. In - -- the above example, assume all coextensions are controlled types. - -- The cycle of analysis, resolution and expansion will yield: - -- - -- 1) Analyze Top_Record - -- 2) Analyze Level_1_Coextension - -- 3) Analyze Level_2_Coextension - -- 4) Resolve Level_2_Coextension. The allocator is marked as a - -- coextension. - -- 5) Expand Level_2_Coextension. A temporary variable Temp_1 is - -- generated to capture the allocated object. Temp_1 is attached - -- to the coextension chain of Level_2_Coextension. - -- 6) Resolve Level_1_Coextension. The allocator is marked as a - -- coextension. A forward tree traversal is performed which finds - -- Level_2_Coextension's list and copies its contents into its - -- own list. - -- 7) Expand Level_1_Coextension. A temporary variable Temp_2 is - -- generated to capture the allocated object. Temp_2 is attached - -- to the coextension chain of Level_1_Coextension. Currently, the - -- contents of the list are [Temp_2, Temp_1]. - -- 8) Resolve Top_Record. A forward tree traversal is performed which - -- finds Level_1_Coextension's list and copies its contents into - -- its own list. - -- 9) Expand Top_Record. Generate finalization calls for Temp_1 and - -- Temp_2 and attach them to Top_Record's finalization list. - ------------------------------------------- -- Check_Allocator_Discrim_Accessibility -- ------------------------------------------- @@ -4107,140 +4072,14 @@ package body Sem_Res is function In_Dispatching_Context return Boolean is Par : constant Node_Id := Parent (N); - begin - return Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement) - and then Is_Entity_Name (Name (Par)) - and then Is_Dispatching_Operation (Entity (Name (Par))); - end In_Dispatching_Context; - - ---------------------------- - -- Propagate_Coextensions -- - ---------------------------- - - procedure Propagate_Coextensions (Root : Node_Id) is - - procedure Copy_List (From : Elist_Id; To : Elist_Id); - -- Copy the contents of list From into list To, preserving the - -- order of elements. - - function Process_Allocator (Nod : Node_Id) return Traverse_Result; - -- Recognize an allocator or a rewritten allocator node and add it - -- along with its nested coextensions to the list of Root. - - --------------- - -- Copy_List -- - --------------- - - procedure Copy_List (From : Elist_Id; To : Elist_Id) is - From_Elmt : Elmt_Id; - begin - From_Elmt := First_Elmt (From); - while Present (From_Elmt) loop - Append_Elmt (Node (From_Elmt), To); - Next_Elmt (From_Elmt); - end loop; - end Copy_List; - - ----------------------- - -- Process_Allocator -- - ----------------------- - - function Process_Allocator (Nod : Node_Id) return Traverse_Result is - Orig_Nod : Node_Id := Nod; - - begin - -- This is a possible rewritten subtype indication allocator. Any - -- nested coextensions will appear as discriminant constraints. - - if Nkind (Nod) = N_Identifier - and then Present (Original_Node (Nod)) - and then Nkind (Original_Node (Nod)) = N_Subtype_Indication - then - declare - Discr : Node_Id; - Discr_Elmt : Elmt_Id; - - begin - if Is_Record_Type (Entity (Nod)) then - Discr_Elmt := - First_Elmt (Discriminant_Constraint (Entity (Nod))); - while Present (Discr_Elmt) loop - Discr := Node (Discr_Elmt); - - if Nkind (Discr) = N_Identifier - and then Present (Original_Node (Discr)) - and then Nkind (Original_Node (Discr)) = N_Allocator - and then Present (Coextensions ( - Original_Node (Discr))) - then - if No (Coextensions (Root)) then - Set_Coextensions (Root, New_Elmt_List); - end if; - - Copy_List - (From => Coextensions (Original_Node (Discr)), - To => Coextensions (Root)); - end if; - - Next_Elmt (Discr_Elmt); - end loop; - - -- There is no need to continue the traversal of this - -- subtree since all the information has already been - -- propagated. - - return Skip; - end if; - end; - - -- Case of either a stand alone allocator or a rewritten allocator - -- with an aggregate. - - else - if Present (Original_Node (Nod)) then - Orig_Nod := Original_Node (Nod); - end if; - - if Nkind (Orig_Nod) = N_Allocator then - - -- Propagate the list of nested coextensions to the Root - -- allocator. This is done through list copy since a single - -- allocator may have multiple coextensions. Do not touch - -- coextensions roots. - - if not Is_Coextension_Root (Orig_Nod) - and then Present (Coextensions (Orig_Nod)) - then - if No (Coextensions (Root)) then - Set_Coextensions (Root, New_Elmt_List); - end if; - - Copy_List - (From => Coextensions (Orig_Nod), - To => Coextensions (Root)); - end if; - - -- There is no need to continue the traversal of this - -- subtree since all the information has already been - -- propagated. - - return Skip; - end if; - end if; - - -- Keep on traversing, looking for the next allocator - - return OK; - end Process_Allocator; - - procedure Process_Allocators is - new Traverse_Proc (Process_Allocator); - - -- Start of processing for Propagate_Coextensions begin - Process_Allocators (Expression (Root)); - end Propagate_Coextensions; + return + Nkind_In (Par, N_Function_Call, + N_Procedure_Call_Statement) + and then Is_Entity_Name (Name (Par)) + and then Is_Dispatching_Operation (Entity (Name (Par))); + end In_Dispatching_Context; -- Start of processing for Resolve_Allocator @@ -4487,13 +4326,6 @@ package body Sem_Res is Set_Is_Dynamic_Coextension (N, False); Set_Is_Static_Coextension (N, False); end if; - - -- There is no need to propagate any nested coextensions if they - -- are marked as static since they will be rewritten on the spot. - - if not Is_Static_Coextension (N) then - Propagate_Coextensions (N); - end if; end if; end Resolve_Allocator; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 59d86593927..f60aea0bcd1 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -505,9 +505,9 @@ package body Sem_Util is P : constant Node_Id := Prefix (N); D : Elmt_Id; Id : Node_Id; - Indx_Type : Entity_Id; + Index_Typ : Entity_Id; - Deaccessed_T : Entity_Id; + Desig_Typ : Entity_Id; -- This is either a copy of T, or if T is an access type, then it is -- the directly designated type of this access type. @@ -533,7 +533,7 @@ package body Sem_Util is Old_Lo : Node_Id; begin - Indx := First_Index (Deaccessed_T); + Indx := First_Index (Desig_Typ); while Present (Indx) loop Old_Lo := Type_Low_Bound (Etype (Indx)); Old_Hi := Type_High_Bound (Etype (Indx)); @@ -584,7 +584,7 @@ package body Sem_Util is D_Val : Node_Id; begin - D := First_Elmt (Discriminant_Constraint (Deaccessed_T)); + D := First_Elmt (Discriminant_Constraint (Desig_Typ)); while Present (D) loop if Denotes_Discriminant (Node (D)) then D_Val := Make_Selected_Component (Loc, @@ -636,19 +636,19 @@ package body Sem_Util is end if; if Ekind (T) = E_Access_Subtype then - Deaccessed_T := Designated_Type (T); + Desig_Typ := Designated_Type (T); else - Deaccessed_T := T; + Desig_Typ := T; end if; - if Ekind (Deaccessed_T) = E_Array_Subtype then - Id := First_Index (Deaccessed_T); + if Ekind (Desig_Typ) = E_Array_Subtype then + Id := First_Index (Desig_Typ); while Present (Id) loop - Indx_Type := Underlying_Type (Etype (Id)); + Index_Typ := Underlying_Type (Etype (Id)); - if Denotes_Discriminant (Type_Low_Bound (Indx_Type)) + if Denotes_Discriminant (Type_Low_Bound (Index_Typ)) or else - Denotes_Discriminant (Type_High_Bound (Indx_Type)) + Denotes_Discriminant (Type_High_Bound (Index_Typ)) then Remove_Side_Effects (P); return @@ -659,11 +659,17 @@ package body Sem_Util is Next_Index (Id); end loop; - elsif Is_Composite_Type (Deaccessed_T) - and then Has_Discriminants (Deaccessed_T) - and then not Has_Unknown_Discriminants (Deaccessed_T) + elsif Is_Composite_Type (Desig_Typ) + and then Has_Discriminants (Desig_Typ) + and then not Has_Unknown_Discriminants (Desig_Typ) then - D := First_Elmt (Discriminant_Constraint (Deaccessed_T)); + if Is_Private_Type (Desig_Typ) + and then No (Discriminant_Constraint (Desig_Typ)) + then + Desig_Typ := Full_View (Desig_Typ); + end if; + + D := First_Elmt (Discriminant_Constraint (Desig_Typ)); while Present (D) loop if Denotes_Discriminant (Node (D)) then Remove_Side_Effects (P); @@ -3114,12 +3120,6 @@ package body Sem_Util is then null; - -- A controller component for a type extension overrides the - -- inherited component. - - elsif Chars (E) = Name_uController then - null; - -- Case of an implicit operation or derived literal. The new entity -- hides the implicit one, which is removed from all visibility, -- i.e. the entity list of its scope, and homonym chain of its name. @@ -3898,7 +3898,6 @@ package body Sem_Util is begin if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent - and then Chars (Comp) /= Name_uController then Append_Elmt (Comp, Into); end if; @@ -5970,6 +5969,118 @@ package body Sem_Util is and then not In_Private_Part (Scope_Id); end In_Visible_Part; + -------------------------------- + -- Incomplete_Or_Private_View -- + -------------------------------- + + function Incomplete_Or_Private_View (Typ : Entity_Id) return Entity_Id is + function Inspect_Decls + (Decls : List_Id; + Taft : Boolean := False) return Entity_Id; + -- Check whether a declarative region contains the incomplete or private + -- view of Typ. + + ------------------- + -- Inspect_Decls -- + ------------------- + + function Inspect_Decls + (Decls : List_Id; + Taft : Boolean := False) return Entity_Id + is + Decl : Node_Id; + Match : Node_Id; + + begin + Decl := First (Decls); + while Present (Decl) loop + Match := Empty; + + if Taft then + if Nkind (Decl) = N_Incomplete_Type_Declaration then + Match := Defining_Identifier (Decl); + end if; + else + if Nkind_In (Decl, N_Private_Extension_Declaration, + N_Private_Type_Declaration) + then + Match := Defining_Identifier (Decl); + end if; + end if; + + if Present (Match) + and then Present (Full_View (Match)) + and then Full_View (Match) = Typ + then + return Match; + end if; + + Next (Decl); + end loop; + + return Empty; + end Inspect_Decls; + + Prev : Entity_Id; + + -- Start of processing for Incomplete_Or_Partial_View + + begin + -- Incomplete type case + + Prev := Current_Entity_In_Scope (Typ); + + if Present (Prev) + and then Is_Incomplete_Type (Prev) + and then Present (Full_View (Prev)) + and then Full_View (Prev) = Typ + then + return Prev; + end if; + + -- Private or Taft amendment type case + + declare + Pkg : constant Entity_Id := Scope (Typ); + Pkg_Decl : Node_Id := Pkg; + + begin + if Ekind (Pkg) = E_Package then + while Nkind (Pkg_Decl) /= N_Package_Specification loop + Pkg_Decl := Parent (Pkg_Decl); + end loop; + + -- It is knows that Typ has a private view, look for it in the + -- visible declarations of the enclosing scope. A special case + -- of this is when the two views have been exchanged - the full + -- appears earlier than the private. + + if Has_Private_Declaration (Typ) then + Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl)); + + -- Exchanged view case, look in the private declarations + + if No (Prev) then + Prev := Inspect_Decls (Private_Declarations (Pkg_Decl)); + end if; + + return Prev; + + -- Otherwise if this is the package body, then Typ is a potential + -- Taft amendment type. The incomplete view should be located in + -- the private declarations of the enclosing scope. + + elsif In_Package_Body (Pkg) then + return Inspect_Decls (Private_Declarations (Pkg_Decl), True); + end if; + end if; + end; + + -- The type has no incomplete or private view + + return Empty; + end Incomplete_Or_Private_View; + --------------------------------- -- Insert_Explicit_Dereference -- --------------------------------- @@ -6294,23 +6405,6 @@ package body Sem_Util is end if; end Is_Atomic_Object; - ------------------------- - -- Is_Coextension_Root -- - ------------------------- - - function Is_Coextension_Root (N : Node_Id) return Boolean is - begin - return - Nkind (N) = N_Allocator - and then Present (Coextensions (N)) - - -- Anonymous access discriminants carry a list of all nested - -- controlled coextensions. - - and then not Is_Dynamic_Coextension (N) - and then not Is_Static_Coextension (N); - end Is_Coextension_Root; - ----------------------------- -- Is_Concurrent_Interface -- ----------------------------- @@ -6819,10 +6913,7 @@ package body Sem_Util is begin Ent := First_Entity (Typ); while Present (Ent) loop - if Chars (Ent) = Name_uController then - null; - - elsif Ekind (Ent) = E_Component + if Ekind (Ent) = E_Component and then (No (Parent (Ent)) or else No (Expression (Parent (Ent)))) and then not Is_Fully_Initialized_Type (Etype (Ent)) diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index ceba869804b..954a11e70e6 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -395,15 +395,15 @@ package Sem_Util is -- discriminant at the same position in this new type. procedure Find_Overlaid_Entity - (N : Node_Id; + (N : Node_Id; Ent : out Entity_Id; Off : out Boolean); - -- The node N should be an address representation clause. Determines if the - -- target expression is the address of an entity with an optional offset. - -- If so, Ent is set to the entity and, if there is an offset, Off is set - -- to True, otherwise to False. If N is not an address representation + -- The node N should be an address representation clause. Determines if + -- the target expression is the address of an entity with an optional + -- offset. If so, set Ent to the entity and, if there is an offset, set + -- Off to True, otherwise to False. If N is not an address representation -- clause, or if it is not possible to determine that the address is of - -- this form, then Ent is set to Empty, and Off is set to False. + -- this form, then set Ent to Empty. function Find_Parameter_Type (Param : Node_Id) return Entity_Id; -- Return the type of formal parameter Param as determined by its @@ -689,6 +689,11 @@ package Sem_Util is -- package specification. The package must be on the scope stack, and the -- corresponding private part must not. + function Incomplete_Or_Private_View (Typ : Entity_Id) return Entity_Id; + -- Given the entity of a type, retrieve the incomplete or private view of + -- the same type. Note that Typ may not have a partial view to begin with, + -- in that case the function returns Empty. + procedure Insert_Explicit_Dereference (N : Node_Id); -- In a context that requires a composite or subprogram type and where a -- prefix is an access type, rewrite the access type node N (which is the @@ -722,10 +727,6 @@ package Sem_Util is -- Determines if the given node denotes an atomic object in the sense of -- the legality checks described in RM C.6(12). - function Is_Coextension_Root (N : Node_Id) return Boolean; - -- Determine whether node N is an allocator which acts as a coextension - -- root. - function Is_Controlling_Limited_Procedure (Proc_Nam : Entity_Id) return Boolean; -- Ada 2005 (AI-345): Determine whether Proc_Nam is a primitive procedure @@ -1209,11 +1210,11 @@ package Sem_Util is -- previous errors (particularly in -gnatq mode). function Requires_Transient_Scope (Id : Entity_Id) return Boolean; - -- E is a type entity. The result is True when temporaries of this - -- type need to be wrapped in a transient scope to be reclaimed - -- properly when a secondary stack is in use. Examples of types - -- requiring such wrapping are controlled types and variable-sized - -- types including unconstrained arrays + -- E is a type entity. The result is True when temporaries of this type + -- need to be wrapped in a transient scope to be reclaimed properly when a + -- secondary stack is in use. Examples of types requiring such wrapping are + -- controlled types and variable-sized types including unconstrained + -- arrays. procedure Reset_Analyzed_Flags (N : Node_Id); -- Reset the Analyzed flags in all nodes of the tree whose root is N diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index fb9ab568f8b..40d8dd6aecd 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -410,14 +410,6 @@ package body Sinfo is return Flag6 (N); end Class_Present; - function Coextensions - (N : Node_Id) return Elist_Id is - begin - pragma Assert (False - or else NT (N).Nkind = N_Allocator); - return Elist4 (N); - end Coextensions; - function Comes_From_Extended_Return_Statement (N : Node_Id) return Boolean is begin @@ -3469,14 +3461,6 @@ package body Sinfo is Set_Flag6 (N, Val); end Set_Class_Present; - procedure Set_Coextensions - (N : Node_Id; Val : Elist_Id) is - begin - pragma Assert (False - or else NT (N).Nkind = N_Allocator); - Set_Elist4 (N, Val); - end Set_Coextensions; - procedure Set_Comes_From_Extended_Return_Statement (N : Node_Id; Val : Boolean := True) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 48b138e4c7c..7ee9a80a550 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -657,10 +657,6 @@ package Sinfo is -- attribute definition clause is given, rather than testing this at the -- freeze point. - -- Coextensions (Elist4-Sem) - -- Present in allocators nodes. Points to list of allocators for the - -- access discriminants of the allocated object. - -- Comes_From_Extended_Return_Statement (Flag18-Sem) -- Present in N_Simple_Return_Statement nodes. True if this node was -- constructed as part of the N_Extended_Return_Statement expansion. @@ -1663,10 +1659,9 @@ package Sinfo is -- Points to an E_Return_Statement representing the return statement. -- Return_Object_Declarations (List3) - -- Present in N_Extended_Return_Statement. - -- Points to a list initially containing a single - -- N_Object_Declaration representing the return object. - -- We use a list (instead of just a pointer to the object decl) + -- Present in N_Extended_Return_Statement. Points to a list initially + -- containing a single N_Object_Declaration representing the return + -- object. We use a list (instead of just a pointer to the object decl) -- because Analyze wants to insert extra actions on this list. -- Rounded_Result (Flag18-Sem) @@ -3959,7 +3954,6 @@ package Sinfo is -- Expression (Node3) subtype indication or qualified expression -- Storage_Pool (Node1-Sem) -- Procedure_To_Call (Node2-Sem) - -- Coextensions (Elist4-Sem) -- Null_Exclusion_Present (Flag11) -- No_Initialization (Flag13-Sem) -- Is_Static_Coextension (Flag14-Sem) @@ -8126,9 +8120,6 @@ package Sinfo is function Class_Present (N : Node_Id) return Boolean; -- Flag6 - function Coextensions - (N : Node_Id) return Elist_Id; -- Elist4 - function Comes_From_Extended_Return_Statement (N : Node_Id) return Boolean; -- Flag18 @@ -9101,9 +9092,6 @@ package Sinfo is procedure Set_Class_Present (N : Node_Id; Val : Boolean := True); -- Flag6 - procedure Set_Coextensions - (N : Node_Id; Val : Elist_Id); -- Elist4 - procedure Set_Comes_From_Extended_Return_Statement (N : Node_Id; Val : Boolean := True); -- Flag18 @@ -10636,7 +10624,7 @@ package Sinfo is (1 => False, -- Storage_Pool (Node1-Sem) 2 => False, -- Procedure_To_Call (Node2-Sem) 3 => True, -- Expression (Node3) - 4 => False, -- Coextensions (Elist4-Sem) + 4 => False, -- unused 5 => False), -- Etype (Node5-Sem) N_Null_Statement => @@ -11717,7 +11705,6 @@ package Sinfo is pragma Inline (Choice_Parameter); pragma Inline (Choices); pragma Inline (Class_Present); - pragma Inline (Coextensions); pragma Inline (Comes_From_Extended_Return_Statement); pragma Inline (Compile_Time_Known_Aggregate); pragma Inline (Component_Associations); @@ -12039,7 +12026,6 @@ package Sinfo is pragma Inline (Set_Choice_Parameter); pragma Inline (Set_Choices); pragma Inline (Set_Class_Present); - pragma Inline (Set_Coextensions); pragma Inline (Set_Comes_From_Extended_Return_Statement); pragma Inline (Set_Compile_Time_Known_Aggregate); pragma Inline (Set_Component_Associations); diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 981784bb37f..73fbdfc4627 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -6,7 +6,7 @@ -- -- -- T e m p l a t e -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -154,15 +154,13 @@ package Snames is Name_uAssign : constant Name_Id := N + $; Name_uATCB : constant Name_Id := N + $; Name_uChain : constant Name_Id := N + $; - Name_uClean : constant Name_Id := N + $; Name_uController : constant Name_Id := N + $; Name_uCPU : constant Name_Id := N + $; Name_uEntry_Bodies : constant Name_Id := N + $; Name_uExpunge : constant Name_Id := N + $; - Name_uFinal_List : constant Name_Id := N + $; + Name_uFinalizer : constant Name_Id := N + $; Name_uIdepth : constant Name_Id := N + $; Name_uInit : constant Name_Id := N + $; - Name_uLocal_Final_List : constant Name_Id := N + $; Name_uMaster : constant Name_Id := N + $; Name_uObject : constant Name_Id := N + $; Name_uPostconditions : constant Name_Id := N + $; @@ -191,17 +189,12 @@ package Snames is Name_uDisp_Requeue : constant Name_Id := N + $; Name_uDisp_Timed_Select : constant Name_Id := N + $; - -- Names of routines in Ada.Finalization, needed by expander + -- Names of routines and fields in Ada.Finalization, needed by expander Name_Initialize : constant Name_Id := N + $; Name_Adjust : constant Name_Id := N + $; Name_Finalize : constant Name_Id := N + $; - - -- Names of fields declared in System.Finalization_Implementation, - -- needed by the expander when generating code for finalization. - - Name_Next : constant Name_Id := N + $; - Name_Prev : constant Name_Id := N + $; + Name_Finalize_Address : constant Name_Id := N + $; -- Names of allocation routines, also needed by expander @@ -240,7 +233,6 @@ package Snames is Name_Exception_Traces : constant Name_Id := N + $; Name_Finalization : constant Name_Id := N + $; - Name_Finalization_Root : constant Name_Id := N + $; Name_Interfaces : constant Name_Id := N + $; Name_Most_Recent_Exception : constant Name_Id := N + $; Name_Standard : constant Name_Id := N + $; @@ -1205,11 +1197,12 @@ package Snames is Name_Unaligned_Valid : constant Name_Id := N + $; - -- Names used to implement iterators over predefined containers + -- Names used to implement iterators over predefined containers Name_Cursor : constant Name_Id := N + $; Name_Element : constant Name_Id := N + $; Name_Element_Type : constant Name_Id := N + $; + Name_Next : constant Name_Id := N + $; Name_No_Element : constant Name_Id := N + $; Name_Previous : constant Name_Id := N + $; diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 3edb41e6e93..91fbf85121a 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -766,8 +766,9 @@ package body Tbuild is (Typ : Entity_Id; Expr : Node_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (Expr); - Result : Node_Id; + Loc : constant Source_Ptr := Sloc (Expr); + Result : Node_Id; + Expr_Parent : Node_Id; begin -- If the expression is already of the correct type, then nothing @@ -797,10 +798,18 @@ package body Tbuild is -- All other cases else + -- Capture the parent of the expression before relocating it and + -- creating the conversion, so the conversion's parent can be set + -- to the original parent below. + + Expr_Parent := Parent (Expr); + Result := Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Typ, Loc), Expression => Relocate_Node (Expr)); + + Set_Parent (Result, Expr_Parent); end if; Set_Etype (Result, Typ); |