+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.
a-envvar$(objext) \
a-except$(objext) \
a-exctra$(objext) \
- a-filico$(objext) \
+ a-fihema$(objext) \
a-finali$(objext) \
a-flteio$(objext) \
a-fwteio$(objext) \
s-ficobl$(objext) \
s-fileio$(objext) \
s-filofl$(objext) \
- s-finimp$(objext) \
s-finroo$(objext) \
s-fishfl$(objext) \
s-fore$(objext) \
-- --
-- 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- --
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;
-- --
-- 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 --
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);
-- --
-- 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- --
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;
-- --
-- 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 --
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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
-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 --
------------
-- --
-- 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 --
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;
-- --
-- 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- --
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 --
---------------------
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 --
-----------------
-- --
-- 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 --
-- +-------------------+
-- | type_is_abstract |
-- +-------------------+
- -- | rec ctrler offset |
+ -- | needs finalization|
-- +-------------------+
-- | Ifaces_Table ---> Interface Data
-- +-------------------+ +------------+
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
-- 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
-- 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;
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 ");
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;
-- --
-- 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- --
------------------------------------------------------------------------------
-- 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;
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 (
-- --
-- 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- --
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;
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);
-- --
-- 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- --
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);
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);
#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)
-- --
-- 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- --
-- 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 --
----------------------------------
-- 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)
-- 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
-- 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
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;
--------------------
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.
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 ("");
end if;
WBI (" end " & Ada_Init_Name.all & ";");
+ WBI ("");
end Gen_Adainit_Ada;
-------------------
WBI ("");
Gen_Elab_Calls_C;
WBI ("}");
+ WBI ("");
end Gen_Adainit_C;
------------------------
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
Set_String (" (void);");
Write_Statement_Buffer;
end if;
-
end loop;
-
WBI ("");
end Gen_Elab_Defs_C;
procedure Gen_Elab_Order_Ada is
begin
- WBI ("");
WBI (" -- BEGIN ELABORATION ORDER");
for J in Elab_Order.First .. Elab_Order.Last loop
end loop;
WBI (" -- END ELABORATION ORDER");
+ WBI ("");
end Gen_Elab_Order_Ada;
----------------------
procedure Gen_Elab_Order_C is
begin
- WBI ("");
WBI ("/* BEGIN ELABORATION ORDER");
for J in Elab_Order.First .. Elab_Order.Last loop
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
-- 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
-- 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
end if;
WBI (" end;");
+ WBI ("");
end Gen_Main_Ada;
----------------
----------------
procedure Gen_Main_C is
+ Needs_Library_Finalization : constant Boolean := Has_Finalizer;
+
begin
if Exit_Status_Supported_On_Target then
WBI ("#include <stdlib.h>");
-- 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
end if;
WBI ("}");
+ WBI ("");
end Gen_Main_C;
------------------------------
-- 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
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
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");
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
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
-----------------------
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)
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
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 --
----------------------
-- 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;
-- Extra_Formal Node15
-- Lit_Indexes Node15
-- Related_Instance Node15
+ -- Return_Flag Node15
-- Scale_Value Uint15
-- Storage_Size_Variable Node15
-- String_Literal_Low_Bound Node15
-- Body_Entity Node19
-- Corresponding_Discriminant Node19
- -- Finalization_Chain_Entity Node19
-- Parent_Subtype Node19
-- Related_Array_Object Node19
-- Size_Check_Code Node19
-- 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
-- Protection_Object Node23
-- Stored_Constraint Elist23
+ -- Finalizer Node24
-- Related_Expression Node24
-- Spec_PPC_List Node24
-- Has_Predicates Flag250
-- Body_Is_In_ALFA Flag251
- -- (unused) Flag252
+ -- Is_Processed_Transient Flag252
-- (unused) Flag253
-- (unused) Flag254
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;
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
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;
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);
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;
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);
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;
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);
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
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;
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;
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;
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;
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;
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);
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;
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;
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;
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;
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;
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);
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;
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;
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);
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;
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;
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;
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;
----------------------
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 --
-----------------------------------
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;
----------------------------
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;
-----------------
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;
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));
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");
when E_Return_Statement =>
Write_Str ("Return_Applies_To");
- when E_Variable =>
- Write_Str ("Hiding_Loop_Variable");
-
when others =>
Write_Str ("Field8??");
end case;
when Type_Kind =>
Write_Str ("Class_Wide_Type");
+ when Object_Kind =>
+ Write_Str ("Current_Value");
+
when E_Function |
E_Generic_Function |
E_Generic_Package |
E_Procedure =>
Write_Str ("Renaming_Map");
- when Object_Kind =>
- Write_Str ("Current_Value");
-
when others =>
Write_Str ("Field9??");
end case;
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 |
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;
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");
E_Procedure =>
Write_Str ("Next_Inlined_Subprogram");
- when E_Package =>
- Write_Str ("Associated_Formal_Package");
-
when others =>
Write_Str ("Field12??");
end case;
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");
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;
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");
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");
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");
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;
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");
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");
Write_Str ("Non_Limited_View");
end if;
+ when E_Component =>
+ Write_Str ("Prival");
+
when others =>
Write_Str ("Field17??");
end case;
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");
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");
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;
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");
when Private_Kind =>
Write_Str ("Underlying_Full_View");
- when E_Record_Type =>
- Write_Str ("Parent_Subtype");
-
when others =>
Write_Str ("Field19??");
end case;
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");
E_Subprogram_Type =>
Write_Str ("Last_Entity");
+ when E_Constant |
+ E_Variable =>
+ Write_Str ("Prival_Link");
+
when Scalar_Kind =>
Write_Str ("Scalar_Range");
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 |
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;
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");
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 |
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");
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");
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 |
Write_Str ("Limited_View");
end if;
- when Entry_Kind =>
- Write_Str ("Protection_Object");
-
when others =>
Write_Str ("Field23??");
end case;
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;
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");
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");
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");
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
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;
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 =>
when E_Procedure =>
Write_Str ("Wrapped_Entity");
- when E_Package | Type_Kind =>
- Write_Str ("Current_Use_Clause");
-
when others =>
Write_Str ("Field27??");
end case;
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 =>
-- 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.
-- 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
-- ??? 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
-- 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
-- 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
-- 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
-- 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
-- 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.
-- 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.
-- 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).
-- 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 --
-- 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)
-- E_Anonymous_Access_Type
-- Storage_Size_Variable (Node15) ??? is this needed ???
-- Directly_Designated_Type (Node20)
+ -- Associated_Collection (Node23)
-- (plus type attributes)
-- E_Array_Type
-- Block_Node (Node11)
-- First_Entity (Node17)
-- Last_Entity (Node20)
- -- Finalization_Chain_Entity (Node19)
-- Scope_Depth_Value (Uint22)
-- Entry_Cancel_Parameter (Node23)
-- Delay_Cleanups (Flag114)
-- Full_View (Node11)
-- Esize (Uint12)
-- Alignment (Uint14)
+ -- Return_Flag (Node15) (constants only)
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18)
-- Size_Check_Code (Node19) (constants only)
-- 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)
-- 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)
-- 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)
-- 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
-- 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)
-- 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)
-- 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)
-- Address_Clause (synth)
-- First_Formal (synth)
-- First_Formal_With_Extras (synth)
+ -- Is_Finalizer (synth)
-- Last_Formal (synth)
-- Number_Formals (synth)
-- 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)
-- E_Return_Statement
-- Return_Applies_To (Node8)
- -- Finalization_Chain_Entity (Node19)
-- E_Signed_Integer_Type
-- E_Signed_Integer_Subtype
-- 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)
-- Esize (Uint12)
-- Extra_Accessibility (Node13)
-- Alignment (Uint14)
+ -- Return_Flag (Node15) (transient object only)
-- Unset_Reference (Node16)
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18)
-- 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)
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;
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;
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;
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;
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;
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;
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;
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;
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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;
-- 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;
-- 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
-- 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;
-- 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;
-- 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
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));
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;
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 (
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
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;
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
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;
(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;
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.
-- 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;
-- 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).
-- 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
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 --
-------------------------------
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
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
-- 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;
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);
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
-- 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;
-- 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
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));
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
-- 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,
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
-- 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));
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.
Append_List_To (L,
Late_Expansion (Expr_Q, Comp_Type,
- New_Reference_To (TmpE, Loc), Internal_Final_List));
+ New_Reference_To (TmpE, Loc)));
-- Slide
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
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;
-- 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;
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);
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);
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;
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;
---------------------------------
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;
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
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
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;
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 --
----------------------------
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
-- --
-- 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- --
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);
-- 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
-- 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
-- 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
-- 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 --
--------------------------
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
-----------------------------
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
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 =>
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;
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;
-- 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,
--
-- 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.
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
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.
----------------------
----------------------
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
-- 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
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;
-- 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)),
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;
------------------------------------
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
-- 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;
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
-- 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);
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;
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));
-- 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
--------------------------
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;
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);
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 :=
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
---------------------------
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
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
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);
-- 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 =>
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;
-- 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
-- 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.
Names := Build_Entry_Names (Rec_Type);
if Present (Names) then
- Append_To (Statement_List, Names);
+ Append_To (Stmts, Names);
end if;
end if;
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
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 =>
-- 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
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);
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),
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;
-- 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 =>
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));
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 --
--------------------------------------
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;
-- 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));
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,
Append_List_To (Stmts,
Make_Eq_Case (Typ, Comps, A));
-
end;
-- Normal case (not unchecked union)
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
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
-- 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,
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
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 --
------------------------
------------------------------
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
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;
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 --
------------------------------------
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
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);
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
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.
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));
-- 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
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;
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
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;
------------------------------
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
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;
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))
-- 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;
-- 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 =>
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
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;
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 =>
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);
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);
-- 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;
-- --
-- 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- --
-- 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;
-- 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;
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;
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;
-- 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
-- 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
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 --
--------------------------------
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
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);
Make_Attribute_Reference (Loc,
Prefix => Exp,
Attribute_Name => Name_Address)))));
-
else
Set_Expression
(Expression (N),
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
-- 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
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),
-- 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
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;
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));
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
-- 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);
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
-- 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);
-- 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,
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
-- 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
-- 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
-- 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
-- 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
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))
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.
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;
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,
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
Result := New_Reference_To (Standard_True, Loc);
C := Suitable_Element (First_Entity (Typ));
+
while Present (C) loop
declare
New_Lhs : Node_Id;
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 --
---------------------------------
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
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;
------------------------------
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:
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
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
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
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;
-- 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;
-- 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;
(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 --
------------------------------
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 --
---------------------------------------------
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 =>
-- 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
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 --
---------------
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);
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))
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 --
--------------------------
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
-- 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
-- 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
-- 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
-- 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;
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
-- 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);
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
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;
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;
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;
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
-- 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.
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
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.
-- 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;
Alloc_If_Stmt :=
Make_If_Statement (Loc,
- Condition =>
+ Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (Obj_Alloc_Formal, Loc),
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
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));
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.
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;
-- 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);
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);
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)));
-- Local variables
- Subp : constant Entity_Id := Entity (N);
+ Subp : constant Entity_Id := Entity (N);
-- Start of processing for Freeze_Subprogram
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
-- 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
(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).
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
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));
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));
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));
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;
----------------------------------------------------
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)
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;
-- --
-- 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- --
-- 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.
-- 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;
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;
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
-- 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.
+ 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_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) 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 --
-- Attach_To_Final_List (_L, Finalizable (Y), 1);
--
-- type R is record
- -- _C : Record_Controller;
-- C : Controlled;
-- end record;
-- W : R;
-- _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.
+
+ 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.
- 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_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 --
Prim => Finalize_Case,
Typ => Typ,
Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
- end Build_Array_Deep_Procs;
-
- -----------------------------
- -- Build_Controlling_Procs --
- -----------------------------
- procedure Build_Controlling_Procs (Typ : Entity_Id) is
- begin
- if Is_Array_Type (Typ) then
- Build_Array_Deep_Procs (Typ);
+ -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
+ -- .NET do not support address arithmetic and unchecked conversions.
- else pragma Assert (Is_Record_Type (Typ));
- Build_Record_Deep_Procs (Typ);
+ 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_Controlling_Procs;
+ end Build_Array_Deep_Procs;
- ----------------------
- -- Build_Final_List --
- ----------------------
+ ------------------------------
+ -- Build_Cleanup_Statements --
+ ------------------------------
- procedure Build_Final_List (N : Node_Id; Typ : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Decl : Node_Id;
+ 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
- Set_Associated_Final_Chain (Typ,
- Make_Defining_Identifier (Loc,
- New_External_Name (Chars (Typ), 'L')));
+ 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;
- 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
- then
- Insert_Action (Parent (Designated_Type (Typ)), Decl);
+ elsif Is_Master then
+ if Restriction_Active (No_Task_Hierarchy) = False then
+ Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master));
+ end if;
- -- 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.
+ -- 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.
- elsif Is_Frozen (Typ)
- or else (Nkind (N) = N_Allocator
- and then Ekind (Etype (N)) = E_Anonymous_Access_Type)
- then
- Insert_Action (N, Decl);
+ -- NOTE: The generated code references _object, a parameter to the
+ -- procedure.
- else
- Append_Freeze_Action (Typ, Decl);
- end if;
- end Build_Final_List;
+ 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;
- ---------------------
- -- Build_Late_Proc --
- ---------------------
+ begin
+ -- Find the _object parameter representing the protected object
- procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
- begin
- for Final_Prim in Name_Of'Range loop
- if Name_Of (Final_Prim) = Nam then
- Set_TSS (Typ,
- Make_Deep_Proc (
- Prim => Final_Prim,
- Typ => Typ,
- Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
- end if;
- end loop;
- end Build_Late_Proc;
+ Param := First (Parameter_Specifications (Spec));
+ loop
+ Param_Typ := Etype (Parameter_Type (Param));
- -----------------------------
- -- Build_Record_Deep_Procs --
- -----------------------------
+ if Ekind (Param_Typ) = E_Record_Type then
+ Conc_Typ := Corresponding_Concurrent_Type (Param_Typ);
+ end if;
- procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
- begin
- Set_TSS (Typ,
- Make_Deep_Proc (
- Prim => Initialize_Case,
- Typ => Typ,
- Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
+ exit when No (Param) or else Present (Conc_Typ);
+ Next (Param);
+ end loop;
- if not Is_Immutably_Limited_Type (Typ) then
- Set_TSS (Typ,
- Make_Deep_Proc (
- Prim => Adjust_Case,
- Typ => Typ,
- Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
- end if;
+ pragma Assert (Present (Param));
- Set_TSS (Typ,
- Make_Deep_Proc (
- Prim => Finalize_Case,
- Typ => Typ,
- Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
- end Build_Record_Deep_Procs;
+ -- If the associated protected object has entries, a protected
+ -- procedure has to service entry queues. In this case generate:
- -------------------
- -- Cleanup_Array --
- -------------------
+ -- Service_Entries (_object._object'Access);
- function Cleanup_Array
- (N : Node_Id;
- Obj : Node_Id;
- Typ : Entity_Id) return List_Id
- is
- Loc : constant Source_Ptr := Sloc (N);
- Index_List : constant List_Id := New_List;
+ 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);
- function Free_Component return List_Id;
- -- Generate the code to finalize the task or protected subcomponents
- -- of a single component of the array.
+ when System_Tasking_Protected_Objects_Single_Entry =>
+ Nam := New_Reference_To (RTE (RE_Service_Entry), Loc);
- function Free_One_Dimension (Dim : Int) return List_Id;
- -- Generate a loop over one dimension of the array
+ when others =>
+ raise Program_Error;
+ end case;
- --------------------
- -- Free_Component --
- --------------------
+ 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))));
- function Free_Component return List_Id is
- Stmts : List_Id := New_List;
- Tsk : Node_Id;
- C_Typ : constant Entity_Id := Component_Type (Typ);
+ else
+ -- Generate:
+ -- Unlock (_object._object'Access);
- begin
- -- Component type is known to contain tasks or protected objects
+ case Corresponding_Runtime_Package (Conc_Typ) is
+ when System_Tasking_Protected_Objects_Entries =>
+ Nam := New_Reference_To (RTE (RE_Unlock_Entries), Loc);
- Tsk :=
- Make_Indexed_Component (Loc,
- Prefix => Duplicate_Subexpr_No_Checks (Obj),
- Expressions => Index_List);
+ when System_Tasking_Protected_Objects_Single_Entry =>
+ Nam := New_Reference_To (RTE (RE_Unlock_Entry), Loc);
- Set_Etype (Tsk, C_Typ);
+ when System_Tasking_Protected_Objects =>
+ Nam := New_Reference_To (RTE (RE_Unlock), Loc);
- if Is_Task_Type (C_Typ) then
- Append_To (Stmts, Cleanup_Task (N, Tsk));
+ when others =>
+ raise Program_Error;
+ end case;
- elsif Is_Simple_Protected_Type (C_Typ) then
- Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
+ 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;
- elsif Is_Record_Type (C_Typ) then
- Stmts := Cleanup_Record (N, Tsk, C_Typ);
+ -- Generate:
+ -- Abort_Undefer;
- elsif Is_Array_Type (C_Typ) then
- Stmts := Cleanup_Array (N, Tsk, C_Typ);
- end if;
+ 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;
- return Stmts;
- end Free_Component;
+ -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
+ -- tasks. Other unactivated tasks are completed by Complete_Task or
+ -- Complete_Master.
- ------------------------
- -- Free_One_Dimension --
- ------------------------
+ -- NOTE: The generated code references _chain, a local object
- function Free_One_Dimension (Dim : Int) return List_Id is
- Index : Entity_Id;
+ elsif Is_Task_Allocation then
- begin
- if Dim > Number_Dimensions (Typ) then
- return Free_Component;
+ -- Generate:
+ -- Expunge_Unactivated_Tasks (_chain);
- -- Here we generate the required 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.
- else
- Index := Make_Temporary (Loc, 'J');
- Append (New_Reference_To (Index, Loc), Index_List);
+ 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))));
- return New_List (
- Make_Implicit_Loop_Statement (N,
- 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 => Duplicate_Subexpr (Obj),
- Attribute_Name => Name_Range,
- Expressions => New_List (
- Make_Integer_Literal (Loc, Dim))))),
- Statements => Free_One_Dimension (Dim + 1)));
- end if;
- end Free_One_Dimension;
+ -- Attempt to cancel an asynchronous entry call whenever the block which
+ -- contains the abortable part is exited.
- -- Start of processing for Cleanup_Array
+ -- NOTE: The generated code references Cnn, a local object
- begin
- return Free_One_Dimension (1);
- end Cleanup_Array;
+ elsif Is_Asynchronous_Call then
+ declare
+ Cancel_Param : constant Entity_Id :=
+ Entry_Cancel_Parameter (Entity (Identifier (N)));
- --------------------
- -- Cleanup_Record --
- --------------------
+ 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))),
- function Cleanup_Record
- (N : Node_Id;
- Obj : Node_Id;
- Typ : Entity_Id) return List_Id
- is
- Loc : constant Source_Ptr := Sloc (N);
- Tsk : Node_Id;
- Comp : Entity_Id;
- Stmts : constant List_Id := New_List;
- U_Typ : constant Entity_Id := Underlying_Type (Typ);
+ 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))))));
- begin
- if Has_Discriminants (U_Typ)
- and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
- and then
- Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
- and then
- Present
- (Variant_Part
- (Component_List (Type_Definition (Parent (U_Typ)))))
- then
- -- For now, do not attempt to free a component that may appear in
- -- a variant, and instead issue a warning. Doing this "properly"
- -- would require building a case statement and would be quite a
- -- mess. Note that the RM only requires that free "work" for the
- -- case of a task access value, so already we go way beyond this
- -- in that we deal with the array case and non-discriminated
- -- record cases.
+ -- Asynchronous delay, generate:
+ -- Cancel_Async_Delay (Cancel_Param);
- Error_Msg_N
- ("task/protected object in variant record will not be freed?", N);
- return New_List (Make_Null_Statement (Loc));
+ 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;
- Comp := First_Component (Typ);
+ return Stmts;
+ end Build_Cleanup_Statements;
- while Present (Comp) loop
- if Has_Task (Etype (Comp))
- or else Has_Simple_Protected_Object (Etype (Comp))
- then
- Tsk :=
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr_No_Checks (Obj),
- Selector_Name => New_Occurrence_Of (Comp, Loc));
- Set_Etype (Tsk, Etype (Comp));
+ -----------------------------
+ -- Build_Controlling_Procs --
+ -----------------------------
- if Is_Task_Type (Etype (Comp)) then
- Append_To (Stmts, Cleanup_Task (N, Tsk));
+ procedure Build_Controlling_Procs (Typ : Entity_Id) is
+ begin
+ if Is_Array_Type (Typ) then
+ Build_Array_Deep_Procs (Typ);
- elsif Is_Simple_Protected_Type (Etype (Comp)) then
- Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
+ else pragma Assert (Is_Record_Type (Typ));
+ Build_Record_Deep_Procs (Typ);
+ end if;
+ end Build_Controlling_Procs;
- elsif Is_Record_Type (Etype (Comp)) then
+ -----------------------------
+ -- Build_Exception_Handler --
+ -----------------------------
- -- Recurse, by generating the prefix of the argument to
- -- the eventual cleanup call.
+ 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;
- Append_List_To
- (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
+ begin
+ pragma Assert (Present (E_Id));
+ pragma Assert (Present (Raised_Id));
- elsif Is_Array_Type (Etype (Comp)) then
- Append_List_To
- (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
- end if;
- end if;
+ -- Generate:
+ -- Get_Current_Excep.all.all
- Next_Component (Comp);
- end loop;
+ 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)))));
- return Stmts;
- end Cleanup_Record;
+ if For_Library then
+ Proc_To_Call := RTE (RE_Save_Library_Occurrence);
- ------------------------------
- -- Cleanup_Protected_Object --
- ------------------------------
+ else
+ Proc_To_Call := RTE (RE_Save_Occurrence);
+ Prepend_To (Actuals, New_Reference_To (E_Id, Loc));
+ end if;
- function Cleanup_Protected_Object
- (N : Node_Id;
- Ref : Node_Id) return Node_Id
- is
- Loc : constant Source_Ptr := Sloc (N);
+ -- Generate:
+ -- when others =>
+ -- if not Raised_Id then
+ -- Raised_Id := True;
- begin
- return
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Finalize_Protection), Loc),
- Parameter_Associations => New_List (
- Concurrent_Ref (Ref)));
- end Cleanup_Protected_Object;
+ -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
+ -- or
+ -- Save_Library_Occurrence (Get_Current_Excep.all.all);
+ -- end if;
- ------------------------------------
- -- Clean_Simple_Protected_Objects --
- ------------------------------------
+ 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;
- 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;
+ -----------------------------------
+ -- Build_Finalization_Collection --
+ -----------------------------------
- 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));
+ 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);
- 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.
+ 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.
- if Ekind (Current_Scope) = E_Function
- and then Nkind (Stmt) = Sinfo.N_Return_Statement
- then
- Stmt := Prev (Stmt);
- end if;
+ ------------------------------
+ -- In_Deallocation_Instance --
+ ------------------------------
- if Is_Simple_Protected_Type (Typ) then
- Insert_After (Stmt, Cleanup_Protected_Object (N, Ref));
+ function In_Deallocation_Instance (E : Entity_Id) return Boolean is
+ Pkg : constant Entity_Id := Scope (E);
+ Par : Node_Id := Empty;
- elsif Has_Simple_Protected_Object (Typ) then
- if Is_Record_Type (Typ) then
- Insert_List_After (Stmt, Cleanup_Record (N, Ref, Typ));
+ 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)));
- elsif Is_Array_Type (Typ) then
- Insert_List_After (Stmt, Cleanup_Array (N, Ref, Typ));
- end if;
- end if;
- end;
+ 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;
- Next_Entity (E);
- end loop;
+ return False;
+ end In_Deallocation_Instance;
- -- Analyze inserted cleanup statements
+ -- Start of processing for Build_Finalization_Collection
- if Present (Stmt) then
- Stmt := Next (Stmt);
+ begin
+ if Present (Associated_Collection (Typ)) then
+ return;
- while Present (Stmt) loop
- Analyze (Stmt);
- Next (Stmt);
- end loop;
- end if;
- end Clean_Simple_Protected_Objects;
+ -- Do not process types that return on the secondary stack
- ------------------
- -- Cleanup_Task --
- ------------------
+ -- ??? The need for a secondary stack should be revisited and perhaps
+ -- changed.
- function Cleanup_Task
- (N : Node_Id;
- Ref : Node_Id) return Node_Id
- is
- Loc : constant Source_Ptr := Sloc (N);
- begin
- return
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Free_Task), Loc),
- Parameter_Associations =>
- New_List (Concurrent_Ref (Ref)));
- end Cleanup_Task;
+ elsif Present (Associated_Storage_Pool (Typ))
+ and then Is_RTE (Associated_Storage_Pool (Typ), RE_SS_Pool)
+ then
+ return;
- ---------------------------------
- -- Has_Simple_Protected_Object --
- ---------------------------------
+ -- Do not process types which may never allocate an object
- function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
- Comp : Entity_Id;
+ elsif No_Pool_Assigned (Typ) then
+ return;
- begin
- if Is_Simple_Protected_Type (T) then
- return True;
+ -- 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 Is_Array_Type (T) then
- return Has_Simple_Protected_Object (Component_Type (T));
+ elsif In_Deallocation_Instance (Typ) then
+ return;
- elsif Is_Record_Type (T) then
- Comp := First_Component (T);
+ -- Ignore the general use of anonymous access types unless the context
+ -- requires a collection.
- while Present (Comp) loop
- if Has_Simple_Protected_Object (Etype (Comp)) then
- return True;
- end if;
+ elsif Ekind (Typ) = E_Anonymous_Access_Type
+ and then No (Ins_Node)
+ then
+ return;
- Next_Component (Comp);
- end loop;
+ -- Do not process non-library access types when restriction No_Nested_
+ -- Finalization is in effect since collections are controlled objects.
- return False;
+ elsif Restriction_Active (No_Nested_Finalization)
+ and then not Is_Library_Level_Entity (Typ)
+ then
+ return;
- else
- return False;
+ -- Do not process access-to-controlled types on .NET/JVM targets
+
+ elsif VM_Target /= No_VM then
+ return;
end if;
- end Has_Simple_Protected_Object;
- ------------------------------
- -- Is_Simple_Protected_Type --
- ------------------------------
+ declare
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Actions : constant List_Id := New_List;
+ Coll_Id : Entity_Id;
+ Pool_Id : Entity_Id;
- 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;
+ 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;
- ------------------------------
- -- Check_Visibly_Controlled --
- ------------------------------
+ Append_To (Actions,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Coll_Id,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Finalization_Collection), Loc)));
- procedure Check_Visibly_Controlled
- (Prim : Final_Primitives;
- Typ : Entity_Id;
- E : in out Entity_Id;
- Cref : in out Node_Id)
- is
- Parent_Type : Entity_Id;
- Op : Entity_Id;
+ -- If the access type has a user-defined pool, use it as the base
+ -- storage medium for the finalization pool.
- begin
- if Is_Derived_Type (Typ)
- and then Comes_From_Source (E)
- and then not Present (Overridden_Operation (E))
- then
- -- We know that the explicit operation on the type does not override
- -- the inherited operation of the parent, and that the derivation
- -- is from a private type that is not visibly controlled.
+ if Present (Associated_Storage_Pool (Typ)) then
+ Pool_Id := Associated_Storage_Pool (Typ);
- Parent_Type := Etype (Typ);
- Op := Find_Prim_Op (Parent_Type, Name_Of (Prim));
+ -- Access subtypes must use the storage pool of their base type
- if Present (Op) then
- E := Op;
+ elsif Ekind (Typ) = E_Access_Subtype then
+ declare
+ Base_Typ : constant Entity_Id := Base_Type (Typ);
- -- Wrap the object to be initialized into the proper
- -- unchecked conversion, to be compatible with the operation
- -- to be called.
+ 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;
- if Nkind (Cref) = N_Unchecked_Type_Conversion then
- Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
+ -- 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
- Cref := Unchecked_Convert_To (Parent_Type, Cref);
+ 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 if;
- end Check_Visibly_Controlled;
+ end;
+ end Build_Finalization_Collection;
- -------------------------------
- -- CW_Or_Has_Controlled_Part --
- -------------------------------
+ ---------------------
+ -- Build_Finalizer --
+ ---------------------
- function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
- begin
- return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
- end CW_Or_Has_Controlled_Part;
+ 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;
- --------------------------
- -- Controller_Component --
- --------------------------
+ begin
+ pragma Assert (Present (Decls));
- 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;
+ -- 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.
- begin
- if Is_Class_Wide_Type (T) then
- T := Root_Type (T);
- end if;
+ if Components_Built then
+ return;
+ end if;
- if Is_Private_Type (T) then
- T := Underlying_Type (T);
- end if;
+ Components_Built := True;
- -- Fetch the outermost controller
+ if Has_Ctrl_Objs then
- Comp := First_Entity (T);
- while Present (Comp) loop
- if Chars (Comp) = Name_uController then
- Comp_Scop := Scope (Original_Record_Component (Comp));
+ -- Create entities for the counter, its type, the local exception
+ -- and the raised flag.
- -- If this controller is at the outermost level, no need to
- -- look for another one
+ Counter_Id := Make_Temporary (Loc, 'C');
+ Counter_Typ := Make_Temporary (Loc, 'T');
- if Comp_Scop = T then
- return Comp;
+ if Exceptions_OK then
+ E_Id := Make_Temporary (Loc, 'E');
+ Raised_Id := Make_Temporary (Loc, 'R');
+ end if;
- -- Otherwise record the outermost one and continue looking
+ -- 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;
- elsif Res = Empty
- or else Is_Ancestor (Res_Scop, Comp_Scop, Use_Full_View => True)
- then
- Res := Comp;
- Res_Scop := Comp_Scop;
+ else
+ Analyze (Counter_Typ_Decl);
+ Analyze (Counter_Decl);
end if;
+
+ Finalizer_Decls := New_List;
+ Jump_Alts := New_List;
end if;
- Next_Entity (Comp);
- end loop;
+ -- If the context requires additional clean up, the finalization
+ -- machinery is added after the clean up code.
- -- If we fall through the loop, there is no controller component
+ 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);
- return Res;
- end Controller_Component;
+ begin
+ -- Climb the scope stack in order to start from the topmost
+ -- name.
- ------------------
- -- Convert_View --
- ------------------
+ if Present (S)
+ and then S /= Standard_Standard
+ then
+ Create_Finalizer_String (S);
+ end if;
- function Convert_View
- (Proc : Entity_Id;
- Arg : Node_Id;
- Ind : Pos := 1) return Node_Id
- is
- Fent : Entity_Id := First_Entity (Proc);
- Ftyp : Entity_Id;
- Atyp : Entity_Id;
+ Get_Name_String (Chars (Id));
+ Store_String_Chars (Name_Buffer (1 .. Name_Len));
+ Store_String_Char ('_');
+ Store_String_Char ('_');
+ end Create_Finalizer_String;
- begin
- for J in 2 .. Ind loop
- Next_Entity (Fent);
- end loop;
+ -- Start of processing for Create_Finalizer_String
- Ftyp := Etype (Fent);
+ begin
+ Start_String;
- if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then
- Atyp := Entity (Subtype_Mark (Arg));
- else
- Atyp := Etype (Arg);
- end if;
+ -- Build a fully qualified name. Compilations for .NET/JVM use the
+ -- finalizer name directly.
- if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
- return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
+ if VM_Target = No_VM then
+ Create_Finalizer_String (Spec_Id);
+ end if;
- elsif Ftyp /= Atyp
- and then Present (Atyp)
- and then
- (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
- and then
- Base_Type (Underlying_Type (Atyp)) =
- Base_Type (Underlying_Type (Ftyp))
- then
- return Unchecked_Convert_To (Ftyp, Arg);
+ -- Add the name of the finalizer
- -- If the argument is already a conversion, as generated by
- -- Make_Init_Call, set the target type to the type of the formal
- -- directly, to avoid spurious typing problems.
+ Get_Name_String (Chars (Fin_Id));
+ Store_String_Chars (Name_Buffer (1 .. Name_Len));
- elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion)
- and then not Is_Class_Wide_Type (Atyp)
- then
- Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
- Set_Etype (Arg, Ftyp);
- return Arg;
+ return End_String;
+ end Create_Finalizer_String;
- else
- return Arg;
- end if;
- end Convert_View;
+ -- Start of processing for Create_Finalizer
- -------------------------------
- -- Establish_Transient_Scope --
- -------------------------------
+ begin
+ -- Step 1: Creation of the finalizer name
- -- This procedure is called each time a transient block has to be inserted
- -- that is to say for each call to a function with unconstrained or tagged
- -- result. It creates a new scope on the stack scope in order to enclose
- -- all transient variables generated
+ -- Packages must use a distinct name for their finalizers since the
+ -- binder will have to generate calls to them by name.
- procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is
- Loc : constant Source_Ptr := Sloc (N);
- Wrap_Node : Node_Id;
+ if For_Package then
- begin
- -- Nothing to do for virtual machines where memory is GCed
+ -- finalizeS for specs
- if VM_Target /= No_VM then
- return;
- end if;
+ if For_Package_Spec then
+ Fin_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Name_Finalize, 'S'));
- -- Do not create a transient scope if we are already inside one
+ -- finalizeB for bodies
- for S in reverse Scope_Stack.First .. Scope_Stack.Last loop
- if Scope_Stack.Table (S).Is_Transient then
- if Sec_Stack then
- Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity);
+ else
+ Fin_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Name_Finalize, 'B'));
end if;
- return;
+ -- The default name is _finalizer
- -- If we have encountered Standard there are no enclosing
- -- transient scopes.
+ else
+ Fin_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Name_uFinalizer));
+ end if;
- elsif Scope_Stack.Table (S).Entity = Standard_Standard then
- exit;
+ -- 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;
- end loop;
- Wrap_Node := Find_Node_To_Be_Wrapped (N);
+ -- Step 3: Creation of the finalizer body
- -- Case of no wrap node, false alert, no transient scope needed
+ if Has_Ctrl_Objs then
- if No (Wrap_Node) then
- null;
+ -- Add L0, the default destination to the jump block
- -- If the node to wrap is an iteration_scheme, the expression is
- -- one of the bounds, and the expansion will make an explicit
- -- declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb),
- -- so do not apply any transformations here.
+ 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);
- elsif Nkind (Wrap_Node) = N_Iteration_Scheme then
- null;
+ -- Generate:
+ -- L0 : label;
- else
- Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
- Set_Scope_Is_Transient;
+ Prepend_To (Finalizer_Decls,
+ Make_Implicit_Label_Declaration (Loc,
+ Defining_Identifier => Entity (Label_Id),
+ Label_Construct => Label));
- if Sec_Stack then
- Set_Uses_Sec_Stack (Current_Scope);
- Check_Restriction (No_Secondary_Stack, N);
+ -- 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;
- Set_Etype (Current_Scope, Standard_Void_Type);
- Set_Node_To_Be_Wrapped (Wrap_Node);
+ -- Add a call to the previous At_End handler if it exists. The call
+ -- must always precede the jump block.
- if Debug_Flag_W then
- Write_Str (" <Transient>");
- Write_Eol;
+ 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;
- end if;
- end Establish_Transient_Scope;
- ----------------------------
- -- Expand_Cleanup_Actions --
- ----------------------------
+ -- Release the secondary stack mark
- 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;
+ 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;
- Is_Master : constant Boolean :=
- Nkind (N) /= N_Entry_Body
- and then Is_Task_Master (N);
- Is_Protected : 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);
+ -- 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.
- Previous_At_End_Proc : constant Node_Id :=
- At_End_Proc (Handled_Statement_Sequence (N));
+ 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)));
- 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;
+ Append_To (Finalizer_Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
+ end if;
- 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;
+ -- 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;
- -- There are cleanup actions only if the secondary stack needs
- -- releasing or some finalizations are needed or in the context
- -- of tasking
+ -- Create the body of the finalizer
- 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;
+ Fin_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Chars (Fin_Id))),
- -- 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.
+ Declarations => Finalizer_Decls,
- 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;
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Finalizer_Stmts));
- -- 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.
+ -- Step 4: Spec and body insertion, analysis
- Old_Poll := Polling_Required;
- Polling_Required := False;
+ if For_Package then
- -- Make sure we have a declaration list, since we will add to it
+ -- 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 No (Declarations (N)) then
- Set_Declarations (N, New_List);
- end if;
+ if For_Package_Spec then
+ Prepend_To (Decls, Prag_Decl);
+ Prepend_To (Decls, Spec_Decl);
- -- The task activation call has already been built for task
- -- allocation blocks.
+ if Present (Priv_Decls) then
+ Append_To (Priv_Decls, Fin_Body);
+ else
+ Append_To (Decls, Fin_Body);
+ end if;
- if not Is_Task_Allocation then
- Build_Task_Activation_Call (N);
- 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.
- if Is_Master then
- Establish_Task_Master (N);
- end if;
+ 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;
- -- If secondary stack is in use, expand:
- -- _Mxx : constant Mark_Id := SS_Mark;
+ Vis_Decls := Visible_Declarations (Spec_Nod);
- -- Suppress calls to SS_Mark and SS_Release if VM_Target,
- -- since we never use the secondary stack on the VM.
+ Prepend_To (Vis_Decls, Prag_Decl);
+ Prepend_To (Vis_Decls, Spec_Decl);
+ Append_To (Decls, Fin_Body);
+ end;
+ end if;
- 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))));
+ -- Push the name of the package
- Set_Uses_Sec_Stack (Current_Scope, False);
- end if;
+ Push_Scope (Spec_Id);
+ Analyze (Spec_Decl);
+ Analyze (Prag_Decl);
+ Analyze (Fin_Body);
+ Pop_Scope;
- -- If finalization list is present then expand:
- -- Local_Final_List : System.FI.Finalizable_Ptr;
+ -- Non-package case
- 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;
+ 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
- -- Clean-up procedure definition
+ 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;
- 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));
+ 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
+ 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;
+
+ -- 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 --
+ ---------------------
+
+ procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
+ begin
+ for Final_Prim in Name_Of'Range loop
+ if Name_Of (Final_Prim) = Nam then
+ Set_TSS (Typ,
+ Make_Deep_Proc (
+ Prim => Final_Prim,
+ Typ => Typ,
+ Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
+ end if;
+ 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 --
+ -----------------------------
+
+ procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
+ begin
+ Set_TSS (Typ,
+ Make_Deep_Proc (
+ Prim => Initialize_Case,
+ Typ => Typ,
+ Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
+
+ if not Is_Immutably_Limited_Type (Typ) then
+ Set_TSS (Typ,
+ Make_Deep_Proc (
+ Prim => Adjust_Case,
+ Typ => Typ,
+ Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
+ end if;
+
+ Set_TSS (Typ,
+ Make_Deep_Proc (
+ 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;
+
+ -------------------
+ -- Cleanup_Array --
+ -------------------
+
+ function Cleanup_Array
+ (N : Node_Id;
+ Obj : Node_Id;
+ Typ : Entity_Id) return List_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Index_List : constant List_Id := New_List;
+
+ function Free_Component return List_Id;
+ -- Generate the code to finalize the task or protected subcomponents
+ -- of a single component of the array.
+
+ function Free_One_Dimension (Dim : Int) return List_Id;
+ -- Generate a loop over one dimension of the array
+
+ --------------------
+ -- Free_Component --
+ --------------------
+
+ function Free_Component return List_Id is
+ Stmts : List_Id := New_List;
+ Tsk : Node_Id;
+ C_Typ : constant Entity_Id := Component_Type (Typ);
+
+ begin
+ -- Component type is known to contain tasks or protected objects
+
+ Tsk :=
+ Make_Indexed_Component (Loc,
+ Prefix => Duplicate_Subexpr_No_Checks (Obj),
+ Expressions => Index_List);
+
+ Set_Etype (Tsk, C_Typ);
+
+ if Is_Task_Type (C_Typ) then
+ Append_To (Stmts, Cleanup_Task (N, Tsk));
+
+ elsif Is_Simple_Protected_Type (C_Typ) then
+ Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
+
+ elsif Is_Record_Type (C_Typ) then
+ Stmts := Cleanup_Record (N, Tsk, C_Typ);
+
+ elsif Is_Array_Type (C_Typ) then
+ Stmts := Cleanup_Array (N, Tsk, C_Typ);
+ end if;
+
+ return Stmts;
+ end Free_Component;
+
+ ------------------------
+ -- Free_One_Dimension --
+ ------------------------
+
+ function Free_One_Dimension (Dim : Int) return List_Id is
+ Index : Entity_Id;
+
+ begin
+ if Dim > Number_Dimensions (Typ) then
+ return Free_Component;
+
+ -- Here we generate the required loop
+
+ else
+ Index := Make_Temporary (Loc, 'J');
+ Append (New_Reference_To (Index, Loc), Index_List);
+
+ return New_List (
+ Make_Implicit_Loop_Statement (N,
+ 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 => Duplicate_Subexpr (Obj),
+ Attribute_Name => Name_Range,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Dim))))),
+ Statements => Free_One_Dimension (Dim + 1)));
+ end if;
+ end Free_One_Dimension;
+
+ -- Start of processing for Cleanup_Array
+
+ begin
+ return Free_One_Dimension (1);
+ end Cleanup_Array;
+
+ --------------------
+ -- Cleanup_Record --
+ --------------------
+
+ function Cleanup_Record
+ (N : Node_Id;
+ Obj : Node_Id;
+ Typ : Entity_Id) return List_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Tsk : Node_Id;
+ Comp : Entity_Id;
+ Stmts : constant List_Id := New_List;
+ U_Typ : constant Entity_Id := Underlying_Type (Typ);
+
+ begin
+ if Has_Discriminants (U_Typ)
+ and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
+ and then
+ Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
+ and then
+ Present
+ (Variant_Part
+ (Component_List (Type_Definition (Parent (U_Typ)))))
+ then
+ -- For now, do not attempt to free a component that may appear in
+ -- a variant, and instead issue a warning. Doing this "properly"
+ -- would require building a case statement and would be quite a
+ -- mess. Note that the RM only requires that free "work" for the
+ -- case of a task access value, so already we go way beyond this
+ -- in that we deal with the array case and non-discriminated
+ -- record cases.
+
+ Error_Msg_N
+ ("task/protected object in variant record will not be freed?", N);
+ return New_List (Make_Null_Statement (Loc));
+ end if;
+
+ Comp := First_Component (Typ);
+
+ while Present (Comp) loop
+ if Has_Task (Etype (Comp))
+ or else Has_Simple_Protected_Object (Etype (Comp))
+ then
+ Tsk :=
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr_No_Checks (Obj),
+ Selector_Name => New_Occurrence_Of (Comp, Loc));
+ Set_Etype (Tsk, Etype (Comp));
+
+ if Is_Task_Type (Etype (Comp)) then
+ Append_To (Stmts, Cleanup_Task (N, Tsk));
+
+ elsif Is_Simple_Protected_Type (Etype (Comp)) then
+ Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
+
+ elsif Is_Record_Type (Etype (Comp)) then
+
+ -- Recurse, by generating the prefix of the argument to
+ -- the eventual cleanup call.
+
+ Append_List_To
+ (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
+
+ elsif Is_Array_Type (Etype (Comp)) then
+ Append_List_To
+ (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
+ end if;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ return Stmts;
+ end Cleanup_Record;
+
+ ------------------------------
+ -- Cleanup_Protected_Object --
+ ------------------------------
+
+ function Cleanup_Protected_Object
+ (N : Node_Id;
+ Ref : Node_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ begin
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Finalize_Protection), Loc),
+ Parameter_Associations =>
+ New_List (Concurrent_Ref (Ref)));
+ end Cleanup_Protected_Object;
+
+ ------------------
+ -- Cleanup_Task --
+ ------------------
+
+ function Cleanup_Task
+ (N : Node_Id;
+ Ref : Node_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ begin
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Free_Task), Loc),
+ Parameter_Associations =>
+ New_List (Concurrent_Ref (Ref)));
+ end Cleanup_Task;
+
+ ------------------------------
+ -- Check_Visibly_Controlled --
+ ------------------------------
+
+ procedure Check_Visibly_Controlled
+ (Prim : Final_Primitives;
+ Typ : Entity_Id;
+ E : in out Entity_Id;
+ Cref : in out Node_Id)
+ is
+ Parent_Type : Entity_Id;
+ Op : Entity_Id;
+
+ begin
+ if Is_Derived_Type (Typ)
+ and then Comes_From_Source (E)
+ and then not Present (Overridden_Operation (E))
+ then
+ -- We know that the explicit operation on the type does not override
+ -- the inherited operation of the parent, and that the derivation
+ -- is from a private type that is not visibly controlled.
+
+ Parent_Type := Etype (Typ);
+ Op := Find_Prim_Op (Parent_Type, Name_Of (Prim));
+
+ if Present (Op) then
+ E := Op;
+
+ -- Wrap the object to be initialized into the proper
+ -- unchecked conversion, to be compatible with the operation
+ -- to be called.
+
+ if Nkind (Cref) = N_Unchecked_Type_Conversion then
+ Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
+ else
+ Cref := Unchecked_Convert_To (Parent_Type, Cref);
+ end if;
+ end if;
+ end if;
+ end Check_Visibly_Controlled;
+
+ -------------------------------
+ -- CW_Or_Has_Controlled_Part --
+ -------------------------------
+
+ function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
+ begin
+ return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
+ end CW_Or_Has_Controlled_Part;
+
+ ------------------
+ -- Convert_View --
+ ------------------
+
+ function Convert_View
+ (Proc : Entity_Id;
+ Arg : Node_Id;
+ Ind : Pos := 1) return Node_Id
+ is
+ Fent : Entity_Id := First_Entity (Proc);
+ Ftyp : Entity_Id;
+ Atyp : Entity_Id;
+
+ begin
+ for J in 2 .. Ind loop
+ Next_Entity (Fent);
+ end loop;
+
+ Ftyp := Etype (Fent);
+
+ if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then
+ Atyp := Entity (Subtype_Mark (Arg));
+ else
+ Atyp := Etype (Arg);
+ end if;
+
+ if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
+ return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
+
+ elsif Ftyp /= Atyp
+ and then Present (Atyp)
+ and then
+ (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
+ and then
+ Base_Type (Underlying_Type (Atyp)) =
+ Base_Type (Underlying_Type (Ftyp))
+ then
+ return Unchecked_Convert_To (Ftyp, Arg);
+
+ -- If the argument is already a conversion, as generated by
+ -- Make_Init_Call, set the target type to the type of the formal
+ -- directly, to avoid spurious typing problems.
+
+ elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion)
+ and then not Is_Class_Wide_Type (Atyp)
+ then
+ Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
+ Set_Etype (Arg, Ftyp);
+ return Arg;
+
+ else
+ return Arg;
+ 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 --
+ -------------------------------
+
+ -- This procedure is called each time a transient block has to be inserted
+ -- that is to say for each call to a function with unconstrained or tagged
+ -- result. It creates a new scope on the stack scope in order to enclose
+ -- all transient variables generated
+
+ procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Wrap_Node : Node_Id;
+
+ begin
+ -- Nothing to do for virtual machines where memory is GCed
+
+ if VM_Target /= No_VM then
+ return;
+ end if;
+
+ -- Do not create a transient scope if we are already inside one
+
+ for S in reverse Scope_Stack.First .. Scope_Stack.Last loop
+ if Scope_Stack.Table (S).Is_Transient then
+ if Sec_Stack then
+ Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity);
+ end if;
+
+ return;
+
+ -- If we have encountered Standard there are no enclosing
+ -- transient scopes.
+
+ elsif Scope_Stack.Table (S).Entity = Standard_Standard then
+ exit;
+
+ end if;
+ end loop;
+
+ Wrap_Node := Find_Node_To_Be_Wrapped (N);
+
+ -- Case of no wrap node, false alert, no transient scope needed
+
+ if No (Wrap_Node) then
+ null;
+
+ -- If the node to wrap is an iteration_scheme, the expression is
+ -- one of the bounds, and the expansion will make an explicit
+ -- declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb),
+ -- so do not apply any transformations here.
+
+ elsif Nkind (Wrap_Node) = N_Iteration_Scheme then
+ null;
+
+ else
+ Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
+ Set_Scope_Is_Transient;
+
+ if Sec_Stack then
+ Set_Uses_Sec_Stack (Current_Scope);
+ Check_Restriction (No_Secondary_Stack, N);
+ end if;
+
+ Set_Etype (Current_Scope, Standard_Void_Type);
+ Set_Node_To_Be_Wrapped (Wrap_Node);
+
+ if Debug_Flag_W then
+ Write_Str (" <Transient>");
+ Write_Eol;
+ end if;
+ end if;
+ end Establish_Transient_Scope;
+
+ ----------------------------
+ -- Expand_Cleanup_Actions --
+ ----------------------------
+
+ procedure Expand_Cleanup_Actions (N : Node_Id) is
+ 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_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;
+ 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 (HSS);
+ 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_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 (Scop);
+ end if;
+ end Wrap_HSS_In_Block;
+
+ -- Start of processing for Expand_Cleanup_Actions
+
+ begin
+ -- The current construct does not need any form of servicing
+
+ if not Actions_Required then
+ return;
+
+ -- 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.
+
+ elsif Is_Task_Body
+ and then Nkind (N) = N_Subprogram_Body
+ and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N))
+ then
+ return;
+ end if;
+
+ declare
+ Decls : List_Id := Declarations (N);
+ Fin_Id : Entity_Id;
+ Mark : Entity_Id := Empty;
+ New_Decls : List_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 .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
+ Loc := No_Location;
+ end if;
+
+ -- Set polling off. The finalization and cleanup code is executed
+ -- with aborts deferred.
+
+ Old_Poll := Polling_Required;
+ Polling_Required := False;
+
+ -- A task activation call has already been built for a task
+ -- allocation block.
+
+ if not Is_Task_Allocation then
+ Build_Task_Activation_Call (N);
+ end if;
+
+ if Is_Master then
+ Establish_Task_Master (N);
+ end if;
+
+ New_Decls := New_List;
+
+ -- If secondary stack is in use, generate:
+ --
+ -- Mnn : constant Mark_Id := SS_Mark;
+
+ -- Suppress calls to SS_Mark and SS_Release if VM_Target, since the
+ -- secondary stack is never used on a VM.
+
+ if Needs_Sec_Stack_Mark 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 (Scop, False);
+ end if;
+
+ -- 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.
+
+ if Present (Exception_Handlers (HSS)) then
+ Wrap_HSS_In_Block;
+
+ -- Ensure that the First_Real_Statement field is set
+
+ elsif No (First_Real_Statement (HSS)) then
+ Set_First_Real_Statement (HSS, First (Statements (HSS)));
+ end if;
+
+ -- 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.
+
+ if Is_Task_Allocation then
+ declare
+ Chain : constant Entity_Id := Activation_Chain_Entity (N);
+ Decl : Node_Id;
+
+ begin
+ Decl := First (Decls);
+ while Nkind (Decl) /= N_Object_Declaration
+ or else Defining_Identifier (Decl) /= Chain
+ loop
+ Next (Decl);
+
+ -- A task allocation block should always include a _chain
+ -- declaration.
+
+ pragma Assert (Present (Decl));
+ end loop;
+
+ Remove (Decl);
+ Prepend_To (New_Decls, Decl);
+ end;
+ end if;
+
+ -- Ensure the presence of a declaration list in order to successfully
+ -- append all original statements to it.
+
+ if No (Decls) then
+ Set_Declarations (N, New_List);
+ Decls := Declarations (N);
+ end if;
+
+ -- 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.
+
+ Append_List_To (Decls, Statements (HSS));
+ Set_Statements (HSS, Decls);
+
+ -- Reset the Sloc of the handled statement sequence to properly
+ -- reflect the new initial "statement" in the sequence.
+
+ Set_Sloc (HSS, Sloc (First (Decls)));
+
+ -- The declarations of finalizer spec and auxiliary variables replace
+ -- the old declarations that have been moved inward.
+
+ Set_Declarations (N, New_Decls);
+ Analyze_Declarations (New_Decls);
+
+ -- Generate finalization calls for all controlled objects appearing
+ -- in the statements of N. Add context specific cleanup for various
+ -- constructs.
+
+ 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 Present (Fin_Id) then
+ Build_Finalizer_Call (N, Fin_Id);
+ end if;
+
+ -- Restore saved polling mode
+
+ Polling_Required := Old_Poll;
+ end;
+ end Expand_Cleanup_Actions;
+
+ ---------------------------
+ -- Expand_N_Package_Body --
+ ---------------------------
+
+ -- Add call to Activate_Tasks if body is an activator (actual processing
+ -- is in chapter 9).
+
+ -- Generate subprogram descriptor for elaboration routine
+
+ -- Encode entity names in package body
+
+ procedure Expand_N_Package_Body (N : Node_Id) is
+ Spec_Ent : constant Entity_Id := Corresponding_Spec (N);
+ Fin_Id : Entity_Id;
+
+ begin
+ -- This is done only for non-generic packages
+
+ 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 (Spec_Ent) then
+ if Tagged_Type_Expansion then
+ Build_Static_Dispatch_Tables (N);
+
+ -- In VM targets there is no need to build dispatch tables but
+ -- we must generate the corresponding Type Specific Data record.
+
+ elsif Unit (Cunit (Main_Unit)) = N then
+
+ -- If the runtime package Ada_Tags has not been loaded then
+ -- this package does not have tagged type declarations and
+ -- there is no need to search for tagged types to generate
+ -- their TSDs.
+
+ if RTU_Loaded (Ada_Tags) then
+ Build_VM_TSDs (N);
+ end if;
+ end if;
+ end if;
+
+ Build_Task_Activation_Call (N);
+ Pop_Scope;
+ end if;
+
+ Set_Elaboration_Flag (N, Corresponding_Spec (N));
+ 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;
+
+ ----------------------------------
+ -- Expand_N_Package_Declaration --
+ ----------------------------------
+
+ -- Add call to Activate_Tasks if there are tasks declared and the package
+ -- has no body. Note that in Ada83, this may result in premature activation
+ -- of some tasks, given that we cannot tell whether a body will eventually
+ -- appear.
+
+ procedure Expand_N_Package_Declaration (N : Node_Id) is
+ 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
+ -- this compilation.
+
+ begin
+ -- Case of a package declaration other than a compilation unit
+
+ if Nkind (Parent (N)) /= N_Compilation_Unit then
+ null;
+
+ -- Case of a compilation unit that does not require a body
+
+ elsif not Body_Required (Parent (N))
+ and then not Unit_Requires_Body (Id)
+ then
+ No_Body := True;
+
+ -- Special case of generating calling stubs for a remote call interface
+ -- package: even though the package declaration requires one, the
+ -- body won't be processed in this compilation (so any stubs for RACWs
+ -- declared in the package must be generated here, along with the
+ -- spec).
+
+ elsif Parent (N) = Cunit (Main_Unit)
+ and then Is_Remote_Call_Interface (Id)
+ and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
+ then
+ No_Body := True;
+ end if;
+
+ -- For a package declaration that implies no associated body, generate
+ -- task activation call and RACW supporting bodies now (since we won't
+ -- have a specific separate compilation unit for that).
+
+ if No_Body then
+ Push_Scope (Id);
+
+ if Has_RACW (Id) then
+
+ -- Generate RACW subprogram bodies
+
+ Decls := Private_Declarations (Spec);
+
+ if No (Decls) then
+ Decls := Visible_Declarations (Spec);
+ end if;
+
+ if No (Decls) then
+ Decls := New_List;
+ Set_Visible_Declarations (Spec, Decls);
+ end if;
+
+ Append_RACW_Bodies (Decls, Id);
+ Analyze_List (Decls);
+ end if;
+
+ if Present (Activation_Chain_Entity (N)) then
+
+ -- Generate task activation call as last step of elaboration
+
+ Build_Task_Activation_Call (N);
+ end if;
+
+ Pop_Scope;
+ end if;
+
+ -- Build dispatch tables of library level tagged types
+
+ if Is_Compilation_Unit (Id)
+ or else (Is_Generic_Instance (Id)
+ and then Is_Library_Level_Entity (Id))
+ then
+ if Tagged_Type_Expansion then
+ Build_Static_Dispatch_Tables (N);
+
+ -- In VM targets there is no need to build dispatch tables, but we
+ -- must generate the corresponding Type Specific Data record.
+
+ elsif Unit (Cunit (Main_Unit)) = N then
+
+ -- If the runtime package Ada_Tags has not been loaded then
+ -- this package does not have tagged types and there is no need
+ -- to search for tagged types to generate their TSDs.
+
+ if RTU_Loaded (Ada_Tags) then
+
+ -- Enter the scope of the package because the new declarations
+ -- are appended at the end of the package and must be analyzed
+ -- in that context.
+
+ Push_Scope (Id);
+
+ if Is_Generic_Instance (Main_Unit_Entity) then
+ if Package_Instantiation (Main_Unit_Entity) = N then
+ Build_VM_TSDs (N);
+ end if;
+
+ else
+ Build_VM_TSDs (N);
+ end if;
+
+ Pop_Scope;
+ end if;
+ end if;
+ end if;
+
+ -- Note: it is not necessary to worry about generating a subprogram
+ -- descriptor, since the only way to get exception handlers into a
+ -- package spec is to include instantiations, and that would cause
+ -- generation of subprogram descriptors to be delayed in any case.
+
+ -- Set to encode entity names in package spec before gigi is called
+
+ Qualify_Entity_Names (N);
+
+ 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);
+
+ Set_Finalizer (Id, Fin_Id);
+ end if;
+ end Expand_N_Package_Declaration;
+
+ -----------------------------
+ -- Find_Node_To_Be_Wrapped --
+ -----------------------------
+
+ function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is
+ P : Node_Id;
+ The_Parent : Node_Id;
+
+ begin
+ The_Parent := N;
+ loop
+ P := The_Parent;
+ pragma Assert (P /= Empty);
+ The_Parent := Parent (P);
+
+ case Nkind (The_Parent) is
+
+ -- Simple statement can be wrapped
+
+ when N_Pragma =>
+ return The_Parent;
+
+ -- Usually assignments are good candidate for wrapping
+ -- except when they have been generated as part of a
+ -- controlled aggregate where the wrapping should take
+ -- place more globally.
+
+ when N_Assignment_Statement =>
+ if No_Ctrl_Actions (The_Parent) then
+ null;
+ else
+ return The_Parent;
+ end if;
+
+ -- An entry call statement is a special case if it occurs in
+ -- the context of a Timed_Entry_Call. In this case we wrap
+ -- the entire timed entry call.
+
+ when N_Entry_Call_Statement |
+ N_Procedure_Call_Statement =>
+ if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative
+ and then Nkind_In (Parent (Parent (The_Parent)),
+ N_Timed_Entry_Call,
+ N_Conditional_Entry_Call)
+ then
+ return Parent (Parent (The_Parent));
+ else
+ return The_Parent;
+ end if;
+
+ -- Object declarations are also a boundary for the transient scope
+ -- even if they are not really wrapped
+ -- (see Wrap_Transient_Declaration)
+
+ when N_Object_Declaration |
+ N_Object_Renaming_Declaration |
+ N_Subtype_Declaration =>
+ return The_Parent;
+
+ -- The expression itself is to be wrapped if its parent is a
+ -- compound statement or any other statement where the expression
+ -- is known to be scalar
+
+ when N_Accept_Alternative |
+ N_Attribute_Definition_Clause |
+ N_Case_Statement |
+ N_Code_Statement |
+ N_Delay_Alternative |
+ N_Delay_Until_Statement |
+ N_Delay_Relative_Statement |
+ N_Discriminant_Association |
+ N_Elsif_Part |
+ N_Entry_Body_Formal_Part |
+ N_Exit_Statement |
+ N_If_Statement |
+ N_Iteration_Scheme |
+ N_Terminate_Alternative =>
+ return P;
- -- 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.
+ when N_Attribute_Reference =>
- Set_At_End_Proc (Handled_Statement_Sequence (N), Empty);
+ if Is_Procedure_Attribute_Name
+ (Attribute_Name (The_Parent))
+ then
+ return The_Parent;
+ end if;
- -- 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.
+ -- A raise statement can be wrapped. This will arise when the
+ -- expression in a raise_with_expression uses the secondary
+ -- stack, for example.
- if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
+ when N_Raise_Statement =>
+ return The_Parent;
- -- Preserve end label to provide proper cross-reference information
+ -- If the expression is within the iteration scheme of a loop,
+ -- we must create a declaration for it, followed by an assignment
+ -- in order to have a usable statement to wrap.
- End_Lab := End_Label (Handled_Statement_Sequence (N));
- Blok :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence => Handled_Statement_Sequence (N));
- 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;
+ when N_Loop_Parameter_Specification =>
+ return Parent (The_Parent);
- -- Comment needed here, see RH for 1.306 ???
+ -- The following nodes contains "dummy calls" which don't
+ -- need to be wrapped.
- if Nkind (N) = N_Subprogram_Body then
- Set_Has_Nested_Block_With_Handler (Current_Scope);
- end if;
+ when N_Parameter_Specification |
+ N_Discriminant_Specification |
+ N_Component_Declaration =>
+ return Empty;
- -- Otherwise we do not wrap
+ -- The return statement is not to be wrapped when the function
+ -- itself needs wrapping at the outer-level
- else
- Wrapped := False;
- Blok := Empty;
- end if;
+ when N_Simple_Return_Statement =>
+ declare
+ Applies_To : constant Entity_Id :=
+ Return_Applies_To
+ (Return_Statement_Entity (The_Parent));
+ Return_Type : constant Entity_Id := Etype (Applies_To);
+ begin
+ if Requires_Transient_Scope (Return_Type) then
+ return Empty;
+ else
+ return The_Parent;
+ end if;
+ end;
- -- 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 we leave a scope without having been able to find a node to
+ -- wrap, something is going wrong but this can happen in error
+ -- situation that are not detected yet (such as a dynamic string
+ -- in a pragma export)
- if Is_Task_Allocation then
- Chain := Activation_Chain_Entity (N);
+ when N_Subprogram_Body |
+ N_Package_Declaration |
+ N_Package_Body |
+ N_Block_Statement =>
+ return Empty;
- 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;
+ -- otherwise continue the search
- Remove (Decl);
- Prepend_To (New_Decls, Decl);
- end if;
+ when others =>
+ null;
+ end case;
+ end loop;
+ end Find_Node_To_Be_Wrapped;
- -- 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.
+ ----------------------------------
+ -- Has_New_Controlled_Component --
+ ----------------------------------
- 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;
+ function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
+ Comp : Entity_Id;
- else
- Set_First_Real_Statement (Handled_Statement_Sequence (N), Blok);
+ begin
+ if not Is_Tagged_Type (E) then
+ return Has_Controlled_Component (E);
+ elsif not Is_Derived_Type (E) then
+ return Has_Controlled_Component (E);
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.
+ Comp := First_Component (E);
+ while Present (Comp) loop
- Set_Declarations (N, New_Decls);
- Analyze_Declarations (New_Decls);
+ if Chars (Comp) = Name_uParent then
+ null;
- -- The At_End call is attached to the sequence of statements
+ elsif Scope (Original_Record_Component (Comp)) = E
+ and then Needs_Finalization (Etype (Comp))
+ then
+ return True;
+ end if;
- declare
- HSS : Node_Id;
+ Next_Component (Comp);
+ end loop;
- 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.
+ return False;
+ end Has_New_Controlled_Component;
- if Is_Protected then
- HSS := Handled_Statement_Sequence
- (Last (Statements (Handled_Statement_Sequence (N))));
- else
- HSS := Handled_Statement_Sequence (N);
- end if;
+ ---------------------------------
+ -- Has_Simple_Protected_Object --
+ ---------------------------------
- -- Never overwrite an existing AT END call
+ function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
+ begin
+ if Has_Task (T) then
+ return False;
- pragma Assert (No (At_End_Proc (HSS)));
+ elsif Is_Simple_Protected_Type (T) then
+ return True;
- Set_At_End_Proc (HSS, New_Occurrence_Of (Clean, Loc));
- Expand_At_End_Handler (HSS, Empty);
- end;
+ elsif Is_Array_Type (T) then
+ return Has_Simple_Protected_Object (Component_Type (T));
- -- Restore saved polling mode
+ elsif Is_Record_Type (T) then
+ declare
+ Comp : Entity_Id;
- Polling_Required := Old_Poll;
- end Expand_Cleanup_Actions;
+ begin
+ Comp := First_Component (T);
- -------------------------------
- -- Expand_Ctrl_Function_Call --
- -------------------------------
+ while Present (Comp) loop
+ if Has_Simple_Protected_Object (Etype (Comp)) then
+ return True;
+ end if;
- 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;
+ Next_Component (Comp);
+ end loop;
- Attach_Level : Uint := Uint_1;
- Len_Ref : Node_Id := Empty;
+ return False;
+ end;
- 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.
+ else
+ return False;
+ end if;
+ end Has_Simple_Protected_Object;
- --------------------------
- -- Last_Array_Component --
- --------------------------
+ ------------------------------------
+ -- Insert_Actions_In_Scope_Around --
+ ------------------------------------
- function Last_Array_Component
- (Ref : Node_Id;
- Typ : Entity_Id) return Node_Id
+ procedure Insert_Actions_In_Scope_Around (N : Node_Id) is
+ SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
+ 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
- Index_List : constant List_Id := New_List;
+ 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
- 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;
+ -- Examine all objects in the list First_Object .. Last_Object
- return
- Make_Indexed_Component (Loc,
- Prefix => Duplicate_Subexpr (Ref),
- Expressions => Index_List);
- end Last_Array_Component;
-
- -- Start of processing for Expand_Ctrl_Function_Call
-
- 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
+ Stmt := First_Object;
+ while Present (Stmt) loop
+ if Nkind (Stmt) = N_Object_Declaration
+ and then Analyzed (Stmt)
+ and then Is_Finalizable_Transient (Stmt, N)
- if Nkind (Parent (N)) = N_Simple_Return_Statement then
- return;
- end if;
+ -- Do not process the node to be wrapped since it will be
+ -- handled by the enclosing finalizer.
- -- Resolution is now finished, make sure we don't start analysis again
- -- because of the duplication.
+ 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_Analyzed (N);
- Ref := Duplicate_Subexpr_No_Checks (N);
+ Set_Is_Processed_Transient (Obj_Id);
- -- 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:
+ -- Handle access types
- -- Resx := F (X)'reference;
- -- Attach_To_Final_List (_Lx, Resx.all, 1);
+ if Is_Access_Type (Desig) then
+ Desig := Available_View (Designated_Type (Desig));
+ end if;
- -- or when there are controlled components:
+ -- Create the necessary entities and declarations the first
+ -- time around.
- -- Attach_To_Final_List (_Lx, Resx._controller, 1);
+ if not Built then
- -- or when it is both Is_Controlled and Has_Controlled_Components:
+ -- Generate:
+ -- Enn : Exception_Occurrence;
- -- Attach_To_Final_List (_Lx, Resx._controller, 1);
- -- Attach_To_Final_List (_Lx, Resx, 1);
+ E_Id := Make_Temporary (Loc, 'E');
- -- or if it is an array with Is_Controlled (and Has_Controlled)
+ 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);
- -- Attach_To_Final_List (_Lx, Resx (Resx'last), 3);
+ -- Generate:
+ -- Rnn : Boolean := False;
- -- An attach level of 3 means that a whole array is to be attached to
- -- the finalization list (including the controlled components).
+ Raised_Id := Make_Temporary (Loc, 'R');
- -- or if it is an array with Has_Controlled_Components but not
- -- Is_Controlled:
+ 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)));
- -- Attach_To_Final_List (_Lx, Resx (Resx'last)._controller, 3);
+ Built := True;
+ end if;
- -- Case where type has controlled components
+ -- Generate:
+ -- begin
+ -- [Deep_]Finalize (Obj_Ref);
- if Has_Controlled_Component (Rtype) then
- declare
- T1 : Entity_Id := Rtype;
- T2 : Entity_Id := Utype;
+ -- exception
+ -- when others =>
+ -- if not Rnn then
+ -- Rnn := True;
+ -- Save_Occurrence
+ -- (Enn, Get_Current_Excep.all.all);
+ -- end if;
+ -- end;
- 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;
+ Obj_Ref := New_Reference_To (Obj_Id, Loc);
- while Is_Array_Type (T2) loop
- if T1 /= T2 then
- Ref := Unchecked_Convert_To (T2, Ref);
+ if Is_Access_Type (Obj_Typ) then
+ Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
end if;
- Ref := Last_Array_Component (Ref, T2);
- Attach_Level := Uint_3;
- T1 := Component_Type (T2);
- T2 := Underlying_Type (T1);
- end loop;
+ 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)),
- -- 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.
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Loc, E_Id, Raised_Id))));
+ Insert_After_And_Analyze (Last_Object, Fin_Block);
- if Is_Array_Type (Rtype) and then Is_Controlled (T2) then
- null;
+ -- The raise statement must be inserted after all the
+ -- finalization blocks.
- elsif Has_Controlled_Component (T2) then
- if T1 /= T2 then
- Ref := Unchecked_Convert_To (T2, Ref);
+ if No (Last_Fin) then
+ Last_Fin := Fin_Block;
end if;
- Ref :=
- Make_Selected_Component (Loc,
- Prefix => Ref,
- Selector_Name => Make_Identifier (Loc, Name_uController));
- end if;
- end;
-
- -- Here we know that 'Ref' has a controller so we may as well attach
- -- it directly.
-
- Action :=
- Make_Attach_Call (
- Obj_Ref => Ref,
- Flist_Ref => Find_Final_List (Current_Scope),
- With_Attach => Make_Integer_Literal (Loc, Attach_Level));
+ -- When the associated node is an array object, the expander may
+ -- sometimes generate a loop and create transient objects inside
+ -- the loop.
- -- If it is also Is_Controlled we need to attach the global object
+ elsif Nkind (Stmt) = N_Loop_Statement then
+ Process_Transient_Objects
+ (First_Object => First (Statements (Stmt)),
+ Last_Object => Last (Statements (Stmt)),
+ Related_Node => Related_Node);
- 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));
- end if;
+ -- Terminate the scan after the last object has been processed
- -- 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.
+ elsif Stmt = Last_Object then
+ exit;
+ end if;
- 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),
+ Next (Stmt);
+ end loop;
- Make_Attribute_Reference (Loc,
- Prefix => Ref,
- Attribute_Name => Name_Address),
+ -- Generate:
+ -- if Rnn then
+ -- Raise_From_Controlled_Operation (Enn);
+ -- end if;
- Make_Integer_Literal (Loc, Attach_Level)));
- 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;
- 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;
+ -- Start of processing for Insert_Actions_In_Scope_Around
- Insert_Action (N, Action);
- if Present (Action2) then
- Insert_Action (N, Action2);
+ begin
+ if No (Before) and then No (After) then
+ return;
end if;
- end Expand_Ctrl_Function_Call;
-
- ---------------------------
- -- Expand_N_Package_Body --
- ---------------------------
- -- Add call to Activate_Tasks if body is an activator (actual processing
- -- is in chapter 9).
-
- -- Generate subprogram descriptor for elaboration routine
-
- -- Encode entity names in package body
-
- procedure Expand_N_Package_Body (N : Node_Id) is
- Ent : constant Entity_Id := Corresponding_Spec (N);
-
- begin
- -- This is done only for non-generic packages
+ declare
+ Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped;
+ First_Obj : Node_Id;
+ Last_Obj : Node_Id;
+ Target : Node_Id;
- if Ekind (Ent) = E_Package then
- Push_Scope (Corresponding_Spec (N));
+ 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;
- -- Build dispatch tables of library level tagged types
+ First_Obj := Target;
+ Last_Obj := Target;
- if Is_Library_Level_Entity (Ent) then
- if Tagged_Type_Expansion then
- Build_Static_Dispatch_Tables (N);
+ -- 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
- -- In VM targets there is no need to build dispatch tables but
- -- we must generate the corresponding Type Specific Data record.
+ if Present (Before) then
- elsif Unit (Cunit (Main_Unit)) = N then
+ -- Flag declarations are inserted before the first object
- -- If the runtime package Ada_Tags has not been loaded then
- -- this package does not have tagged type declarations and
- -- there is no need to search for tagged types to generate
- -- their TSDs.
+ First_Obj := First (Before);
- if RTU_Loaded (Ada_Tags) then
- Build_VM_TSDs (N);
- end if;
- end if;
+ Insert_List_Before (Target, Before);
end if;
- Build_Task_Activation_Call (N);
- Pop_Scope;
- end if;
-
- Set_Elaboration_Flag (N, Corresponding_Spec (N));
- Set_In_Package_Body (Ent, False);
-
- -- Set to encode entity names in package body before gigi is called
-
- Qualify_Entity_Names (N);
- end Expand_N_Package_Body;
-
- ----------------------------------
- -- Expand_N_Package_Declaration --
- ----------------------------------
+ if Present (After) then
- -- Add call to Activate_Tasks if there are tasks declared and the package
- -- has no body. Note that in Ada83, this may result in premature activation
- -- of some tasks, given that we cannot tell whether a body will eventually
- -- appear.
+ -- Finalization calls are inserted after the last object
- procedure Expand_N_Package_Declaration (N : Node_Id) is
- Spec : constant Node_Id := Specification (N);
- Id : constant Entity_Id := Defining_Entity (N);
- Decls : List_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
- -- this compilation.
+ Last_Obj := Last (After);
- begin
- -- Case of a package declaration other than a compilation unit
+ Insert_List_After (Target, After);
+ end if;
- if Nkind (Parent (N)) /= N_Compilation_Unit then
- null;
+ -- Check for transient controlled objects associated with Target and
+ -- generate the appropriate finalization actions for them.
- -- Case of a compilation unit that does not require a body
+ Process_Transient_Objects
+ (First_Object => First_Obj,
+ Last_Object => Last_Obj,
+ Related_Node => Target);
- elsif not Body_Required (Parent (N))
- and then not Unit_Requires_Body (Id)
- then
- No_Body := True;
+ -- Reset the action lists
- -- Special case of generating calling stubs for a remote call interface
- -- package: even though the package declaration requires one, the
- -- body won't be processed in this compilation (so any stubs for RACWs
- -- declared in the package must be generated here, along with the
- -- spec).
+ if Present (Before) then
+ Before := No_List;
+ end if;
- elsif Parent (N) = Cunit (Main_Unit)
- and then Is_Remote_Call_Interface (Id)
- and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
- then
- No_Body := True;
- end if;
+ if Present (After) then
+ After := No_List;
+ end if;
+ end;
+ end Insert_Actions_In_Scope_Around;
- -- For a package declaration that implies no associated body, generate
- -- task activation call and RACW supporting bodies now (since we won't
- -- have a specific separate compilation unit for that).
+ ------------------------------
+ -- Is_Simple_Protected_Type --
+ ------------------------------
- if No_Body then
- Push_Scope (Id);
+ 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;
- if Has_RACW (Id) then
+ -----------------------
+ -- Make_Adjust_Call --
+ -----------------------
- -- Generate RACW subprogram bodies
+ function Make_Adjust_Call
+ (Obj_Ref : Node_Id;
+ Typ : Entity_Id;
+ For_Parent : Boolean := False) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Obj_Ref);
+ Adj_Id : Entity_Id := Empty;
+ Ref : Node_Id := Obj_Ref;
+ Utyp : Entity_Id;
- Decls := Private_Declarations (Spec);
+ begin
+ -- Recover the proper type which contains Deep_Adjust
- if No (Decls) then
- Decls := Visible_Declarations (Spec);
- end if;
+ if Is_Class_Wide_Type (Typ) then
+ Utyp := Root_Type (Typ);
+ else
+ Utyp := Typ;
+ end if;
- if No (Decls) then
- Decls := New_List;
- Set_Visible_Declarations (Spec, Decls);
- end if;
+ Utyp := Underlying_Type (Base_Type (Utyp));
+ Set_Assignment_OK (Ref);
- Append_RACW_Bodies (Decls, Id);
- Analyze_List (Decls);
- end if;
+ -- Deal with non-tagged derivation of private views
- if Present (Activation_Chain_Entity (N)) then
+ if Is_Untagged_Derivation (Typ) then
+ Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
+ Ref := Unchecked_Convert_To (Utyp, Ref);
+ Set_Assignment_OK (Ref);
+ end if;
- -- Generate task activation call as last step of elaboration
+ -- When dealing with the completion of a private type, use the base
+ -- type instead.
- Build_Task_Activation_Call (N);
- end if;
+ if Utyp /= Base_Type (Utyp) then
+ pragma Assert (Is_Private_Type (Typ));
- Pop_Scope;
+ Utyp := Base_Type (Utyp);
+ Ref := Unchecked_Convert_To (Utyp, Ref);
end if;
- -- Build dispatch tables of library level tagged types
+ -- Select the appropriate version of adjust
- if Is_Compilation_Unit (Id)
- or else (Is_Generic_Instance (Id)
- and then Is_Library_Level_Entity (Id))
- then
- if Tagged_Type_Expansion then
- Build_Static_Dispatch_Tables (N);
+ if For_Parent then
+ if Has_Controlled_Component (Utyp) then
+ Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
+ end if;
- -- In VM targets there is no need to build dispatch tables, but we
- -- must generate the corresponding Type Specific Data record.
+ -- For types that are both controlled and have controlled components,
+ -- generate a call to Deep_Adjust.
- elsif Unit (Cunit (Main_Unit)) = N then
+ elsif Is_Controlled (Utyp)
+ and then Has_Controlled_Component (Utyp)
+ then
+ Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
- -- If the runtime package Ada_Tags has not been loaded then
- -- this package does not have tagged types and there is no need
- -- to search for tagged types to generate their TSDs.
+ -- 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.
- if RTU_Loaded (Ada_Tags) then
+ elsif Is_Class_Wide_Type (Typ)
+ or else Has_Controlled_Component (Utyp)
+ then
+ if Is_Tagged_Type (Utyp) then
+ Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
+ else
+ Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
+ end if;
- -- Enter the scope of the package because the new declarations
- -- are appended at the end of the package and must be analyzed
- -- in that context.
+ -- For types that are derived from Controlled and do not have controlled
+ -- components, build a call to Adjust.
- Push_Scope (Id);
+ else
+ Adj_Id := Find_Prim_Op (Utyp, Name_Of (Adjust_Case));
+ end if;
- if Is_Generic_Instance (Main_Unit_Entity) then
- if Package_Instantiation (Main_Unit_Entity) = N then
- Build_VM_TSDs (N);
- end if;
+ if Present (Adj_Id) then
- else
- Build_VM_TSDs (N);
- end if;
+ -- If the object is unanalyzed, set its expected type for use in
+ -- Convert_View in case an additional conversion is needed.
- Pop_Scope;
- end if;
+ if No (Etype (Ref))
+ and then Nkind (Ref) /= N_Unchecked_Type_Conversion
+ then
+ Set_Etype (Ref, Typ);
end if;
- end if;
- -- Note: it is not necessary to worry about generating a subprogram
- -- descriptor, since the only way to get exception handlers into a
- -- package spec is to include instantiations, and that would cause
- -- generation of subprogram descriptors to be delayed in any case.
+ -- The object reference may need another conversion depending on the
+ -- type of the formal and that of the actual.
- -- Set to encode entity names in package spec before gigi is called
+ if not Is_Class_Wide_Type (Typ) then
+ Ref := Convert_View (Adj_Id, Ref);
+ end if;
- Qualify_Entity_Names (N);
- end Expand_N_Package_Declaration;
+ return Make_Call (Loc, Adj_Id, New_Copy_Tree (Ref), For_Parent);
+ else
+ return Empty;
+ end if;
+ end Make_Adjust_Call;
- ---------------------
- -- Find_Final_List --
- ---------------------
+ ---------------
+ -- Make_Call --
+ ---------------
- function Find_Final_List
- (E : Entity_Id;
- Ref : Node_Id := Empty) 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 (Ref);
- S : Entity_Id;
- Id : Entity_Id;
- R : Node_Id;
+ Params : constant List_Id := New_List (Param);
begin
- -- If the restriction No_Finalization applies, then there isn't a
- -- finalization list available to return, so return Empty.
+ -- 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 Restriction_Active (No_Finalization) then
- return Empty;
+ if For_Parent then
+ Append_To (Params, New_Reference_To (Standard_False, Loc));
+ end if;
- -- Case of an internal component. The Final list is the record
- -- controller of the enclosing record.
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (Proc_Id, Loc),
+ Parameter_Associations => Params);
+ end Make_Call;
- elsif Present (Ref) then
- R := Ref;
- loop
- case Nkind (R) is
- when N_Unchecked_Type_Conversion | N_Type_Conversion =>
- R := Expression (R);
+ --------------------------
+ -- Make_Deep_Array_Body --
+ --------------------------
- when N_Indexed_Component | N_Explicit_Dereference =>
- R := Prefix (R);
+ 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
- when N_Selected_Component =>
- R := Prefix (R);
- exit;
+ 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;
- when N_Identifier =>
- exit;
+ -- Start of processing for Build_Adjust_Or_Finalize_Statements
- when others =>
- raise Program_Error;
- end case;
- end loop;
+ begin
+ Build_Indices;
- 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));
+ if Exceptions_OK then
+ E_Id := Make_Temporary (Loc, 'E');
+ Raised_Id := Make_Temporary (Loc, 'R');
+ end if;
- -- Use the access type's associated finalization chain
+ 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);
- 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;
+ -- Generate:
+ -- [Deep_]Adjust (V (J1, ..., JN))
- else
- S := Nearest_Dynamic_Scope (E);
+ if Prim = Adjust_Case then
+ Call :=
+ Make_Adjust_Call (
+ Obj_Ref => Comp_Ref,
+ Typ => Comp_Typ);
- -- 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.
+ -- Generate:
+ -- [Deep_]Finalize (V (J1, ..., JN))
- -- This is a nasty kludge, see ??? note in exp_ch11
+ else pragma Assert (Prim = Finalize_Case);
+ Call :=
+ Make_Final_Call (
+ Obj_Ref => Comp_Ref,
+ Typ => Comp_Typ);
+ end if;
- while Finalization_Chain_Entity (S) = Error loop
- S := Enclosing_Dynamic_Scope (S);
- end loop;
+ -- Generate the block which houses the adjust or finalize call:
- if S = Standard_Standard then
- return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E));
- else
- if No (Finalization_Chain_Entity (S)) then
+ -- <adjust or finalize call>; -- No_Exception_Propagation
- -- 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.
+ -- begin -- Exception handlers allowed
+ -- <adjust or finalize call>
- declare
- Flist_Loc : Source_Ptr := Sloc (S);
- Subp_Body : Node_Id;
+ -- exception
+ -- when others =>
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence (E, Get_Current_Excep.all.all);
+ -- end if;
+ -- end;
- begin
- if Ekind (S) in Subprogram_Kind then
- Subp_Body := Unit_Declaration_Node (S);
+ if Exceptions_OK then
+ Core_Loop :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Call),
- if Nkind (Subp_Body) /= N_Subprogram_Body then
- Subp_Body := Corresponding_Body (Subp_Body);
- end if;
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Loc, E_Id, Raised_Id))));
+ else
+ Core_Loop := Call;
+ end if;
- if Present (Subp_Body) then
- Flist_Loc := Sloc (Subp_Body);
- end if;
- end if;
+ -- Generate the dimension loops starting from the innermost one
- Id := Make_Temporary (Flist_Loc, 'F');
- end;
+ -- for Jnn in [reverse] V'Range (Dim) loop
+ -- <core loop>
+ -- end loop;
- Set_Finalization_Chain_Entity (S, Id);
+ J := Last (Index_List);
+ Dim := Num_Dims;
+ while Present (J)
+ and then Dim > 0
+ loop
+ Loop_Id := J;
+ Prev (J);
+ Remove (Loop_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.
+ 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))),
- Set_Ekind (Id, E_Variable);
- Set_Etype (Id, RTE (RE_Finalizable_Ptr));
- end if;
+ Reverse_Present => Prim = Finalize_Case)),
- return New_Reference_To (Finalization_Chain_Entity (S), Sloc (E));
- end if;
- end if;
- end Find_Final_List;
+ Statements => New_List (Core_Loop),
+ End_Label => Empty);
- -----------------------------
- -- Find_Node_To_Be_Wrapped --
- -----------------------------
+ Dim := Dim - 1;
+ end loop;
- function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is
- P : Node_Id;
- The_Parent : Node_Id;
+ -- Generate the block which contains the core loop, the declarations
+ -- of the flag and exception occurrence and the conditional raise:
- begin
- The_Parent := N;
- loop
- P := The_Parent;
- pragma Assert (P /= Empty);
- The_Parent := Parent (P);
+ -- declare
+ -- E : Exception_Occurrence;
+ -- Raised : Boolean := False;
- case Nkind (The_Parent) is
+ -- begin
+ -- <core loop>
- -- Simple statement can be wrapped
+ -- if Raised then -- Expection handlers allowed
+ -- Raise_From_Controlled_Operation (E);
+ -- end if;
+ -- end;
- when N_Pragma =>
- return The_Parent;
+ Stmts := New_List (Core_Loop);
- -- Usually assignments are good candidate for wrapping
- -- except when they have been generated as part of a
- -- controlled aggregate where the wrapping should take
- -- place more globally.
+ if Exceptions_OK then
+ Append_To (Stmts, Build_Raise_Statement (Loc, E_Id, Raised_Id));
+ end if;
- when N_Assignment_Statement =>
- if No_Ctrl_Actions (The_Parent) then
- null;
- else
- return The_Parent;
- 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 => 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;
- -- An entry call statement is a special case if it occurs in
- -- the context of a Timed_Entry_Call. In this case we wrap
- -- the entire timed entry call.
+ begin
+ -- Start from the first dimension and generate:
+ -- V'Length (1)
- when N_Entry_Call_Statement |
- N_Procedure_Call_Statement =>
- if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative
- and then Nkind_In (Parent (Parent (The_Parent)),
- N_Timed_Entry_Call,
- N_Conditional_Entry_Call)
- then
- return Parent (Parent (The_Parent));
- else
- return The_Parent;
- end if;
+ 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;
- -- Object declarations are also a boundary for the transient scope
- -- even if they are not really wrapped
- -- (see Wrap_Transient_Declaration)
+ -- Generate:
+ -- Counter := Expr - Counter;
- when N_Object_Declaration |
- N_Object_Renaming_Declaration |
- N_Subtype_Declaration =>
- return The_Parent;
+ 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));
- -- The expression itself is to be wrapped if its parent is a
- -- compound statement or any other statement where the expression
- -- is known to be scalar
+ begin
+ Set_Etype (Comp_Ref, Comp_Typ);
- when N_Accept_Alternative |
- N_Attribute_Definition_Clause |
- N_Case_Statement |
- N_Code_Statement |
- N_Delay_Alternative |
- N_Delay_Until_Statement |
- N_Delay_Relative_Statement |
- N_Discriminant_Association |
- N_Elsif_Part |
- N_Entry_Body_Formal_Part |
- N_Exit_Statement |
- N_If_Statement |
- N_Iteration_Scheme |
- N_Terminate_Alternative =>
- return P;
+ -- Generate:
+ -- [Deep_]Finalize (V);
- when N_Attribute_Reference =>
+ return
+ Make_Final_Call (
+ Obj_Ref => Comp_Ref,
+ Typ => Comp_Typ);
+ end Build_Finalization_Call;
- if Is_Procedure_Attribute_Name
- (Attribute_Name (The_Parent))
- then
- return The_Parent;
- end if;
+ -------------------
+ -- Build_Indices --
+ -------------------
- -- A raise statement can be wrapped. This will arise when the
- -- expression in a raise_with_expression uses the secondary
- -- stack, for example.
+ procedure Build_Indices is
+ begin
+ -- Generate the following identifiers:
+ -- Jnn - for initialization
+ -- Fnn - for finalization
- when N_Raise_Statement =>
- return The_Parent;
+ for Dim in 1 .. Num_Dims loop
+ Append_To (Index_List,
+ Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
- -- If the expression is within the iteration scheme of a loop,
- -- we must create a declaration for it, followed by an assignment
- -- in order to have a usable statement to wrap.
+ Append_To (Final_List,
+ Make_Defining_Identifier (Loc, New_External_Name ('F', Dim)));
+ end loop;
+ end Build_Indices;
- when N_Loop_Parameter_Specification =>
- return Parent (The_Parent);
+ -------------------------------
+ -- Build_Initialization_Call --
+ -------------------------------
- -- The following nodes contains "dummy calls" which don't
- -- need to be wrapped.
+ 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));
- when N_Parameter_Specification |
- N_Discriminant_Specification |
- N_Component_Declaration =>
- return Empty;
+ begin
+ Set_Etype (Comp_Ref, Comp_Typ);
+
+ -- Generate:
+ -- [Deep_]Initialize (V (J1, ..., JN));
- -- The return statement is not to be wrapped when the function
- -- itself needs wrapping at the outer-level
+ return
+ Make_Init_Call (
+ Obj_Ref => Comp_Ref,
+ Typ => Comp_Typ);
+ end Build_Initialization_Call;
- when N_Simple_Return_Statement =>
- declare
- Applies_To : constant Entity_Id :=
- Return_Applies_To
- (Return_Statement_Entity (The_Parent));
- Return_Type : constant Entity_Id := Etype (Applies_To);
- begin
- if Requires_Transient_Scope (Return_Type) then
- return Empty;
- else
- return The_Parent;
- end if;
- end;
+ -- Start of processing for Build_Initialize_Statements
- -- If we leave a scope without having been able to find a node to
- -- wrap, something is going wrong but this can happen in error
- -- situation that are not detected yet (such as a dynamic string
- -- in a pragma export)
+ begin
+ Build_Indices;
- when N_Subprogram_Body |
- N_Package_Declaration |
- N_Package_Body |
- N_Block_Statement =>
- return Empty;
+ Counter_Id := Make_Temporary (Loc, 'C');
- -- otherwise continue the search
+ if Exceptions_OK then
+ E_Id := Make_Temporary (Loc, 'E');
+ Raised_Id := Make_Temporary (Loc, 'R');
+ end if;
- when others =>
- null;
- end case;
- end loop;
- end Find_Node_To_Be_Wrapped;
+ -- 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
+ Fin_Stmt := Build_Finalization_Call;
+ end if;
- ----------------------
- -- Global_Flist_Ref --
- ----------------------
+ -- This is the core of the loop, the dimension iterators are added
+ -- one by one in reverse.
- function Global_Flist_Ref (Flist_Ref : Node_Id) return Boolean is
- Flist : Entity_Id;
+ 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);
- begin
- -- Look for the Global_Final_List
+ 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))),
- if Is_Entity_Name (Flist_Ref) then
- Flist := Entity (Flist_Ref);
+ Reverse_Present => True)),
- -- Look for the final list associated with an access to controlled
+ Statements => New_List (Final_Loop),
+ End_Label => Empty);
- 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;
+ Dim := Dim - 1;
+ end loop;
- return Present (Flist)
- and then Present (Scope (Flist))
- and then Enclosing_Dynamic_Scope (Flist) = Standard_Standard;
- end Global_Flist_Ref;
+ -- Generate the block which houses the finalization failure flag,
+ -- all the finalization loops and the exception raise.
- ----------------------------------
- -- Has_New_Controlled_Component --
- ----------------------------------
+ -- declare
+ -- E : Exception_Occurrence;
+ -- Raised : Boolean := False;
- function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
- Comp : Entity_Id;
+ -- begin
+ -- Counter :=
+ -- V'Length (1) *
+ -- ...
+ -- V'Length (N) - Counter;
- begin
- if not Is_Tagged_Type (E) then
- return Has_Controlled_Component (E);
- elsif not Is_Derived_Type (E) then
- return Has_Controlled_Component (E);
- end if;
+ -- <final loop>
- Comp := First_Component (E);
- while Present (Comp) loop
+ -- if Raised then -- Exception handlers allowed
+ -- Raise_From_Controlled_Operation (E);
+ -- end if;
- if Chars (Comp) = Name_uParent then
- null;
+ -- raise; -- Exception handlers allowed
+ -- end;
- elsif Scope (Original_Record_Component (Comp)) = E
- and then Needs_Finalization (Etype (Comp))
- then
- return True;
+ Stmts := New_List (Build_Counter_Assignment, Final_Loop);
+
+ if Exceptions_OK then
+ Append_To (Stmts, Build_Raise_Statement (Loc, E_Id, Raised_Id));
+ Append_To (Stmts, Make_Raise_Statement (Loc));
end if;
- Next_Component (Comp);
- end loop;
+ Final_Block :=
+ Make_Block_Statement (Loc,
+ Declarations =>
+ Build_Object_Declarations (Loc, E_Id, Raised_Id),
- return False;
- end Has_New_Controlled_Component;
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts));
- --------------------------
- -- In_Finalization_Root --
- --------------------------
+ -- Generate the block which contains the initialization call and
+ -- the partial finalization code.
- -- 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.
+ -- begin
+ -- [Deep_]Initialize (V (J1, ..., JN));
- function In_Finalization_Root (E : Entity_Id) return Boolean is
- S : constant Entity_Id := Scope (E);
+ -- Counter := Counter + 1;
- 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;
+ -- exception
+ -- when others =>
+ -- <finalization code>
+ -- end;
- ------------------------------------
- -- Insert_Actions_In_Scope_Around --
- ------------------------------------
+ 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);
- procedure Insert_Actions_In_Scope_Around (N : Node_Id) is
- SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
- Target : Node_Id;
+ 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))))),
- 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;
- end if;
+ Statements => New_List (Init_Loop),
+ End_Label => Empty);
- 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;
+ Dim := Dim - 1;
+ end loop;
- 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;
- end Insert_Actions_In_Scope_Around;
+ -- Generate the block which contains the counter variable and the
+ -- initialization loops.
- -----------------------
- -- Make_Adjust_Call --
- -----------------------
+ -- declare
+ -- Counter : Integer := 0;
+ -- begin
+ -- <init loop>
+ -- end;
- function Make_Adjust_Call
- (Ref : Node_Id;
- Typ : Entity_Id;
- Flist_Ref : Node_Id;
- With_Attach : Node_Id;
- Allocator : Boolean := False) return List_Id
- is
- Loc : constant Source_Ptr := Sloc (Ref);
- Res : constant List_Id := New_List;
- Utyp : Entity_Id;
- Proc : Entity_Id;
- Cref : Node_Id := Ref;
- Cref2 : Node_Id;
- Attach : Node_Id := With_Attach;
+ 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;
- begin
- if Is_Class_Wide_Type (Typ) then
- Utyp := Underlying_Type (Base_Type (Root_Type (Typ)));
- else
- Utyp := Underlying_Type (Base_Type (Typ));
- end if;
+ begin
+ Id := First (L);
+ while Present (Id) loop
+ Append_To (Refs, New_Reference_To (Id, Loc));
+ Next (Id);
+ end loop;
- Set_Assignment_OK (Cref);
+ return Refs;
+ end New_References_To;
- -- Deal with non-tagged derivation of private views
+ -- Start of processing for Make_Deep_Array_Body
- 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 ???
- end if;
+ begin
+ case Prim is
+ when Address_Case =>
+ return Make_Finalize_Address_Stmts (Typ);
- -- 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 Adjust_Case |
+ Finalize_Case =>
+ return Build_Adjust_Or_Finalize_Statements (Typ);
- if Utyp /= Base_Type (Utyp) then
- pragma Assert (Is_Private_Type (Typ));
- Utyp := Base_Type (Utyp);
- Cref := Unchecked_Convert_To (Utyp, Cref);
- end if;
+ when Initialize_Case =>
+ return Build_Initialize_Statements (Typ);
+ end case;
+ end Make_Deep_Array_Body;
- -- If the object is unanalyzed, set its expected type for use
- -- in Convert_View in case an additional conversion is needed.
+ --------------------
+ -- Make_Deep_Proc --
+ --------------------
- if No (Etype (Cref))
- and then Nkind (Cref) /= N_Unchecked_Type_Conversion
- then
- Set_Etype (Cref, Typ);
- end if;
+ 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_Id : Entity_Id;
- -- We do not need to attach to one of the Global Final Lists
- -- the objects whose type is Finalize_Storage_Only
+ begin
+ -- Create the object formal, generate:
+ -- V : System.Address
- 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);
- end if;
+ if Prim = Address_Case then
+ Formals := New_List (
+ Make_Parameter_Specification (Loc,
+ Make_Defining_Identifier (Loc, Name_V),
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Address), Loc)));
- -- Special case for allocators: need initialization of the chain
- -- pointers. For the 0 case, reset them to null.
+ -- Default case
- if Allocator then
- pragma Assert (Nkind (Attach) = N_Integer_Literal);
+ else
+ -- V : in out Typ
+
+ 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)));
- if Intval (Attach) = 0 then
- Set_Intval (Attach, Uint_4);
+ -- 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;
- -- Generate:
- -- Deep_Adjust (Flist_Ref, Ref, Attach);
+ Proc_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
- if Has_Controlled_Component (Utyp)
- or else Is_Class_Wide_Type (Typ)
- then
- if Is_Tagged_Type (Utyp) then
- Proc := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
+ -- 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;
- else
- Proc := TSS (Utyp, TSS_Deep_Adjust);
- end if;
+ -- or
- Cref := Convert_View (Proc, Cref, 2);
+ -- procedure Finalize_Address (V : System.Address) is
+ -- begin
+ -- <stmts>
+ -- end Finalize_Address;
- Append_To (Res,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (Proc, Loc),
- Parameter_Associations =>
- New_List (Flist_Ref, Cref, Attach)));
+ Discard_Node (
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Proc_Id,
+ Parameter_Specifications => Formals),
- -- Generate:
- -- if With_Attach then
- -- Attach_To_Final_List (Ref, Flist_Ref);
- -- end if;
- -- Adjust (Ref);
+ Declarations => Empty_List,
- else -- Is_Controlled (Utyp)
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts)));
- Proc := Find_Prim_Op (Utyp, Name_Of (Adjust_Case));
- Cref := Convert_View (Proc, Cref);
- Cref2 := New_Copy_Tree (Cref);
+ return Proc_Id;
+ end Make_Deep_Proc;
- Append_To (Res,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (Proc, Loc),
- Parameter_Associations => New_List (Cref2)));
+ ---------------------------
+ -- Make_Deep_Record_Body --
+ ---------------------------
- Append_To (Res, Make_Attach_Call (Cref, Flist_Ref, Attach));
- end if;
+ function Make_Deep_Record_Body
+ (Prim : Final_Primitives;
+ Typ : Entity_Id;
+ Is_Local : Boolean := False) return List_Id
+ is
+ 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;
- return Res;
- end Make_Adjust_Call;
+ 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;
- ----------------------
- -- Make_Attach_Call --
- ----------------------
+ Append_To (Stmts, Adj_Stmt);
+ end Process_Component_For_Adjust;
- -- Generate:
- -- System.FI.Attach_To_Final_List (Flist, Ref, Nb_Link)
+ -- Start of processing for Process_Component_List_For_Adjust
- function Make_Attach_Call
- (Obj_Ref : Node_Id;
- Flist_Ref : Node_Id;
- With_Attach : Node_Id) return Node_Id
- is
- Loc : constant Source_Ptr := Sloc (Obj_Ref);
+ 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.
- begin
- -- Optimization: If the number of links is statically '0', don't
- -- call the attach_proc.
+ Preprocess_Components (Comps, Num_Comps, Has_POC);
- if Nkind (With_Attach) = N_Integer_Literal
- and then Intval (With_Attach) = Uint_0
- then
- return Make_Null_Statement (Loc);
- end if;
+ -- The processing in this routine is done in the following order:
+ -- 1) Regular components
+ -- 2) Per-object constrained components
+ -- 3) Variant parts
- 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;
+ if Num_Comps > 0 then
- Sbody : Node_Id;
- Spec : Node_Id;
- Name : Node_Id;
- Param : Node_Id;
- Param_Type : Entity_Id;
- Pid : Entity_Id := Empty;
- Cancel_Param : Entity_Id;
+ -- Process all regular components in order of declarations
- 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;
+ Decl := First_Non_Pragma (Component_Items (Comps));
+ while Present (Decl) loop
+ Decl_Id := Defining_Identifier (Decl);
+ Decl_Typ := Etype (Decl_Id);
- elsif Is_Master then
- if Restriction_Active (No_Task_Hierarchy) = False then
- Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Master));
- end if;
+ -- Skip _parent as well as per-object constrained components
- elsif Is_Protected_Subprogram then
+ 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;
- -- 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.
+ Next_Non_Pragma (Decl);
+ end loop;
- -- NOTE: This cleanup handler references _object, a parameter
- -- to the procedure.
+ -- Process all per-object constrained components in order of
+ -- declarations.
- -- Find the _object parameter representing the protected object
+ 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);
- Spec := Parent (Corresponding_Spec (N));
+ -- Skip _parent
- Param := First (Parameter_Specifications (Spec));
- loop
- Param_Type := Etype (Parameter_Type (Param));
+ 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;
- if Ekind (Param_Type) = E_Record_Type then
- Pid := Corresponding_Concurrent_Type (Param_Type);
+ Next_Non_Pragma (Decl);
+ end loop;
+ end if;
end if;
- exit when No (Param) or else Present (Pid);
- Next (Param);
- end loop;
+ -- Process all variants, if any
- pragma Assert (Present (Param));
+ Var_Case := Empty;
+ if Present (Variant_Part (Comps)) then
+ declare
+ Var_Alts : constant List_Id := New_List;
+ Var : Node_Id;
- -- If the associated protected object declares entries,
- -- a protected procedure has to service entry queues.
- -- In this case, add
+ 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;
- -- Service_Entries (_object._object'Access);
+ -- Add the variant case statement to the list of statements
- -- _object is the record used to implement the protected object.
- -- It is a parameter to the protected subprogram.
+ if Present (Var_Case) then
+ Append_To (Stmts, Var_Case);
+ end if;
- 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 the component list did not have any controlled components
+ -- nor variants, return null.
- when System_Tasking_Protected_Objects_Single_Entry =>
- Name := New_Reference_To (RTE (RE_Service_Entry), Loc);
+ if Is_Empty_List (Stmts) then
+ Append_To (Stmts, Make_Null_Statement (Loc));
+ end if;
- when others =>
- raise Program_Error;
- end case;
+ return Stmts;
+ end Process_Component_List_For_Adjust;
- 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))));
+ -- Start of processing for Build_Adjust_Statements
- else
- -- Unlock (_object._object'Access);
+ begin
+ if Exceptions_OK then
+ E_Id := Make_Temporary (Loc, 'E');
+ Raised_Id := Make_Temporary (Loc, 'R');
+ end if;
- -- object is the record used to implement the protected object.
- -- It is a parameter to the protected subprogram.
+ if Nkind (Typ_Def) = N_Derived_Type_Definition then
+ Rec_Def := Record_Extension_Part (Typ_Def);
+ else
+ Rec_Def := Typ_Def;
+ end if;
- case Corresponding_Runtime_Package (Pid) is
- when System_Tasking_Protected_Objects_Entries =>
- Name := New_Reference_To (RTE (RE_Unlock_Entries), Loc);
+ -- Create an adjust sequence for all record components
- when System_Tasking_Protected_Objects_Single_Entry =>
- Name := New_Reference_To (RTE (RE_Unlock_Entry), Loc);
+ if Present (Component_List (Rec_Def)) then
+ Bod_Stmts :=
+ Process_Component_List_For_Adjust (Component_List (Rec_Def));
+ end if;
- when System_Tasking_Protected_Objects =>
- Name := New_Reference_To (RTE (RE_Unlock), Loc);
+ -- 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;
- when others =>
- raise Program_Error;
- end case;
+ 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;
- 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))));
+ Prepend_To (Bod_Stmts, Adj_Stmt);
+ end if;
+ end if;
+ end;
end if;
- if Abort_Allowed then
+ -- 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;
- -- Abort_Undefer;
+ 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 (Stmt,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (
- RTE (RE_Abort_Undefer), Loc),
- Parameter_Associations => Empty_List));
+ 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;
- elsif Is_Task_Allocation_Block then
-
- -- Add a call to Expunge_Unactivated_Tasks to the cleanup
- -- handler of a block created for the dynamic allocation of
- -- tasks:
+ -- At this point either all adjustment statements have been generated
+ -- or the type is not controlled.
- -- Expunge_Unactivated_Tasks (_chain);
+ if Is_Empty_List (Bod_Stmts) then
+ Append_To (Bod_Stmts, Make_Null_Statement (Loc));
- -- 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.
+ return Bod_Stmts;
- -- This only applies to dynamically allocated tasks;
- -- other unactivated tasks are completed by Complete_Task or
- -- Complete_Master.
+ -- Generate:
+ -- declare
+ -- E : Exception_Occurence;
+ -- Raised : Boolean := False;
- -- NOTE: This cleanup handler references _chain, a local
- -- object.
+ -- begin
+ -- Root_Controlled (V).Finalized := False;
- 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))));
+ -- <adjust statements>
- elsif Is_Asynchronous_Call_Block then
+ -- if Raised then
+ -- Raise_From_Controlled_Operation (E);
+ -- end if;
+ -- end;
- -- Add a call to attempt to cancel the asynchronous entry call
- -- whenever the block containing the abortable part is exited.
+ else
+ if Exceptions_OK then
+ Append_To (Bod_Stmts,
+ Build_Raise_Statement (Loc, E_Id, Raised_Id));
+ end if;
- -- NOTE: This cleanup handler references C, a local object
+ 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;
- -- Get the argument to the Cancel procedure
- Cancel_Param := Entry_Cancel_Parameter (Entity (Identifier (N)));
+ 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;
- -- If it is of type Communication_Block, this must be a
- -- protected entry call.
+ -- 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;
- if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
+ Append_To (Stmts, Fin_Stmt);
+ end Process_Component_For_Finalize;
- Append_To (Stmt,
+ -- Start of processing for Process_Component_List_For_Finalize
- -- if Enqueued (Cancel_Parameter) then
+ begin
+ -- Perform an initial check, look for controlled and per-object
+ -- constrained components.
- 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 (
+ Preprocess_Components (Comps, Num_Comps, Has_POC);
- -- Cancel_Protected_Entry_Call (Cancel_Param);
+ -- 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.
- 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))))));
+ if Num_Comps > 0
+ and then Is_Local
+ then
+ Counter := Counter + 1;
- -- Asynchronous delay
+ Counter_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name ('C', Counter));
+ end if;
- 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))));
+ -- Process the component in the following order:
+ -- 1) Variants
+ -- 2) Per-object constrained components
+ -- 3) Regular components
- -- Task entry call
+ -- Start with the variant parts
- else
- -- Append call to Cancel_Task_Entry_Call (C);
+ Var_Case := Empty;
+ if Present (Variant_Part (Comps)) then
+ declare
+ Var_Alts : constant List_Id := New_List;
+ Var : Node_Id;
- 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))));
+ 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;
- end if;
- 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 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;
+ 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;
- 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;
+ -- Prepare all lists
- if Present (Chained_Cleanup_Action) then
- Append_To (Stmt,
- Make_Procedure_Call_Statement (Loc,
- Name => Chained_Cleanup_Action));
- end if;
+ Alts := New_List;
+ Decls := New_List;
+ Stmts := New_List;
- Sbody :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Clean),
+ -- Process all per-object constrained components in reverse order
- Declarations => New_List,
+ 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);
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmt));
+ -- Skip _parent
- if Present (Flist) or else Is_Task or else Is_Master then
- Wrap_Cleanup_Procedure (Sbody);
- end if;
+ 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;
- -- We do not want debug information for _Clean routines,
- -- since it just confuses the debugging operation unless
- -- we are debugging generated code.
+ Prev_Non_Pragma (Decl);
+ end loop;
+ end if;
- if not Debug_Generated_Code then
- Set_Debug_Info_Off (Clean, True);
- end if;
+ -- Process the rest of the components in reverse order
- return Sbody;
- end Make_Clean;
+ Decl := Last_Non_Pragma (Component_Items (Comps));
+ while Present (Decl) loop
+ Decl_Id := Defining_Identifier (Decl);
+ Decl_Typ := Etype (Decl_Id);
- --------------------------
- -- Make_Deep_Array_Body --
- --------------------------
+ -- Skip _parent
- -- 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>;
+ 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.
- function Make_Deep_Array_Body
- (Prim : Final_Primitives;
- Typ : Entity_Id) return List_Id
- is
- Loc : constant Source_Ptr := Sloc (Typ);
+ 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;
- Index_List : constant List_Id := New_List;
- -- Stores the list of references to the indexes (one per dimension)
+ Prev_Non_Pragma (Decl);
+ end loop;
- function One_Component return List_Id;
- -- Create one statement to initialize/adjust/finalize one array
- -- component, designated by a full set of indexes.
+ -- 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;
- 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.
+ Jump_Block :=
+ Make_Block_Statement (Loc,
+ Declarations => Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts));
- -------------------
- -- One_Component --
- -------------------
+ 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;
- 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);
+ -- Start of processing for Build_Finalize_Statements
begin
- -- Set the etype of the component Reference, which is used to
- -- determine whether a conversion to a parent type is needed.
+ if Exceptions_OK then
+ E_Id := Make_Temporary (Loc, 'E');
+ Raised_Id := Make_Temporary (Loc, 'R');
+ end if;
- Set_Etype (Comp_Ref, Comp_Typ);
+ if Nkind (Typ_Def) = N_Derived_Type_Definition then
+ Rec_Def := Record_Extension_Part (Typ_Def);
+ else
+ Rec_Def := Typ_Def;
+ end if;
- case Prim is
- when Initialize_Case =>
- return Make_Init_Call (Comp_Ref, Comp_Typ,
- Make_Identifier (Loc, Name_L),
- Make_Identifier (Loc, Name_B));
+ -- Create a finalization sequence for all record components
- when Adjust_Case =>
- return Make_Adjust_Call (Comp_Ref, Comp_Typ,
- Make_Identifier (Loc, Name_L),
- Make_Identifier (Loc, Name_B));
+ if Present (Component_List (Rec_Def)) then
+ Bod_Stmts :=
+ Process_Component_List_For_Finalize (Component_List (Rec_Def));
+ end if;
- when Finalize_Case =>
- return Make_Final_Call (Comp_Ref, Comp_Typ,
- Make_Identifier (Loc, Name_B));
- end case;
- end One_Component;
+ -- 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;
- -------------------
- -- One_Dimension --
- -------------------
+ 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;
- function One_Dimension (N : Int) return List_Id is
- Index : Entity_Id;
+ Append_To (Bod_Stmts, Fin_Stmt);
+ end if;
+ end if;
+ end;
+ end if;
- begin
- if N > Number_Dimensions (Typ) then
- return One_Component;
+ -- Finalize the object. This action must be performed first before
+ -- all components have been finalized.
- else
- Index :=
- Make_Defining_Identifier (Loc, New_External_Name ('J', N));
+ if Is_Controlled (Typ)
+ and then not Is_Local
+ then
+ declare
+ Fin_Stmt : Node_Id;
+ Proc : Entity_Id;
- Append_To (Index_List, New_Reference_To (Index, Loc));
+ 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;
- 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)));
+ 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;
- end One_Dimension;
- -- Start of processing for Make_Deep_Array_Body
+ -- At this point either all finalization statements have been
+ -- generated or the type is not controlled.
- begin
- return One_Dimension (1);
- end Make_Deep_Array_Body;
+ if No (Bod_Stmts) then
+ return New_List (Make_Null_Statement (Loc));
- --------------------
- -- Make_Deep_Proc --
- --------------------
+ -- Generate:
+ -- declare
+ -- E : Exception_Occurence;
+ -- Raised : Boolean := False;
- -- 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>;
+ -- begin
+ -- if V.Finalized then
+ -- return;
+ -- end if;
- 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;
+ -- <finalize statements>
+ -- V.Finalized := True;
- begin
- if Prim = Finalize_Case then
- Formals := New_List;
- Type_B := Standard_Boolean;
+ -- if Raised then
+ -- Raise_From_Controlled_Operation (E);
+ -- end if;
+ -- end;
- else
- 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;
+ else
+ if Exceptions_OK then
+ Append_To (Bod_Stmts,
+ Build_Raise_Statement (Loc, E_Id, Raised_Id));
+ end if;
- 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)));
+ 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;
- Append_To (Formals,
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Make_Defining_Identifier (Loc, Name_B),
- Parameter_Type => New_Reference_To (Type_B, Loc)));
+ -----------------------
+ -- Parent_Field_Type --
+ -----------------------
- if Prim = Finalize_Case or else Prim = Adjust_Case then
- Handler := New_List (Make_Handler_For_Ctrl_Operation (Loc));
- end if;
+ function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is
+ Field : Entity_Id;
- Proc_Name :=
- Make_Defining_Identifier (Loc,
- Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
+ begin
+ Field := First_Entity (Typ);
+ while Present (Field) loop
+ if Chars (Field) = Name_uParent then
+ return Etype (Field);
+ end if;
- Discard_Node (
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Proc_Name,
- Parameter_Specifications => Formals),
+ Next_Entity (Field);
+ end loop;
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts,
- Exception_Handlers => Handler)));
+ -- A derived tagged type should always have a parent field
- return Proc_Name;
- end Make_Deep_Proc;
+ raise Program_Error;
+ end Parent_Field_Type;
- ---------------------------
- -- Make_Deep_Record_Body --
- ---------------------------
+ ---------------------------
+ -- Preprocess_Components --
+ ---------------------------
- -- 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.
+ procedure Preprocess_Components
+ (Comps : Node_Id;
+ Num_Comps : out Int;
+ Has_POC : out Boolean)
+ is
+ Decl : Node_Id;
+ Id : Entity_Id;
+ Typ : Entity_Id;
- function Make_Deep_Record_Body
- (Prim : Final_Primitives;
- Typ : Entity_Id) 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;
+ begin
+ Num_Comps := 0;
+ Has_POC := False;
- begin
- if Is_Immutably_Limited_Type (Typ) then
- Controller_Typ := RTE (RE_Limited_Record_Controller);
- else
- Controller_Typ := RTE (RE_Record_Controller);
- end if;
+ Decl := First_Non_Pragma (Component_Items (Comps));
+ while Present (Decl) loop
+ Id := Defining_Identifier (Decl);
+ Typ := Etype (Id);
- 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)));
+ -- Skip field _parent
- -- When the type is also a controlled type by itself,
- -- initialize it and attach it to the finalization chain.
+ if Chars (Id) /= Name_uParent
+ and then Needs_Finalization (Typ)
+ then
+ Num_Comps := Num_Comps + 1;
- 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 Has_Access_Constraint (Id)
+ and then No (Expression (Decl))
+ then
+ Has_POC := True;
+ 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)));
+ Next_Non_Pragma (Decl);
+ end loop;
+ end Preprocess_Components;
- -- When the type is also a controlled type by itself,
- -- adjust it and attach it to the finalization chain.
+ -- Start of processing for Make_Deep_Record_Body
- 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)));
- end if;
+ begin
+ case Prim is
+ when Address_Case =>
+ return Make_Finalize_Address_Stmts (Typ);
+
+ when Adjust_Case =>
+ return Build_Adjust_Statements (Typ);
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))))),
+ return Build_Finalize_Statements (Typ);
- 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))))));
- end if;
+ when Initialize_Case =>
+ declare
+ Loc : constant Source_Ptr := Sloc (Typ);
- Append_List_To (Res,
- Make_Final_Call
- (Controller_Ref, Controller_Typ,
- Make_Identifier (Loc, Name_B)));
+ 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;
-
- return Res;
end Make_Deep_Record_Body;
----------------------
----------------------
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;
+
+ Ref := Unchecked_Convert_To (Utyp, Ref);
+ Set_Assignment_OK (Ref);
+ end if;
+
+ -- 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.
+
+ 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;
+
+ -- 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);
+ Ref := Unchecked_Convert_To (Utyp, Ref);
+ Set_Assignment_OK (Ref);
+ end if;
+
+ -- 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.
+
+ elsif Is_Class_Wide_Type (Typ)
+ or else Is_Interface (Typ)
+ or else Has_Controlled_Component (Utyp)
+ then
+ if Is_Tagged_Type (Utyp) then
+ Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
+ else
+ Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
+ end if;
+
+ -- For types that are derived from Controlled and do not have controlled
+ -- components, build a call to Finalize.
+
+ else
+ Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
+ 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
+ return Empty;
+ end if;
+ end Make_Final_Call;
+
+ --------------------------------
+ -- Make_Finalize_Address_Body --
+ --------------------------------
+
+ 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;
- if Is_Untagged_Derivation (Typ) then
- if Is_Protected_Type (Typ) then
- Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
+ begin
+ if Is_Array_Type (Typ) then
+ if Is_Constrained (First_Subtype (Typ)) then
+ Desg_Typ := First_Subtype (Typ);
else
- Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
+ Desg_Typ := Base_Type (Typ);
end if;
- Cref := Unchecked_Convert_To (Utyp, Cref);
+ -- 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);
- -- 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).
+ begin
+ -- Climb the parent type chain looking for a non-constrained type
- Set_Assignment_OK (Cref);
- end if;
+ 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;
- -- 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.
+ -- Handle views created for tagged types with unknown
+ -- discriminants.
- if Utyp /= Base_Type (Utyp) then
- pragma Assert (Is_Private_Type (Typ));
- Utyp := Base_Type (Utyp);
- Cref := Unchecked_Convert_To (Utyp, Cref);
+ 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;
-- Generate:
- -- Deep_Finalize (Ref, With_Detach);
-
- if Has_Controlled_Component (Utyp)
- or else Is_Class_Wide_Type (Typ)
+ -- 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
- if Is_Tagged_Type (Utyp) then
- Proc := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
- else
- Proc := TSS (Utyp, TSS_Deep_Finalize);
- end if;
+ 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
- Cref := Convert_View (Proc, Cref);
+ begin
+ -- Ensure that Ptr_Typ a thin pointer, generate:
+ --
+ -- for Ptr_Typ'Size use System.Address'Size;
- Append_To (Res,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (Proc, Loc),
- Parameter_Associations =>
- New_List (Cref, With_Detach)));
+ 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)));
- -- Generate:
- -- if With_Detach then
- -- Finalize_One (Ref);
- -- else
- -- Finalize (Ref);
- -- end if;
+ -- 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.
- else
- Proc := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
+ Index := First_Index (Typ);
+ while Present (Index) loop
- 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))));
+ -- Generate:
+ -- 2 * Esize (Index_Typ) / Storage_Unit
- 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))));
+ if For_First then
+ For_First := False;
+ Dope_Expr := Bounds_Size_Expression (Etype (Index));
- 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))))));
- end if;
+ -- 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;
- return Res;
- end Make_Final_Call;
+ -- 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 --
-- 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.
+
+ 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.
+ -- 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;
--------------------
--------------------
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))
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
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
-- 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
-- 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);
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
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 --
------------------------
-- (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
-- 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
-- --
-- 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- --
-- 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"
-- 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 --
-- 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 --
-- 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
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;
-- 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;
-- 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;
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 --
---------------------
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;
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);
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.
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;
-- 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 ]
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
-- 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
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)));
Kill_Current_Values;
else
- Append_List_To (Stmts, Free_Cod);
+ Append_List_To (Stmts, Final_Code);
end if;
end if;
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.
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);
-- --
-- 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- --
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
TSS_Deep_Finalize,
TSS_Deep_Initialize,
TSS_Composite_Equality,
+ TSS_Finalize_Address,
TSS_From_Any,
TSS_Init_Proc,
TSS_CPP_Init_Proc,
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 --
------------------------
-- 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,
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;
-- 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;
(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
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;
----------------------------
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 --
----------------------
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 ???
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 --
------------------------------
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 --
--------------------
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 --
---------------------------------
and then Is_Library_Level_Entity (Typ);
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 --
----------------------------------
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 --
--------------------------------
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 --
----------------------------
-- 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);
-- 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
-- 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);
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
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
-- 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
-- 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
-- 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
-- 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
-- --
-- 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- --
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);
-- --
-- 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- --
Set_Expression (Par, New_Occurrence_Of (Temp, Loc));
return True;
-
else
return False;
end if;
Subp : Entity_Id;
begin
- Prim := First_Elmt (Prim_List);
+ Prim := First_Elmt (Prim_List);
while Present (Prim) loop
Subp := Node (Prim);
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);
-- 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);
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)
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);
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
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,
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;
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;
-- 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
-- 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
-- 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
-- Children of Ada.Finalization
- Ada_Finalization_List_Controller,
+ Ada_Finalization_Heap_Management,
-- Children of Ada.Interrupts
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,
-- 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
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
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
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
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
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
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
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,
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,
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,
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,
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,
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,
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
-- --
-- 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- --
-- 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;
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
-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
-- Allocate --
--------------
- procedure Allocate
+ overriding procedure Allocate
(Pool : in out Unbounded_No_Reclaim_Pool;
Address : out System.Address;
Storage_Size : SSE.Storage_Count;
-- Deallocate --
----------------
- procedure Deallocate
+ overriding procedure Deallocate
(Pool : in out Unbounded_No_Reclaim_Pool;
Address : System.Address;
Storage_Size : SSE.Storage_Count;
-- Storage_Size --
------------------
- function Storage_Size
+ overriding function Storage_Size
(Pool : Unbounded_No_Reclaim_Pool)
return SSE.Storage_Count
is
-- --
-- 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- --
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;
---------------------------
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 --
-- --
-- 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- --
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);
-- 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)
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
-- 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.
-- 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 --
------------------------
-- --
-- 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- --
-- 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);
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
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;
-- 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
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);
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
-- --
-- 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- --
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
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;
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;
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
procedure Decorate_Tagged_Type
(Loc : Source_Ptr;
T : Entity_Id;
- Scop : Entity_Id)
+ Scop : Entity_Id;
+ Mark : Boolean := False)
is
CW : Entity_Id;
-- 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
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
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);
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
----------------------------
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);
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);
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
-- 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;
-----------------------------------
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
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;
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)
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;
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;
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
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
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);
-- 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;
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
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;
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:
(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);
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;
-- --
-- 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- --
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);
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);
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
-- --
-- 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- --
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
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;
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;
-- 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 --
-------------------------------------------
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
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;
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.
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));
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,
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
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);
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.
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;
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 --
---------------------------------
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 --
-----------------------------
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))
-- 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
-- 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
-- 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
-- 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
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
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
-- 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.
-- 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)
-- 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)
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
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
(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 =>
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);
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);
-- --
-- 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- --
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 + $;
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
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 + $;
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 + $;
-- --
-- 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- --
(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
-- 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);
projects / gcc.git / commitdiff