diff options
73 files changed, 11928 insertions, 7005 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 75eeedc..b526c82 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 ed7ec12..0c8dac0 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 d7763db..e69e859 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 033244d..a17d655 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 e80e264..2b51c1f 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 14aea1d..1fa0d1c 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 0000000..cc800f3 --- /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 0000000..028d771 --- /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 f6bd78dd2..0000000 --- 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 566d0df..0000000 --- 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 5dae78e..dc2cdf7 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 9e81722..d5cada2 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 7a5f7bc..3473b4d 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 3d415a0..99ee5aa1 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 026837c..e998aee 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 ab15ca1..0a80817 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 bb678a5..0df415d 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 2f88bb4..6538a19c 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 cc4e9b1..31df7e9 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 5d1928d..eeec470 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 ff07cfc..9478ae3 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 e05834c..3fa3751 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 27602cd..a38eb59 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 a0250ec..d2143c1 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 4090d8a..484fe64 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 f4e103f..682ae94 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 91431ef..54aba22 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 1487f77..95b23d8 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -44,6 +44,7 @@ with Exp_Util; use Exp_Util; with Exp_VFpt; use Exp_VFpt; with Freeze; use Freeze; with Inline; use Inline; +with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -56,7 +57,6 @@ with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; -with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; @@ -91,6 +91,13 @@ package body Exp_Ch4 is -- If a boolean array assignment can be done in place, build call to -- corresponding library procedure. + procedure Complete_Controlled_Allocation (Temp_Decl : Node_Id); + -- Subsidiary to Expand_N_Allocator and Expand_Allocator_Expression. Formal + -- Temp_Decl is the declaration of a temporary which hold the value of the + -- original allocator. Create a custom Allocate routine for the expression + -- of Temp_Decl. The routine does special processing for anonymous access + -- types. + procedure Displace_Allocator_Pointer (N : Node_Id); -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and -- Expand_Allocator_Expression. Allocating class-wide interface objects @@ -158,14 +165,6 @@ package body Exp_Ch4 is -- routine is to find the real type by looking up the tree. We also -- determine if the operation must be rounded. - function Get_Allocator_Final_List - (N : Node_Id; - T : Entity_Id; - PtrT : Entity_Id) return Entity_Id; - -- If the designated type is controlled, build final_list expression for - -- created object. If context is an access parameter, create a local access - -- type to have a usable finalization list. - function Has_Inferable_Discriminants (N : Node_Id) return Boolean; -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable -- discriminants if it has a constrained nominal type, unless the object @@ -375,6 +374,113 @@ package body Exp_Ch4 is return; end Build_Boolean_Array_Proc_Call; + ------------------------------------ + -- Complete_Controlled_Allocation -- + ------------------------------------ + + procedure Complete_Controlled_Allocation (Temp_Decl : Node_Id) is + pragma Assert (Nkind (Temp_Decl) = N_Object_Declaration); + + Ptr_Typ : constant Entity_Id := Etype (Defining_Identifier (Temp_Decl)); + + function First_Declaration_Of_Current_Unit return Node_Id; + -- Return the current unit's first declaration. If the declaration list + -- is empty, the routine generates a null statement and returns it. + + --------------------------------------- + -- First_Declaration_Of_Current_Unit -- + --------------------------------------- + + function First_Declaration_Of_Current_Unit return Node_Id is + Sem_U : Node_Id := Unit (Cunit (Current_Sem_Unit)); + Decl : Node_Id; + Decls : List_Id; + + begin + if Nkind (Sem_U) = N_Package_Declaration then + Sem_U := Specification (Sem_U); + Decls := Visible_Declarations (Sem_U); + + if No (Decls) then + Decl := Make_Null_Statement (Sloc (Sem_U)); + Decls := New_List (Decl); + Set_Visible_Declarations (Sem_U, Decls); + else + Decl := First (Decls); + end if; + + else + Decls := Declarations (Sem_U); + + if No (Decls) then + Decl := Make_Null_Statement (Sloc (Sem_U)); + Decls := New_List (Decl); + Set_Declarations (Sem_U, Decls); + else + Decl := First (Decls); + end if; + end if; + + return Decl; + end First_Declaration_Of_Current_Unit; + + -- Start of processing for Complete_Controlled_Allocation + + begin + -- Do nothing if the access type may never allocate an object + + if No_Pool_Assigned (Ptr_Typ) then + return; + + -- Access-to-controlled types are not supported on .NET/JVM + + elsif VM_Target /= No_VM then + return; + end if; + + -- Processing for anonymous access-to-controlled types. These access + -- types receive a special collection which appears on the declarations + -- of the enclosing semantic unit. + + if Ekind (Ptr_Typ) = E_Anonymous_Access_Type + and then No (Associated_Collection (Ptr_Typ)) + and then + (not Restriction_Active (No_Nested_Finalization) + or else Is_Library_Level_Entity (Ptr_Typ)) + then + declare + Pool_Id : constant Entity_Id := RTE (RE_Global_Pool_Object); + Scop : Node_Id := Cunit_Entity (Current_Sem_Unit); + + begin + -- Use the scope of the current semantic unit when analyzing + + if Ekind (Scop) = E_Subprogram_Body then + Scop := Corresponding_Spec (Parent (Parent (Parent (Scop)))); + end if; + + Build_Finalization_Collection + (Typ => Ptr_Typ, + Ins_Node => First_Declaration_Of_Current_Unit, + Encl_Scope => Scop); + + -- Decorate the anonymous access type and the allocator node + + Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); + Set_Storage_Pool (Expression (Temp_Decl), Pool_Id); + end; + end if; + + -- Since the temporary object reuses the original allocator, generate a + -- custom Allocate routine for the temporary. + + if Present (Associated_Collection (Ptr_Typ)) then + Build_Allocate_Deallocate_Proc + (N => Temp_Decl, + Is_Allocate => True); + end if; + end Complete_Controlled_Allocation; + -------------------------------- -- Displace_Allocator_Pointer -- -------------------------------- @@ -545,28 +651,30 @@ package body Exp_Ch4 is end if; Insert_Action (N, - Make_Raise_Program_Error (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => - Build_Get_Access_Level (Loc, - Make_Attribute_Reference (Loc, - Prefix => Ref_Node, - Attribute_Name => Name_Tag)), - Right_Opnd => - Make_Integer_Literal (Loc, - Type_Access_Level (PtrT))), - Reason => PE_Accessibility_Check_Failed)); + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => + Build_Get_Access_Level (Loc, + Make_Attribute_Reference (Loc, + Prefix => Ref_Node, + Attribute_Name => Name_Tag)), + Right_Opnd => + Make_Integer_Literal (Loc, + Type_Access_Level (PtrT))), + Reason => PE_Accessibility_Check_Failed)); end if; end Apply_Accessibility_Check; -- Local variables - Indic : constant Node_Id := Subtype_Mark (Expression (N)); - T : constant Entity_Id := Entity (Indic); - Flist : Node_Id; - Node : Node_Id; - Temp : Entity_Id; + Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp); + Indic : constant Node_Id := Subtype_Mark (Expression (N)); + T : constant Entity_Id := Entity (Indic); + Node : Node_Id; + Tag_Assign : Node_Id; + Temp : Entity_Id; + Temp_Decl : Node_Id; TagT : Entity_Id := Empty; -- Type used as source for tag assignment @@ -574,39 +682,37 @@ package body Exp_Ch4 is TagR : Node_Id := Empty; -- Target reference for tag assignment - Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp); - - Tag_Assign : Node_Id; - Tmp_Node : Node_Id; - -- Start of processing for Expand_Allocator_Expression begin - if Is_Tagged_Type (T) or else Needs_Finalization (T) then - + if Is_Tagged_Type (T) + or else Needs_Finalization (T) + then if Is_CPP_Constructor_Call (Exp) then -- Generate: - -- Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn + -- Pnnn : constant ptr_T := new (T); + -- Init (Pnnn.all,...); - -- Allocate the object with no expression + -- Allocate the object without an expression Node := Relocate_Node (N); Set_Expression (Node, New_Reference_To (Etype (Exp), Loc)); -- Avoid its expansion to avoid generating a call to the default - -- C++ constructor + -- C++ constructor. Set_Analyzed (Node); Temp := Make_Temporary (Loc, 'P', N); - Insert_Action (N, + Temp_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Constant_Present => True, Object_Definition => New_Reference_To (PtrT, Loc), - Expression => Node)); + Expression => Node); + Insert_Action (N, Temp_Decl); Apply_Accessibility_Check (Temp); @@ -698,7 +804,6 @@ package body Exp_Ch4 is Make_Attribute_Reference (Loc, Prefix => Exp, Attribute_Name => Name_Address))))); - else Set_Expression (Expression (N), @@ -708,17 +813,18 @@ package body Exp_Ch4 is Analyze_And_Resolve (Expression (N), Entity (Indic)); end if; - -- Keep separate the management of allocators returning interfaces + -- Processing for allocators returning non-interface types if not Is_Interface (Directly_Designated_Type (PtrT)) then if Aggr_In_Place then - Tmp_Node := + Temp_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => New_Reference_To (PtrT, Loc), Expression => Make_Allocator (Loc, - New_Reference_To (Etype (Exp), Loc))); + Expression => + New_Reference_To (Etype (Exp), Loc))); -- Copy the Comes_From_Source flag for the allocator we just -- built, since logically this allocator is a replacement of @@ -726,30 +832,27 @@ package body Exp_Ch4 is -- restriction No_Implicit_Heap_Allocations. Set_Comes_From_Source - (Expression (Tmp_Node), Comes_From_Source (N)); + (Expression (Temp_Decl), Comes_From_Source (N)); - Set_No_Initialization (Expression (Tmp_Node)); - Insert_Action (N, Tmp_Node); + Set_No_Initialization (Expression (Temp_Decl)); + Insert_Action (N, Temp_Decl); - if Needs_Finalization (T) - and then Ekind (PtrT) = E_Anonymous_Access_Type - then - -- Create local finalization list for access parameter - - Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT); - end if; - - Convert_Aggr_In_Allocator (N, Tmp_Node, Exp); + Complete_Controlled_Allocation (Temp_Decl); + Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); else Node := Relocate_Node (N); Set_Analyzed (Node); - Insert_Action (N, + + Temp_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Constant_Present => True, Object_Definition => New_Reference_To (PtrT, Loc), - Expression => Node)); + Expression => Node); + + Insert_Action (N, Temp_Decl); + Complete_Controlled_Allocation (Temp_Decl); end if; -- Ada 2005 (AI-251): Handle allocators whose designated type is an @@ -775,18 +878,19 @@ package body Exp_Ch4 is Insert_Action (N, New_Decl); - -- Inherit the final chain to ensure that the expansion of the - -- aggregate is correct in case of controlled types + -- Inherit the allocation-related attributes from the original + -- access type. - if Needs_Finalization (Directly_Designated_Type (PtrT)) then - Set_Associated_Final_Chain (Def_Id, - Associated_Final_Chain (PtrT)); - end if; + Set_Associated_Collection (Def_Id, + Associated_Collection (PtrT)); + + Set_Associated_Storage_Pool (Def_Id, + Associated_Storage_Pool (PtrT)); -- Declare the object using the previous type declaration if Aggr_In_Place then - Tmp_Node := + Temp_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => New_Reference_To (Def_Id, Loc), @@ -800,30 +904,27 @@ package body Exp_Ch4 is -- of restriction No_Implicit_Heap_Allocations. Set_Comes_From_Source - (Expression (Tmp_Node), Comes_From_Source (N)); - - Set_No_Initialization (Expression (Tmp_Node)); - Insert_Action (N, Tmp_Node); + (Expression (Temp_Decl), Comes_From_Source (N)); - if Needs_Finalization (T) - and then Ekind (PtrT) = E_Anonymous_Access_Type - then - -- Create local finalization list for access parameter + Set_No_Initialization (Expression (Temp_Decl)); + Insert_Action (N, Temp_Decl); - Flist := - Get_Allocator_Final_List (N, Base_Type (T), PtrT); - end if; + Complete_Controlled_Allocation (Temp_Decl); + Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); - Convert_Aggr_In_Allocator (N, Tmp_Node, Exp); else Node := Relocate_Node (N); Set_Analyzed (Node); - Insert_Action (N, + + Temp_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Constant_Present => True, Object_Definition => New_Reference_To (Def_Id, Loc), - Expression => Node)); + Expression => Node); + + Insert_Action (N, Temp_Decl); + Complete_Controlled_Allocation (Temp_Decl); end if; -- Generate an additional object containing the address of the @@ -835,15 +936,18 @@ package body Exp_Ch4 is New_Decl := Make_Object_Declaration (Loc, - Defining_Identifier => Make_Temporary (Loc, 'P'), - Object_Definition => New_Reference_To (PtrT, Loc), - Expression => Unchecked_Convert_To (PtrT, - New_Reference_To (Temp, Loc))); + Defining_Identifier => + Make_Temporary (Loc, 'P'), + Object_Definition => + New_Reference_To (PtrT, Loc), + Expression => + Unchecked_Convert_To (PtrT, + New_Reference_To (Temp, Loc))); Insert_Action (N, New_Decl); - Tmp_Node := New_Decl; - Temp := Defining_Identifier (New_Decl); + Temp_Decl := New_Decl; + Temp := Defining_Identifier (New_Decl); end; end if; @@ -906,77 +1010,43 @@ package body Exp_Ch4 is if Needs_Finalization (DesigT) and then Needs_Finalization (T) then - declare - Attach : Node_Id; - Apool : constant Entity_Id := - Associated_Storage_Pool (PtrT); - - begin - -- If it is an allocation on the secondary stack (i.e. a value - -- returned from a function), the object is attached on the - -- caller side as soon as the call is completed (see - -- Expand_Ctrl_Function_Call) - - if Is_RTE (Apool, RE_SS_Pool) then - declare - F : constant Entity_Id := Make_Temporary (Loc, 'F'); - begin - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => F, - Object_Definition => - New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); - Flist := New_Reference_To (F, Loc); - Attach := Make_Integer_Literal (Loc, 1); - end; - - -- Normal case, not a secondary stack allocation - - else - if Needs_Finalization (T) - and then Ekind (PtrT) = E_Anonymous_Access_Type - then - -- Create local finalization list for access parameter - - Flist := - Get_Allocator_Final_List (N, Base_Type (T), PtrT); - else - Flist := Find_Final_List (PtrT); - end if; - - Attach := Make_Integer_Literal (Loc, 2); - end if; - - -- Generate an Adjust call if the object will be moved. In Ada - -- 2005, the object may be inherently limited, in which case - -- there is no Adjust procedure, and the object is built in - -- place. In Ada 95, the object can be limited but not - -- inherently limited if this allocator came from a return - -- statement (we're allocating the result on the secondary - -- stack). In that case, the object will be moved, so we _do_ - -- want to Adjust. - - if not Aggr_In_Place - and then not Is_Immutably_Limited_Type (T) - then - Insert_Actions (N, - Make_Adjust_Call ( - Ref => + -- Generate an Adjust call if the object will be moved. In Ada + -- 2005, the object may be inherently limited, in which case + -- there is no Adjust procedure, and the object is built in + -- place. In Ada 95, the object can be limited but not + -- inherently limited if this allocator came from a return + -- statement (we're allocating the result on the secondary + -- stack). In that case, the object will be moved, so we _do_ + -- want to Adjust. + + if not Aggr_In_Place + and then not Is_Immutably_Limited_Type (T) + then + Insert_Action (N, + Make_Adjust_Call ( + Obj_Ref => -- An unchecked conversion is needed in the classwide - -- case because the designated type can be an ancestor of - -- the subtype mark of the allocator. + -- case because the designated type can be an ancestor + -- of the subtype mark of the allocator. - Unchecked_Convert_To (T, - Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Temp, Loc))), + Unchecked_Convert_To (T, + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Temp, Loc))), + Typ => T)); + end if; - Typ => T, - Flist_Ref => Flist, - With_Attach => Attach, - Allocator => True)); - end if; - end; + -- Generate: + -- Set_Finalize_Address_Ptr + -- (Collection, <Finalize_Address>'Unrestricted_Access) + + if Present (Associated_Collection (PtrT)) then + Insert_Action (N, + Make_Set_Finalize_Address_Ptr_Call ( + Loc => Loc, + Typ => T, + Ptr_Typ => PtrT)); + end if; end if; Rewrite (N, New_Reference_To (Temp, Loc)); @@ -992,12 +1062,14 @@ package body Exp_Ch4 is elsif Aggr_In_Place then Temp := Make_Temporary (Loc, 'P', N); - Tmp_Node := + Temp_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => New_Reference_To (PtrT, Loc), - Expression => Make_Allocator (Loc, - New_Reference_To (Etype (Exp), Loc))); + Expression => + Make_Allocator (Loc, + Expression => + New_Reference_To (Etype (Exp), Loc))); -- Copy the Comes_From_Source flag for the allocator we just built, -- since logically this allocator is a replacement of the original @@ -1005,11 +1077,14 @@ package body Exp_Ch4 is -- No_Implicit_Heap_Allocations. Set_Comes_From_Source - (Expression (Tmp_Node), Comes_From_Source (N)); + (Expression (Temp_Decl), Comes_From_Source (N)); + + Set_No_Initialization (Expression (Temp_Decl)); + Insert_Action (N, Temp_Decl); + + Complete_Controlled_Allocation (Temp_Decl); + Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); - Set_No_Initialization (Expression (Tmp_Node)); - Insert_Action (N, Tmp_Node); - Convert_Aggr_In_Allocator (N, Tmp_Node, Exp); Rewrite (N, New_Reference_To (Temp, Loc)); Analyze_And_Resolve (N, PtrT); @@ -3108,10 +3183,6 @@ package body Exp_Ch4 is Temp : Entity_Id; Nod : Node_Id; - procedure Complete_Coextension_Finalization; - -- Generate finalization calls for all nested coextensions of N. This - -- routine may allocate list controllers if necessary. - procedure Rewrite_Coextension (N : Node_Id); -- Static coextensions have the same lifetime as the entity they -- constrain. Such occurrences can be rewritten as aliased objects @@ -3123,227 +3194,49 @@ package body Exp_Ch4 is -- This is done without using the attribute (which malfunctions for -- large sizes ???) - --------------------------------------- - -- Complete_Coextension_Finalization -- - --------------------------------------- - - procedure Complete_Coextension_Finalization is - Coext : Node_Id; - Coext_Elmt : Elmt_Id; - Flist : Node_Id; - Ref : Node_Id; - - function Inside_A_Return_Statement (N : Node_Id) return Boolean; - -- Determine whether node N is part of a return statement - - function Needs_Initialization_Call (N : Node_Id) return Boolean; - -- Determine whether node N is a subtype indicator allocator which - -- acts a coextension. Such coextensions need initialization. - - ------------------------------- - -- Inside_A_Return_Statement -- - ------------------------------- - - function Inside_A_Return_Statement (N : Node_Id) return Boolean is - P : Node_Id; - - begin - P := Parent (N); - while Present (P) loop - if Nkind_In - (P, N_Extended_Return_Statement, N_Simple_Return_Statement) - then - return True; - - -- Stop the traversal when we reach a subprogram body - - elsif Nkind (P) = N_Subprogram_Body then - return False; - end if; - - P := Parent (P); - end loop; - - return False; - end Inside_A_Return_Statement; - - ------------------------------- - -- Needs_Initialization_Call -- - ------------------------------- - - function Needs_Initialization_Call (N : Node_Id) return Boolean is - Obj_Decl : Node_Id; - - begin - if Nkind (N) = N_Explicit_Dereference - and then Nkind (Prefix (N)) = N_Identifier - and then Nkind (Parent (Entity (Prefix (N)))) = - N_Object_Declaration - then - Obj_Decl := Parent (Entity (Prefix (N))); - - return - Present (Expression (Obj_Decl)) - and then Nkind (Expression (Obj_Decl)) = N_Allocator - and then Nkind (Expression (Expression (Obj_Decl))) /= - N_Qualified_Expression; - end if; - - return False; - end Needs_Initialization_Call; - - -- Start of processing for Complete_Coextension_Finalization - - begin - -- When a coextension root is inside a return statement, we need to - -- use the finalization chain of the function's scope. This does not - -- apply for controlled named access types because in those cases we - -- can use the finalization chain of the type itself. - - if Inside_A_Return_Statement (N) - and then - (Ekind (PtrT) = E_Anonymous_Access_Type - or else - (Ekind (PtrT) = E_Access_Type - and then No (Associated_Final_Chain (PtrT)))) - then - declare - Decl : Node_Id; - Outer_S : Entity_Id; - S : Entity_Id; - - begin - S := Current_Scope; - while Present (S) and then S /= Standard_Standard loop - if Ekind (S) = E_Function then - Outer_S := Scope (S); - - -- Retrieve the declaration of the body - - Decl := - Parent - (Parent - (Corresponding_Body (Parent (Parent (S))))); - exit; - end if; - - S := Scope (S); - end loop; - - -- Push the scope of the function body since we are inserting - -- the list before the body, but we are currently in the body - -- itself. Override the finalization list of PtrT since the - -- finalization context is now different. - - Push_Scope (Outer_S); - Build_Final_List (Decl, PtrT); - Pop_Scope; - end; - - -- The root allocator may not be controlled, but it still needs a - -- finalization list for all nested coextensions. - - elsif No (Associated_Final_Chain (PtrT)) then - Build_Final_List (N, PtrT); - end if; - - Flist := - Make_Selected_Component (Loc, - Prefix => - New_Reference_To (Associated_Final_Chain (PtrT), Loc), - Selector_Name => Make_Identifier (Loc, Name_F)); - - Coext_Elmt := First_Elmt (Coextensions (N)); - while Present (Coext_Elmt) loop - Coext := Node (Coext_Elmt); - - -- Generate: - -- typ! (coext.all) - - if Nkind (Coext) = N_Identifier then - Ref := - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => New_Reference_To (Etype (Coext), Loc), - Expression => - Make_Explicit_Dereference (Loc, - Prefix => New_Copy_Tree (Coext))); - else - Ref := New_Copy_Tree (Coext); - end if; - - -- No initialization call if not allowed - - Check_Restriction (No_Default_Initialization, N); - - if not Restriction_Active (No_Default_Initialization) then - - -- Generate: - -- initialize (Ref) - -- attach_to_final_list (Ref, Flist, 2) - - if Needs_Initialization_Call (Coext) then - Insert_Actions (N, - Make_Init_Call ( - Ref => Ref, - Typ => Etype (Coext), - Flist_Ref => Flist, - With_Attach => Make_Integer_Literal (Loc, Uint_2))); - - -- Generate: - -- attach_to_final_list (Ref, Flist, 2) - - else - Insert_Action (N, - Make_Attach_Call ( - Obj_Ref => Ref, - Flist_Ref => New_Copy_Tree (Flist), - With_Attach => Make_Integer_Literal (Loc, Uint_2))); - end if; - end if; - - Next_Elmt (Coext_Elmt); - end loop; - end Complete_Coextension_Finalization; - ------------------------- -- Rewrite_Coextension -- ------------------------- procedure Rewrite_Coextension (N : Node_Id) is - Temp : constant Node_Id := Make_Temporary (Loc, 'C'); + Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C'); + Temp_Decl : Node_Id; + Insert_Nod : Node_Id; + begin -- Generate: -- Cnn : aliased Etyp; - Decl : constant Node_Id := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Aliased_Present => True, - Object_Definition => - New_Occurrence_Of (Etyp, Loc)); - Nod : Node_Id; + Temp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (Etyp, Loc)); - begin if Nkind (Expression (N)) = N_Qualified_Expression then - Set_Expression (Decl, Expression (Expression (N))); + Set_Expression (Temp_Decl, Expression (Expression (N))); end if; -- Find the proper insertion node for the declaration - Nod := Parent (N); - while Present (Nod) loop - exit when Nkind (Nod) in N_Statement_Other_Than_Procedure_Call - or else Nkind (Nod) = N_Procedure_Call_Statement - or else Nkind (Nod) in N_Declaration; - Nod := Parent (Nod); + Insert_Nod := Parent (N); + while Present (Insert_Nod) loop + exit when + Nkind (Insert_Nod) in N_Statement_Other_Than_Procedure_Call + or else Nkind (Insert_Nod) = N_Procedure_Call_Statement + or else Nkind (Insert_Nod) in N_Declaration; + + Insert_Nod := Parent (Insert_Nod); end loop; - Insert_Before (Nod, Decl); - Analyze (Decl); + Insert_Before (Insert_Nod, Temp_Decl); + Analyze (Temp_Decl); Rewrite (N, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Temp, Loc), + Prefix => + New_Occurrence_Of (Temp_Id, Loc), Attribute_Name => Name_Unrestricted_Access)); Analyze_And_Resolve (N, PtrT); @@ -3463,7 +3356,7 @@ package body Exp_Ch4 is -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is -- marked as requiring static allocation. - Temp := Make_Temporary (Loc, 'T', Expression (Expression (N))); + Temp := Make_Temporary (Loc, 'T', Expression (Expression (N))); Desig := Subtype_Mark (Expression (N)); -- If context is constrained, use constrained subtype directly, @@ -3505,14 +3398,6 @@ package body Exp_Ch4 is return; end if; - -- The current allocator creates an object which may contain nested - -- coextensions. Use the current allocator's finalization list to - -- generate finalization call for all nested coextensions. - - if Is_Coextension_Root (N) then - Complete_Coextension_Finalization; - end if; - -- Check for size too large, we do this because the back end misses -- proper checks here and can generate rubbish allocation calls when -- we are near the limit. We only do this for the 32-bit address case @@ -3578,21 +3463,27 @@ package body Exp_Ch4 is -- first argument to Init must be converted to the task record type. declare - T : constant Entity_Id := Entity (Expression (N)); - Init : Entity_Id; - Arg1 : Node_Id; - Args : List_Id; - Decls : List_Id; - Decl : Node_Id; - Discr : Elmt_Id; - Flist : Node_Id; - Temp_Decl : Node_Id; - Temp_Type : Entity_Id; - Attach_Level : Uint; + T : constant Entity_Id := Entity (Expression (N)); + Args : List_Id; + Decls : List_Id; + Decl : Node_Id; + Discr : Elmt_Id; + Init : Entity_Id; + Init_Arg1 : Node_Id; + Temp_Decl : Node_Id; + Temp_Type : Entity_Id; begin if No_Initialization (N) then - null; + + -- Even though this might be a simple allocation, create a custom + -- Allocate if the context requires it. + + if Present (Associated_Collection (PtrT)) then + Build_Allocate_Deallocate_Proc + (N => Parent (N), + Is_Allocate => True); + end if; -- Case of no initialization procedure present @@ -3630,10 +3521,12 @@ package body Exp_Ch4 is -- Construct argument list for the initialization routine call - Arg1 := + Init_Arg1 := Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Temp, Loc)); - Set_Assignment_OK (Arg1); + Prefix => + New_Reference_To (Temp, Loc)); + + Set_Assignment_OK (Init_Arg1); Temp_Type := PtrT; -- The initialization procedure expects a specific type. if the @@ -3641,7 +3534,7 @@ package body Exp_Ch4 is -- being allocated has the right specific type. if Is_Class_Wide_Type (Dtyp) then - Arg1 := Unchecked_Convert_To (T, Arg1); + Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1); end if; -- If designated type is a concurrent type or if it is private @@ -3652,27 +3545,29 @@ package body Exp_Ch4 is -- type. if Is_Concurrent_Type (T) then - Arg1 := - Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1); + Init_Arg1 := + Unchecked_Convert_To ( + Corresponding_Record_Type (T), Init_Arg1); elsif Is_Private_Type (T) and then Present (Full_View (T)) and then Is_Concurrent_Type (Full_View (T)) then - Arg1 := + Init_Arg1 := Unchecked_Convert_To - (Corresponding_Record_Type (Full_View (T)), Arg1); + (Corresponding_Record_Type (Full_View (T)), Init_Arg1); elsif Etype (First_Formal (Init)) /= Base_Type (T) then declare Ftyp : constant Entity_Id := Etype (First_Formal (Init)); + begin - Arg1 := OK_Convert_To (Etype (Ftyp), Arg1); - Set_Etype (Arg1, Ftyp); + Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1); + Set_Etype (Init_Arg1, Ftyp); end; end if; - Args := New_List (Arg1); + Args := New_List (Init_Arg1); -- For the task case, pass the Master_Id of the access type as -- the value of the _Master parameter, and _Chain as the value @@ -3786,7 +3681,7 @@ package body Exp_Ch4 is if not Is_Constrained (Typ) and then Present (Discriminant_Default_Value - (First_Discriminant (Typ))) + (First_Discriminant (Typ))) and then (Ada_Version < Ada_2005 or else not Has_Constrained_Partial_View (Typ)) @@ -3844,6 +3739,8 @@ package body Exp_Ch4 is Set_Assignment_OK (Temp_Decl); Insert_Action (N, Temp_Decl, Suppress => All_Checks); + Complete_Controlled_Allocation (Temp_Decl); + -- If the designated type is a task type or contains tasks, -- create block to activate created tasks, and insert -- declaration for Task_Image variable ahead of call. @@ -3868,42 +3765,24 @@ package body Exp_Ch4 is if Needs_Finalization (T) then - -- Postpone the generation of a finalization call for the - -- current allocator if it acts as a coextension. - - if Is_Dynamic_Coextension (N) then - if No (Coextensions (N)) then - Set_Coextensions (N, New_Elmt_List); - end if; + -- Generate: + -- [Deep_]Initialize (Init_Arg1); - Append_Elmt (New_Copy_Tree (Arg1), Coextensions (N)); + Insert_Action (N, + Make_Init_Call ( + Obj_Ref => New_Copy_Tree (Init_Arg1), + Typ => T)); - else - Flist := - Get_Allocator_Final_List (N, Base_Type (T), PtrT); - - -- Anonymous access types created for access parameters - -- are attached to an explicitly constructed controller, - -- which ensures that they can be finalized properly, - -- even if their deallocation might not happen. The list - -- associated with the controller is doubly-linked. For - -- other anonymous access types, the object may end up - -- on the global final list which is singly-linked. - -- Work needed for access discriminants in Ada 2005 ??? - - if Ekind (PtrT) = E_Anonymous_Access_Type then - Attach_Level := Uint_1; - else - Attach_Level := Uint_2; - end if; + -- Generate: + -- Set_Finalize_Address_Ptr + -- (Pool, <Finalize_Address>'Unrestricted_Access) - Insert_Actions (N, - Make_Init_Call ( - Ref => New_Copy_Tree (Arg1), - Typ => T, - Flist_Ref => Flist, - With_Attach => Make_Integer_Literal (Loc, - Intval => Attach_Level))); + if Present (Associated_Collection (PtrT)) then + Insert_Action (N, + Make_Set_Finalize_Address_Ptr_Call ( + Loc => Loc, + Typ => T, + Ptr_Typ => PtrT)); end if; end if; @@ -4169,7 +4048,8 @@ package body Exp_Ch4 is P_Decl := Make_Full_Type_Declaration (Loc, - Defining_Identifier => Make_Temporary (Loc, 'A'), + Defining_Identifier => + Make_Temporary (Loc, 'A'), Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, @@ -9220,9 +9100,7 @@ package body Exp_Ch4 is then return Suitable_Element (Next_Entity (C)); - elsif Chars (C) = Name_uController - or else Chars (C) = Name_uTag - then + elsif Chars (C) = Name_uTag then return Suitable_Element (Next_Entity (C)); elsif Is_Interface (Etype (C)) then @@ -9248,6 +9126,7 @@ package body Exp_Ch4 is Result := New_Reference_To (Standard_True, Loc); C := Suitable_Element (First_Entity (Typ)); + while Present (C) loop declare New_Lhs : Node_Id; @@ -9527,81 +9406,6 @@ package body Exp_Ch4 is end if; end Fixup_Universal_Fixed_Operation; - ------------------------------ - -- Get_Allocator_Final_List -- - ------------------------------ - - function Get_Allocator_Final_List - (N : Node_Id; - T : Entity_Id; - PtrT : Entity_Id) return Entity_Id - is - Loc : constant Source_Ptr := Sloc (N); - - Owner : Entity_Id := PtrT; - -- The entity whose finalization list must be used to attach the - -- allocated object. - - begin - if Ekind (PtrT) = E_Anonymous_Access_Type then - - -- If the context is an access parameter, we need to create a - -- non-anonymous access type in order to have a usable final list, - -- because there is otherwise no pool to which the allocated object - -- can belong. We create both the type and the finalization chain - -- here, because freezing an internal type does not create such a - -- chain. The Final_Chain that is thus created is shared by the - -- access parameter. The access type is tested against the result - -- type of the function to exclude allocators whose type is an - -- anonymous access result type. We freeze the type at once to - -- ensure that it is properly decorated for the back-end, even - -- if the context and current scope is a loop. - - if Nkind (Associated_Node_For_Itype (PtrT)) - in N_Subprogram_Specification - and then - PtrT /= - Etype (Defining_Unit_Name (Associated_Node_For_Itype (PtrT))) - then - Owner := Make_Temporary (Loc, 'J'); - Insert_Action (N, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Owner, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (T, Loc)))); - - Freeze_Before (N, Owner); - Build_Final_List (N, Owner); - Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Owner)); - - -- Ada 2005 (AI-318-02): If the context is a return object - -- declaration, then the anonymous return subtype is defined to have - -- the same accessibility level as that of the function's result - -- subtype, which means that we want the scope where the function is - -- declared. - - elsif Nkind (Associated_Node_For_Itype (PtrT)) = N_Object_Declaration - and then Ekind (Scope (PtrT)) = E_Return_Statement - then - Owner := Scope (Return_Applies_To (Scope (PtrT))); - - -- Case of an access discriminant, or (Ada 2005) of an anonymous - -- access component or anonymous access function result: find the - -- final list associated with the scope of the type. (In the - -- anonymous access component kind, a list controller will have - -- been allocated when freezing the record type, and PtrT has an - -- Associated_Final_Chain attribute designating it.) - - elsif No (Associated_Final_Chain (PtrT)) then - Owner := Scope (PtrT); - end if; - end if; - - return Find_Final_List (Owner); - end Get_Allocator_Final_List; - --------------------------------- -- Has_Inferable_Discriminants -- --------------------------------- diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 51ae183..4f175f1 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 d09261e..87403a5 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -110,19 +110,14 @@ package body Exp_Ch6 is -- Adds Extra_Actual as a named parameter association for the formal -- Extra_Formal in Subprogram_Call. - procedure Add_Final_List_Actual_To_Build_In_Place_Call - (Function_Call : Node_Id; - Function_Id : Entity_Id; - Acc_Type : Entity_Id; - Sel_Comp : Node_Id := Empty); - -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has - -- controlled parts, add an actual parameter that is a pointer to - -- appropriate finalization list. The finalization list is that of the - -- current scope, except for "new Acc'(F(...))" in which case it's the - -- finalization list of the access type returned by the allocator. Acc_Type - -- is that type in the allocator case; Empty otherwise. If Sel_Comp is - -- not Empty, then it denotes a selected component and the finalization - -- list is obtained from the _controller list of the prefix object. + procedure Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call : Node_Id; + Func_Id : Entity_Id; + Ptr_Typ : Entity_Id := Empty); + -- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs + -- finalization actions, add an actual parameter which is a pointer to the + -- finalization collection of the caller. If Ptr_Typ is left Empty, this + -- will result in an automatic "null" value for the actual. procedure Add_Task_Actuals_To_Build_In_Place_Call (Function_Call : Node_Id; @@ -191,6 +186,11 @@ package body Exp_Ch6 is -- For non-scalar objects that are possibly unaligned, add call by copy -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT). + procedure Expand_Ctrl_Function_Call (N : Node_Id); + -- N is a function call which returns a controlled object. Transform the + -- call into a temporary which retrieves the returned object from the + -- secondary stack using 'reference. + procedure Expand_Inlined_Call (N : Node_Id; Subp : Entity_Id; @@ -340,6 +340,91 @@ package body Exp_Ch6 is (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual); end Add_Alloc_Form_Actual_To_Build_In_Place_Call; + -------------------------------------------------- + -- Add_Collection_Actual_To_Build_In_Place_Call -- + -------------------------------------------------- + + procedure Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call : Node_Id; + Func_Id : Entity_Id; + Ptr_Typ : Entity_Id := Empty) + is + begin + if not Needs_BIP_Collection (Func_Id) then + return; + end if; + + declare + Formal : constant Entity_Id := + Build_In_Place_Formal (Func_Id, BIP_Collection); + Loc : constant Source_Ptr := Sloc (Func_Call); + + Actual : Node_Id; + Desig_Typ : Entity_Id; + + begin + -- Case where the context does not require an actual collection + + if No (Ptr_Typ) then + Actual := Make_Null (Loc); + + else + Desig_Typ := Directly_Designated_Type (Ptr_Typ); + + -- Check for a library-level access type whose designated type has + -- supressed finalization. Such an access types lack a collection. + -- Pass a null actual to the callee in order to signal a missing + -- collection. + + if Is_Library_Level_Entity (Ptr_Typ) + and then Finalize_Storage_Only (Desig_Typ) + then + Actual := Make_Null (Loc); + + -- Types in need of finalization actions + + elsif Needs_Finalization (Desig_Typ) then + + -- The general mechanism of creating finalization collections + -- for anonymous access types is disabled by default, otherwise + -- collections will pop all over the place. Such types use + -- context-specific collections. + + if Ekind (Ptr_Typ) = E_Anonymous_Access_Type + and then No (Associated_Collection (Ptr_Typ)) + then + Build_Finalization_Collection + (Typ => Ptr_Typ, + Ins_Node => Associated_Node_For_Itype (Ptr_Typ), + Encl_Scope => Scope (Ptr_Typ)); + end if; + + -- Access-to-controlled types should always have a collection + + pragma Assert (Present (Associated_Collection (Ptr_Typ))); + + Actual := + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Associated_Collection (Ptr_Typ), Loc), + Attribute_Name => Name_Unrestricted_Access); + + -- Tagged types + + else + Actual := Make_Null (Loc); + end if; + end if; + + Analyze_And_Resolve (Actual, Etype (Formal)); + + -- Build the parameter association for the new actual and add it to + -- the end of the function's actuals. + + Add_Extra_Actual_To_Call (Func_Call, Formal, Actual); + end; + end Add_Collection_Actual_To_Build_In_Place_Call; + ------------------------------ -- Add_Extra_Actual_To_Call -- ------------------------------ @@ -393,79 +478,6 @@ package body Exp_Ch6 is end if; end Add_Extra_Actual_To_Call; - -------------------------------------------------- - -- Add_Final_List_Actual_To_Build_In_Place_Call -- - -------------------------------------------------- - - procedure Add_Final_List_Actual_To_Build_In_Place_Call - (Function_Call : Node_Id; - Function_Id : Entity_Id; - Acc_Type : Entity_Id; - Sel_Comp : Node_Id := Empty) - is - Loc : constant Source_Ptr := Sloc (Function_Call); - Final_List : Node_Id; - Final_List_Actual : Node_Id; - Final_List_Formal : Node_Id; - Is_Ctrl_Result : constant Boolean := - Needs_Finalization - (Underlying_Type (Etype (Function_Id))); - - begin - -- No such extra parameter is needed if there are no controlled parts. - -- The test for Needs_Finalization accounts for class-wide results - -- (which potentially have controlled parts, even if the root type - -- doesn't), and the test for a tagged result type is needed because - -- calls to such a function can in general occur in dispatching - -- contexts, which must be treated the same as a call to class-wide - -- functions. Both of these situations require that a finalization list - -- be passed. - - if not Needs_BIP_Final_List (Function_Id) then - return; - end if; - - -- Locate implicit finalization list parameter in the called function - - Final_List_Formal := Build_In_Place_Formal (Function_Id, BIP_Final_List); - - -- Create the actual which is a pointer to the appropriate finalization - -- list. Acc_Type is present if and only if this call is the - -- initialization of an allocator. Use the Current_Scope or the - -- Acc_Type as appropriate. - - if Present (Acc_Type) - and then (Ekind (Acc_Type) = E_Anonymous_Access_Type - or else - Present (Associated_Final_Chain (Base_Type (Acc_Type)))) - then - Final_List := Find_Final_List (Acc_Type); - - -- If Sel_Comp is present and the function result is controlled, then - -- the finalization list will be obtained from the _controller list of - -- the selected component's prefix object. - - elsif Present (Sel_Comp) and then Is_Ctrl_Result then - Final_List := Find_Final_List (Current_Scope, Sel_Comp); - - else - Final_List := Find_Final_List (Current_Scope); - end if; - - Final_List_Actual := - Make_Attribute_Reference (Loc, - Prefix => Final_List, - Attribute_Name => Name_Unrestricted_Access); - - Analyze_And_Resolve (Final_List_Actual, Etype (Final_List_Formal)); - - -- Build the parameter association for the new actual and add it to the - -- end of the function's actuals. - - Add_Extra_Actual_To_Call - (Function_Call, Final_List_Formal, Final_List_Actual); - end Add_Final_List_Actual_To_Build_In_Place_Call; - --------------------------------------------- -- Add_Task_Actuals_To_Build_In_Place_Call -- --------------------------------------------- @@ -549,8 +561,8 @@ package body Exp_Ch6 is case Kind is when BIP_Alloc_Form => return "BIPalloc"; - when BIP_Final_List => - return "BIPfinallist"; + when BIP_Collection => + return "BIPcollection"; when BIP_Master => return "BIPmaster"; when BIP_Activation_Chain => @@ -1777,6 +1789,10 @@ package body Exp_Ch6 is -- convoluted tree traversal before setting the proper subprogram to be -- called. + function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean; + -- Determine whether Subp denotes a non-dispatching call to a Deep + -- routine. + function New_Value (From : Node_Id) return Node_Id; -- From is the original Expression. New_Value is equivalent to a call -- to Duplicate_Subexpr with an explicit dereference when From is an @@ -1945,6 +1961,42 @@ package body Exp_Ch6 is raise Program_Error; end Inherited_From_Formal; + ------------------------- + -- Is_Direct_Deep_Call -- + ------------------------- + + function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean is + begin + if Is_TSS (Subp, TSS_Deep_Adjust) + or else Is_TSS (Subp, TSS_Deep_Finalize) + or else Is_TSS (Subp, TSS_Deep_Initialize) + then + declare + Actual : Node_Id; + Formal : Node_Id; + + begin + Actual := First (Parameter_Associations (N)); + Formal := First_Formal (Subp); + while Present (Actual) + and then Present (Formal) + loop + if Nkind (Actual) = N_Identifier + and then Is_Controlling_Actual (Actual) + and then Etype (Actual) = Etype (Formal) + then + return True; + end if; + + Next (Actual); + Next_Formal (Formal); + end loop; + end; + end if; + + return False; + end Is_Direct_Deep_Call; + --------------- -- New_Value -- --------------- @@ -2795,6 +2847,7 @@ package body Exp_Ch6 is if Nkind (Call_Node) /= N_Entry_Call_Statement and then No (Controlling_Argument (Call_Node)) and then Present (Parent_Subp) + and then not Is_Direct_Deep_Call (Subp) then if Present (Inherited_From_Formal (Subp)) then Parent_Subp := Inherited_From_Formal (Subp); @@ -3229,12 +3282,12 @@ package body Exp_Ch6 is Expand_Protected_Subprogram_Call (Call_Node, Subp, Scop); end if; - -- Functions returning controlled objects need special attention: - -- if the return type is limited, the context is an initialization - -- and different processing applies. If the call is to a protected - -- function, the expansion above will call Expand_Call recursively. - -- To prevent a double attachment, check that the current call is - -- not a rewriting of a protected function call. + -- Functions returning controlled objects need special attention. If + -- the return type is limited, then the context is initialization and + -- different processing applies. If the call is to a protected function, + -- the expansion above will call Expand_Call recursively. Otherwise the + -- function call is transformed into a temporary which obtains the + -- result from the secondary stack. if Needs_Finalization (Etype (Subp)) then if not Is_Immutably_Limited_Type (Etype (Subp)) @@ -3407,6 +3460,33 @@ package body Exp_Ch6 is end if; end Expand_Call; + ------------------------------- + -- Expand_Ctrl_Function_Call -- + ------------------------------- + + procedure Expand_Ctrl_Function_Call (N : Node_Id) is + begin + -- Optimization, if the returned value (which is on the sec-stack) is + -- returned again, no need to copy/readjust/finalize, we can just pass + -- the value thru (see Expand_N_Simple_Return_Statement), and thus no + -- attachment is needed + + if Nkind (Parent (N)) = N_Simple_Return_Statement then + return; + end if; + + -- Resolution is now finished, make sure we don't start analysis again + -- because of the duplication. + + Set_Analyzed (N); + + -- A function which returns a controlled object uses the secondary + -- stack. Rewrite the call into a temporary which obtains the result of + -- the function using 'reference. + + Remove_Side_Effects (N); + end Expand_Ctrl_Function_Call; + -------------------------- -- Expand_Inlined_Call -- -------------------------- @@ -4245,20 +4325,53 @@ package body Exp_Ch6 is procedure Expand_N_Extended_Return_Statement (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Return_Object_Entity : constant Entity_Id := - First_Entity (Return_Statement_Entity (N)); - Return_Object_Decl : constant Node_Id := - Parent (Return_Object_Entity); - Parent_Function : constant Entity_Id := - Return_Applies_To (Return_Statement_Entity (N)); - Is_Build_In_Place : constant Boolean := - Is_Build_In_Place_Function (Parent_Function); - - Return_Stm : Node_Id; - Statements : List_Id; - Handled_Stm_Seq : Node_Id; - Result : Node_Id; - Exp : Node_Id; + Par_Func : constant Entity_Id := + Return_Applies_To (Return_Statement_Entity (N)); + Ret_Obj_Id : constant Entity_Id := + First_Entity (Return_Statement_Entity (N)); + Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id); + + Is_Build_In_Place : constant Boolean := + Is_Build_In_Place_Function (Par_Func); + + Exp : Node_Id; + HSS : Node_Id; + Result : Node_Id; + Return_Stmt : Node_Id; + Stmts : List_Id; + + function Build_Heap_Allocator + (Temp_Id : Entity_Id; + Temp_Typ : Entity_Id; + Func_Id : Entity_Id; + Ret_Typ : Entity_Id; + Alloc_Expr : Node_Id) return Node_Id; + -- Create the statements necessary to allocate a return object on the + -- caller's collection. The collection is available through implicit + -- parameter BIPcollection. + -- + -- if BIPcollection /= null then + -- declare + -- type Ptr_Typ is access Ret_Typ; + -- for Ptr_Typ'Storage_Pool use + -- Base_Pool (BIPcollection.all).all; + -- Local : Ptr_Typ; + -- + -- begin + -- procedure Allocate (...) is + -- begin + -- Ada.Finalization.Heap_Management.Allocate (...); + -- end Allocate; + -- + -- Local := <Alloc_Expr>; + -- Temp_Id := Temp_Typ (Local); + -- end; + -- end if; + -- + -- Temp_Id is the temporary which is used to reference the internally + -- created object in all allocation forms. Temp_Typ is the type of the + -- temporary. Func_Id is the enclosing function. Ret_Typ is the return + -- type of Func_Id. Alloc_Expr is the actual allocator. function Move_Activation_Chain return Node_Id; -- Construct a call to System.Tasking.Stages.Move_Activation_Chain @@ -4267,99 +4380,254 @@ package body Exp_Ch6 is -- To activation chain passed in by the caller -- New_Master master passed in by the caller - function Move_Final_List return Node_Id; - -- Construct call to System.Finalization_Implementation.Move_Final_List - -- with parameters: - -- - -- From finalization list of the return statement - -- To finalization list passed in by the caller + -------------------------- + -- Build_Heap_Allocator -- + -------------------------- + + function Build_Heap_Allocator + (Temp_Id : Entity_Id; + Temp_Typ : Entity_Id; + Func_Id : Entity_Id; + Ret_Typ : Entity_Id; + Alloc_Expr : Node_Id) return Node_Id + is + begin + -- Processing for build-in-place object allocation. This is disabled + -- on .NET/JVM because pools are not supported. + + if VM_Target = No_VM + and then Is_Build_In_Place_Function (Func_Id) + and then Needs_Finalization (Ret_Typ) + then + declare + Collect : constant Entity_Id := + Build_In_Place_Formal (Func_Id, BIP_Collection); + Decls : constant List_Id := New_List; + Stmts : constant List_Id := New_List; + + Local_Id : Entity_Id; + Pool_Id : Entity_Id; + Ptr_Typ : Entity_Id; + + begin + -- Generate: + -- Pool_Id renames Base_Pool (BIPcollection.all).all; + + Pool_Id := Make_Temporary (Loc, 'P'); + + Append_To (Decls, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Pool_Id, + Subtype_Mark => + New_Reference_To (RTE (RE_Root_Storage_Pool), Loc), + Name => + Make_Explicit_Dereference (Loc, + Prefix => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Base_Pool), Loc), + + Parameter_Associations => New_List ( + Make_Explicit_Dereference (Loc, + Prefix => + New_Reference_To (Collect, Loc))))))); + + -- Create an access type which uses the storage pool of the + -- caller's collection. This additional type is necessary + -- because the collection cannot be associated with the type + -- of the temporary. Otherwise the secondary stack allocation + -- will fail. + + -- Generate: + -- type Ptr_Typ is access Ret_Typ; + + Ptr_Typ := Make_Temporary (Loc, 'P'); + + Append_To (Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Reference_To (Ret_Typ, Loc)))); + + -- Perform minor decoration in order to set the collection and + -- the storage pool attributes. + + Set_Ekind (Ptr_Typ, E_Access_Type); + Set_Associated_Collection (Ptr_Typ, Collect); + Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); + + -- Create the temporary, generate: + -- + -- Local_Id : Ptr_Typ; + + Local_Id := Make_Temporary (Loc, 'T'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Id, + Object_Definition => + New_Reference_To (Ptr_Typ, Loc))); + + -- Allocate the object, generate: + -- + -- Local_Id := <Alloc_Expr>; + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Local_Id, Loc), + Expression => Alloc_Expr)); + + -- Generate: + -- Temp_Id := Temp_Typ (Local_Id); + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Temp_Id, Loc), + Expression => + Unchecked_Convert_To (Temp_Typ, + New_Reference_To (Local_Id, Loc)))); + + -- Wrap the allocation in a block. This is further conditioned + -- by checking the caller collection at runtime. A null value + -- indicates a non-existent collection, most likely due to a + -- Finalize_Storage_Only allocation. + + -- Generate: + -- if BIPcollection /= null then + -- declare + -- <Decls> + -- begin + -- <Stmts> + -- end; + -- end if; + + return + Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + New_Reference_To (Collect, Loc), + Right_Opnd => + Make_Null (Loc)), + + Then_Statements => New_List ( + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)))); + end; + + -- For all other cases, generate: + -- + -- Temp_Id := <Alloc_Expr>; + + else + return + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Temp_Id, Loc), + Expression => Alloc_Expr); + end if; + end Build_Heap_Allocator; --------------------------- -- Move_Activation_Chain -- --------------------------- function Move_Activation_Chain return Node_Id is - Activation_Chain_Formal : constant Entity_Id := - Build_In_Place_Formal - (Parent_Function, BIP_Activation_Chain); - To : constant Node_Id := - New_Reference_To - (Activation_Chain_Formal, Loc); - Master_Formal : constant Entity_Id := - Build_In_Place_Formal - (Parent_Function, BIP_Master); - New_Master : constant Node_Id := - New_Reference_To (Master_Formal, Loc); - - Chain_Entity : Entity_Id; - From : Node_Id; + Chain_Formal : constant Entity_Id := + Build_In_Place_Formal + (Par_Func, BIP_Activation_Chain); + To : constant Node_Id := + New_Reference_To (Chain_Formal, Loc); + Master_Formal : constant Entity_Id := + Build_In_Place_Formal (Par_Func, BIP_Master); + New_Master : constant Node_Id := + New_Reference_To (Master_Formal, Loc); + + Chain_Id : Entity_Id; + From : Node_Id; begin - Chain_Entity := First_Entity (Return_Statement_Entity (N)); - while Chars (Chain_Entity) /= Name_uChain loop - Chain_Entity := Next_Entity (Chain_Entity); + Chain_Id := First_Entity (Return_Statement_Entity (N)); + while Chars (Chain_Id) /= Name_uChain loop + Chain_Id := Next_Entity (Chain_Id); end loop; From := Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Chain_Entity, Loc), + Prefix => + New_Reference_To (Chain_Id, Loc), Attribute_Name => Name_Unrestricted_Access); -- ??? Not clear why "Make_Identifier (Loc, Name_uChain)" doesn't - -- work, instead of "New_Reference_To (Chain_Entity, Loc)" above. + -- work, instead of "New_Reference_To (Chain_Id, Loc)" above. return Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Move_Activation_Chain), Loc), + Name => + New_Reference_To (RTE (RE_Move_Activation_Chain), Loc), Parameter_Associations => New_List (From, To, New_Master)); end Move_Activation_Chain; - --------------------- - -- Move_Final_List -- - --------------------- + -- Start of processing for Expand_N_Extended_Return_Statement - function Move_Final_List return Node_Id is - Flist : constant Entity_Id := - Finalization_Chain_Entity (Return_Statement_Entity (N)); + begin + if Nkind (Ret_Obj_Decl) = N_Object_Declaration then + Exp := Expression (Ret_Obj_Decl); + else + Exp := Empty; + end if; - From : constant Node_Id := New_Reference_To (Flist, Loc); + HSS := Handled_Statement_Sequence (N); - Caller_Final_List : constant Entity_Id := - Build_In_Place_Formal - (Parent_Function, BIP_Final_List); + -- If the returned object needs finalization actions, the function must + -- perform the appropriate cleanup should it fail to return. The state + -- of the function itself is tracked through a flag which is coupled + -- with the scope finalizer. There is one flag per each return object + -- in case of multiple returns. - To : constant Node_Id := New_Reference_To (Caller_Final_List, Loc); + if Is_Build_In_Place + and then Needs_Finalization (Etype (Ret_Obj_Id)) + then + declare + Flag_Decl : Node_Id; + Flag_Id : Entity_Id; + Func_Bod : Node_Id; - begin - -- Catch cases where a finalization chain entity has not been - -- associated with the return statement entity. + begin + -- Recover the function body - pragma Assert (Present (Flist)); + Func_Bod := Unit_Declaration_Node (Par_Func); + if Nkind (Func_Bod) = N_Subprogram_Declaration then + Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod))); + end if; - -- Build required call + -- Create a flag to track the function state - return - Make_If_Statement (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => New_Copy (From), - Right_Opnd => New_Node (N_Null, Loc)), - Then_Statements => - New_List ( - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Move_Final_List), Loc), - Parameter_Associations => New_List (From, To)))); - end Move_Final_List; + Flag_Id := Make_Temporary (Loc, 'F'); + Set_Return_Flag (Ret_Obj_Id, Flag_Id); - -- Start of processing for Expand_N_Extended_Return_Statement + -- Insert the flag at the beginning of the function declarations, + -- generate: + -- Fnn : Boolean := False; - begin - if Nkind (Return_Object_Decl) = N_Object_Declaration then - Exp := Expression (Return_Object_Decl); - else - Exp := Empty; - end if; + Flag_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Flag_Id, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => + New_Reference_To (Standard_False, Loc)); - Handled_Stm_Seq := Handled_Statement_Sequence (N); + Prepend_To (Declarations (Func_Bod), Flag_Decl); + Analyze (Flag_Decl); + end; + end if; -- Build a simple_return_statement that returns the return object when -- there is a statement sequence, or no expression, or the result will @@ -4367,89 +4635,79 @@ package body Exp_Ch6 is -- composite cases, even though nonlimited composite results are not yet -- built in place (though we plan to do so eventually). - if Present (Handled_Stm_Seq) - or else Is_Composite_Type (Etype (Parent_Function)) + if Present (HSS) + or else Is_Composite_Type (Etype (Par_Func)) or else No (Exp) then - if No (Handled_Stm_Seq) then - Statements := New_List; + if No (HSS) then + Stmts := New_List; -- If the extended return has a handled statement sequence, then wrap -- it in a block and use the block as the first statement. else - Statements := - New_List (Make_Block_Statement (Loc, - Declarations => New_List, - Handled_Statement_Sequence => Handled_Stm_Seq)); + Stmts := New_List ( + Make_Block_Statement (Loc, + Declarations => New_List, + Handled_Statement_Sequence => HSS)); end if; - -- If control gets past the above Statements, we have successfully - -- completed the return statement. If the result type has controlled - -- parts and the return is for a build-in-place function, then we - -- call Move_Final_List to transfer responsibility for finalization - -- of the return object to the caller. An alternative would be to - -- declare a Success flag in the function, initialize it to False, - -- and set it to True here. Then move the Move_Final_List call into - -- the cleanup code, and check Success. If Success then make a call - -- to Move_Final_List else do finalization. Then we can remove the - -- abort-deferral and the nulling-out of the From parameter from - -- Move_Final_List. Note that the current method is not quite correct - -- in the rather obscure case of a select-then-abort statement whose - -- abortable part contains the return statement. - - -- Check the type of the function to determine whether to move the - -- finalization list. A special case arises when processing a simple - -- return statement which has been rewritten as an extended return. - -- In that case check the type of the returned object or the original - -- expression. Note that Needs_Finalization accounts for the case - -- of class-wide types, which which must be assumed to require - -- finalization. + -- If the result type contains tasks, we call Move_Activation_Chain. + -- Later, the cleanup code will call Complete_Master, which will + -- terminate any unactivated tasks belonging to the return statement + -- master. But Move_Activation_Chain updates their master to be that + -- of the caller, so they will not be terminated unless the return + -- statement completes unsuccessfully due to exception, abort, goto, + -- or exit. As a formality, we test whether the function requires the + -- result to be built in place, though that's necessarily true for + -- the case of result types with task parts. if Is_Build_In_Place - and then Needs_BIP_Final_List (Parent_Function) - and then - ((Present (Exp) and then Needs_Finalization (Etype (Exp))) - or else - (not Present (Exp) - and then Needs_Finalization (Etype (Return_Object_Entity)))) + and Has_Task (Etype (Par_Func)) then - Append_To (Statements, Move_Final_List); + Append_To (Stmts, Move_Activation_Chain); end if; - -- Similarly to the above Move_Final_List, if the result type - -- contains tasks, we call Move_Activation_Chain. Later, the cleanup - -- code will call Complete_Master, which will terminate any - -- unactivated tasks belonging to the return statement master. But - -- Move_Activation_Chain updates their master to be that of the - -- caller, so they will not be terminated unless the return statement - -- completes unsuccessfully due to exception, abort, goto, or exit. - -- As a formality, we test whether the function requires the result - -- to be built in place, though that's necessarily true for the case - -- of result types with task parts. - - if Is_Build_In_Place and Has_Task (Etype (Parent_Function)) then - Append_To (Statements, Move_Activation_Chain); + -- Update the state of the function right before the object is + -- returned. + + if Is_Build_In_Place + and then Needs_Finalization (Etype (Ret_Obj_Id)) + then + declare + Flag_Id : constant Entity_Id := Return_Flag (Ret_Obj_Id); + + begin + -- Generate: + -- Fnn := True; + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Flag_Id, Loc), + Expression => + New_Reference_To (Standard_True, Loc))); + end; end if; -- Build a simple_return_statement that returns the return object - Return_Stm := + Return_Stmt := Make_Simple_Return_Statement (Loc, - Expression => New_Occurrence_Of (Return_Object_Entity, Loc)); - Append_To (Statements, Return_Stm); + Expression => + New_Occurrence_Of (Ret_Obj_Id, Loc)); + Append_To (Stmts, Return_Stmt); - Handled_Stm_Seq := - Make_Handled_Sequence_Of_Statements (Loc, Statements); + HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts); end if; - -- Case where we build a block + -- Case where we build a return statement block - if Present (Handled_Stm_Seq) then + if Present (HSS) then Result := Make_Block_Statement (Loc, Declarations => Return_Object_Declarations (N), - Handled_Statement_Sequence => Handled_Stm_Seq); + Handled_Statement_Sequence => HSS); -- We set the entity of the new block statement to be that of the -- return statement. This is necessary so that various fields, such @@ -4468,15 +4726,16 @@ package body Exp_Ch6 is -- allocation of the return object. if Is_Build_In_Place - and then - Nkind (Return_Object_Decl) = N_Object_Renaming_Declaration + and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration then - pragma Assert (Nkind (Original_Node (Return_Object_Decl)) = - N_Object_Declaration - and then Is_Build_In_Place_Function_Call - (Expression (Original_Node (Return_Object_Decl)))); + pragma Assert + (Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration + and then Is_Build_In_Place_Function_Call + (Expression (Original_Node (Ret_Obj_Decl)))); + + -- Return the build-in-place result by reference - Set_By_Ref (Return_Stm); -- Return build-in-place results by ref + Set_By_Ref (Return_Stmt); elsif Is_Build_In_Place then @@ -4488,27 +4747,26 @@ package body Exp_Ch6 is -- expanded as separate assignments, then add an assignment -- statement to ensure the return object gets initialized. - -- declare - -- Result : T [:= <expression>]; - -- begin - -- ... + -- declare + -- Result : T [:= <expression>]; + -- begin + -- ... -- is converted to - -- declare - -- Result : T renames FuncRA.all; - -- [Result := <expression;] - -- begin - -- ... + -- declare + -- Result : T renames FuncRA.all; + -- [Result := <expression;] + -- begin + -- ... declare Return_Obj_Id : constant Entity_Id := - Defining_Identifier (Return_Object_Decl); + Defining_Identifier (Ret_Obj_Decl); Return_Obj_Typ : constant Entity_Id := Etype (Return_Obj_Id); Return_Obj_Expr : constant Node_Id := - Expression (Return_Object_Decl); - Result_Subt : constant Entity_Id := - Etype (Parent_Function); + Expression (Ret_Obj_Decl); + Result_Subt : constant Entity_Id := Etype (Par_Func); Constr_Result : constant Boolean := Is_Constrained (Result_Subt); Obj_Alloc_Formal : Entity_Id; @@ -4519,12 +4777,12 @@ package body Exp_Ch6 is begin -- Build-in-place results must be returned by reference - Set_By_Ref (Return_Stm); + Set_By_Ref (Return_Stmt); -- Retrieve the implicit access parameter passed by the caller Object_Access := - Build_In_Place_Formal (Parent_Function, BIP_Object_Access); + Build_In_Place_Formal (Par_Func, BIP_Object_Access); -- If the return object's declaration includes an expression -- and the declaration isn't marked as No_Initialization, then @@ -4543,13 +4801,16 @@ package body Exp_Ch6 is -- interface has no assignment operation). if Present (Return_Obj_Expr) - and then not No_Initialization (Return_Object_Decl) + and then not No_Initialization (Ret_Obj_Decl) and then not Is_Interface (Return_Obj_Typ) then Init_Assignment := Make_Assignment_Statement (Loc, - Name => New_Reference_To (Return_Obj_Id, Loc), - Expression => Relocate_Node (Return_Obj_Expr)); + Name => + New_Reference_To (Return_Obj_Id, Loc), + Expression => + Relocate_Node (Return_Obj_Expr)); + Set_Etype (Name (Init_Assignment), Etype (Return_Obj_Id)); Set_Assignment_OK (Name (Init_Assignment)); Set_No_Ctrl_Actions (Init_Assignment); @@ -4557,7 +4818,7 @@ package body Exp_Ch6 is Set_Parent (Name (Init_Assignment), Init_Assignment); Set_Parent (Expression (Init_Assignment), Init_Assignment); - Set_Expression (Return_Object_Decl, Empty); + Set_Expression (Ret_Obj_Decl, Empty); if Is_Class_Wide_Type (Etype (Return_Obj_Id)) and then not Is_Class_Wide_Type @@ -4566,8 +4827,7 @@ package body Exp_Ch6 is Rewrite (Expression (Init_Assignment), Make_Type_Conversion (Loc, Subtype_Mark => - New_Occurrence_Of - (Etype (Return_Obj_Id), Loc), + New_Occurrence_Of (Etype (Return_Obj_Id), Loc), Expression => Relocate_Node (Expression (Init_Assignment)))); end if; @@ -4581,7 +4841,7 @@ package body Exp_Ch6 is if Constr_Result and then not Is_Tagged_Type (Underlying_Type (Result_Subt)) then - Insert_After (Return_Object_Decl, Init_Assignment); + Insert_After (Ret_Obj_Decl, Init_Assignment); end if; end if; @@ -4608,7 +4868,7 @@ package body Exp_Ch6 is or else Is_Tagged_Type (Underlying_Type (Result_Subt)) then Obj_Alloc_Formal := - Build_In_Place_Formal (Parent_Function, BIP_Alloc_Form); + Build_In_Place_Formal (Par_Func, BIP_Alloc_Form); declare Ref_Type : Entity_Id; @@ -4616,8 +4876,8 @@ package body Exp_Ch6 is Alloc_Obj_Id : Entity_Id; Alloc_Obj_Decl : Node_Id; Alloc_If_Stmt : Node_Id; - SS_Allocator : Node_Id; Heap_Allocator : Node_Id; + SS_Allocator : Node_Id; begin -- Reuse the itype created for the function's implicit @@ -4625,7 +4885,7 @@ package body Exp_Ch6 is -- access type here, plus it allows assigning the access -- formal directly without applying a conversion. - -- Ref_Type := Etype (Object_Access); + -- Ref_Type := Etype (Object_Access); -- Create an access type designating the function's -- result subtype. @@ -4641,7 +4901,7 @@ package body Exp_Ch6 is Subtype_Indication => New_Reference_To (Return_Obj_Typ, Loc))); - Insert_Before (Return_Object_Decl, Ptr_Type_Decl); + Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl); -- Create an access object that will be initialized to an -- access value denoting the return object, either coming @@ -4654,17 +4914,17 @@ package body Exp_Ch6 is Alloc_Obj_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Alloc_Obj_Id, - Object_Definition => New_Reference_To - (Ref_Type, Loc)); + Object_Definition => + New_Reference_To (Ref_Type, Loc)); - Insert_Before (Return_Object_Decl, Alloc_Obj_Decl); + Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl); -- Create allocators for both the secondary stack and -- global heap. If there's an initialization expression, -- then create these as initialized allocators. if Present (Return_Obj_Expr) - and then not No_Initialization (Return_Object_Decl) + and then not No_Initialization (Ret_Obj_Decl) then -- Always use the type of the expression for the -- qualified expression, rather than the result type. @@ -4755,10 +5015,10 @@ package body Exp_Ch6 is -- statement, past the point where these flags are -- normally set. - Set_Sec_Stack_Needed_For_Return (Parent_Function); + Set_Sec_Stack_Needed_For_Return (Par_Func); Set_Sec_Stack_Needed_For_Return (Return_Statement_Entity (N)); - Set_Uses_Sec_Stack (Parent_Function); + Set_Uses_Sec_Stack (Par_Func); Set_Uses_Sec_Stack (Return_Statement_Entity (N)); end if; @@ -4780,7 +5040,7 @@ package body Exp_Ch6 is Alloc_If_Stmt := Make_If_Statement (Loc, - Condition => + Condition => Make_Op_Eq (Loc, Left_Opnd => New_Reference_To (Obj_Alloc_Formal, Loc), @@ -4788,45 +5048,42 @@ package body Exp_Ch6 is Make_Integer_Literal (Loc, UI_From_Int (BIP_Allocation_Form'Pos (Caller_Allocation)))), - Then_Statements => - New_List (Make_Assignment_Statement (Loc, - Name => - New_Reference_To - (Alloc_Obj_Id, Loc), - Expression => - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => - New_Reference_To (Ref_Type, Loc), - Expression => - New_Reference_To - (Object_Access, Loc)))), - Elsif_Parts => - New_List (Make_Elsif_Part (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To - (Obj_Alloc_Formal, Loc), - Right_Opnd => - Make_Integer_Literal (Loc, - UI_From_Int ( - BIP_Allocation_Form'Pos + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Alloc_Obj_Id, Loc), + Expression => + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To (Ref_Type, Loc), + Expression => + New_Reference_To (Object_Access, Loc)))), + + Elsif_Parts => New_List ( + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (Obj_Alloc_Formal, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, + UI_From_Int (BIP_Allocation_Form'Pos (Secondary_Stack)))), - Then_Statements => - New_List - (Make_Assignment_Statement (Loc, - Name => - New_Reference_To - (Alloc_Obj_Id, Loc), - Expression => - SS_Allocator)))), - Else_Statements => - New_List (Make_Assignment_Statement (Loc, - Name => - New_Reference_To - (Alloc_Obj_Id, Loc), - Expression => - Heap_Allocator))); + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Alloc_Obj_Id, Loc), + Expression => SS_Allocator)))), + + Else_Statements => New_List ( + Build_Heap_Allocator + (Temp_Id => Alloc_Obj_Id, + Temp_Typ => Ref_Type, + Func_Id => Par_Func, + Ret_Typ => Return_Obj_Typ, + Alloc_Expr => Heap_Allocator))); -- If a separate initialization assignment was created -- earlier, append that following the assignment of the @@ -4839,7 +5096,9 @@ package body Exp_Ch6 is if Present (Init_Assignment) then Rewrite (Name (Init_Assignment), Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Alloc_Obj_Id, Loc))); + Prefix => + New_Reference_To (Alloc_Obj_Id, Loc))); + Set_Etype (Name (Init_Assignment), Etype (Return_Obj_Id)); @@ -4848,7 +5107,7 @@ package body Exp_Ch6 is Init_Assignment); end if; - Insert_Before (Return_Object_Decl, Alloc_If_Stmt); + Insert_Before (Ret_Obj_Decl, Alloc_If_Stmt); -- Remember the local access object for use in the -- dereference of the renaming created below. @@ -4863,15 +5122,16 @@ package body Exp_Ch6 is Obj_Acc_Deref := Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Object_Access, Loc)); + Prefix => + New_Reference_To (Object_Access, Loc)); - Rewrite (Return_Object_Decl, + Rewrite (Ret_Obj_Decl, Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Return_Obj_Id, - Access_Definition => Empty, - Subtype_Mark => New_Occurrence_Of - (Return_Obj_Typ, Loc), - Name => Obj_Acc_Deref)); + Access_Definition => Empty, + Subtype_Mark => + New_Occurrence_Of (Return_Obj_Typ, Loc), + Name => Obj_Acc_Deref)); Set_Renamed_Object (Return_Obj_Id, Obj_Acc_Deref); end; @@ -4880,49 +5140,23 @@ package body Exp_Ch6 is -- Case where we do not build a block else + -- We're about to drop Return_Object_Declarations on the floor, so + -- we need to insert it, in case it got expanded into useful code. -- Remove side effects from expression, which may be duplicated in -- subsequent checks (see Expand_Simple_Function_Return). + Insert_List_Before (N, Return_Object_Declarations (N)); Remove_Side_Effects (Exp); -- Build simple_return_statement that returns the expression directly - Return_Stm := Make_Simple_Return_Statement (Loc, Expression => Exp); - - -- The expansion of the return expression may create a finalization - -- chain to service transient temporaries. The entity of the chain - -- appears as a semantic attribute of the return statement scope. - -- For the chain to be handled properly by Expand_Cleanup_Actions, - -- the return statement is wrapped in a block and reanalyzed. - - if Present - (Finalization_Chain_Entity (Return_Statement_Entity (N))) - then - Result := - Make_Block_Statement (Loc, - Declarations => Return_Object_Declarations (N), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Return_Stm))); - - -- Propagate the return statement scope to the block in order to - -- preserve the various semantic fields. - - Set_Identifier - (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc)); - else - -- We're about to drop Return_Object_Declarations on the floor, so - -- we need to insert it, in case it got expanded into useful code. - - Insert_List_Before (N, Return_Object_Declarations (N)); - - Result := Return_Stm; - end if; + Return_Stmt := Make_Simple_Return_Statement (Loc, Expression => Exp); + Result := Return_Stmt; end if; -- Set the flag to prevent infinite recursion - Set_Comes_From_Extended_Return_Statement (Return_Stm); + Set_Comes_From_Extended_Return_Statement (Return_Stmt); Rewrite (N, Result); Analyze (N); @@ -6557,7 +6791,7 @@ package body Exp_Ch6 is Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)))); while Present (Iface_DT_Ptr) - and then Ekind (Node (Iface_DT_Ptr)) = E_Constant + and then Ekind (Node (Iface_DT_Ptr)) = E_Constant loop pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); @@ -6600,7 +6834,7 @@ package body Exp_Ch6 is pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); -- Skip the tag of the predefined primitives no-thunks dispatch - -- table + -- table. Next_Elmt (Iface_DT_Ptr); pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); @@ -6611,7 +6845,7 @@ package body Exp_Ch6 is -- Local variables - Subp : constant Entity_Id := Entity (N); + Subp : constant Entity_Id := Entity (N); -- Start of processing for Freeze_Subprogram @@ -6862,7 +7096,7 @@ package body Exp_Ch6 is Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); - Add_Final_List_Actual_To_Build_In_Place_Call + Add_Collection_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Acc_Type); Add_Task_Actuals_To_Build_In_Place_Call @@ -6890,14 +7124,13 @@ package body Exp_Ch6 is -- operations. ??? else - -- Pass an allocation parameter indicating that the function should -- allocate its result on the heap. Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Alloc_Form => Global_Heap); - Add_Final_List_Actual_To_Build_In_Place_Call + Add_Collection_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Acc_Type); Add_Task_Actuals_To_Build_In_Place_Call @@ -6910,6 +7143,30 @@ package body Exp_Ch6 is (Func_Call, Function_Id, Return_Object => Empty); end if; + -- If the build-in-place function call returns a controlled object, the + -- finalization collection will require a reference to routine Finalize_ + -- Address of the designated type. Setting this attribute is done in the + -- same manner to expansion of allocators. + + if Needs_Finalization (Result_Subt) then + + -- Controlled types with supressed finalization do not need to + -- associate the address of their Finalize_Address primitives with a + -- collection since they do not need a collection to begin with. + + if Is_Library_Level_Entity (Acc_Type) + and then Finalize_Storage_Only (Result_Subt) + then + null; + + else + Insert_Action (Allocator, + Make_Set_Finalize_Address_Ptr_Call (Loc, + Typ => Etype (Function_Id), + Ptr_Typ => Acc_Type)); + end if; + end if; + -- Finally, replace the allocator node with a reference to the result -- of the function call itself (which will effectively be an access -- to the object created by the allocator). @@ -6970,10 +7227,47 @@ package body Exp_Ch6 is Result_Subt := Etype (Function_Id); + -- If the build-in-place function returns a controlled object, then the + -- object needs to be finalized immediately after the context. Since + -- this case produces a transient scope, the servicing finalizer needs + -- to name the returned object. Create a temporary which is initialized + -- with the function call: + -- + -- Temp_Id : Func_Type := BIP_Func_Call; + -- + -- The initialization expression of the temporary will be rewritten by + -- the expander using the appropriate mechanism in Make_Build_In_Place_ + -- Call_In_Object_Declaration. + + if Needs_Finalization (Result_Subt) then + declare + Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R'); + Temp_Decl : Node_Id; + + begin + -- Reset the guard on the function call since the following does + -- not perform actual call expansion. + + Set_Is_Expanded_Build_In_Place_Call (Func_Call, False); + + Temp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Object_Definition => + New_Reference_To (Result_Subt, Loc), + Expression => + New_Copy_Tree (Function_Call)); + + Insert_Action (Function_Call, Temp_Decl); + + Rewrite (Function_Call, New_Reference_To (Temp_Id, Loc)); + Analyze (Function_Call); + end; + -- When the result subtype is constrained, an object of the subtype is -- declared and an access value designating it is passed as an actual. - if Is_Constrained (Underlying_Type (Result_Subt)) then + elsif Is_Constrained (Underlying_Type (Result_Subt)) then -- Create a temporary object to hold the function result @@ -6999,8 +7293,8 @@ package body Exp_Ch6 is Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); - Add_Final_List_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, Acc_Type => Empty); + Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id); Add_Task_Actuals_To_Build_In_Place_Call (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); @@ -7023,8 +7317,8 @@ package body Exp_Ch6 is Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); - Add_Final_List_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, Acc_Type => Empty); + Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id); Add_Task_Actuals_To_Build_In_Place_Call (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); @@ -7101,16 +7395,8 @@ package body Exp_Ch6 is Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Func_Id, Alloc_Form => Caller_Allocation); - -- If Lhs is a selected component, then pass it along so that its prefix - -- object will be used as the source of the finalization list. - - if Nkind (Lhs) = N_Selected_Component then - Add_Final_List_Actual_To_Build_In_Place_Call - (Func_Call, Func_Id, Acc_Type => Empty, Sel_Comp => Lhs); - else - Add_Final_List_Actual_To_Build_In_Place_Call - (Func_Call, Func_Id, Acc_Type => Empty); - end if; + Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call, Func_Id); Add_Task_Actuals_To_Build_In_Place_Call (Func_Call, Func_Id, Make_Identifier (Loc, Name_uMaster)); @@ -7176,58 +7462,6 @@ package body Exp_Ch6 is else return; end if; - - -- When the target of the assignment is a return object of an enclosing - -- build-in-place function and also requires finalization, the list - -- generated for the assignment must be moved to that of the enclosing - -- function. - - -- function Enclosing_BIP_Function return Ctrl_Typ is - -- begin - -- return (Ctrl_Parent_Part => BIP_Function with ...); - -- end Enclosing_BIP_Function; - - if Is_Return_Object (Target) - and then Needs_Finalization (Etype (Target)) - and then Needs_Finalization (Result_Subt) - then - declare - Obj_List : constant Node_Id := Find_Final_List (Obj_Id); - Encl_List : Node_Id; - Encl_Scop : Entity_Id; - - begin - Encl_Scop := Scope (Target); - - -- Locate the scope of the extended return statement - - while Present (Encl_Scop) - and then Ekind (Encl_Scop) /= E_Return_Statement - loop - Encl_Scop := Scope (Encl_Scop); - end loop; - - -- A return object should always be enclosed by a return statement - -- scope at some level. - - pragma Assert (Present (Encl_Scop)); - - Encl_List := - Make_Attribute_Reference (Loc, - Prefix => - New_Reference_To ( - Finalization_Chain_Entity (Encl_Scop), Loc), - Attribute_Name => Name_Unrestricted_Access); - - -- Generate a call to move final list - - Insert_After_And_Analyze (Obj_Decl, - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Move_Final_List), Loc), - Parameter_Associations => New_List (Obj_List, Encl_List))); - end; - end if; end Make_Build_In_Place_Call_In_Assignment; ---------------------------------------------------- @@ -7377,8 +7611,8 @@ package body Exp_Ch6 is Establish_Transient_Scope (Object_Decl, Sec_Stack => True); end if; - Add_Final_List_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, Acc_Type => Empty); + Add_Collection_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id); if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement and then Has_Task (Result_Subt) @@ -7525,23 +7759,17 @@ package body Exp_Ch6 is end Make_Build_In_Place_Call_In_Object_Declaration; -------------------------- - -- Needs_BIP_Final_List -- + -- Needs_BIP_Collection -- -------------------------- - function Needs_BIP_Final_List (E : Entity_Id) return Boolean is - pragma Assert (Is_Build_In_Place_Function (E)); - Result_Subt : constant Entity_Id := Underlying_Type (Etype (E)); + function Needs_BIP_Collection (Func_Id : Entity_Id) return Boolean is + pragma Assert (Is_Build_In_Place_Function (Func_Id)); + Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); begin - -- We need the BIP_Final_List if the result type needs finalization. We - -- also need it for tagged types, even if not class-wide, because some - -- type extension might need finalization, and all overriding functions - -- must have the same calling conventions. However, if there is a - -- pragma Restrictions (No_Finalization), we never need this parameter. - - return (Needs_Finalization (Result_Subt) - or else Is_Tagged_Type (Underlying_Type (Result_Subt))) - and then not Restriction_Active (No_Finalization); - end Needs_BIP_Final_List; + return + not Restriction_Active (No_Finalization) + and then Needs_Finalization (Func_Typ); + end Needs_BIP_Collection; end Exp_Ch6; diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index e04e217..433b96a 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 8063601..4fd7d2a 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 669f998..9aa7b0a 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 6500ea6..d12c92c 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 47161e93..60711df 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 dff0044..b858c97f 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 b89e088..0f365e2 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 d6a18fb..0fd967e 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 7557a12..9388e66 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -312,6 +312,320 @@ package body Exp_Util is end if; end Append_Freeze_Actions; + ------------------------------------ + -- Build_Allocate_Deallocate_Proc -- + ------------------------------------ + + procedure Build_Allocate_Deallocate_Proc + (N : Node_Id; + Is_Allocate : Boolean) + is + Expr : constant Node_Id := Expression (N); + Ptr_Typ : constant Entity_Id := Etype (Expr); + Desig_Typ : constant Entity_Id := + Available_View (Designated_Type (Ptr_Typ)); + + function Find_Object (E : Node_Id) return Node_Id; + -- Given an arbitrary expression of an allocator, try to find an object + -- reference in it, otherwise return the original expression. + + function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean; + -- Determine whether subprogram Subp denotes a custom allocate or + -- deallocate. + + ----------------- + -- Find_Object -- + ----------------- + + function Find_Object (E : Node_Id) return Node_Id is + Expr : Node_Id := E; + Change : Boolean := True; + + begin + pragma Assert (Is_Allocate); + + while Change loop + Change := False; + + if Nkind_In (Expr, N_Qualified_Expression, + N_Unchecked_Type_Conversion) + then + Expr := Expression (Expr); + Change := True; + + elsif Nkind (Expr) = N_Explicit_Dereference then + Expr := Prefix (Expr); + Change := True; + end if; + end loop; + + return Expr; + end Find_Object; + + --------------------------------- + -- Is_Allocate_Deallocate_Proc -- + --------------------------------- + + function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is + begin + -- Look for a subprogram body with only one statement which is a + -- call to one of the Allocate / Deallocate routines in package + -- Ada.Finalization.Heap_Management. + + if Ekind (Subp) = E_Procedure + and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body + then + declare + HSS : constant Node_Id := + Handled_Statement_Sequence (Parent (Parent (Subp))); + Proc : Entity_Id; + + begin + if Present (Statements (HSS)) + and then Nkind (First (Statements (HSS))) = + N_Procedure_Call_Statement + then + Proc := Entity (Name (First (Statements (HSS)))); + + return + Is_RTE (Proc, RE_Allocate) + or else Is_RTE (Proc, RE_Deallocate); + end if; + end; + end if; + + return False; + end Is_Allocate_Deallocate_Proc; + + -- Start of processing for Build_Allocate_Deallocate_Proc + + begin + -- The allocation / deallocation of a non-controlled object does not + -- need the machinery created by this routine. + + if not Needs_Finalization (Desig_Typ) then + return; + + -- The allocator or free statmenet has already been expanded and already + -- has a custom Allocate / Deallocate routine. + + elsif Nkind (Expr) = N_Allocator + and then Present (Procedure_To_Call (Expr)) + and then Is_Allocate_Deallocate_Proc (Procedure_To_Call (Expr)) + then + return; + end if; + + declare + Loc : constant Source_Ptr := Sloc (N); + Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A'); + Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L'); + Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P'); + Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S'); + + Actuals : List_Id; + Collect_Act : Node_Id; + Collect_Id : Entity_Id; + Collect_Typ : Entity_Id; + Proc_To_Call : Entity_Id; + + begin + -- When dealing with an access subtype, use the collection of the + -- base type. + + if Ekind (Ptr_Typ) = E_Access_Subtype then + Collect_Typ := Base_Type (Ptr_Typ); + else + Collect_Typ := Ptr_Typ; + end if; + + Collect_Id := Associated_Collection (Collect_Typ); + Collect_Act := New_Reference_To (Collect_Id, Loc); + + -- Handle the case where the collection is actually a pointer to a + -- collection. This case arises in build-in-place functions. + + if Is_Access_Type (Etype (Collect_Id)) then + Collect_Act := + Make_Explicit_Dereference (Loc, + Prefix => Collect_Act); + end if; + + -- Create the actuals for the call to Allocate / Deallocate + + Actuals := New_List ( + Collect_Act, + New_Reference_To (Addr_Id, Loc), + New_Reference_To (Size_Id, Loc), + New_Reference_To (Alig_Id, Loc)); + + -- Generate a run-time check to determine whether a class-wide object + -- is truly controlled. + + if Is_Class_Wide_Type (Desig_Typ) + or else Is_Generic_Actual_Type (Desig_Typ) + then + declare + Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F'); + Flag_Expr : Node_Id; + Param : Node_Id; + Temp : Node_Id; + + begin + if Is_Allocate then + Temp := Find_Object (Expression (Expr)); + else + Temp := Expr; + end if; + + -- Processing for generic actuals + + if Is_Generic_Actual_Type (Desig_Typ) then + Flag_Expr := + New_Reference_To (Boolean_Literals + (Needs_Finalization (Base_Type (Desig_Typ))), Loc); + + -- Processing for subtype indications + + elsif Nkind (Temp) in N_Has_Entity + and then Is_Type (Entity (Temp)) + then + Flag_Expr := + New_Reference_To (Boolean_Literals + (Needs_Finalization (Entity (Temp))), Loc); + + -- Generate a runtime check to test the controlled state of an + -- object for the purposes of allocation / deallocation. + + else + -- The following case arises when allocating through an + -- interface class-wide type, generate: + -- + -- Temp.all + + if Is_RTE (Etype (Temp), RE_Tag_Ptr) then + Param := + Make_Explicit_Dereference (Loc, + Prefix => + Relocate_Node (Temp)); + + -- Generate: + -- Temp'Tag + + else + Param := + Make_Attribute_Reference (Loc, + Prefix => + Relocate_Node (Temp), + Attribute_Name => Name_Tag); + end if; + + -- Generate: + -- Needs_Finalization (Param) + + Flag_Expr := + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Needs_Finalization), Loc), + Parameter_Associations => New_List (Param)); + end if; + + -- Create the temporary which represents the finalization state + -- of the expression. Generate: + -- + -- F : constant Boolean := <Flag_Expr>; + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Flag_Id, + Constant_Present => True, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => Flag_Expr)); + + -- The flag acts as the fifth actual + + Append_To (Actuals, New_Reference_To (Flag_Id, Loc)); + end; + end if; + + -- Select the proper routine to call + + if Is_Allocate then + Proc_To_Call := RTE (RE_Allocate); + else + Proc_To_Call := RTE (RE_Deallocate); + end if; + + -- Create a custom Allocate / Deallocate routine which has identical + -- profile to that of System.Storage_Pools. + + Insert_Action (N, + Make_Subprogram_Body (Loc, + Specification => + + -- procedure Pnn + + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Id, + Parameter_Specifications => New_List ( + + -- P : Root_Storage_Pool + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Temporary (Loc, 'P'), + Parameter_Type => + New_Reference_To (RTE (RE_Root_Storage_Pool), Loc)), + + -- A : [out] Address + + Make_Parameter_Specification (Loc, + Defining_Identifier => Addr_Id, + Out_Present => Is_Allocate, + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), + + -- S : Storage_Count + + Make_Parameter_Specification (Loc, + Defining_Identifier => Size_Id, + Parameter_Type => + New_Reference_To (RTE (RE_Storage_Count), Loc)), + + -- L : Storage_Count + + Make_Parameter_Specification (Loc, + Defining_Identifier => Alig_Id, + Parameter_Type => + New_Reference_To (RTE (RE_Storage_Count), Loc)))), + + Declarations => No_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + + -- Allocate / Deallocate + -- (<Ptr_Typ collection>, A, S, L[, F]); + + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Proc_To_Call, Loc), + Parameter_Associations => Actuals))))); + + -- The newly generated Allocate / Deallocate becomes the default + -- procedure to call when the back end processes the allocation / + -- deallocation. + + if Is_Allocate then + Set_Procedure_To_Call (Expr, Proc_Id); + else + Set_Procedure_To_Call (N, Proc_Id); + end if; + end; + end Build_Allocate_Deallocate_Proc; + ------------------------ -- Build_Runtime_Call -- ------------------------ @@ -1351,13 +1665,17 @@ package body Exp_Util is -- Renamings of class-wide interface types require no equivalent -- constrained type declarations because we only need to reference - -- the tag component associated with the interface. + -- the tag component associated with the interface. The same is + -- presumably true for class-wide types in general, so this test + -- is broadened to include all class-wide renamings, which also + -- avoids cases of unbounded recursion in Remove_Side_Effects. + -- (Is this really correct, or are there some cases of class-wide + -- renamings that require action in this procedure???) elsif Present (N) and then Nkind (N) = N_Object_Renaming_Declaration - and then Is_Interface (Unc_Type) + and then Is_Class_Wide_Type (Unc_Type) then - pragma Assert (Is_Class_Wide_Type (Unc_Type)); null; -- In Ada95 nothing to be done if the type of the expression is limited, @@ -1428,11 +1746,12 @@ package body Exp_Util is while Present (Init_Call) and then Init_Call /= Rep_Clause loop if Nkind (Init_Call) = N_Procedure_Call_Statement - and then Is_Entity_Name (Name (Init_Call)) - and then Entity (Name (Init_Call)) = Init_Proc + and then Is_Entity_Name (Name (Init_Call)) + and then Entity (Name (Init_Call)) = Init_Proc then return Init_Call; end if; + Next (Init_Call); end loop; @@ -1461,8 +1780,8 @@ package body Exp_Util is -- applying to Var). if No (Init_Call) and then Present (Freeze_Node (Var)) then - Init_Call := Find_Init_Call_In_List - (First (Actions (Freeze_Node (Var)))); + Init_Call := + Find_Init_Call_In_List (First (Actions (Freeze_Node (Var)))); end if; return Init_Call; @@ -1701,8 +2020,11 @@ package body Exp_Util is (T : Entity_Id; Name : TSS_Name_Type) return Entity_Id is - Prim : Elmt_Id; - Typ : Entity_Id := T; + Inher_Op : Entity_Id := Empty; + Own_Op : Entity_Id := Empty; + Prim_Elmt : Elmt_Id; + Prim_Id : Entity_Id; + Typ : Entity_Id := T; begin if Is_Class_Wide_Type (Typ) then @@ -1711,18 +2033,31 @@ package body Exp_Util is Typ := Underlying_Type (Typ); - Prim := First_Elmt (Primitive_Operations (Typ)); - while not Is_TSS (Node (Prim), Name) loop - Next_Elmt (Prim); + -- This search is based on the assertion that the dispatching version + -- of the TSS routine always precedes the real primitive. - -- Raise program error if no primitive found + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim_Id := Node (Prim_Elmt); - if No (Prim) then - raise Program_Error; + if Is_TSS (Prim_Id, Name) then + if Present (Alias (Prim_Id)) then + Inher_Op := Prim_Id; + else + Own_Op := Prim_Id; + end if; end if; + + Next_Elmt (Prim_Elmt); end loop; - return Node (Prim); + if Present (Own_Op) then + return Own_Op; + elsif Present (Inher_Op) then + return Inher_Op; + else + raise Program_Error; + end if; end Find_Prim_Op; ---------------------------- @@ -1753,6 +2088,34 @@ package body Exp_Util is raise Program_Error; end Find_Protection_Object; + -------------------------- + -- Find_Protection_Type -- + -------------------------- + + function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is + Comp : Entity_Id; + Typ : Entity_Id := Conc_Typ; + + begin + if Is_Concurrent_Type (Typ) then + Typ := Corresponding_Record_Type (Typ); + end if; + + Comp := First_Component (Typ); + while Present (Comp) loop + if Chars (Comp) = Name_uObject then + return Base_Type (Etype (Comp)); + end if; + + Next_Component (Comp); + end loop; + + -- The corresponding record of a protected type should always have an + -- _object field. + + raise Program_Error; + end Find_Protection_Type; + ---------------------- -- Force_Evaluation -- ---------------------- @@ -2190,45 +2553,254 @@ package body Exp_Util is end if; end Get_Stream_Size; - --------------------------------- - -- Has_Controlled_Coextensions -- - --------------------------------- + --------------------------- + -- Has_Access_Constraint -- + --------------------------- - function Has_Controlled_Coextensions (Typ : Entity_Id) return Boolean is - D_Typ : Entity_Id; - Discr : Entity_Id; + function Has_Access_Constraint (E : Entity_Id) return Boolean is + Disc : Entity_Id; + T : constant Entity_Id := Etype (E); begin - -- Only consider record types + if Has_Per_Object_Constraint (E) + and then Has_Discriminants (T) + then + Disc := First_Discriminant (T); + while Present (Disc) loop + if Is_Access_Type (Etype (Disc)) then + return True; + end if; + + Next_Discriminant (Disc); + end loop; - if not Ekind_In (Typ, E_Record_Type, E_Record_Subtype) then + return False; + else return False; end if; + end Has_Access_Constraint; + + ---------------------------- + -- Has_Controlled_Objects -- + ---------------------------- - if Has_Discriminants (Typ) then - Discr := First_Discriminant (Typ); - while Present (Discr) loop - D_Typ := Etype (Discr); + function Has_Controlled_Objects (N : Node_Id) return Boolean is + For_Pkg : constant Boolean := + Nkind_In (N, N_Package_Body, N_Package_Specification); - if Ekind (D_Typ) = E_Anonymous_Access_Type + begin + case Nkind (N) is + when N_Accept_Statement | + N_Block_Statement | + N_Entry_Body | + N_Package_Body | + N_Protected_Body | + N_Subprogram_Body | + N_Task_Body => + return Has_Controlled_Objects (Declarations (N), For_Pkg) + or else + + -- An expanded sequence of statements may introduce + -- controlled objects. + + (Present (Handled_Statement_Sequence (N)) + and then + Has_Controlled_Objects + (Statements (Handled_Statement_Sequence (N)), For_Pkg)); + + when N_Package_Specification => + return Has_Controlled_Objects (Visible_Declarations (N), For_Pkg) + or else + Has_Controlled_Objects (Private_Declarations (N), For_Pkg); + + when others => + return False; + end case; + end Has_Controlled_Objects; + + ---------------------------- + -- Has_Controlled_Objects -- + ---------------------------- + + function Has_Controlled_Objects + (L : List_Id; + For_Package : Boolean) return Boolean + is + Decl : Node_Id; + Expr : Node_Id; + Obj_Id : Entity_Id; + Obj_Typ : Entity_Id; + Pack_Id : Entity_Id; + Typ : Entity_Id; + + begin + if No (L) + or else Is_Empty_List (L) + then + return False; + end if; + + Decl := First (L); + while Present (Decl) loop + + -- Regular object declarations + + if Nkind (Decl) = N_Object_Declaration then + Obj_Id := Defining_Identifier (Decl); + Obj_Typ := Base_Type (Etype (Obj_Id)); + Expr := Expression (Decl); + + -- Bypass any form of processing for objects which have their + -- finalization disabled. This applies only to objects at the + -- library level. + + if For_Package + and then Finalize_Storage_Only (Obj_Typ) + then + null; + + -- Transient variables are treated separately in order to minimize + -- the size of the generated code. See Exp_Ch7.Process_Transient_ + -- Objects. + + elsif Is_Processed_Transient (Obj_Id) then + null; + + -- The object is of the form: + -- Obj : Typ [:= Expr]; + -- + -- Do not process the incomplete view of a deferred constant + + elsif not Is_Imported (Obj_Id) + and then Needs_Finalization (Obj_Typ) + and then not (Ekind (Obj_Id) = E_Constant + and then not Has_Completion (Obj_Id)) + then + return True; + + -- The object is of the form: + -- Obj : Access_Typ := Non_BIP_Function_Call'reference; + -- + -- Obj : Access_Typ := + -- BIP_Function_Call + -- (..., BIPaccess => null, ...)'reference; + + elsif Is_Access_Type (Obj_Typ) + and then Needs_Finalization + (Available_View (Designated_Type (Obj_Typ))) + and then Present (Expr) and then - (Is_Controlled (Designated_Type (D_Typ)) + (Is_Null_Access_BIP_Func_Call (Expr) or else - Is_Concurrent_Type (Designated_Type (D_Typ))) + (Is_Non_BIP_Func_Call (Expr) + and then not Is_Related_To_Func_Return (Obj_Id))) + then + return True; + + -- Simple protected objects which use type System.Tasking. + -- Protected_Objects.Protection to manage their locks should be + -- treated as controlled since they require manual cleanup. + + elsif Ekind (Obj_Id) = E_Variable + and then + (Is_Simple_Protected_Type (Obj_Typ) + or else Has_Simple_Protected_Object (Obj_Typ)) then return True; end if; - Next_Discriminant (Discr); - end loop; - end if; + -- Specific cases of object renamings + + elsif Nkind (Decl) = N_Object_Renaming_Declaration + and then Nkind (Name (Decl)) = N_Explicit_Dereference + and then Nkind (Prefix (Name (Decl))) = N_Identifier + then + Obj_Id := Defining_Identifier (Decl); + Obj_Typ := Base_Type (Etype (Obj_Id)); + + -- Bypass any form of processing for objects which have their + -- finalization disabled. This applies only to objects at the + -- library level. + + if For_Package + and then Finalize_Storage_Only (Obj_Typ) + then + null; + + -- Return object of a build-in-place function. This case is + -- recognized and marked by the expansion of an extended return + -- statement (see Expand_N_Extended_Return_Statement). + + elsif Needs_Finalization (Obj_Typ) + and then Is_Return_Object (Obj_Id) + and then Present (Return_Flag (Obj_Id)) + then + return True; + end if; + + -- Inspect the freeze node of an access-to-controlled type and + -- look for a delayed finalization collection. This case arises + -- when the freeze actions are inserted at a later time than the + -- expansion of the context. Since Build_Finalizer is never called + -- on a single construct twice, the collection will be ultimately + -- left out and never finalized. This is also needed for freeze + -- actions of designated types themselves, since in some cases the + -- finalization collection is associated with a designated type's + -- freeze node rather than that of the access type (see handling + -- for freeze actions in Build_Finalization_Collection). + + elsif Nkind (Decl) = N_Freeze_Entity + and then Present (Actions (Decl)) + then + Typ := Entity (Decl); + + if (Is_Access_Type (Typ) + and then not Is_Access_Subprogram_Type (Typ) + and then Needs_Finalization + (Available_View (Designated_Type (Typ)))) + or else + (Is_Type (Typ) + and then Needs_Finalization (Typ)) + then + return True; + end if; + + -- Nested package declarations + + elsif Nkind (Decl) = N_Package_Declaration then + Pack_Id := Defining_Unit_Name (Specification (Decl)); + + if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then + Pack_Id := Defining_Identifier (Pack_Id); + end if; + + if Ekind (Pack_Id) /= E_Generic_Package + and then Has_Controlled_Objects (Specification (Decl)) + then + return True; + end if; + + -- Nested package bodies + + elsif Nkind (Decl) = N_Package_Body then + Pack_Id := Corresponding_Spec (Decl); + + if Ekind (Pack_Id) /= E_Generic_Package + and then Has_Controlled_Objects (Decl) + then + return True; + end if; + end if; + + Next (Decl); + end loop; return False; - end Has_Controlled_Coextensions; + end Has_Controlled_Objects; - ------------------------ - -- Has_Address_Clause -- - ------------------------ + ---------------------------------- + -- Has_Following_Address_Clause -- + ---------------------------------- -- Should this function check the private part in a package ??? @@ -2279,6 +2851,27 @@ package body Exp_Util is return Count; end Homonym_Number; + ----------------------------------- + -- In_Library_Level_Package_Body -- + ----------------------------------- + + function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is + begin + -- First determine whether the entity appears at the library level, then + -- look at the containing unit. + + if Is_Library_Level_Entity (Id) then + declare + Container : constant Node_Id := Cunit (Get_Source_Unit (Id)); + + begin + return Nkind (Unit (Container)) = N_Package_Body; + end; + end if; + + return False; + end In_Library_Level_Package_Body; + ------------------------------ -- In_Unconditional_Context -- ------------------------------ @@ -2330,6 +2923,18 @@ package body Exp_Util is Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress); end Insert_Action; + ------------------------- + -- Insert_Action_After -- + ------------------------- + + procedure Insert_Action_After + (Assoc_Node : Node_Id; + Ins_Action : Node_Id) + is + begin + Insert_Actions_After (Assoc_Node, New_List (Ins_Action)); + end Insert_Action_After; + -------------------- -- Insert_Actions -- -------------------- @@ -3098,6 +3703,277 @@ package body Exp_Util is return True; end Is_All_Null_Statements; + ------------------------------ + -- Is_Finalizable_Transient -- + ------------------------------ + + function Is_Finalizable_Transient + (Decl : Node_Id; + Rel_Node : Node_Id) return Boolean + is + Obj_Id : constant Entity_Id := Defining_Identifier (Decl); + Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); + Desig : Entity_Id := Obj_Typ; + Has_Rens : Boolean := True; + Ren_Obj : Entity_Id; + + function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean; + -- Determine whether transient object Trans_Id is initialized either + -- by a function call which returns an access type or simply renames + -- another pointer. + + function Initialized_By_Aliased_BIP_Func_Call + (Trans_Id : Entity_Id) return Boolean; + -- Determine whether transient object Trans_Id is initialized by a + -- build-in-place function call where the BIPalloc parameter is of + -- value 1 and BIPaccess is not null. This case creates an aliasing + -- between the returned value and the value denoted by BIPaccess. + + function Is_Allocated (Trans_Id : Entity_Id) return Boolean; + -- Determine whether transient object Trans_Id is allocated on the heap + + function Is_Renamed + (Trans_Id : Entity_Id; + First_Stmt : Node_Id) return Boolean; + -- Determine whether transient object Trans_Id has been renamed in the + -- statement list starting from First_Stmt. + + --------------------------- + -- Initialized_By_Access -- + --------------------------- + + function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is + Expr : constant Node_Id := Expression (Parent (Trans_Id)); + + begin + return + Present (Expr) + and then Nkind (Expr) /= N_Reference + and then Is_Access_Type (Etype (Expr)); + end Initialized_By_Access; + + ------------------------------------------ + -- Initialized_By_Aliased_BIP_Func_Call -- + ------------------------------------------ + + function Initialized_By_Aliased_BIP_Func_Call + (Trans_Id : Entity_Id) return Boolean + is + Call : Node_Id := Expression (Parent (Trans_Id)); + + begin + -- Build-in-place calls usually appear in 'reference format + + if Nkind (Call) = N_Reference then + Call := Prefix (Call); + end if; + + if Is_Build_In_Place_Function_Call (Call) then + declare + Access_Nam : Name_Id := No_Name; + Access_OK : Boolean := False; + Actual : Node_Id; + Alloc_Nam : Name_Id := No_Name; + Alloc_OK : Boolean := False; + Formal : Node_Id; + Func_Id : Entity_Id; + Param : Node_Id; + + begin + -- Examine all parameter associations of the function call + + Param := First (Parameter_Associations (Call)); + while Present (Param) loop + if Nkind (Param) = N_Parameter_Association + and then Nkind (Selector_Name (Param)) = N_Identifier + then + Actual := Explicit_Actual_Parameter (Param); + Formal := Selector_Name (Param); + + -- Construct the names of formals BIPaccess and BIPalloc + -- using the function name retrieved from an arbitrary + -- formal. + + if Access_Nam = No_Name + and then Alloc_Nam = No_Name + and then Present (Entity (Formal)) + then + Func_Id := Scope (Entity (Formal)); + + Access_Nam := + New_External_Name (Chars (Func_Id), + BIP_Formal_Suffix (BIP_Object_Access)); + + Alloc_Nam := + New_External_Name (Chars (Func_Id), + BIP_Formal_Suffix (BIP_Alloc_Form)); + end if; + + -- A match for BIPaccess => Temp has been found + + if Chars (Formal) = Access_Nam + and then Nkind (Actual) /= N_Null + then + Access_OK := True; + end if; + + -- A match for BIPalloc => 1 has been found + + if Chars (Formal) = Alloc_Nam + and then Nkind (Actual) = N_Integer_Literal + and then Intval (Actual) = Uint_1 + then + Alloc_OK := True; + end if; + end if; + + Next (Param); + end loop; + + return Access_OK and then Alloc_OK; + end; + end if; + + return False; + end Initialized_By_Aliased_BIP_Func_Call; + + ------------------ + -- Is_Allocated -- + ------------------ + + function Is_Allocated (Trans_Id : Entity_Id) return Boolean is + Expr : constant Node_Id := Expression (Parent (Trans_Id)); + + begin + return + Is_Access_Type (Etype (Trans_Id)) + and then Present (Expr) + and then Nkind (Expr) = N_Allocator; + end Is_Allocated; + + ---------------- + -- Is_Renamed -- + ---------------- + + function Is_Renamed + (Trans_Id : Entity_Id; + First_Stmt : Node_Id) return Boolean + is + Stmt : Node_Id; + + function Extract_Renamed_Object + (Ren_Decl : Node_Id) return Entity_Id; + -- Given an object renaming declaration, retrieve the entity of the + -- renamed name. Return Empty if the renamed name is anything other + -- than a variable or a constant. + + ---------------------------- + -- Extract_Renamed_Object -- + ---------------------------- + + function Extract_Renamed_Object + (Ren_Decl : Node_Id) return Entity_Id + is + Change : Boolean; + Ren_Obj : Node_Id; + + begin + Change := True; + Ren_Obj := Renamed_Object (Defining_Identifier (Ren_Decl)); + + while Change loop + Change := False; + + if Nkind_In (Ren_Obj, N_Explicit_Dereference, + N_Indexed_Component, + N_Selected_Component) + then + Ren_Obj := Prefix (Ren_Obj); + Change := True; + end if; + end loop; + + if Nkind (Ren_Obj) in N_Has_Entity then + return Entity (Ren_Obj); + end if; + + return Empty; + end Extract_Renamed_Object; + + -- Start of processing for Is_Renamed + + begin + -- If a previous invocation of this routine has determined that a + -- list has no renamings, there is no point in repeating the same + -- scan. + + if not Has_Rens then + return False; + end if; + + -- Assume that the statement list does not have a renaming. This is a + -- minor optimization. + + Has_Rens := False; + + Stmt := First_Stmt; + while Present (Stmt) loop + if Nkind (Stmt) = N_Object_Renaming_Declaration then + Has_Rens := True; + Ren_Obj := Extract_Renamed_Object (Stmt); + + if Present (Ren_Obj) + and then Ren_Obj = Trans_Id + then + return True; + end if; + end if; + + Next (Stmt); + end loop; + + return False; + end Is_Renamed; + + -- Start of processing for Is_Finalizable_Transient + + begin + -- Handle access types + + if Is_Access_Type (Desig) then + Desig := Available_View (Designated_Type (Desig)); + end if; + + return + Ekind_In (Obj_Id, E_Constant, E_Variable) + and then Needs_Finalization (Desig) + and then Requires_Transient_Scope (Desig) + and then Nkind (Rel_Node) /= N_Simple_Return_Statement + + -- Do not consider transient objects allocated on the heap since they + -- are attached to a finalization collection. + + and then not Is_Allocated (Obj_Id) + + -- Do not consider renamed transient objects because the act of + -- renaming extends the object's lifetime. + + and then not Is_Renamed (Obj_Id, Decl) + + -- If the transient object is a pointer, check that it is not + -- initialized by a function which returns a pointer or acts as a + -- renaming of another pointer. + + and then + (not Is_Access_Type (Obj_Typ) + or else not Initialized_By_Access (Obj_Id)) + + -- Do not consider transient objects which act as indirect aliases of + -- build-in-place function results. + + and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id); + end Is_Finalizable_Transient; + --------------------------------- -- Is_Fully_Repped_Tagged_Type -- --------------------------------- @@ -3146,6 +4022,90 @@ package body Exp_Util is end Is_Library_Level_Tagged_Type; ---------------------------------- + -- Is_Null_Access_BIP_Func_Call -- + ---------------------------------- + + function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean is + Call : Node_Id := Expr; + + begin + -- Build-in-place calls usually appear in 'reference format + + if Nkind (Call) = N_Reference then + Call := Prefix (Call); + end if; + + if Nkind_In (Call, N_Qualified_Expression, + N_Unchecked_Type_Conversion) + then + Call := Expression (Call); + end if; + + if Is_Build_In_Place_Function_Call (Call) then + declare + Access_Nam : Name_Id := No_Name; + Actual : Node_Id; + Param : Node_Id; + Formal : Node_Id; + + begin + -- Examine all parameter associations of the function call + + Param := First (Parameter_Associations (Call)); + while Present (Param) loop + if Nkind (Param) = N_Parameter_Association + and then Nkind (Selector_Name (Param)) = N_Identifier + then + Formal := Selector_Name (Param); + Actual := Explicit_Actual_Parameter (Param); + + -- Construct the name of formal BIPaccess. It is much easier + -- to extract the name of the function using an arbitrary + -- formal's scope rather than the Name field of Call. + + if Access_Nam = No_Name + and then Present (Entity (Formal)) + then + Access_Nam := + New_External_Name + (Chars (Scope (Entity (Formal))), + BIP_Formal_Suffix (BIP_Object_Access)); + end if; + + -- A match for BIPaccess => null has been found + + if Chars (Formal) = Access_Nam + and then Nkind (Actual) = N_Null + then + return True; + end if; + end if; + + Next (Param); + end loop; + end; + end if; + + return False; + end Is_Null_Access_BIP_Func_Call; + + -------------------------- + -- Is_Non_BIP_Func_Call -- + -------------------------- + + function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is + begin + -- The expected call is of the format + -- + -- Func_Call'reference + + return + Nkind (Expr) = N_Reference + and then Nkind (Prefix (Expr)) = N_Function_Call + and then not Is_Build_In_Place_Function_Call (Prefix (Expr)); + end Is_Non_BIP_Func_Call; + + ---------------------------------- -- Is_Possibly_Unaligned_Object -- ---------------------------------- @@ -3427,6 +4387,20 @@ package body Exp_Util is end; end Is_Possibly_Unaligned_Slice; + ------------------------------- + -- Is_Related_To_Func_Return -- + ------------------------------- + + function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is + Expr : constant Node_Id := Related_Expression (Id); + + begin + return + Present (Expr) + and then Nkind (Expr) = N_Explicit_Dereference + and then Nkind (Parent (Expr)) = N_Simple_Return_Statement; + end Is_Related_To_Func_Return; + -------------------------------- -- Is_Ref_To_Bit_Packed_Array -- -------------------------------- @@ -4341,6 +5315,73 @@ package body Exp_Util is end if; end May_Generate_Large_Temp; + ------------------------ + -- Needs_Finalization -- + ------------------------ + + function Needs_Finalization (T : Entity_Id) return Boolean is + function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean; + -- If type is not frozen yet, check explicitly among its components, + -- because the Has_Controlled_Component flag is not necessarily set. + + ----------------------------------- + -- Has_Some_Controlled_Component -- + ----------------------------------- + + function Has_Some_Controlled_Component + (Rec : Entity_Id) return Boolean + is + Comp : Entity_Id; + + begin + if Has_Controlled_Component (Rec) then + return True; + + elsif not Is_Frozen (Rec) then + if Is_Record_Type (Rec) then + Comp := First_Entity (Rec); + + while Present (Comp) loop + if not Is_Type (Comp) + and then Needs_Finalization (Etype (Comp)) + then + return True; + end if; + + Next_Entity (Comp); + end loop; + + return False; + + elsif Is_Array_Type (Rec) then + return Needs_Finalization (Component_Type (Rec)); + + else + return Has_Controlled_Component (Rec); + end if; + else + return False; + end if; + end Has_Some_Controlled_Component; + + -- Start of processing for Needs_Finalization + + begin + -- Class-wide types must be treated as controlled because they may + -- contain an extension that has controlled components + + -- We can skip this if finalization is not available + + return (Is_Class_Wide_Type (T) + and then not Restriction_Active (No_Finalization)) + or else Is_Controlled (T) + or else Has_Controlled_Component (T) + or else Has_Some_Controlled_Component (T) + or else (Is_Concurrent_Type (T) + and then Present (Corresponding_Record_Type (T)) + and then Needs_Finalization (Corresponding_Record_Type (T))); + end Needs_Finalization; + ---------------------------- -- Needs_Constant_Address -- ---------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index ae938a0..e9b373d 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 308b5d7..ffb8dad 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 c9d47bd..cec09ed 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 5f5a4a0..ec534e1 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 78a55ed..eab4a10 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 fa75a4d..98786f4 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 8d45b2c..f2fc765 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 29257dc..652ec29 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 050f799..0000000 --- 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 944fe6f..0000000 --- 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 da373f7..4de2b7c 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 35bdf64..dc55962 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 4ae51f3..1c05844 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 5a2c556..7f8de10 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 1663b89..34e3291 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 71fe0fb..050930b 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 0e5c3db..8c54517 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 cf9af2e..03ff2fe 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 6c4e244..e2e566d 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 48ffe4a..53f79cb 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 8f2376d..42303e7 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 6dacae5..dd527b2 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 6c69643..3169111 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 19581b9..3256ae8 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 b1e99dc..96f2ff8 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 73f5b10..0a676ef 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 840592f..d2b8d3e 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 e88e551..95080c3 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 59d8659..f60aea0 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 ceba869..954a11e 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 fb9ab56..40d8dd6 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 48b138e..7ee9a80 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 981784b..73fbdfc 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 3edb41e..91fbf85 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); |