From b0efe69eaeb85421c7a98d53934ffb4f64020d1e Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Wed, 15 Feb 2006 10:39:06 +0100 Subject: [PATCH] exp_disp.ads, [...] (Expand_Dispatching_Call): If the controlling argument of the dispatching call is an abstract interface... 2006-02-13 Javier Miranda * exp_disp.ads, exp_disp.adb (Expand_Dispatching_Call): If the controlling argument of the dispatching call is an abstract interface class-wide type then we use it directly. Check No_Dispatching_Calls restriction. (Default_Prim_Op_Position): Remove the code that looks for the last entity in the list of aliased subprograms. This code was wrong in case of renamings. (Fill_DT_Entry): Add assertion to avoid the use of this subprogram when the source is compiled with the No_Dispatching_Calls restriction. (Init_Predefined_Interface_Primitives): No need to inherit primitives if we are compiling with restriction No_Dispatching_Calls. (Make_Disp_XXX): Addition of assertion to avoid the use of all these subprograms if we are compiling under No_Dispatching_Calls restriction. (Make_DT): Generate a dispatch table with a single dummy entry if we are compiling with the No_Dispatching_Calls restriction. In addition, in this case we don't generate code that calls to the following run-time subprograms: Set_Type_Kind, Inherit_DT. (Make_Select_Specific_Data_Table): Add assertion to avoid the use of this subprogram if compiling with the No_Dispatching_Calls restriction. (Expand_Type_Conversion): Instead of using the actual parameter, the argument passed as parameter to the conversion function was erroneously referenced by the expander. (Ada_Actions): Addition of Get_Predefined_Prim_Op_Address, Set_Predefined_Primitive_Op_Address and Set_Signature. (Expand_Dispatching_Call): Generate call to Get_Predefined_Prim_Op_Address for predefined primitives. (Fill_DT_Entry): Generate call to Set_Predefined_Prim_Op_Address for predefined primitives. (Make_DT, Make_Secondary_DT): If the tagged type has no user defined primitives we reserve one dummy entry to ensure that the tag does not point to some memory that is associated with some other object. In addition, remove all the old code that generated the assignments associated with the signature of the dispatch table and replace them by a call to the new subprogram Set_Signature. (Set_All_DT_Position): Change the algorithm because now we have a separate dispatch table associated with predefined primitive operations. (Expand_Interface_Conversion): In case of non-static offset_to_top add explicit dereference to get access to the object after the call to displace the pointer to the object. (Expand_Interface_Thunk): Modify the generation of the actual used in the calls to the run-time function Offset_To_Top to fulfil its new interface. (Make_DT): Add the new actuals required to call Set_Offset_To_Top. From-SVN: r111064 --- gcc/ada/exp_disp.adb | 992 ++++++++++++++++++++++++------------------- gcc/ada/exp_disp.ads | 14 +- 2 files changed, 565 insertions(+), 441 deletions(-) diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index e3daf07bfc4..a29714e976c 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -40,6 +40,8 @@ with Nmake; use Nmake; with Namet; use Namet; with Opt; use Opt; with Output; use Output; +with Restrict; use Restrict; +with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Disp; use Sem_Disp; @@ -302,113 +304,122 @@ package body Exp_Disp is package SEU renames Select_Expansion_Utilities; Ada_Actions : constant array (DT_Access_Action) of RE_Id := - (CW_Membership => RE_CW_Membership, - IW_Membership => RE_IW_Membership, - DT_Entry_Size => RE_DT_Entry_Size, - DT_Prologue_Size => RE_DT_Prologue_Size, - Get_Access_Level => RE_Get_Access_Level, - Get_Entry_Index => RE_Get_Entry_Index, - Get_External_Tag => RE_Get_External_Tag, - Get_Prim_Op_Address => RE_Get_Prim_Op_Address, - Get_Prim_Op_Kind => RE_Get_Prim_Op_Kind, - Get_RC_Offset => RE_Get_RC_Offset, - Get_Remotely_Callable => RE_Get_Remotely_Callable, - Get_Tagged_Kind => RE_Get_Tagged_Kind, - Inherit_DT => RE_Inherit_DT, - Inherit_TSD => RE_Inherit_TSD, - Register_Interface_Tag => RE_Register_Interface_Tag, - Register_Tag => RE_Register_Tag, - Set_Access_Level => RE_Set_Access_Level, - Set_Entry_Index => RE_Set_Entry_Index, - Set_Expanded_Name => RE_Set_Expanded_Name, - Set_External_Tag => RE_Set_External_Tag, - Set_Interface_Table => RE_Set_Interface_Table, - Set_Offset_Index => RE_Set_Offset_Index, - Set_OSD => RE_Set_OSD, - Set_Prim_Op_Address => RE_Set_Prim_Op_Address, - Set_Prim_Op_Kind => RE_Set_Prim_Op_Kind, - Set_RC_Offset => RE_Set_RC_Offset, - Set_Remotely_Callable => RE_Set_Remotely_Callable, - Set_SSD => RE_Set_SSD, - Set_TSD => RE_Set_TSD, - Set_Tagged_Kind => RE_Set_Tagged_Kind, - TSD_Entry_Size => RE_TSD_Entry_Size, - TSD_Prologue_Size => RE_TSD_Prologue_Size); + (CW_Membership => RE_CW_Membership, + IW_Membership => RE_IW_Membership, + DT_Entry_Size => RE_DT_Entry_Size, + DT_Prologue_Size => RE_DT_Prologue_Size, + Get_Access_Level => RE_Get_Access_Level, + Get_Entry_Index => RE_Get_Entry_Index, + Get_External_Tag => RE_Get_External_Tag, + Get_Predefined_Prim_Op_Address => RE_Get_Predefined_Prim_Op_Address, + Get_Prim_Op_Address => RE_Get_Prim_Op_Address, + Get_Prim_Op_Kind => RE_Get_Prim_Op_Kind, + Get_RC_Offset => RE_Get_RC_Offset, + Get_Remotely_Callable => RE_Get_Remotely_Callable, + Get_Tagged_Kind => RE_Get_Tagged_Kind, + Inherit_DT => RE_Inherit_DT, + Inherit_TSD => RE_Inherit_TSD, + Register_Interface_Tag => RE_Register_Interface_Tag, + Register_Tag => RE_Register_Tag, + Set_Access_Level => RE_Set_Access_Level, + Set_Entry_Index => RE_Set_Entry_Index, + Set_Expanded_Name => RE_Set_Expanded_Name, + Set_External_Tag => RE_Set_External_Tag, + Set_Interface_Table => RE_Set_Interface_Table, + Set_Offset_Index => RE_Set_Offset_Index, + Set_OSD => RE_Set_OSD, + Set_Predefined_Prim_Op_Address => RE_Set_Predefined_Prim_Op_Address, + Set_Prim_Op_Address => RE_Set_Prim_Op_Address, + Set_Prim_Op_Kind => RE_Set_Prim_Op_Kind, + Set_RC_Offset => RE_Set_RC_Offset, + Set_Remotely_Callable => RE_Set_Remotely_Callable, + Set_Signature => RE_Set_Signature, + Set_SSD => RE_Set_SSD, + Set_TSD => RE_Set_TSD, + Set_Tagged_Kind => RE_Set_Tagged_Kind, + TSD_Entry_Size => RE_TSD_Entry_Size, + TSD_Prologue_Size => RE_TSD_Prologue_Size); Action_Is_Proc : constant array (DT_Access_Action) of Boolean := - (CW_Membership => False, - IW_Membership => False, - DT_Entry_Size => False, - DT_Prologue_Size => False, - Get_Access_Level => False, - Get_Entry_Index => False, - Get_External_Tag => False, - Get_Prim_Op_Address => False, - Get_Prim_Op_Kind => False, - Get_RC_Offset => False, - Get_Remotely_Callable => False, - Get_Tagged_Kind => False, - Inherit_DT => True, - Inherit_TSD => True, - Register_Interface_Tag => True, - Register_Tag => True, - Set_Access_Level => True, - Set_Entry_Index => True, - Set_Expanded_Name => True, - Set_External_Tag => True, - Set_Interface_Table => True, - Set_Offset_Index => True, - Set_OSD => True, - Set_Prim_Op_Address => True, - Set_Prim_Op_Kind => True, - Set_RC_Offset => True, - Set_Remotely_Callable => True, - Set_SSD => True, - Set_TSD => True, - Set_Tagged_Kind => True, - TSD_Entry_Size => False, - TSD_Prologue_Size => False); + (CW_Membership => False, + IW_Membership => False, + DT_Entry_Size => False, + DT_Prologue_Size => False, + Get_Access_Level => False, + Get_Entry_Index => False, + Get_External_Tag => False, + Get_Predefined_Prim_Op_Address => False, + Get_Prim_Op_Address => False, + Get_Prim_Op_Kind => False, + Get_RC_Offset => False, + Get_Remotely_Callable => False, + Get_Tagged_Kind => False, + Inherit_DT => True, + Inherit_TSD => True, + Register_Interface_Tag => True, + Register_Tag => True, + Set_Access_Level => True, + Set_Entry_Index => True, + Set_Expanded_Name => True, + Set_External_Tag => True, + Set_Interface_Table => True, + Set_Offset_Index => True, + Set_OSD => True, + Set_Predefined_Prim_Op_Address => True, + Set_Prim_Op_Address => True, + Set_Prim_Op_Kind => True, + Set_RC_Offset => True, + Set_Remotely_Callable => True, + Set_Signature => True, + Set_SSD => True, + Set_TSD => True, + Set_Tagged_Kind => True, + TSD_Entry_Size => False, + TSD_Prologue_Size => False); Action_Nb_Arg : constant array (DT_Access_Action) of Int := - (CW_Membership => 2, - IW_Membership => 2, - DT_Entry_Size => 0, - DT_Prologue_Size => 0, - Get_Access_Level => 1, - Get_Entry_Index => 2, - Get_External_Tag => 1, - Get_Prim_Op_Address => 2, - Get_Prim_Op_Kind => 2, - Get_RC_Offset => 1, - Get_Remotely_Callable => 1, - Get_Tagged_Kind => 1, - Inherit_DT => 3, - Inherit_TSD => 2, - Register_Interface_Tag => 3, - Register_Tag => 1, - Set_Access_Level => 2, - Set_Entry_Index => 3, - Set_Expanded_Name => 2, - Set_External_Tag => 2, - Set_Interface_Table => 2, - Set_Offset_Index => 3, - Set_OSD => 2, - Set_Prim_Op_Address => 3, - Set_Prim_Op_Kind => 3, - Set_RC_Offset => 2, - Set_Remotely_Callable => 2, - Set_SSD => 2, - Set_TSD => 2, - Set_Tagged_Kind => 2, - TSD_Entry_Size => 0, - TSD_Prologue_Size => 0); + (CW_Membership => 2, + IW_Membership => 2, + DT_Entry_Size => 0, + DT_Prologue_Size => 0, + Get_Access_Level => 1, + Get_Entry_Index => 2, + Get_External_Tag => 1, + Get_Predefined_Prim_Op_Address => 2, + Get_Prim_Op_Address => 2, + Get_Prim_Op_Kind => 2, + Get_RC_Offset => 1, + Get_Remotely_Callable => 1, + Get_Tagged_Kind => 1, + Inherit_DT => 3, + Inherit_TSD => 2, + Register_Interface_Tag => 3, + Register_Tag => 1, + Set_Access_Level => 2, + Set_Entry_Index => 3, + Set_Expanded_Name => 2, + Set_External_Tag => 2, + Set_Interface_Table => 2, + Set_Offset_Index => 3, + Set_OSD => 2, + Set_Predefined_Prim_Op_Address => 3, + Set_Prim_Op_Address => 3, + Set_Prim_Op_Kind => 3, + Set_RC_Offset => 2, + Set_Remotely_Callable => 2, + Set_Signature => 2, + Set_SSD => 2, + Set_TSD => 2, + Set_Tagged_Kind => 2, + TSD_Entry_Size => 0, + TSD_Prologue_Size => 0); procedure Collect_All_Interfaces (T : Entity_Id); -- Ada 2005 (AI-251): Collect the whole list of interfaces that are -- directly or indirectly implemented by T. Used to compute the size -- of the table of interfaces. - function Default_Prim_Op_Position (Subp : Entity_Id) return Uint; + function Default_Prim_Op_Position (E : Entity_Id) return Uint; -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table -- of the default primitive operations. @@ -453,7 +464,7 @@ package body Exp_Disp is Next_Elmt (Elmt); end loop; - if not Present (Elmt) then + if No (Elmt) then Append_Elmt (Iface, Abstract_Interfaces (T)); end if; end Add_Interface; @@ -520,17 +531,10 @@ package body Exp_Disp is -- Default_Prim_Op_Position -- ------------------------------ - function Default_Prim_Op_Position (Subp : Entity_Id) return Uint is + function Default_Prim_Op_Position (E : Entity_Id) return Uint is TSS_Name : TSS_Name_Type; - E : Entity_Id := Subp; begin - -- Handle overriden subprograms - - while Present (Alias (E)) loop - E := Alias (E); - end loop; - Get_Name_String (Chars (E)); TSS_Name := TSS_Name_Type @@ -672,6 +676,8 @@ package body Exp_Disp is -- Start of processing for Expand_Dispatching_Call begin + Check_Restriction (No_Dispatching_Calls, Call_Node); + -- If this is an inherited operation that was overridden, the body -- that is being called is its alias. @@ -702,7 +708,8 @@ package body Exp_Disp is -- implementation of AI-260 (for the generic dispatching constructors). if Etype (Ctrl_Arg) = RTE (RE_Tag) - or else Etype (Ctrl_Arg) = RTE (RE_Interface_Tag) + or else (RTE_Available (RE_Interface_Tag) + and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)) then CW_Typ := Class_Wide_Type (Controlling_Type (Subp)); @@ -739,7 +746,6 @@ package body Exp_Disp is -- Generate the Tag checks when appropriate New_Params := New_List; - Param := First_Actual (Call_Node); while Present (Param) loop @@ -825,7 +831,7 @@ package body Exp_Disp is -- Generate the appropriate subprogram pointer type - if Etype (Subp) = Typ then + if Etype (Subp) = Typ then Res_Typ := CW_Typ; else Res_Typ := Etype (Subp); @@ -909,12 +915,20 @@ package body Exp_Disp is Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ); - -- If the controlling argument is a value of type Ada.Tag then - -- use it directly. Otherwise, the tag must be extracted from - -- the controlling object. + -- If the controlling argument is a value of type Ada.Tag or an abstract + -- interface class-wide type then use it directly. Otherwise, the tag + -- must be extracted from the controlling object. if Etype (Ctrl_Arg) = RTE (RE_Tag) - or else Etype (Ctrl_Arg) = RTE (RE_Interface_Tag) + or else (RTE_Available (RE_Interface_Tag) + and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)) + then + Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); + + -- Ada 2005 (AI-251): Abstract interface class-wide type + + elsif Is_Interface (Etype (Ctrl_Arg)) + and then Is_Class_Wide_Type (Etype (Ctrl_Arg)) then Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); @@ -928,19 +942,38 @@ package body Exp_Disp is -- Generate: -- Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos)); - New_Call_Name := - Unchecked_Convert_To (Subp_Ptr_Typ, - Make_DT_Access_Action (Typ, - Action => Get_Prim_Op_Address, - Args => New_List ( + if Is_Predefined_Dispatching_Operation (Subp) then + New_Call_Name := + Unchecked_Convert_To (Subp_Ptr_Typ, + Make_DT_Access_Action (Typ, + Action => Get_Predefined_Prim_Op_Address, + Args => New_List ( + + -- Vptr - -- Vptr + Unchecked_Convert_To (RTE (RE_Tag), + Controlling_Tag), - Controlling_Tag, + -- Position - -- Position + Make_Integer_Literal (Loc, DT_Position (Subp))))); + + else + New_Call_Name := + Unchecked_Convert_To (Subp_Ptr_Typ, + Make_DT_Access_Action (Typ, + Action => Get_Prim_Op_Address, + Args => New_List ( - Make_Integer_Literal (Loc, DT_Position (Subp))))); + -- Vptr + + Unchecked_Convert_To (RTE (RE_Tag), + Controlling_Tag), + + -- Position + + Make_Integer_Literal (Loc, DT_Position (Subp))))); + end if; if Nkind (Call_Node) = N_Function_Call then @@ -1060,6 +1093,14 @@ package body Exp_Disp is and then Is_Interface (Iface_Typ)); if not Is_Static then + + -- Give error if configurable run time and Displace not available + + if not RTE_Available (RE_Displace) then + Error_Msg_CRT ("abstract interface types", N); + return; + end if; + Rewrite (N, Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Displace), Loc), @@ -1086,8 +1127,10 @@ package body Exp_Disp is Set_Directly_Designated_Type (New_Itype, Class_Wide_Type (Iface_Typ)); - Rewrite (N, Unchecked_Convert_To (New_Itype, - Relocate_Node (N))); + Rewrite (N, Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (New_Itype, + Relocate_Node (N)))); + Analyze (N); end; return; @@ -1166,7 +1209,7 @@ package body Exp_Disp is Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, - Prefix => Relocate_Node (Expression (N)), + Prefix => Make_Identifier (Loc, Name_uO), Selector_Name => New_Occurrence_Of (Iface_Tag, Loc)), Attribute_Name => Name_Address)))))))); @@ -1455,6 +1498,13 @@ package body Exp_Disp is Next_Formal (E); end loop; + -- Give message if configurable run-time and Offset_To_Top unavailable + + if not RTE_Available (RE_Offset_To_Top) then + Error_Msg_CRT ("abstract interface types", N); + return Empty; + end if; + if Ekind (First_Formal (Target)) = E_In_Parameter and then Ekind (Etype (First_Formal (Target))) = E_Anonymous_Access_Type @@ -1501,12 +1551,10 @@ package body Exp_Disp is Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), Parameter_Associations => New_List ( - Make_Selected_Component (Loc, - Prefix => New_Reference_To - (Defining_Identifier (First (Formals)), - Loc), - Selector_Name => Make_Identifier (Loc, - Name_uTag)))))); + Unchecked_Convert_To + (RTE (RE_Address), + New_Reference_To + (Defining_Identifier (First (Formals)), Loc)))))); Append_To (Decl, Decl_2); Append_To (Decl, Decl_1); @@ -1546,12 +1594,11 @@ package body Exp_Disp is Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), Parameter_Associations => New_List ( - Make_Selected_Component (Loc, + Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Defining_Identifier (First (Formals)), Loc), - Selector_Name => Make_Identifier (Loc, - Name_uTag)))))); + Attribute_Name => Name_Address))))); Decl_2 := Make_Object_Declaration (Loc, @@ -1637,22 +1684,37 @@ package body Exp_Disp is Tag : constant Entity_Id := First_Tag_Component (Typ); begin - if Pos = Uint_0 or else Pos > DT_Entry_Count (Tag) then - raise Program_Error; - end if; + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); - return - Make_DT_Access_Action (Typ, - Action => Set_Prim_Op_Address, - Args => New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (DT_Ptr, Loc)), -- DTptr + if Is_Predefined_Dispatching_Operation (Prim) then + return + Make_DT_Access_Action (Typ, + Action => Set_Predefined_Prim_Op_Address, + Args => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), -- DTptr + + Make_Integer_Literal (Loc, Pos), -- Position + + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Address))); + else + pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); + + return + Make_DT_Access_Action (Typ, + Action => Set_Prim_Op_Address, + Args => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), -- DTptr - Make_Integer_Literal (Loc, Pos), -- Position + Make_Integer_Literal (Loc, Pos), -- Position - Make_Attribute_Reference (Loc, -- Value - Prefix => New_Reference_To (Prim, Loc), - Attribute_Name => Name_Address))); + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Address))); + end if; end Fill_DT_Entry; ----------------------------- @@ -1672,22 +1734,35 @@ package body Exp_Disp is First_Tag_Component (Scope (DTC_Entity (Iface_Prim))); begin - if Pos = Uint_0 or else Pos > DT_Entry_Count (Tag) then - raise Program_Error; - end if; + if Is_Predefined_Dispatching_Operation (Prim) then + return + Make_DT_Access_Action (Typ, + Action => Set_Predefined_Prim_Op_Address, + Args => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Iface_DT_Ptr, Loc)), -- DTptr - return - Make_DT_Access_Action (Typ, - Action => Set_Prim_Op_Address, - Args => New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (Iface_DT_Ptr, Loc)), -- DTptr + Make_Integer_Literal (Loc, Pos), -- Position - Make_Integer_Literal (Loc, Pos), -- Position + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (Thunk_Id, Loc), + Attribute_Name => Name_Address))); + else + pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); - Make_Attribute_Reference (Loc, -- Value - Prefix => New_Reference_To (Thunk_Id, Loc), - Attribute_Name => Name_Address))); + return + Make_DT_Access_Action (Typ, + Action => Set_Prim_Op_Address, + Args => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Iface_DT_Ptr, Loc)), -- DTptr + + Make_Integer_Literal (Loc, Pos), -- Position + + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (Thunk_Id, Loc), + Attribute_Name => Name_Address))); + end if; end Fill_Secondary_DT_Entry; --------------------------- @@ -1723,7 +1798,10 @@ package body Exp_Disp is -- No need to inherit primitives if we have an abstract interface -- type or a concurrent type. - if Is_Interface (Typ) or else Is_Concurrent_Record_Type (Typ) then + if Is_Interface (Typ) + or else Is_Concurrent_Record_Type (Typ) + or else Restriction_Active (No_Dispatching_Calls) + then return Result; end if; @@ -1734,7 +1812,7 @@ package body Exp_Disp is -- associated with predefined primitives. -- Generate: - -- Inherit_DT (T'Tag, Iface'Tag, Default_Prim_Op_Count); + -- Inherit_DT (T'Tag, Iface'Tag, 0); Append_To (Result, Make_DT_Access_Action (Typ, @@ -1743,7 +1821,7 @@ package body Exp_Disp is Node1 => New_Reference_To (DT_Ptr, Loc), Node2 => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To (Node (AI), Loc)), - Node3 => Make_Integer_Literal (Loc, Default_Prim_Op_Count)))); + Node3 => Make_Integer_Literal (Loc, Uint_0)))); Next_Elmt (AI); end loop; @@ -1765,6 +1843,8 @@ package body Exp_Disp is Stmts : constant List_Id := New_List; begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + -- Null body is generated for interface types if Is_Interface (Typ) then @@ -1911,6 +1991,8 @@ package body Exp_Disp is Params : constant List_Id := New_List; begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + -- "T" - Object parameter -- "S" - Primitive operation slot -- "P" - Wrapped parameters @@ -1946,6 +2028,8 @@ package body Exp_Disp is Stmts : constant List_Id := New_List; begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + -- Null body is generated for interface types if Is_Interface (Typ) then @@ -2152,6 +2236,8 @@ package body Exp_Disp is Params : constant List_Id := New_List; begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + -- "T" - Object parameter -- "S" - Primitive operation slot -- "P" - Wrapped parameters @@ -2183,6 +2269,8 @@ package body Exp_Disp is DT_Ptr : Entity_Id; begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + if Is_Interface (Typ) then return Make_Subprogram_Body (Loc, @@ -2240,6 +2328,8 @@ package body Exp_Disp is Params : constant List_Id := New_List; begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + -- "T" - Object parameter -- "S" - Primitive operation slot -- "C" - Call kind @@ -2267,6 +2357,8 @@ package body Exp_Disp is Ret : Node_Id; begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + if Is_Concurrent_Record_Type (Typ) and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type then @@ -2312,6 +2404,8 @@ package body Exp_Disp is Name_uDisp_Get_Task_Id); begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + Set_Is_Internal (Def_Id); return @@ -2341,6 +2435,8 @@ package body Exp_Disp is Stmts : constant List_Id := New_List; begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + -- Null body is generated for interface types if Is_Interface (Typ) then @@ -2515,6 +2611,8 @@ package body Exp_Disp is Params : constant List_Id := New_List; begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + -- "T" - Object parameter -- "S" - Primitive operation slot -- "P" - Wrapped parameters @@ -2590,6 +2688,7 @@ package body Exp_Disp is TSD_Num_Entries : Int; Ancestor_Copy : Entity_Id; + Empty_DT : Boolean := False; Typ_Copy : Entity_Id; begin @@ -2601,11 +2700,13 @@ package body Exp_Disp is -- Calculate the size of the DT and the TSD if Is_Interface (Typ) then + -- Abstract interfaces need neither the DT nor the ancestors table. -- We reserve a single entry for its DT because at run-time the -- pointer to this dummy DT will be used as the tag of this abstract -- interface type. + Empty_DT := True; Nb_Prim := 1; TSD_Num_Entries := 0; Num_Ifaces := 0; @@ -2669,12 +2770,14 @@ package body Exp_Disp is TSD_Num_Entries := I_Depth + 1; Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); - -- If the number of primitives of Typ is less that the number of - -- predefined primitives, we must reserve at least enough space - -- for the predefined primitives. + -- If the number of primitives of Typ is 0 (or we are compiling with + -- the No_Dispatching_Calls restriction) we reserve a dummy single + -- entry for its DT because at run-time the pointer to this dummy DT + -- will be used as the tag of this tagged type. - if Nb_Prim < Default_Prim_Op_Count then - Nb_Prim := Default_Prim_Op_Count; + if Nb_Prim = 0 or else Restriction_Active (No_Dispatching_Calls) then + Empty_DT := True; + Nb_Prim := 1; end if; end if; @@ -2746,52 +2849,6 @@ package body Exp_Disp is Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); - -- Initialize the signature of the interface tag. It is a sequence - -- two bytes located in the header of the dispatch table. - - Append_To (Result, - Make_Assignment_Statement (Loc, - Name => - Make_Indexed_Component (Loc, - Prefix => New_Occurrence_Of (DT, Loc), - Expressions => New_List ( - Make_Integer_Literal (Loc, Uint_1))), - Expression => - Unchecked_Convert_To (RTE (RE_Storage_Element), - New_Reference_To (RTE (RE_Valid_Signature), Loc)))); - - if not Is_Interface (Typ) then - - -- The signature of a Primary Dispatch table is: - -- (Valid_Signature, Primary_DT) - - Append_To (Result, - Make_Assignment_Statement (Loc, - Name => - Make_Indexed_Component (Loc, - Prefix => New_Occurrence_Of (DT, Loc), - Expressions => New_List ( - Make_Integer_Literal (Loc, Uint_2))), - Expression => - Unchecked_Convert_To (RTE (RE_Storage_Element), - New_Reference_To (RTE (RE_Primary_DT), Loc)))); - - else - -- The signature of an abstract interface is: - -- (Valid_Signature, Abstract_Interface) - - Append_To (Result, - Make_Assignment_Statement (Loc, - Name => - Make_Indexed_Component (Loc, - Prefix => New_Occurrence_Of (DT, Loc), - Expressions => New_List ( - Make_Integer_Literal (Loc, Uint_2))), - Expression => - Unchecked_Convert_To (RTE (RE_Storage_Element), - New_Reference_To (RTE (RE_Abstract_Interface), Loc)))); - end if; - -- Generate code to create the pointer to the dispatch table -- DT_Ptr : Tag := Tag!(DT'Address); @@ -2829,7 +2886,7 @@ package body Exp_Disp is -- Set Access_Disp_Table field to be the dispatch table pointer - if not Present (Access_Disp_Table (Typ)) then + if No (Access_Disp_Table (Typ)) then Set_Access_Disp_Table (Typ, New_Elmt_List); end if; @@ -2876,6 +2933,26 @@ package body Exp_Disp is Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); + -- Generate: + -- Set_Signature (DT_Ptr, Value); + + if Is_Interface (Typ) then + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Signature, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + New_Reference_To (RTE (RE_Abstract_Interface), Loc)))); + + elsif RTE_Available (RE_Set_Signature) then + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Signature, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + New_Reference_To (RTE (RE_Primary_DT), Loc)))); + end if; + -- Generate code to put the Address of the TSD in the dispatch table -- Set_TSD (DT_Ptr, TSD); @@ -2895,17 +2972,19 @@ package body Exp_Disp is null; elsif Num_Ifaces = 0 then - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Set_Interface_Table, - Args => New_List ( - New_Reference_To (DT_Ptr, Loc), -- DTptr - New_Reference_To (RTE (RE_Null_Address), Loc)))); -- null + if RTE_Available (RE_Set_Interface_Table) then + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Interface_Table, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + New_Reference_To (RTE (RE_Null_Address), Loc)))); -- null + end if; -- Generate the Interface_Table object and set the access -- component if the TSD to it. - else + elsif RTE_Available (RE_Set_Interface_Table) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => ITable, @@ -2932,65 +3011,77 @@ package body Exp_Disp is -- Generate: -- Set_Num_Prim_Ops (T'Tag, Nb_Prim) - if not Is_Interface (Typ) then - Append_To (Elab_Code, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), - Parameter_Associations => New_List ( - New_Reference_To (DT_Ptr, Loc), - Make_Integer_Literal (Loc, Nb_Prim)))); - end if; - - if Ada_Version >= Ada_05 - and then not Is_Interface (Typ) - and then not Is_Abstract (Typ) - and then not Is_Controlled (Typ) - then - -- Generate: - -- Set_Type_Kind (T'Tag, Type_Kind (Typ)); - - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Set_Tagged_Kind, - Args => New_List ( - New_Reference_To (DT_Ptr, Loc), -- DTptr - Tagged_Kind (Typ)))); -- Value - - -- Generate the Select Specific Data table for synchronized - -- types that implement a synchronized interface. The size - -- of the table is constrained by the number of non-predefined - -- primitive operations. + if RTE_Available (RE_Set_Num_Prim_Ops) then + if not Is_Interface (Typ) then + if Empty_DT then + Append_To (Elab_Code, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), + Parameter_Associations => New_List ( + New_Reference_To (DT_Ptr, Loc), + Make_Integer_Literal (Loc, Uint_0)))); + else + Append_To (Elab_Code, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), + Parameter_Associations => New_List ( + New_Reference_To (DT_Ptr, Loc), + Make_Integer_Literal (Loc, Nb_Prim)))); + end if; + end if; - if Is_Concurrent_Record_Type (Typ) - and then Implements_Interface ( - Typ => Typ, - Kind => Any_Limited_Interface, - Check_Parent => True) - and then (Nb_Prim - Default_Prim_Op_Count) > 0 + if Ada_Version >= Ada_05 + and then not Is_Interface (Typ) + and then not Is_Abstract (Typ) + and then not Is_Controlled (Typ) + and then not Restriction_Active (No_Dispatching_Calls) then - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => SSD, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Reference_To ( - RTE (RE_Select_Specific_Data), Loc), - Constraint => Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Integer_Literal (Loc, - Nb_Prim - Default_Prim_Op_Count)))))); - - -- Set the pointer to the Select Specific Data table in the TSD + -- Generate: + -- Set_Type_Kind (T'Tag, Type_Kind (Typ)); Append_To (Elab_Code, Make_DT_Access_Action (Typ, - Action => Set_SSD, + Action => Set_Tagged_Kind, Args => New_List ( - New_Reference_To (DT_Ptr, Loc), -- DTptr - Make_Attribute_Reference (Loc, -- Value - Prefix => New_Reference_To (SSD, Loc), - Attribute_Name => Name_Address)))); + New_Reference_To (DT_Ptr, Loc), -- DTptr + Tagged_Kind (Typ)))); -- Value + + -- Generate the Select Specific Data table for synchronized + -- types that implement a synchronized interface. The size + -- of the table is constrained by the number of non-predefined + -- primitive operations. + + if not Empty_DT + and then Is_Concurrent_Record_Type (Typ) + and then Implements_Interface ( + Typ => Typ, + Kind => Any_Limited_Interface, + Check_Parent => True) + then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => SSD, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To ( + RTE (RE_Select_Specific_Data), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, Nb_Prim)))))); + + -- Set the pointer to the Select Specific Data table in the TSD + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_SSD, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (SSD, Loc), + Attribute_Name => Name_Address)))); + end if; end if; end if; @@ -3052,24 +3143,37 @@ package body Exp_Disp is if Typ /= Etype (Typ) and then not Is_Interface (Typ) + and then not Restriction_Active (No_Dispatching_Calls) then -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent); if not Is_Interface (Etype (Typ)) then - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Inherit_DT, - Args => New_List ( - Node1 => Old_Tag1, - Node2 => New_Reference_To (DT_Ptr, Loc), - Node3 => - Make_Integer_Literal (Loc, - DT_Entry_Count (First_Tag_Component (Etype (Typ))))))); + if Restriction_Active (No_Dispatching_Calls) then + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Inherit_DT, + Args => New_List ( + Node1 => Old_Tag1, + Node2 => New_Reference_To (DT_Ptr, Loc), + Node3 => Make_Integer_Literal (Loc, Uint_0)))); + else + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Inherit_DT, + Args => New_List ( + Node1 => Old_Tag1, + Node2 => New_Reference_To (DT_Ptr, Loc), + Node3 => Make_Integer_Literal (Loc, + DT_Entry_Count + (First_Tag_Component (Etype (Typ))))))); + end if; end if; -- Inherit the secondary dispatch tables of the ancestor - if not Is_CPP_Class (Etype (Typ)) then + if not Restriction_Active (No_Dispatching_Calls) + and then not Is_CPP_Class (Etype (Typ)) + then declare Sec_DT_Ancestor : Elmt_Id := Next_Elmt @@ -3089,8 +3193,8 @@ package body Exp_Disp is ------------------------ procedure Copy_Secondary_DTs (Typ : Entity_Id) is - E : Entity_Id; - Iface : Elmt_Id; + E : Entity_Id; + Iface : Elmt_Id; begin -- Climb to the ancestor (if any) handling private types @@ -3110,7 +3214,6 @@ package body Exp_Disp is then Iface := First_Elmt (Abstract_Interfaces (Typ)); E := First_Entity (Typ); - while Present (E) and then Present (Node (Sec_DT_Ancestor)) loop @@ -3168,23 +3271,24 @@ package body Exp_Disp is Node1 => Old_Tag2, Node2 => New_Reference_To (DT_Ptr, Loc)))); - -- For types with no controlled components, generate: - -- Set_RC_Offset (DT_Ptr, 0); + if not Is_Interface (Typ) then - -- For simple types with controlled components, generate: - -- Set_RC_Offset (DT_Ptr, type._record_controller'position); + -- For types with no controlled components, generate: + -- Set_RC_Offset (DT_Ptr, 0); - -- For complex types with controlled components where the position - -- of the record controller is not statically computable, if there are - -- controlled components at this level, generate: - -- Set_RC_Offset (DT_Ptr, -1); - -- to indicate that the _controller field is right after the _parent + -- For simple types with controlled components, generate: + -- Set_RC_Offset (DT_Ptr, type._record_controller'position); - -- Or if there are no controlled components at this level, generate: - -- Set_RC_Offset (DT_Ptr, -2); - -- to indicate that we need to get the position from the parent. + -- For complex types with controlled components where the position + -- of the record controller is not statically computable, if there + -- are controlled components at this level, generate: + -- Set_RC_Offset (DT_Ptr, -1); + -- to indicate that the _controller field is right after the _parent + + -- Or if there are no controlled components at this level, generate: + -- Set_RC_Offset (DT_Ptr, -2); + -- to indicate that we need to get the position from the parent. - if not Is_Interface (Typ) then declare Position : Node_Id; @@ -3258,16 +3362,20 @@ package body Exp_Disp is New_Occurrence_Of (Status, Loc)))); end; - -- Generate: - -- Set_Offset_To_Top (0, DT_Ptr, 0); + if RTE_Available (RE_Set_Offset_To_Top) then + -- Generate: + -- Set_Offset_To_Top (0, DT_Ptr, True, 0, null); - Append_To (Elab_Code, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc), - Parameter_Associations => New_List ( - New_Reference_To (RTE (RE_Null_Address), Loc), - New_Reference_To (DT_Ptr, Loc), - Make_Integer_Literal (Loc, Uint_0)))); + Append_To (Elab_Code, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + New_Reference_To (RTE (RE_Null_Address), Loc), + New_Reference_To (DT_Ptr, Loc), + New_Occurrence_Of (Standard_True, Loc), + Make_Integer_Literal (Loc, Uint_0), + New_Reference_To (RTE (RE_Null_Address), Loc)))); + end if; end if; -- Generate: Set_External_Tag (DT_Ptr, exname'Address); @@ -3284,15 +3392,15 @@ package body Exp_Disp is Prefix => New_Reference_To (Exname, Loc), Attribute_Name => Name_Address)))); - -- Generate code to register the Tag in the External_Tag hash - -- table for the pure Ada type only. + -- Generate code to register the Tag in the External_Tag hash + -- table for the pure Ada type only. - -- Register_Tag (Dt_Ptr); + -- Register_Tag (Dt_Ptr); - -- Skip this if routine not available, or in No_Run_Time mode - -- or Typ is an abstract interface type (because the table to - -- register it is not available in the abstract type but in - -- types implementing this interface) + -- Skip this if routine not available, or in No_Run_Time mode + -- or Typ is an abstract interface type (because the table to + -- register it is not available in the abstract type but in + -- types implementing this interface) if not No_Run_Time_Mode and then RTE_Available (RE_Register_Tag) @@ -3459,6 +3567,7 @@ package body Exp_Disp is Loc : constant Source_Ptr := Sloc (AI_Tag); Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag); Name_DT : constant Name_Id := New_Internal_Name ('T'); + Empty_DT : Boolean := False; Iface_DT : Node_Id; Iface_DT_Ptr : Node_Id; Name_DT_Ptr : Name_Id; @@ -3493,14 +3602,15 @@ package body Exp_Disp is Set_Is_Statically_Allocated (Iface_DT_Ptr); -- Generate code to create the storage for the Dispatch_Table object. - -- If the number of primitives of Typ is less that the number of - -- predefined primitives, we must reserve at least enough space - -- for the predefined primitives. + -- If the number of primitives of Typ is 0 we reserve a dummy single + -- entry for its DT because at run-time the pointer to this dummy entry + -- will be used as the tag. Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag)); - if Nb_Prim < Default_Prim_Op_Count then - Nb_Prim := Default_Prim_Op_Count; + if Nb_Prim = 0 then + Empty_DT := True; + Nb_Prim := 1; end if; -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size); @@ -3542,32 +3652,6 @@ package body Exp_Disp is Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); - -- Initialize the signature of the interface tag. It is a sequence of - -- two bytes located in the header of the dispatch table. The signature - -- of a Secondary Dispatch Table is (Valid_Signature, Secondary_DT). - - Append_To (Result, - Make_Assignment_Statement (Loc, - Name => - Make_Indexed_Component (Loc, - Prefix => New_Occurrence_Of (Iface_DT, Loc), - Expressions => New_List ( - Make_Integer_Literal (Loc, Uint_1))), - Expression => - Unchecked_Convert_To (RTE (RE_Storage_Element), - New_Reference_To (RTE (RE_Valid_Signature), Loc)))); - - Append_To (Result, - Make_Assignment_Statement (Loc, - Name => - Make_Indexed_Component (Loc, - Prefix => New_Occurrence_Of (Iface_DT, Loc), - Expressions => New_List ( - Make_Integer_Literal (Loc, Uint_2))), - Expression => - Unchecked_Convert_To (RTE (RE_Storage_Element), - New_Reference_To (RTE (RE_Secondary_DT), Loc)))); - -- Generate code to create the pointer to the dispatch table -- Iface_DT_Ptr : Tag := Tag!(DT'Address); @@ -3607,9 +3691,16 @@ package body Exp_Disp is OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + -- Nothing to do if configurable run time does not support the + -- Object_Specific_Data entity. + + if not RTE_Available (RE_Object_Specific_Data) then + Error_Msg_CRT ("abstract interface types", Typ); + return; + end if; + -- Generate: - -- OSD : Ada.Tags.Object_Specific_Data - -- (Nb_Prims - Default_Prim_Op_Count); + -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims); -- where the constraint is used to allocate space for the -- non-predefined primitive operations only. @@ -3623,8 +3714,15 @@ package body Exp_Disp is Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( - Make_Integer_Literal (Loc, - Nb_Prim - Default_Prim_Op_Count + 1)))))); + Make_Integer_Literal (Loc, Nb_Prim)))))); + + Append_To (Result, + Make_DT_Access_Action (Typ, + Action => Set_Signature, + Args => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Iface_DT_Ptr, Loc)), + New_Reference_To (RTE (RE_Secondary_DT), Loc)))); -- Generate: -- Ada.Tags.Set_OSD (Iface_DT_Ptr, OSD); @@ -3642,18 +3740,32 @@ package body Exp_Disp is -- Generate: -- Set_Num_Prim_Ops (T'Tag, Nb_Prim) - Append_To (Result, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), - Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (Iface_DT_Ptr, Loc)), - Make_Integer_Literal (Loc, Nb_Prim)))); + if RTE_Available (RE_Set_Num_Prim_Ops) then + if Empty_DT then + Append_To (Result, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Iface_DT_Ptr, Loc)), + Make_Integer_Literal (Loc, Uint_0)))); + else + Append_To (Result, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Iface_DT_Ptr, Loc)), + Make_Integer_Literal (Loc, Nb_Prim)))); + end if; + end if; if Ada_Version >= Ada_05 and then not Is_Interface (Typ) and then not Is_Abstract (Typ) and then not Is_Controlled (Typ) + and then RTE_Available (RE_Set_Tagged_Kind) + and then not Restriction_Active (No_Dispatching_Calls) then -- Generate: -- Set_Tagged_Kind (Iface'Tag, Tagged_Kind (Iface)); @@ -3666,12 +3778,12 @@ package body Exp_Disp is New_Reference_To (Iface_DT_Ptr, Loc)), Tagged_Kind (Typ)))); -- Value - if Is_Concurrent_Record_Type (Typ) + if not Empty_DT + and then Is_Concurrent_Record_Type (Typ) and then Implements_Interface ( Typ => Typ, Kind => Any_Limited_Interface, Check_Parent => True) - and then (Nb_Prim - Default_Prim_Op_Count) > 0 then declare Prim : Entity_Id; @@ -3729,14 +3841,14 @@ package body Exp_Disp is Assignments : constant List_Id := New_List; Loc : constant Source_Ptr := Sloc (Typ); - Conc_Typ : Entity_Id; - Decls : List_Id; - DT_Ptr : Entity_Id; - Prim : Entity_Id; - Prim_Als : Entity_Id; - Prim_Elmt : Elmt_Id; - Prim_Pos : Uint; - Nb_Prim : Int := 0; + Conc_Typ : Entity_Id; + Decls : List_Id; + DT_Ptr : Entity_Id; + Prim : Entity_Id; + Prim_Als : Entity_Id; + Prim_Elmt : Elmt_Id; + Prim_Pos : Uint; + Nb_Prim : Int := 0; type Examined_Array is array (Int range <>) of Boolean; @@ -3776,6 +3888,8 @@ package body Exp_Disp is -- Start of processing for Make_Select_Specific_Data_Table begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); if Present (Corresponding_Concurrent_Type (Typ)) then @@ -3803,8 +3917,7 @@ package body Exp_Disp is end loop; declare - Examined_Size : constant Int := Nb_Prim + Default_Prim_Op_Count; - Examined : Examined_Array (1 .. Examined_Size) := (others => False); + Examined : Examined_Array (1 .. Nb_Prim) := (others => False); begin Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); @@ -3812,64 +3925,69 @@ package body Exp_Disp is Prim := Node (Prim_Elmt); Prim_Pos := DT_Position (Prim); - pragma Assert (UI_To_Int (Prim_Pos) <= Examined_Size); - - if Examined (UI_To_Int (Prim_Pos)) then - goto Continue; - else - Examined (UI_To_Int (Prim_Pos)) := True; - end if; - - -- The current primitive overrides an interface-level subprogram - - if Present (Abstract_Interface_Alias (Prim)) then - - -- Set the primitive operation kind regardless of subprogram - -- type. Generate: - -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, , ); + if not Is_Predefined_Dispatching_Operation (Prim) then + pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim); - Append_To (Assignments, - Make_DT_Access_Action (Typ, - Action => - Set_Prim_Op_Kind, - Args => - New_List ( - New_Reference_To (DT_Ptr, Loc), - Make_Integer_Literal (Loc, Prim_Pos), - Prim_Op_Kind (Prim, Typ)))); - - -- Retrieve the root of the alias chain if one is present - - if Present (Alias (Prim)) then - Prim_Als := Prim; - while Present (Alias (Prim_Als)) loop - Prim_Als := Alias (Prim_Als); - end loop; + if Examined (UI_To_Int (Prim_Pos)) then + goto Continue; else - Prim_Als := Empty; + Examined (UI_To_Int (Prim_Pos)) := True; end if; - -- In the case of an entry wrapper, set the entry index + -- The current primitive overrides an interface-level + -- subprogram - if Ekind (Prim) = E_Procedure - and then Present (Prim_Als) - and then Is_Primitive_Wrapper (Prim_Als) - and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry - then + if Present (Abstract_Interface_Alias (Prim)) then - -- Generate: - -- Ada.Tags.Set_Entry_Index (DT_Ptr, , ); + -- Set the primitive operation kind regardless of subprogram + -- type. Generate: + -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, , ); Append_To (Assignments, Make_DT_Access_Action (Typ, Action => - Set_Entry_Index, + Set_Prim_Op_Kind, Args => New_List ( New_Reference_To (DT_Ptr, Loc), Make_Integer_Literal (Loc, Prim_Pos), - Make_Integer_Literal (Loc, - Find_Entry_Index (Wrapped_Entity (Prim_Als)))))); + Prim_Op_Kind (Prim, Typ)))); + + -- Retrieve the root of the alias chain if one is present + + if Present (Alias (Prim)) then + Prim_Als := Prim; + while Present (Alias (Prim_Als)) loop + Prim_Als := Alias (Prim_Als); + end loop; + else + Prim_Als := Empty; + end if; + + -- In the case of an entry wrapper, set the entry index + + if Ekind (Prim) = E_Procedure + and then Present (Prim_Als) + and then Is_Primitive_Wrapper (Prim_Als) + and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry + then + + -- Generate: + -- Ada.Tags.Set_Entry_Index + -- (DT_Ptr, , ); + + Append_To (Assignments, + Make_DT_Access_Action (Typ, + Action => + Set_Entry_Index, + Args => + New_List ( + New_Reference_To (DT_Ptr, Loc), + Make_Integer_Literal (Loc, Prim_Pos), + Make_Integer_Literal (Loc, + Find_Entry_Index + (Wrapped_Entity (Prim_Als)))))); + end if; end if; end if; @@ -3919,11 +4037,12 @@ package body Exp_Disp is is Full_Typ : Entity_Id := Typ; Loc : constant Source_Ptr := Sloc (Prim); - Prim_Op : Entity_Id := Prim; + Prim_Op : Entity_Id; begin -- Retrieve the original primitive operation + Prim_Op := Prim; while Present (Alias (Prim_Op)) loop Prim_Op := Alias (Prim_Op); end loop; @@ -4037,8 +4156,8 @@ package body Exp_Disp is if Present (Abstract_Interface_Alias (Node (Prim_Elmt))) then null; - -- Predefined dispatching operations are completely safe. - -- They are allocated at fixed positions. + -- Predefined dispatching operations are completely safe. They + -- are allocated at fixed positions in a separate table. elsif Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then null; @@ -4266,8 +4385,7 @@ package body Exp_Disp is end loop; declare - Fixed_Prim : array (Int range 0 .. Default_Prim_Op_Count + - Parent_EC + Count_Prim) + Fixed_Prim : array (Int range 0 .. Parent_EC + Count_Prim) of Boolean := (others => False); E : Entity_Id; @@ -4275,17 +4393,16 @@ package body Exp_Disp is begin -- Second stage: Register fixed entries - Nb_Prim := Default_Prim_Op_Count; + Nb_Prim := 0; Prim_Elmt := First_Prim; while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); - -- Predefined primitives have a fixed position in all the - -- dispatch tables + -- Predefined primitives have a separate table and all its + -- entries are at predefined fixed positions if Is_Predefined_Dispatching_Operation (Prim) then Set_DT_Position (Prim, Default_Prim_Op_Position (Prim)); - Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True; -- Overriding interface primitives of an ancestor @@ -4355,7 +4472,10 @@ package body Exp_Disp is -- Skip primitives previously set entries - if DT_Position (Prim) /= No_Uint then + if Is_Predefined_Dispatching_Operation (Prim) then + null; + + elsif DT_Position (Prim) /= No_Uint then null; elsif Etype (DTC_Entity (Prim)) /= RTE (RE_Tag) then @@ -4442,14 +4562,18 @@ package body Exp_Disp is -- Calculate real size of the dispatch table - if UI_To_Int (DT_Position (Prim)) > DT_Length then + if not Is_Predefined_Dispatching_Operation (Prim) + and then UI_To_Int (DT_Position (Prim)) > DT_Length + then DT_Length := UI_To_Int (DT_Position (Prim)); end if; - -- Ensure that the asignated position in the dispatch - -- table is correct + -- Ensure that the asignated position to non-predefined + -- dispatching operations in the dispatch table is correct. - Validate_Position (Prim); + if not Is_Predefined_Dispatching_Operation (Prim) then + Validate_Position (Prim); + end if; if Chars (Prim) = Name_Finalize then Finalized := True; @@ -4591,7 +4715,8 @@ package body Exp_Disp is Loc : constant Source_Ptr := Sloc (T); begin - pragma Assert (Is_Tagged_Type (T)); + pragma Assert + (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind)); -- Abstract kinds @@ -4676,6 +4801,11 @@ package body Exp_Disp is Write_Int (Int (Prim)); Write_Str (": "); + + if Is_Predefined_Dispatching_Operation (Prim) then + Write_Str ("(predefined) "); + end if; + Write_Name (Chars (Prim)); -- Indicate if this primitive has an aliased primitive diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index a0f6b18672d..50f1a6b2f26 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -136,12 +136,8 @@ package Exp_Disp is -- Guidelines for addition of new predefined primitive operations - -- Update the value of constant Default_Prim_Op_Count in Exp_Disp.ads - -- to reflect the new number of PPOs. - -- Update the value of constant Default_Prim_Op_Count in A-Tags.ads - -- to reflect the new number of PPOs. This value should be the same - -- as the one in Exp_Disp.ads. + -- to reflect the new number of PPOs. -- Introduce a new predefined name for the new PPO in Snames.ads and -- Snames.adb. @@ -149,9 +145,6 @@ package Exp_Disp is -- Categorize the new PPO name as predefined by adding an entry in -- Is_Predefined_Dispatching_Operation in Exp_Util.adb. - -- Reserve a dispatch table position for the new PPO by adding an entry - -- in Default_Prim_Op_Position in Exp_Disp.adb. - -- Generate the specification of the new PPO in Make_Predefined_ -- Primitive_Spec in Exp_Ch3.adb. The Is_Internal flag of the defining -- identifier of the specification must be set to True. @@ -174,8 +167,6 @@ package Exp_Disp is -- Exp_Disp.Default_Prim_Op_Position - indirect use -- Exp_Disp.Set_All_DT_Position - direct use - Default_Prim_Op_Count : constant Int := 15; - type DT_Access_Action is (CW_Membership, IW_Membership, @@ -184,6 +175,7 @@ package Exp_Disp is Get_Access_Level, Get_Entry_Index, Get_External_Tag, + Get_Predefined_Prim_Op_Address, Get_Prim_Op_Address, Get_Prim_Op_Kind, Get_RC_Offset, @@ -200,10 +192,12 @@ package Exp_Disp is Set_Interface_Table, Set_Offset_Index, Set_OSD, + Set_Predefined_Prim_Op_Address, Set_Prim_Op_Address, Set_Prim_Op_Kind, Set_RC_Offset, Set_Remotely_Callable, + Set_Signature, Set_SSD, Set_TSD, Set_Tagged_Kind, -- 2.30.2