diff options
Diffstat (limited to 'gcc/ada/exp_ch7.adb')
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 87 |
1 files changed, 52 insertions, 35 deletions
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 6dcfae8..4dc1164 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -36,6 +36,7 @@ with Exp_Ch9; use Exp_Ch9; with Exp_Ch11; use Exp_Ch11; with Exp_Dbug; use Exp_Dbug; with Exp_Dist; use Exp_Dist; +with Exp_Disp; use Exp_Disp; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; @@ -310,7 +311,7 @@ package body Exp_Ch7 is -- Here is a simple example of the expansion of a controlled block : -- declare - -- X : Controlled ; + -- X : Controlled; -- Y : Controlled := Init; -- -- type R is record @@ -369,10 +370,10 @@ package body Exp_Ch7 is -- 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 + -- 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. procedure Clean_Simple_Protected_Objects (N : Node_Id); -- Protected objects without entries are not controlled types, and the @@ -1415,12 +1416,12 @@ package body Exp_Ch7 is -- 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_Return_Statement), and thus no + -- 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_Return_Statement then + if Nkind (Parent (N)) = N_Simple_Return_Statement then return; end if; @@ -1579,6 +1580,13 @@ package body Exp_Ch7 is if Ekind (Ent) = E_Package then Push_Scope (Corresponding_Spec (N)); + + -- Build dispatch tables of library level tagged types + + if Is_Compilation_Unit (Ent) then + Build_Static_Dispatch_Tables (N); + end if; + Build_Task_Activation_Call (N); Pop_Scope; end if; @@ -1595,23 +1603,21 @@ package body Exp_Ch7 is -- 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. + -- 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 - Spec : constant Node_Id := Specification (N); + Spec : constant Node_Id := Specification (N); + Id : constant Entity_Id := Defining_Entity (N); Decls : List_Id; - - No_Body : Boolean; + 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 - - No_Body := False; + begin -- Case of a package declaration other than a compilation unit if Nkind (Parent (N)) /= N_Compilation_Unit then @@ -1620,7 +1626,7 @@ package body Exp_Ch7 is -- Case of a compilation unit that does not require a body elsif not Body_Required (Parent (N)) - and then not Unit_Requires_Body (Defining_Entity (N)) + and then not Unit_Requires_Body (Id) then No_Body := True; @@ -1631,7 +1637,7 @@ package body Exp_Ch7 is -- spec). elsif Parent (N) = Cunit (Main_Unit) - and then Is_Remote_Call_Interface (Defining_Entity (N)) + and then Is_Remote_Call_Interface (Id) and then Distribution_Stub_Mode = Generate_Caller_Stub_Body then No_Body := True; @@ -1642,9 +1648,9 @@ package body Exp_Ch7 is -- have a specific separate compilation unit for that). if No_Body then - Push_Scope (Defining_Entity (N)); + Push_Scope (Id); - if Has_RACW (Defining_Entity (N)) then + if Has_RACW (Id) then -- Generate RACW subprogram bodies @@ -1659,7 +1665,7 @@ package body Exp_Ch7 is Set_Visible_Declarations (Spec, Decls); end if; - Append_RACW_Bodies (Decls, Defining_Entity (N)); + Append_RACW_Bodies (Decls, Id); Analyze_List (Decls); end if; @@ -1673,6 +1679,15 @@ package body Exp_Ch7 is 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 + Build_Static_Dispatch_Tables (N); + 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 @@ -1698,7 +1713,7 @@ package body Exp_Ch7 is begin -- Case of an internal component. The Final list is the record - -- controller of the enclosing record + -- controller of the enclosing record. if Present (Ref) then R := Ref; @@ -1741,7 +1756,9 @@ package body Exp_Ch7 is -- context is a declaration or an assignment. elsif Is_Access_Type (E) - and then Ekind (E) /= E_Anonymous_Access_Type + and then (Ekind (E) /= E_Anonymous_Access_Type + or else + Present (Associated_Final_Chain (E))) then if not From_With_Type (E) then return @@ -1775,15 +1792,15 @@ package body Exp_Ch7 is return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E)); else if No (Finalization_Chain_Entity (S)) then - - Id := Make_Defining_Identifier (Sloc (S), - New_Internal_Name ('F')); + Id := + Make_Defining_Identifier (Sloc (S), + Chars => New_Internal_Name ('F')); Set_Finalization_Chain_Entity (S, Id); -- Set momentarily some semantics attributes to allow normal -- analysis of expansions containing references to this chain. -- Will be fully decorated during the expansion of the scope - -- itself + -- itself. Set_Ekind (Id, E_Variable); Set_Etype (Id, RTE (RE_Finalizable_Ptr)); @@ -1813,7 +1830,7 @@ package body Exp_Ch7 is -- Simple statement can be wrapped - when N_Pragma => + when N_Pragma => return The_Parent; -- Usually assignments are good candidate for wrapping @@ -1876,7 +1893,7 @@ package body Exp_Ch7 is N_Terminate_Alternative => return P; - when N_Attribute_Reference => + when N_Attribute_Reference => if Is_Procedure_Attribute_Name (Attribute_Name (The_Parent)) @@ -1888,7 +1905,7 @@ package body Exp_Ch7 is -- expression in a raise_with_expression uses the secondary -- stack, for example. - when N_Raise_Statement => + when N_Raise_Statement => return The_Parent; -- If the expression is within the iteration scheme of a loop, @@ -1909,7 +1926,7 @@ package body Exp_Ch7 is -- The return statement is not to be wrapped when the function -- itself needs wrapping at the outer-level - when N_Return_Statement => + when N_Simple_Return_Statement => declare Applies_To : constant Entity_Id := Return_Applies_To @@ -3139,7 +3156,7 @@ package body Exp_Ch7 is if VM_Target = No_VM and then Uses_Sec_Stack (Current_Scope) and then No (Flist) - and then Nkind (Action) /= N_Return_Statement + and then Nkind (Action) /= N_Simple_Return_Statement and then Nkind (Par) /= N_Exception_Handler then |