From: Javier Miranda Date: Thu, 7 Jul 2005 09:42:10 +0000 (+0200) Subject: exp_ch3.adb (Build_Record_Init_Proc/Freeze_Record_Type): Reimplementation of the... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=3ca505dc9c40cdb738dc6acec445a31b32a950e7;p=gcc.git exp_ch3.adb (Build_Record_Init_Proc/Freeze_Record_Type): Reimplementation of the support for abstract interface types in order to leave... 2005-07-07 Javier Miranda * exp_ch3.adb (Build_Record_Init_Proc/Freeze_Record_Type): Reimplementation of the support for abstract interface types in order to leave the code more clear and easy to maintain. * exp_ch6.adb (Freeze_Subprogram): Reimplementation of the support for abstract interface types in order to leave the code clearer and easier to maintain. * exp_disp.ads, exp_disp.adb (Fill_DT_Entry): Part of its functionality is now implemented by the new subprogram Fill_Secondary_DT_Entry. (Fill_Secondary_DT_Entry): Generate the code necessary to fill the appropriate entry of the secondary dispatch table. (Make_DT): Add code to inherit the secondary dispatch tables of the ancestors. * exp_util.adb (Find_Interface_Tag/Find_Interface_ADT): Instead of implementing both functionalities by means of a common routine, each routine has its own code. From-SVN: r101694 --- diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index c4ff3af8aed..465a792e495 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1361,10 +1361,6 @@ package body Exp_Ch3 is Rec_Type : Entity_Id; Set_Tag : Entity_Id := Empty; - ADT : Elmt_Id; - Aux_N : Node_Id; - Aux_Comp : Node_Id; - 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 left hand side @@ -1735,6 +1731,100 @@ package body Exp_Ch3 is Record_Extension_Node : Node_Id; Init_Tag : Node_Id; + procedure Init_Secondary_Tags (Typ : Entity_Id); + -- Ada 2005 (AI-251): Initialize the tags of all the secondary + -- tables associated with abstract interface types + + ------------------------- + -- Init_Secondary_Tags -- + ------------------------- + + procedure Init_Secondary_Tags (Typ : Entity_Id) is + ADT : Elmt_Id; + + procedure Init_Secondary_Tags_Internal (Typ : Entity_Id); + -- Internal subprogram used to recursively climb to the root type + + ---------------------------------- + -- Init_Secondary_Tags_Internal -- + ---------------------------------- + + procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is + E : Entity_Id; + Aux_N : Node_Id; + + begin + if not Is_Interface (Typ) + and then Etype (Typ) /= Typ + then + Init_Secondary_Tags_Internal (Etype (Typ)); + end if; + + if Present (Abstract_Interfaces (Typ)) + and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) + then + E := First_Entity (Typ); + while Present (E) loop + if Is_Tag (E) + and then Chars (E) /= Name_uTag + then + Aux_N := Node (ADT); + pragma Assert (Present (Aux_N)); + + -- Initialize the pointer to the secondary DT + -- associated with the interface + + Append_To (Body_Stmts, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => + New_Reference_To (E, Loc)), + Expression => + New_Reference_To (Aux_N, Loc))); + + -- Generate: + -- Set_Offset_To_Top (DT_Ptr, n); + + Append_To (Body_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To + (RTE (RE_Set_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Aux_N, Loc)), + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, + Name_uInit), + Selector_Name => New_Reference_To + (E, Loc)), + Attribute_Name => Name_Position))))); + + Next_Elmt (ADT); + end if; + + Next_Entity (E); + end loop; + end if; + end Init_Secondary_Tags_Internal; + + -- Start of processing for Init_Secondary_Tags + + begin + -- Skip the first _Tag, which is the main tag of the + -- tagged type. Following tags correspond with abstract + -- interfaces. + + ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); + Init_Secondary_Tags_Internal (Typ); + end Init_Secondary_Tags; + + -- Start of processing for Build_Init_Procedure + begin Body_Stmts := New_List; Body_Node := New_Node (N_Subprogram_Body, Loc); @@ -1864,55 +1954,10 @@ package body Exp_Ch3 is -- Ada 2005 (AI-251): Initialization of all the tags -- corresponding with abstract interfaces - if Present (First_Tag_Component (Rec_Type)) then - - -- Skip the first _Tag, which is the main tag of the - -- tagged type. Following tags correspond with abstract - -- interfaces. - - Aux_Comp := - Next_Tag_Component (First_Tag_Component (Rec_Type)); - - ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Rec_Type))); - while Present (ADT) loop - Aux_N := Node (ADT); - - -- Initialize the pointer to the secondary DT associated - -- with the interface - - Append_To (Body_Stmts, - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => - New_Reference_To (Aux_Comp, Loc)), - Expression => - New_Reference_To (Aux_N, Loc))); - - -- Generate: - -- Set_Offset_To_Top (DT_Ptr, n); - - Append_To (Body_Stmts, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), - Loc), - Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (Aux_N, Loc)), - Unchecked_Convert_To (RTE (RE_Storage_Offset), - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, - Name_uInit), - Selector_Name => New_Reference_To - (Aux_Comp, Loc)), - Attribute_Name => Name_Position))))); - - Aux_Comp := Next_Tag_Component (Aux_Comp); - Next_Elmt (ADT); - end loop; + if Ada_Version >= Ada_05 + and then not Is_Interface (Rec_Type) + then + Init_Secondary_Tags (Rec_Type); end if; else @@ -4480,36 +4525,6 @@ package body Exp_Ch3 is Expand_Tagged_Root (Def_Id); end if; - -- Build the secondary tables - - if not Java_VM - and then Present (Abstract_Interfaces (Def_Id)) - and then not Is_Empty_Elmt_List (Abstract_Interfaces (Def_Id)) - then - declare - E : Entity_Id; - Result : List_Id; - ADT : Elist_Id := Access_Disp_Table (Def_Id); - - begin - E := First_Entity (Def_Id); - while Present (E) loop - if Is_Tag (E) and then Chars (E) /= Name_uTag then - Make_Abstract_Interface_DT - (AI_Tag => E, - Acc_Disp_Tables => ADT, - Result => Result); - - Append_Freeze_Actions (Def_Id, Result); - end if; - - Next_Entity (E); - end loop; - - Set_Access_Disp_Table (Def_Id, ADT); - end; - end if; - -- Unfreeze momentarily the type to add the predefined primitives -- operations. The reason we unfreeze is so that these predefined -- operations will indeed end up as primitive operations (which @@ -4533,7 +4548,55 @@ package body Exp_Ch3 is -- dispatching mechanism is handled internally by the JVM. if not Java_VM then - Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); + + -- Ada 2005 (AI-251): Build the secondary dispatch tables + + declare + ADT : Elist_Id := Access_Disp_Table (Def_Id); + + procedure Add_Secondary_Tables (Typ : Entity_Id); + -- Comment required ??? + + -------------------------- + -- Add_Secondary_Tables -- + -------------------------- + + procedure Add_Secondary_Tables (Typ : Entity_Id) is + E : Entity_Id; + Result : List_Id; + + begin + if Etype (Typ) /= Typ then + Add_Secondary_Tables (Etype (Typ)); + end if; + + if Present (Abstract_Interfaces (Typ)) + and then not Is_Empty_Elmt_List + (Abstract_Interfaces (Typ)) + then + E := First_Entity (Typ); + while Present (E) loop + if Is_Tag (E) and then Chars (E) /= Name_uTag then + Make_Abstract_Interface_DT + (AI_Tag => E, + Acc_Disp_Tables => ADT, + Result => Result); + + Append_Freeze_Actions (Def_Id, Result); + end if; + + Next_Entity (E); + end loop; + end if; + end Add_Secondary_Tables; + + -- Start of processing to build secondary dispatch tables + + begin + Add_Secondary_Tables (Def_Id); + Set_Access_Disp_Table (Def_Id, ADT); + Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); + end; end if; -- Make sure that the primitives Initialize, Adjust and Finalize @@ -5681,7 +5744,7 @@ package body Exp_Ch3 is Ret_Type => Standard_Integer)); - -- Specs for dispatching stream attributes. + -- Specs for dispatching stream attributes declare Stream_Op_TSS_Names : diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index ee7278cc426..41620784065 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -4062,37 +4062,157 @@ package body Exp_Ch6 is procedure Freeze_Subprogram (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); E : constant Entity_Id := Entity (N); - Thunk_Id : Entity_Id; - Iface_Tag : Entity_Id; - New_Thunk : Node_Id; - begin - -- When a primitive is frozen, enter its name in the corresponding - -- dispatch table. If the DTC_Entity field is not set this is an - -- overridden primitive that can be ignored. We suppress the - -- initialization of the dispatch table entry when Java_VM because - -- the dispatching mechanism is handled internally by the JVM. + procedure Check_Overriding_Inherited_Interfaces (E : Entity_Id); + -- (Ada 2005): Check if the primitive E covers some interface already + -- implemented by some ancestor of the tagged-type associated with E + + procedure Register_Interface_DT_Entry + (Prim : Entity_Id; + Ancestor_Iface_Prim : Entity_Id := Empty); + -- (Ada 2005): Register an interface primitive in a secondary dispatch + -- table. If Prim overrides an ancestor primitive of its associated + -- tagged-type then Ancestor_Iface_Prim indicates the entity of that + -- immediate ancestor associated with the interface; otherwise Prim and + -- Ancestor_Iface_Prim have the same info. + + ------------------------------------------- + -- Check_Overriding_Inherited_Interfaces -- + ------------------------------------------- + + procedure Check_Overriding_Inherited_Interfaces (E : Entity_Id) is + Typ : Entity_Id; + Elmt : Elmt_Id; + Prim_Op : Entity_Id; + Overriden_Op : Entity_Id := Empty; - if Is_Dispatching_Operation (E) - and then not Is_Abstract (E) - and then Present (DTC_Entity (E)) - and then not Is_CPP_Class (Scope (DTC_Entity (E))) - and then not Java_VM - then - Check_Overriding_Operation (E); + begin + if Ada_Version < Ada_05 + or else not Is_Overriding_Operation (E) + or else Is_Predefined_Dispatching_Operation (E) + or else Present (Alias (E)) + then + return; + end if; + + -- Get the entity associated with this primitive operation + + Typ := Scope (DTC_Entity (E)); + while Etype (Typ) /= Typ loop + + -- Climb to the immediate ancestor + + Typ := Etype (Typ); - -- Common case: Primitive subprogram + if Present (Abstract_Interfaces (Typ)) then - if not Present (Abstract_Interface_Alias (E)) then - Insert_After (N, Fill_DT_Entry (Sloc (N), E)); + -- Look for the overriden subprogram in the primary dispatch + -- table of the ancestor. - -- Ada 2005 (AI-251): Primitive subprogram that covers an interface + Overriden_Op := Empty; + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Prim_Op := Node (Elmt); + + if DT_Position (Prim_Op) = DT_Position (E) + and then Etype (DTC_Entity (Prim_Op)) = RTE (RE_Tag) + and then not Present (Abstract_Interface_Alias (Prim_Op)) + then + if Overriden_Op /= Empty then + raise Program_Error; + end if; + + Overriden_Op := Prim_Op; + end if; + + Next_Elmt (Elmt); + end loop; + + -- if not found this is the first overriding of some + -- abstract interface + + if Overriden_Op /= Empty then + Elmt := First_Elmt (Primitive_Operations (Typ)); + + -- Find the entries associated with interfaces that are + -- alias of this primitive operation in the ancestor + + while Present (Elmt) loop + Prim_Op := Node (Elmt); + + if Present (Abstract_Interface_Alias (Prim_Op)) + and then Alias (Prim_Op) = Overriden_Op + then + Register_Interface_DT_Entry (E, Prim_Op); + end if; + + Next_Elmt (Elmt); + end loop; + end if; + end if; + end loop; + end Check_Overriding_Inherited_Interfaces; + + --------------------------------- + -- Register_Interface_DT_Entry -- + --------------------------------- + + procedure Register_Interface_DT_Entry + (Prim : Entity_Id; + Ancestor_Iface_Prim : Entity_Id := Empty) + is + Prim_Typ : Entity_Id; + Prim_Op : Entity_Id; + Iface_Typ : Entity_Id; + Iface_DT_Ptr : Entity_Id; + Iface_Tag : Entity_Id; + New_Thunk : Node_Id; + Thunk_Id : Entity_Id; + + begin + if not Present (Ancestor_Iface_Prim) then + Prim_Typ := Scope (DTC_Entity (Alias (Prim))); + Iface_Typ := Scope (DTC_Entity (Abstract_Interface_Alias (Prim))); + Iface_Tag := Find_Interface_Tag + (T => Prim_Typ, + Iface => Iface_Typ); + + -- Generate the code of the thunk only when this primitive + -- operation is associated with a secondary dispatch table + + if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then + Thunk_Id := Make_Defining_Identifier (Loc, + New_Internal_Name ('T')); + New_Thunk := + Expand_Interface_Thunk + (N => Prim, + Thunk_Alias => Alias (Prim), + Thunk_Id => Thunk_Id, + Iface_Tag => Iface_Tag); + + Insert_After (N, New_Thunk); + + Iface_DT_Ptr := + Find_Interface_ADT + (T => Prim_Typ, + Iface => Iface_Typ); + + Insert_After (New_Thunk, + Fill_Secondary_DT_Entry (Sloc (Prim), + Prim => Prim, + Iface_DT_Ptr => Iface_DT_Ptr, + Thunk_Id => Thunk_Id)); + end if; else + Iface_Typ := + Scope (DTC_Entity (Abstract_Interface_Alias + (Ancestor_Iface_Prim))); + Iface_Tag := Find_Interface_Tag - (T => Scope (DTC_Entity (Alias (E))), -- Formal Type - Iface => Scope (DTC_Entity (Abstract_Interface_Alias (E)))); + (T => Scope (DTC_Entity (Alias (Ancestor_Iface_Prim))), + Iface => Iface_Typ); -- Generate the thunk only if the associated tag is an interface -- tag. The case in which the associated tag is the primary tag @@ -4107,12 +4227,69 @@ package body Exp_Ch6 is Thunk_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); - New_Thunk := Expand_Interface_Thunk (N, Thunk_Id, Iface_Tag); + if Present (Alias (Prim)) then + Prim_Op := Alias (Prim); + else + Prim_Op := Prim; + end if; + + New_Thunk := + Expand_Interface_Thunk + (N => Ancestor_Iface_Prim, + Thunk_Alias => Prim_Op, + Thunk_Id => Thunk_Id, + Iface_Tag => Iface_Tag); + + Insert_After (N, New_Thunk); + + Iface_DT_Ptr := + Find_Interface_ADT + (T => Scope (DTC_Entity (Prim_Op)), + Iface => Iface_Typ); Insert_After (New_Thunk, - Fill_DT_Entry (Sloc (N), - Prim => E, - Thunk_Id => Thunk_Id)); + Fill_Secondary_DT_Entry (Sloc (Prim), + Prim => Ancestor_Iface_Prim, + Iface_DT_Ptr => Iface_DT_Ptr, + Thunk_Id => Thunk_Id)); + end if; + end if; + end Register_Interface_DT_Entry; + + -- Start of processing for Freeze_Subprogram + + begin + -- When a primitive is frozen, enter its name in the corresponding + -- dispatch table. If the DTC_Entity field is not set this is an + -- overridden primitive that can be ignored. We suppress the + -- initialization of the dispatch table entry when Java_VM because + -- the dispatching mechanism is handled internally by the JVM. + + if Is_Dispatching_Operation (E) + and then not Is_Abstract (E) + and then Present (DTC_Entity (E)) + and then not Java_VM + and then not Is_CPP_Class (Scope (DTC_Entity (E))) + then + Check_Overriding_Operation (E); + + if Ada_Version < Ada_05 then + Insert_After (N, + Fill_DT_Entry (Sloc (N), Prim => E)); + + else + -- Ada 2005 (AI-251): Check if this entry corresponds with + -- a subprogram that covers an abstract interface type + + if Present (Abstract_Interface_Alias (E)) then + Register_Interface_DT_Entry (E); + + -- Common case: Primitive subprogram + + else + Insert_After (N, + Fill_DT_Entry (Sloc (N), Prim => E)); + Check_Overriding_Inherited_Interfaces (E); end if; end if; end if; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index b5c8b7bbd70..05ecfb655e9 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -902,6 +902,7 @@ package body Exp_Disp is function Expand_Interface_Thunk (N : Node_Id; + Thunk_Alias : Entity_Id; Thunk_Id : Entity_Id; Iface_Tag : Entity_Id) return Node_Id is @@ -910,7 +911,6 @@ package body Exp_Disp is Decl : constant List_Id := New_List; Formals : constant List_Id := New_List; Thunk_Tag : constant Node_Id := Iface_Tag; - Thunk_Alias : constant Entity_Id := Alias (Entity (N)); Target : Entity_Id; New_Code : Node_Id; Formal : Node_Id; @@ -950,11 +950,7 @@ package body Exp_Disp is if Is_Controlling_Formal (Formal) then Set_Parameter_Type (New_Formal, - New_Reference_To (Etype (First_Entity (Entity (N))), Loc)); - - -- Why is this line silently commented out ??? - - -- New_Reference_To (Etype (Formal), Loc)); + New_Reference_To (Etype (First_Entity (N)), Loc)); end if; Append_To (Formals, New_Formal); @@ -1150,66 +1146,76 @@ package body Exp_Disp is end if; Analyze (New_Code); - Insert_After (N, New_Code); return New_Code; end Expand_Interface_Thunk; - ------------- - -- Fill_DT -- - ------------- + ------------------- + -- Fill_DT_Entry -- + ------------------- function Fill_DT_Entry - (Loc : Source_Ptr; - Prim : Entity_Id; - Thunk_Id : Entity_Id := Empty) return Node_Id + (Loc : Source_Ptr; + Prim : Entity_Id) return Node_Id is Typ : constant Entity_Id := Scope (DTC_Entity (Prim)); - DT_Ptr : Entity_Id := Node (First_Elmt (Access_Disp_Table (Typ))); - Target : Entity_Id; - Tag : Entity_Id := First_Tag_Component (Typ); - Prim_Op : Entity_Id := Prim; + DT_Ptr : constant Entity_Id := + Node (First_Elmt (Access_Disp_Table (Typ))); + Pos : constant Uint := DT_Position (Prim); + Tag : constant Entity_Id := First_Tag_Component (Typ); begin - -- Ada 2005 (AI-251): If we have a thunk available then generate code - -- that saves its address in the secondary dispatch table of its - -- abstract interface; otherwise save the address of the primitive - -- subprogram in the main virtual table. - - if Thunk_Id /= Empty then - Target := Thunk_Id; - else - Target := Prim; + if Pos = Uint_0 or else Pos > DT_Entry_Count (Tag) then + raise Program_Error; end if; - -- Ada 2005 (AI-251): If the subprogram is the alias of an abstract - -- interface subprogram then find the correct dispatch table pointer + 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 Present (Abstract_Interface_Alias (Prim)) then - Prim_Op := Abstract_Interface_Alias (Prim); + Make_Integer_Literal (Loc, Pos), -- Position - DT_Ptr := Find_Interface_ADT - (T => Typ, - Iface => Scope (DTC_Entity (Prim_Op))); + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Address))); + end Fill_DT_Entry; - Tag := First_Tag_Component (Scope (DTC_Entity (Prim_Op))); - end if; + ----------------------------- + -- Fill_Secondary_DT_Entry -- + ----------------------------- - pragma Assert (DT_Position (Prim_Op) <= DT_Entry_Count (Tag)); - pragma Assert (DT_Position (Prim_Op) > Uint_0); + function Fill_Secondary_DT_Entry + (Loc : Source_Ptr; + Prim : Entity_Id; + Thunk_Id : Entity_Id; + Iface_DT_Ptr : Entity_Id) return Node_Id + is + Typ : constant Entity_Id := Scope (DTC_Entity (Alias (Prim))); + Iface_Prim : constant Entity_Id := Abstract_Interface_Alias (Prim); + Pos : constant Uint := DT_Position (Iface_Prim); + Tag : constant Entity_Id := + 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; 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 + New_Reference_To (Iface_DT_Ptr, Loc)), -- DTptr - Make_Integer_Literal (Loc, DT_Position (Prim_Op)), -- Position + Make_Integer_Literal (Loc, Pos), -- Position Make_Attribute_Reference (Loc, -- Value - Prefix => New_Reference_To (Target, Loc), + Prefix => New_Reference_To (Thunk_Id, Loc), Attribute_Name => Name_Address))); - end Fill_DT_Entry; + end Fill_Secondary_DT_Entry; --------------------------- -- Get_Remotely_Callable -- @@ -1313,7 +1319,6 @@ package body Exp_Disp is Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); -- ---------------------------------------------------------------- - -- Dispatch table and related entities are allocated statically Set_Ekind (DT, E_Variable); @@ -1538,6 +1543,71 @@ package body Exp_Disp is Node3 => Make_Integer_Literal (Loc, DT_Entry_Count (First_Tag_Component (Etype (Typ))))))); + -- Inherit the secondary dispatch tables of the ancestor + + if not Is_CPP_Class (Etype (Typ)) then + declare + Sec_DT_Ancestor : Elmt_Id := + Next_Elmt (First_Elmt (Access_Disp_Table (Etype (Typ)))); + Sec_DT_Typ : Elmt_Id := + Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); + + procedure Copy_Secondary_DTs (Typ : Entity_Id); + -- ??? comment required + + ------------------------ + -- Copy_Secondary_DTs -- + ------------------------ + + procedure Copy_Secondary_DTs (Typ : Entity_Id) is + E : Entity_Id; + + begin + if Etype (Typ) /= Typ then + Copy_Secondary_DTs (Etype (Typ)); + end if; + + if Present (Abstract_Interfaces (Typ)) + and then not Is_Empty_Elmt_List + (Abstract_Interfaces (Typ)) + then + E := First_Entity (Typ); + + while Present (E) + and then Present (Node (Sec_DT_Ancestor)) + loop + if Is_Tag (E) and then Chars (E) /= Name_uTag then + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Inherit_DT, + Args => New_List ( + Node1 => Unchecked_Convert_To + (RTE (RE_Tag), + New_Reference_To + (Node (Sec_DT_Ancestor), Loc)), + Node2 => Unchecked_Convert_To + (RTE (RE_Tag), + New_Reference_To + (Node (Sec_DT_Typ), Loc)), + Node3 => Make_Integer_Literal (Loc, + DT_Entry_Count (E))))); + + Next_Elmt (Sec_DT_Ancestor); + Next_Elmt (Sec_DT_Typ); + end if; + + Next_Entity (E); + end loop; + end if; + end Copy_Secondary_DTs; + + begin + if Present (Node (Sec_DT_Ancestor)) then + Copy_Secondary_DTs (Typ); + end if; + end; + end if; + -- Generate: Inherit_TSD (parent'tag, DT_Ptr); Append_To (Elab_Code, @@ -1547,17 +1617,20 @@ 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); - -- for simple types with controlled components - -- Generate: Set_RC_Offset (DT_Ptr, type._record_controller'position); - -- for complex types with controlled components where the position + -- For types with no controlled components, generate: + -- Set_RC_Offset (DT_Ptr, 0); + + -- For simple types with controlled components, generate: + -- Set_RC_Offset (DT_Ptr, type._record_controller'position); + + -- 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); + -- 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. declare @@ -1588,6 +1661,8 @@ package body Exp_Disp is -- 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 (Position); Set_Etype (Prefix (Position), RTE (RE_Record_Controller)); Set_Etype (Prefix (Prefix (Position)), Typ); @@ -1604,8 +1679,8 @@ package body Exp_Disp is Node2 => Position))); end; - -- Generate: Set_Remotely_Callable (DT_Ptr, Status); - -- where Status is described in E.4 (18) + -- Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is + -- described in E.4 (18) declare Status : Entity_Id; @@ -1681,8 +1756,8 @@ package body Exp_Disp is -- Ada 2005 (AI-251): Register the tag of the interfaces into -- the table of implemented interfaces - if Present (Abstract_Interfaces (Typ)) - and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) + if Present (Abstract_Interfaces (Typ_Copy)) + and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ_Copy)) then AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); while Present (AI) loop @@ -1718,9 +1793,8 @@ package body Exp_Disp is Result : out List_Id) is Loc : constant Source_Ptr := Sloc (AI_Tag); - Tname : constant Name_Id := Chars (AI_Tag); - Name_DT : constant Name_Id := New_External_Name (Tname, 'T'); - Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P'); + Name_DT : constant Name_Id := New_Internal_Name ('T'); + Name_DT_Ptr : constant Name_Id := New_Internal_Name ('P'); Iface_DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT); @@ -1848,7 +1922,6 @@ package body Exp_Disp is end if; Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables); - end Make_Abstract_Interface_DT; --------------------------- @@ -2117,6 +2190,7 @@ package body Exp_Disp is Prim_Elmt := First_Prim; Count_Prim := 0; + while Present (Prim_Elmt) loop Count_Prim := Count_Prim + 1; Prim := Node (Prim_Elmt); diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 0da765b904d..10900d04103 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -55,12 +55,20 @@ package Exp_Disp is TSD_Prologue_Size); function Fill_DT_Entry - (Loc : Source_Ptr; - Prim : Entity_Id; - Thunk_Id : Entity_Id := Empty) return Node_Id; + (Loc : Source_Ptr; + Prim : Entity_Id) return Node_Id; -- Generate the code necessary to fill the appropriate entry of the -- dispatch table of Prim's controlling type with Prim's address. + function Fill_Secondary_DT_Entry + (Loc : Source_Ptr; + Prim : Entity_Id; + Thunk_Id : Entity_Id; + Iface_DT_Ptr : Entity_Id) return Node_Id; + -- (Ada 2005): Generate the code necessary to fill the appropriate entry of + -- the secondary dispatch table of Prim's controlling type with Thunk_Id's + -- address. + procedure Make_Abstract_Interface_DT (AI_Tag : Entity_Id; Acc_Disp_Tables : in out Elist_Id; @@ -102,9 +110,10 @@ package Exp_Disp is -- secondary dispatch table function Expand_Interface_Thunk - (N : Node_Id; - Thunk_Id : Entity_Id; - Iface_Tag : Entity_Id) return Node_Id; + (N : Node_Id; + Thunk_Alias : Node_Id; + Thunk_Id : Entity_Id; + Iface_Tag : Entity_Id) return Node_Id; -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we -- generate additional subprograms (thunks) to have a layout compatible -- with the C++ ABI. The thunk modifies the value of the first actual of diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 9004213d5f2..643ed8a31e3 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -108,15 +108,6 @@ package body Exp_Util is -- procedure of record with task components, or for a dynamically -- created task that is assigned to a selected component. - procedure Find_Interface_Tag - (T : Entity_Id; - Iface : Entity_Id; - Iface_Tag : out Entity_Id; - Iface_ADT : out Entity_Id); - -- Ada 2005 (AI-251): Subsidiary procedure to Find_Interface_ADT and - -- Find_Interface_Tag. Given a type T implementing the interface, - -- returns the corresponding Tag and Access_Disp_Table entities. - function Make_CW_Equivalent_Type (T : Entity_Id; E : Node_Id) return Entity_Id; @@ -1298,26 +1289,100 @@ package body Exp_Util is -- Find_Interface_Tag -- ------------------------ - procedure Find_Interface_Tag - (T : Entity_Id; - Iface : Entity_Id; - Iface_Tag : out Entity_Id; - Iface_ADT : out Entity_Id) + function Find_Interface_ADT + (T : Entity_Id; + Iface : Entity_Id) return Entity_Id + is + ADT : Elmt_Id; + Found : Boolean := False; + Typ : Entity_Id := T; + + procedure Find_Secondary_Table (Typ : Entity_Id); + -- Comment required ??? + + -------------------------- + -- Find_Secondary_Table -- + -------------------------- + + procedure Find_Secondary_Table (Typ : Entity_Id) is + AI_Elmt : Elmt_Id; + AI : Node_Id; + + begin + if Etype (Typ) /= Typ then + Find_Secondary_Table (Etype (Typ)); + end if; + + if Present (Abstract_Interfaces (Typ)) + and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) + then + AI_Elmt := First_Elmt (Abstract_Interfaces (Typ)); + while Present (AI_Elmt) loop + AI := Node (AI_Elmt); + + if AI = Iface or else Is_Ancestor (Iface, AI) then + Found := True; + return; + end if; + + Next_Elmt (ADT); + Next_Elmt (AI_Elmt); + end loop; + end if; + end Find_Secondary_Table; + + -- Start of processing for Find_Interface_Tag + + begin + -- Handle private types + + if Has_Private_Declaration (Typ) + and then Present (Full_View (Typ)) + then + Typ := Full_View (Typ); + end if; + + -- Handle access types + + if Is_Access_Type (Typ) then + Typ := Directly_Designated_Type (Typ); + end if; + + -- Handle task and protected types implementing interfaces + + if Ekind (Typ) = E_Protected_Type + or else Ekind (Typ) = E_Task_Type + then + Typ := Corresponding_Record_Type (Typ); + end if; + + ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); + pragma Assert (Present (Node (ADT))); + Find_Secondary_Table (Typ); + pragma Assert (Found); + return Node (ADT); + end Find_Interface_ADT; + + ------------------------ + -- Find_Interface_Tag -- + ------------------------ + + function Find_Interface_Tag + (T : Entity_Id; + Iface : Entity_Id) return Entity_Id is - AI_Tag : Entity_Id; - ADT_Elmt : Elmt_Id; - Found : Boolean := False; + AI_Tag : Entity_Id; + Found : Boolean := False; + Typ : Entity_Id := T; - procedure Find_AI_Tag (Typ : in Entity_Id; Found : in out Boolean); - -- This must be commented ??? + procedure Find_Tag (Typ : in Entity_Id); + -- Internal subprogram used to recursively climb to the ancestors ----------------- -- Find_AI_Tag -- ----------------- - procedure Find_AI_Tag (Typ : in Entity_Id; Found : in out Boolean) is - T : Entity_Id := Typ; - Etyp : Entity_Id; -- := Etype (Typ); -- why is this commented ??? + procedure Find_Tag (Typ : in Entity_Id) is AI_Elmt : Elmt_Id; AI : Node_Id; @@ -1326,60 +1391,31 @@ package body Exp_Util is -- therefore shares the main tag. if Typ = Iface then - AI_Tag := First_Tag_Component (Typ); - ADT_Elmt := First_Elmt (Access_Disp_Table (Typ)); - Found := True; + pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); + AI_Tag := First_Tag_Component (Typ); + Found := True; return; end if; - -- Handle private types - - if Has_Private_Declaration (T) - and then Present (Full_View (T)) - then - T := Full_View (T); - end if; - - if Is_Access_Type (Typ) then - T := Directly_Designated_Type (T); - - elsif Ekind (T) = E_Protected_Type - or else Ekind (T) = E_Task_Type - then - T := Corresponding_Record_Type (T); - end if; - - Etyp := Etype (T); - -- Climb to the root type - if Etyp /= Typ then - Find_AI_Tag (Etyp, Found); + if Etype (Typ) /= Typ then + Find_Tag (Etype (Typ)); end if; -- Traverse the list of interfaces implemented by the type if not Found - and then Present (Abstract_Interfaces (T)) - and then not Is_Empty_Elmt_List (Abstract_Interfaces (T)) + and then Present (Abstract_Interfaces (Typ)) + and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ))) then - -- Skip the tag associated with the primary table (if - -- already placed in the record) - - if Etype (Node (First_Elmt - (Access_Disp_Table (T)))) = RTE (RE_Tag) - then - AI_Tag := Next_Tag_Component (First_Tag_Component (T)); - ADT_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (T))); - else - AI_Tag := First_Tag_Component (T); - ADT_Elmt := First_Elmt (Access_Disp_Table (T)); - end if; + -- Skip the tag associated with the primary table. + pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); + AI_Tag := Next_Tag_Component (First_Tag_Component (Typ)); pragma Assert (Present (AI_Tag)); - pragma Assert (Present (Node (ADT_Elmt))); - AI_Elmt := First_Elmt (Abstract_Interfaces (T)); + AI_Elmt := First_Elmt (Abstract_Interfaces (Typ)); while Present (AI_Elmt) loop AI := Node (AI_Elmt); @@ -1390,47 +1426,38 @@ package body Exp_Util is AI_Tag := Next_Tag_Component (AI_Tag); Next_Elmt (AI_Elmt); - Next_Elmt (ADT_Elmt); end loop; end if; - end Find_AI_Tag; + end Find_Tag; + + -- Start of processing for Find_Interface_Tag begin - Find_AI_Tag (T, Found); - pragma Assert (Found); + -- Handle private types - Iface_Tag := AI_Tag; - Iface_ADT := Node (ADT_Elmt); - end Find_Interface_Tag; + if Has_Private_Declaration (Typ) + and then Present (Full_View (Typ)) + then + Typ := Full_View (Typ); + end if; - ------------------------ - -- Find_Interface_Tag -- - ------------------------ + -- Handle access types - function Find_Interface_ADT - (T : Entity_Id; - Iface : Entity_Id) return Entity_Id - is - Iface_Tag : Entity_Id := Empty; - Iface_ADT : Entity_Id := Empty; - begin - Find_Interface_Tag (T, Iface, Iface_Tag, Iface_ADT); - return Iface_ADT; - end Find_Interface_ADT; + if Is_Access_Type (Typ) then + Typ := Directly_Designated_Type (Typ); + end if; - ------------------------ - -- Find_Interface_Tag -- - ------------------------ + -- Handle task and protected types implementing interfaces - function Find_Interface_Tag - (T : Entity_Id; - Iface : Entity_Id) return Entity_Id - is - Iface_Tag : Entity_Id := Empty; - Iface_ADT : Entity_Id := Empty; - begin - Find_Interface_Tag (T, Iface, Iface_Tag, Iface_ADT); - return Iface_Tag; + if Ekind (Typ) = E_Protected_Type + or else Ekind (Typ) = E_Task_Type + then + Typ := Corresponding_Record_Type (Typ); + end if; + + Find_Tag (Typ); + pragma Assert (Found); + return AI_Tag; end Find_Interface_Tag; ------------------