diff options
Diffstat (limited to 'gcc/ada/exp_ch7.adb')
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 118 |
1 files changed, 102 insertions, 16 deletions
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 9a648e5..678948a 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -297,8 +297,11 @@ package body Exp_Ch7 is 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. + -- protected subprogram body, task allocation block or task body. Generate + -- code to unregister the external tags of all library-level tagged types + -- found in the declarations and/or statements of N. If the context does + -- not contain the above constructs or types, the routine returns an empty + -- list. function Build_Exception_Handler (Loc : Source_Ptr; @@ -486,8 +489,11 @@ package body Exp_Ch7 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 + not Nkind_In (N, N_Entry_Body, + N_Package_Body, + N_Package_Declaration) and then Is_Task_Master (N); Is_Protected_Body : constant Boolean := Nkind (N) = N_Subprogram_Body @@ -501,6 +507,59 @@ package body Exp_Ch7 is Loc : constant Source_Ptr := Sloc (N); Stmts : constant List_Id := New_List; + procedure Unregister_Tagged_Types (Decls : List_Id); + -- Unregister the external tag of each tagged type found in the list + -- Decls. The generated statements are added to list Stmts. + + ----------------------------- + -- Unregister_Tagged_Types -- + ----------------------------- + + procedure Unregister_Tagged_Types (Decls : List_Id) is + Decl : Node_Id; + DT_Ptr : Entity_Id; + Typ : Entity_Id; + + begin + if No (Decls) or else Is_Empty_List (Decls) then + return; + end if; + + -- Process all declarations or statements in reverse order + + Decl := Last_Non_Pragma (Decls); + while Present (Decl) loop + if Nkind (Decl) = N_Full_Type_Declaration then + Typ := Defining_Identifier (Decl); + + if Is_Tagged_Type (Typ) + and then Is_Library_Level_Entity (Typ) + and then Convention (Typ) = Convention_Ada + and then Present (Access_Disp_Table (Typ)) + and then RTE_Available (RE_Unregister_Tag) + and then not No_Run_Time_Mode + and then not Is_Abstract_Type (Typ) + then + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); + + -- Generate: + -- Ada.Tags.Unregister_Tag (<Typ>P); + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Unregister_Tag), Loc), + Parameter_Associations => New_List ( + New_Reference_To (DT_Ptr, Loc)))); + end if; + end if; + + Prev_Non_Pragma (Decl); + end loop; + end Unregister_Tagged_Types; + + -- Start of processing for Build_Cleanup_Statements + begin if Is_Task_Body then if Restricted_Profile then @@ -711,6 +770,26 @@ package body Exp_Ch7 is end; end if; + -- Inspect all declaration and/or statement lists of N for library-level + -- tagged types. Generate code to unregister the external tag of such a + -- type. + + if Nkind (N) = N_Package_Declaration then + Unregister_Tagged_Types (Private_Declarations (Specification (N))); + Unregister_Tagged_Types (Visible_Declarations (Specification (N))); + + -- Accept statement, block, entry body, package body, protected body, + -- subprogram body or task body. + + else + if Present (Handled_Statement_Sequence (N)) then + Unregister_Tagged_Types + (Statements (Handled_Statement_Sequence (N))); + end if; + + Unregister_Tagged_Types (Declarations (N)); + end if; + return Stmts; end Build_Cleanup_Statements; @@ -2686,22 +2765,29 @@ package body Exp_Ch7 is if For_Package_Spec then Process_Declarations (Priv_Decls, Preprocess => True, Top_Level => True); + end if; - -- 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. + -- 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 Has_Ctrl_Objs then - Build_Components; - Process_Declarations (Priv_Decls); - end if; + if Acts_As_Clean or else Has_Ctrl_Objs then + Build_Components; end if; - -- Process the public declarations + -- The preprocessing has determined that the context has objects that + -- need finalization actions. if Has_Ctrl_Objs then - Build_Components; + + -- Private declarations are processed first in order to preserve + -- possible dependencies between public and private objects. + + if For_Package_Spec then + Process_Declarations (Priv_Decls); + end if; + Process_Declarations (Decls); end if; @@ -3495,7 +3581,7 @@ package body Exp_Ch7 is and then VM_Target = No_VM; Actions_Required : constant Boolean := - Has_Controlled_Objects (N) + Requires_Cleanup_Actions (N) or else Is_Asynchronous_Call or else Is_Master or else Is_Protected_Body @@ -3770,7 +3856,7 @@ package body Exp_Ch7 is if Ekind (Spec_Ent) /= E_Generic_Package then Build_Finalizer (N => N, - Clean_Stmts => No_List, + Clean_Stmts => Build_Cleanup_Statements (N), Mark_Id => Empty, Top_Decls => No_List, Defer_Abort => False, @@ -3924,7 +4010,7 @@ package body Exp_Ch7 is if Ekind (Id) /= E_Generic_Package then Build_Finalizer (N => N, - Clean_Stmts => No_List, + Clean_Stmts => Build_Cleanup_Statements (N), Mark_Id => Empty, Top_Decls => No_List, Defer_Abort => False, |